Index: LMDZ6/trunk/libf/phylmd/cosp2/MISR_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/MISR_simulator.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/MISR_simulator.F90 (revision 3358) @@ -0,0 +1,292 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Roger Marchand, version 1.2 +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_MISR_SIMULATOR + use cosp_kinds, only: wp + use MOD_COSP_STATS, ONLY: hist2D + use mod_cosp_config, ONLY: R_UNDEF,numMISRHgtBins,numMISRTauBins,misr_histHgt, & + misr_histTau + implicit none + + ! Parameters + real(wp),parameter :: & + misr_taumin = 0.3_wp, & ! Minimum optical depth for joint-histogram + tauchk = -1.*log(0.9999999) ! Lower limit on optical depth + +contains + + ! ###################################################################################### + ! SUBROUTINE misr_subcolumn + ! ###################################################################################### + SUBROUTINE MISR_SUBCOLUMN(npoints,ncol,nlev,dtau,zfull,at,sunlit,tauOUT, & + dist_model_layertops,box_MISR_ztop) + ! INPUTS + INTEGER, intent(in) :: & + npoints, & ! Number of horizontal gridpoints + ncol, & ! Number of subcolumns + nlev ! Number of vertical layers + INTEGER, intent(in),dimension(npoints) :: & + sunlit ! 1 for day points, 0 for night time + REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: & + dtau ! Optical thickness + REAL(WP),intent(in),dimension(npoints,nlev) :: & + zfull, & ! Height of full model levels (i.e. midpoints), [nlev] is bottom + at ! Temperature (K) + + ! OUTPUTS + REAL(WP),intent(out),dimension(npoints,ncol) :: & + box_MISR_ztop, & ! Cloud-top height in each column + tauOUT ! Optical depth in each column + REAL(WP),intent(out),dimension(npoints,numMISRHgtBins) :: & + dist_model_layertops ! + + ! INTERNAL VARIABLES + INTEGER :: ilev,j,loop,ibox,thres_crossed_MISR + INTEGER :: iMISR_ztop + REAL(WP) :: cloud_dtau,MISR_penetration_height,ztest + + ! ############################################################################ + ! Initialize + box_MISR_ztop(1:npoints,1:ncol) = 0._wp + + do j=1,npoints + + ! Estimate distribution of Model layer tops + dist_model_layertops(j,:)=0 + do ilev=1,nlev + ! Define location of "layer top" + if(ilev.eq.1 .or. ilev.eq.nlev) then + ztest=zfull(j,ilev) + else + ztest=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) + endif + + ! Find MISR layer that contains this level + ! *NOTE* the first MISR level is "no height" level + iMISR_ztop=2 + do loop=2,numMISRHgtBins + if ( ztest .gt. 1000*misr_histHgt(loop+1) ) then + iMISR_ztop=loop+1 + endif + enddo + + dist_model_layertops(j,iMISR_ztop) = dist_model_layertops(j,iMISR_ztop)+1 + enddo + + ! For each GCM cell or horizontal model grid point + do ibox=1,ncol + ! Compute optical depth as a cummulative distribution in the vertical (nlev). + tauOUT(j,ibox)=sum(dtau(j,ibox,1:nlev)) + + thres_crossed_MISR=0 + do ilev=1,nlev + ! If there a cloud, start the counter and store this height + if(thres_crossed_MISR .eq. 0 .and. dtau(j,ibox,ilev) .gt. 0.) then + ! First encountered a "cloud" + thres_crossed_MISR = 1 + cloud_dtau = 0 + endif + + if( thres_crossed_MISR .lt. 99 .and. thres_crossed_MISR .gt. 0 ) then + if( dtau(j,ibox,ilev) .eq. 0.) then + ! We have come to the end of the current cloud layer without yet + ! selecting a CTH boundary. Restart cloud tau counter + cloud_dtau=0 + else + ! Add current optical depth to count for the current cloud layer + cloud_dtau=cloud_dtau+dtau(j,ibox,ilev) + endif + + ! If the cloud is continuous but optically thin (< 1) from above the + ! current layer cloud top to the current level then MISR will like + ! see a top below the top of the current layer. + if( dtau(j,ibox,ilev).gt.0 .and. (cloud_dtau-dtau(j,ibox,ilev)) .lt. 1) then + if(dtau(j,ibox,ilev) .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then + ! MISR will likely penetrate to some point within this layer ... the middle + MISR_penetration_height=zfull(j,ilev) + else + ! Take the OD = 1.0 level into this layer + MISR_penetration_height=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) - & + 0.5_wp*(zfull(j,ilev-1)-zfull(j,ilev+1))/dtau(j,ibox,ilev) + endif + box_MISR_ztop(j,ibox)=MISR_penetration_height + endif + + ! Check for a distinctive water layer + if(dtau(j,ibox,ilev) .gt. 1 .and. at(j,ilev) .gt. 273 ) then + ! Must be a water cloud, take this as CTH level + thres_crossed_MISR=99 + endif + + ! If the total column optical depth is "large" than MISR can't see + ! anything else. Set current point as CTH level + if(sum(dtau(j,ibox,1:ilev)) .gt. 5) then + thres_crossed_MISR=99 + endif + endif + enddo + + ! Check to see if there was a cloud for which we didn't + ! set a MISR cloud top boundary + if( thres_crossed_MISR .eq. 1) then + ! If the cloud has a total optical depth of greater + ! than ~ 0.5 MISR will still likely pick up this cloud + ! with a height near the true cloud top + ! otherwise there should be no CTH + if(sum(dtau(j,ibox,1:nlev)) .gt. 0.5) then + ! keep MISR detected CTH + elseif(sum(dtau(j,ibox,1:nlev)) .gt. 0.2) then + ! MISR may detect but wont likley have a good height + box_MISR_ztop(j,ibox)=-1 + else + ! MISR not likely to even detect. + ! so set as not cloudy + box_MISR_ztop(j,ibox)=0 + endif + endif + enddo ! loop of subcolumns + + enddo ! loop of gridpoints + + ! Modify MISR CTH for satellite spatial / pattern matcher effects + ! Code in this region added by roj 5/2006 to account + ! for spatial effect of the MISR pattern matcher. + ! Basically, if a column is found between two neighbors + ! at the same CTH, and that column has no hieght or + ! a lower CTH, THEN misr will tend to but place the + ! odd column at the same height as it neighbors. + + ! This setup assumes the columns represent a about a 1 to 4 km scale + ! it will need to be modified significantly, otherwise +! ! DS2015: Add loop over gridpoints and index accordingly. +! if(ncol.eq.1) then +! ! Adjust based on neightboring points. +! do j=2,npoints-1 +! if(box_MISR_ztop(j-1,1) .gt. 0 .and. & +! box_MISR_ztop(j+1,1) .gt. 0 .and. & +! abs(box_MISR_ztop(j-1,1)-box_MISR_ztop(j+1,1)) .lt. 500 .and. & +! box_MISR_ztop(j,1) .lt. box_MISR_ztop(j+1,1)) then +! box_MISR_ztop(j,1) = box_MISR_ztop(j+1,1) +! endif +! enddo +! else +! ! Adjust based on neighboring subcolumns. +! do j=1,npoints +! do ibox=2,ncol-1 +! if(box_MISR_ztop(j,ibox-1) .gt. 0 .and. & +! box_MISR_ztop(j,ibox+1) .gt. 0 .and. & +! abs(box_MISR_ztop(j,ibox-1)-box_MISR_ztop(j,ibox+1)) .lt. 500 .and. & +! box_MISR_ztop(j,ibox) .lt. box_MISR_ztop(j,ibox+1)) then +! box_MISR_ztop(j,ibox) = box_MISR_ztop(j,ibox+1) +! endif +! enddo +! enddo +! endif +! ! DS2015 END + + ! Fill dark scenes + do j=1,numMISRHgtBins + where(sunlit .ne. 1) dist_model_layertops(1:npoints,j) = R_UNDEF + enddo + + end SUBROUTINE MISR_SUBCOLUMN + + ! ###################################################################################### + ! SUBROUTINE misr_column + ! ###################################################################################### + SUBROUTINE MISR_COLUMN(npoints,ncol,box_MISR_ztop,sunlit,tau,MISR_cldarea,MISR_mean_ztop,fq_MISR_TAU_v_CTH) + + ! INPUTS + INTEGER, intent(in) :: & + npoints, & ! Number of horizontal gridpoints + ncol ! Number of subcolumns + INTEGER, intent(in),dimension(npoints) :: & + sunlit ! 1 for day points, 0 for night time + REAL(WP),intent(in),dimension(npoints,ncol) :: & + box_MISR_ztop, & ! Cloud-top height in each column + tau ! Column optical thickness + + ! OUTPUTS + REAL(WP),intent(inout),dimension(npoints) :: & + MISR_cldarea, & ! Fraction area covered by clouds + MISR_mean_ztop ! Mean cloud top height MISR would observe + REAL(WP),intent(inout),dimension(npoints,7,numMISRHgtBins) :: & + fq_MISR_TAU_v_CTH ! Joint histogram of cloud-cover and tau + + ! INTERNAL VARIABLES + INTEGER :: j + LOGICAL,dimension(ncol) :: box_cloudy + real(wp),dimension(npoints,ncol) :: tauWRK,box_MISR_ztopWRK + ! ############################################################################ + + ! Compute column quantities and joint-histogram + MISR_cldarea(1:npoints) = 0._wp + MISR_mean_ztop(1:npoints) = 0._wp + fq_MISR_TAU_v_CTH(1:npoints,1:7,1:numMISRHgtBins) = 0._wp + tauWRK(1:npoints,1:ncol) = tau(1:npoints,1:ncol) + box_MISR_ztopWRK(1:npoints,1:ncol) = box_MISR_ztop(1:npoints,1:ncol) + do j=1,npoints + + ! Subcolumns that are cloudy(true) and not(false) + box_cloudy(1:ncol) = merge(.true.,.false.,tau(j,1:ncol) .gt. tauchk) + + ! Fill optically thin clouds with fill value + where(.not. box_cloudy(1:ncol)) tauWRK(j,1:ncol) = -999._wp + where(box_MISR_ztopWRK(j,1:ncol) .eq. 0) box_MISR_ztopWRK(j,1:ncol)=-999._wp + + ! Compute joint histogram and column quantities for points that are sunlit and cloudy + if (sunlit(j) .eq. 1) then + ! Joint histogram + call hist2D(tauWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol),ncol,misr_histTau,numMISRTauBins,& + 1000*misr_histHgt,numMISRHgtBins,fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)) + fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins) = & + 100._wp*fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)/ncol + + ! Column cloud area + MISR_cldarea(j)=real(count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.))/ncol + + ! Column cloud-top height + if ( count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) .ne. 0 ) then + MISR_mean_ztop(j) = sum(box_MISR_ztopWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol) .ne. -999.)/ & + count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) + else + MISR_mean_ztop(j) = R_UNDEF + endif + + else + MISR_cldarea(j) = R_UNDEF + MISR_mean_ztop(npoints) = R_UNDEF + endif + enddo + + end SUBROUTINE MISR_COLUMN + +end MODULE MOD_MISR_SIMULATOR Index: LMDZ6/trunk/libf/phylmd/cosp2/array_lib.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/array_lib.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/array_lib.F90 (revision 3358) @@ -0,0 +1,103 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! 10/16/03 John Haynes - Original version (haynes@atmos.colostate.edu) +! 01/31/06 John Haynes - IDL to Fortran 90 +! 01/01/15 Dustin Swales - Modified for COSPv2.0 +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module array_lib + USE COSP_KINDS, ONLY: wp + implicit none +contains + + ! ############################################################################ + ! function INFIND + ! ############################################################################ + function infind(list,val) + implicit none + ! ########################################################################## + ! Purpose: + ! Finds the index of an array that is closest to a value, plus the + ! difference between the value found and the value specified + ! + ! Inputs: + ! [list] an array of sequential values + ! [val] a value to locate + ! Optional input: + ! [sort] set to 1 if [list] is in unknown/non-sequential order + ! + ! Returns: + ! index of [list] that is closest to [val] + ! + ! Optional output: + ! [dist] set to variable containing [list([result])] - [val] + ! + ! Requires: + ! mrgrnk library + ! + ! ########################################################################## + + ! INPUTS + real(wp), dimension(:), intent(in) :: & + list ! An array of sequential values + real(wp), intent(in) :: & + val ! A value to locate + ! OUTPUTS + integer :: & + infind ! Index of [list] that is closest to [val] + + ! Internal Variables + real(wp), dimension(size(list)) :: lists + integer :: nlist, result, tmp(1), sort_list + integer, dimension(size(list)) :: mask + + sort_list = 0 + + nlist = size(list) + lists = list + + if (val >= lists(nlist)) then + result = nlist + else if (val <= lists(1)) then + result = 1 + else + mask(:) = 0 + where (lists < val) mask = 1 + tmp = minloc(mask,1) + if (abs(lists(tmp(1)-1)-val) < abs(lists(tmp(1))-val)) then + result = tmp(1) - 1 + else + result = tmp(1) + endif + endif + infind = result + end function infind + +end module array_lib Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp.F90 (revision 3358) @@ -0,0 +1,2345 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +MODULE MOD_COSP + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: R_UNDEF,PARASOL_NREFL,LIDAR_NCAT,SR_BINS, & + N_HYDRO,RTTOV_MAX_CHANNELS,numMISRHgtBins, & + DBZE_BINS,LIDAR_NTEMP,calipso_histBsct, & + use_vgrid,Nlvgrid,vgrid_zu,vgrid_zl,vgrid_z, & + numMODISTauBins,numMODISPresBins, & + numMODISReffIceBins,numMODISReffLiqBins, & + numISCCPTauBins,numISCCPPresBins,numMISRTauBins,& + ntau,modis_histTau,tau_binBounds, & + modis_histTauEdges,tau_binEdges, & + modis_histTauCenters,tau_binCenters + USE MOD_COSP_MODIS_INTERFACE, ONLY: cosp_modis_init, modis_IN +! USE MOD_COSP_RTTOV_INTERFACE, ONLY: cosp_rttov_init, rttov_IN + USE MOD_COSP_MISR_INTERFACE, ONLY: cosp_misr_init, misr_IN + USE MOD_COSP_ISCCP_INTERFACE, ONLY: cosp_isccp_init, isccp_IN + USE MOD_COSP_CALIPSO_INTERFACE, ONLY: cosp_calipso_init, calipso_IN + USE MOD_COSP_PARASOL_INTERFACE, ONLY: cosp_parasol_init, parasol_in + USE MOD_COSP_CLOUDSAT_INTERFACE, ONLY: cosp_cloudsat_init, cloudsat_IN + USE quickbeam, ONLY: quickbeam_subcolumn, quickbeam_column, radar_cfg + USE MOD_ICARUS, ONLY: icarus_subcolumn, icarus_column + USE MOD_MISR_SIMULATOR, ONLY: misr_subcolumn, misr_column + USE MOD_LIDAR_SIMULATOR, ONLY: lidar_subcolumn, lidar_column + USE MOD_MODIS_SIM, ONLY: modis_subcolumn, modis_column + USE MOD_PARASOL, ONLY: parasol_subcolumn, parasol_column +! use mod_cosp_rttov, ONLY: rttov_column + USE MOD_COSP_STATS, ONLY: COSP_LIDAR_ONLY_CLOUD,COSP_CHANGE_VERTICAL_GRID + + IMPLICIT NONE + + logical :: linitialization ! Initialization flag + + ! ###################################################################################### + ! TYPE cosp_column_inputs + ! ###################################################################################### + type cosp_column_inputs + integer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + + integer,allocatable,dimension(:) :: & + sunlit ! Sunlit flag (0-1) + + real(wp),allocatable,dimension(:,:) :: & + at, & ! Temperature (K) + pfull, & ! Pressure (Pa) + phalf, & ! Pressure at half-levels (Pa) + qv, & ! Specific humidity (kg/kg) + hgt_matrix, & ! Height of hydrometeors (km) + hgt_matrix_half ! Height of hydrometeors at half levels (km) + + real(wp),allocatable,dimension(:) :: & + land, & ! Land/Sea mask (0-1) + skt ! Surface temperature (K) + ! Fields used ONLY by RTTOV + integer :: & + month ! Month for surface emissivty atlas (1-12) + real(wp) :: & + zenang, & ! Satellite zenith angle for RTTOV (deg) + co2, & ! CO2 (kg/kg) + ch4, & ! Methane (kg/kg) + n2o, & ! N2O (kg/kg) + co ! CO (kg/kg) + real(wp),allocatable,dimension(:) :: & + emis_sfc, & ! Surface emissivity (1) + u_sfc, & ! Surface u-wind (m/s) + v_sfc, & ! Surface v-wind (m/s) + seaice, & ! Sea-ice fraction (0-1) + lat, & ! Latitude (deg) + lon ! Longitude (deg) + real(wp),allocatable,dimension(:,:) :: & + o3, & ! Ozone (kg/kg) + tca, & ! Total column cloud fraction (0-1) + cloudIce, & ! Cloud ice water mixing ratio (kg/kg) + cloudLiq, & ! Cloud liquid water mixing ratio (kg/kg) + fl_rain, & ! Precipitation (rain) flux (kg/m2/s) + fl_snow ! Precipitation (snow) flux (kg/m2/s) + end type cosp_column_inputs + + ! ###################################################################################### + ! TYPE cosp_optical_inputs + ! ###################################################################################### + type cosp_optical_inputs + integer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels, & ! Number of levels. + Npart, & ! Number of cloud meteors for LIDAR simulator. + Nrefl ! Number of reflectances for PARASOL simulator + real(wp) :: & + emsfc_lw ! 11 micron surface emissivity + real(wp),allocatable,dimension(:,:,:) :: & + frac_out, & ! Cloud fraction + tau_067, & ! Optical depth + fracLiq, & ! Cloud fraction + emiss_11, & ! Emissivity + asym, & ! Assymetry parameter + ss_alb, & ! Single-scattering albedo + betatot, & ! Backscatter coefficient for polarized optics (total) + betatot_ice, & ! Backscatter coefficient for polarized optics (ice) + betatot_liq, & ! Backscatter coefficient for polarized optics (liquid) + tautot, & ! Optical thickess integrated from top (total) + tautot_ice, & ! Optical thickess integrated from top (ice) + tautot_liq, & ! Optical thickess integrated from top (liquid) + z_vol_cloudsat, & ! Effective reflectivity factor (mm^6/m^3) + kr_vol_cloudsat, & ! Attenuation coefficient hydro (dB/km) + g_vol_cloudsat ! Attenuation coefficient gases (dB/km) + real(wp),allocatable,dimension(:,:) :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol, & ! Molecular optical depth + tautot_S_liq, & ! Liquid water optical thickness, from TOA to SFC + tautot_S_ice ! Ice water optical thickness, from TOA to SFC + type(radar_cfg) :: & + rcfg_cloudsat ! Radar comfiguration information (CLOUDSAT) + end type cosp_optical_inputs + + ! ###################################################################################### + ! TYPE cosp_outputs + ! ###################################################################################### + type cosp_outputs + + ! CALIPSO outputs + real(wp),dimension(:,:,:),pointer :: & + calipso_betaperp_tot => null(), & ! Total backscattered signal + calipso_beta_tot => null(), & ! Total backscattered signal + calipso_tau_tot => null(), & ! Optical thickness integrated from top to level z + calipso_lidarcldphase => null(), & ! 3D "lidar" phase cloud fraction + calipso_cldlayerphase => null(), & ! low, mid, high-level lidar phase cloud cover + calipso_lidarcldtmp => null(), & ! 3D "lidar" phase cloud temperature + calipso_cfad_sr => null() ! CFAD of scattering ratio + real(wp), dimension(:,:),pointer :: & + calipso_lidarcld => null(), & ! 3D "lidar" cloud fraction + calipso_cldlayer => null(), & ! low, mid, high-level, total lidar cloud cover + calipso_beta_mol => null(), & ! Molecular backscatter + calipso_temp_tot => null() + real(wp), dimension(:),pointer :: & + calipso_srbval => null() ! SR bins in cfad_sr + + ! PARASOL outputs + real(wp),dimension(:,:,:),pointer :: & + parasolPix_refl => null() ! PARASOL reflectances (subcolumn) + real(wp),dimension(:,:),pointer :: & + parasolGrid_refl => null() ! PARASOOL reflectances (column) + + ! CLOUDSAT outputs + real(wp),dimension(:,:,:),pointer :: & + cloudsat_Ze_tot => null(), & ! Effective reflectivity factor (Npoints,Ncolumns,Nlevels) + cloudsat_cfad_ze => null() ! Ze CFAD(Npoints,dBZe_bins,Nlevels) + real(wp), dimension(:,:),pointer :: & + lidar_only_freq_cloud => null() ! (Npoints,Nlevels) + real(wp),dimension(:),pointer :: & + radar_lidar_tcc => null() ! Radar&lidar total cloud amount, grid-box scale (Npoints) + + ! ISCCP outputs + real(wp),dimension(:),pointer :: & + isccp_totalcldarea => null(), & ! The fraction of model grid box columns with cloud + ! somewhere in them. (%) + isccp_meantb => null(), & ! Mean all-sky 10.5 micron brightness temperature. (K) + isccp_meantbclr => null(), & ! Mean clear-sky 10.5 micron brightness temperature. (K) + isccp_meanptop => null(), & ! Mean cloud top pressure (mb). + isccp_meantaucld => null(), & ! Mean optical thickness. (1) + isccp_meanalbedocld => null() ! Mean cloud albedo. (1) + real(wp),dimension(:,:),pointer ::& + isccp_boxtau => null(), & ! Optical thickness in each column. (1) + isccp_boxptop => null() ! Cloud top pressure in each column. (mb) + real(wp),dimension(:,:,:),pointer :: & + isccp_fq => null() ! The fraction of the model grid box covered by each of + ! the 49 ISCCP D level cloud types. (%) + + ! MISR outptus + real(wp),dimension(:,:,:),pointer :: & ! + misr_fq => null() ! Fraction of the model grid box covered by each of the MISR + ! cloud types + real(wp),dimension(:,:),pointer :: & ! + misr_dist_model_layertops => null() ! + real(wp),dimension(:),pointer :: & ! + misr_meanztop => null(), & ! Mean MISR cloud top height + misr_cldarea => null() ! Mean MISR cloud cover area + + ! MODIS outptus + real(wp),pointer,dimension(:) :: & ! + modis_Cloud_Fraction_Total_Mean => null(), & ! L3 MODIS retrieved cloud fraction (total) + modis_Cloud_Fraction_Water_Mean => null(), & ! L3 MODIS retrieved cloud fraction (liq) + modis_Cloud_Fraction_Ice_Mean => null(), & ! L3 MODIS retrieved cloud fraction (ice) + modis_Cloud_Fraction_High_Mean => null(), & ! L3 MODIS retrieved cloud fraction (high) + modis_Cloud_Fraction_Mid_Mean => null(), & ! L3 MODIS retrieved cloud fraction (middle) + modis_Cloud_Fraction_Low_Mean => null(), & ! L3 MODIS retrieved cloud fraction (low ) + modis_Optical_Thickness_Total_Mean => null(), & ! L3 MODIS retrieved optical thickness (tot) + modis_Optical_Thickness_Water_Mean => null(), & ! L3 MODIS retrieved optical thickness (liq) + modis_Optical_Thickness_Ice_Mean => null(), & ! L3 MODIS retrieved optical thickness (ice) + modis_Optical_Thickness_Total_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness + modis_Optical_Thickness_Water_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness + modis_Optical_Thickness_Ice_LogMean => null(), & ! L3 MODIS retrieved log10 optical thickness + modis_Cloud_Particle_Size_Water_Mean => null(), & ! L3 MODIS retrieved particle size (liquid) + modis_Cloud_Particle_Size_Ice_Mean => null(), & ! L3 MODIS retrieved particle size (ice) + modis_Cloud_Top_Pressure_Total_Mean => null(), & ! L3 MODIS retrieved cloud top pressure + modis_Liquid_Water_Path_Mean => null(), & ! L3 MODIS retrieved liquid water path + modis_Ice_Water_Path_Mean => null() ! L3 MODIS retrieved ice water path + real(wp),pointer,dimension(:,:,:) :: & + modis_Optical_Thickness_vs_Cloud_Top_Pressure => null(), & ! Tau/Pressure joint histogram + modis_Optical_Thickness_vs_ReffICE => null(), & ! Tau/ReffICE joint histogram + modis_Optical_Thickness_vs_ReffLIQ => null() ! Tau/ReffLIQ joint histogram + + ! RTTOV outputs + real(wp),pointer :: & + rttov_tbs(:,:) => null() ! Brightness Temperature + + end type cosp_outputs + +CONTAINS + ! ###################################################################################### + ! FUNCTION cosp_simulator + ! ###################################################################################### + function COSP_SIMULATOR(cospIN,cospgridIN,cospOUT,start_idx,stop_idx,debug) + type(cosp_optical_inputs),intent(in),target :: cospIN ! Optical inputs to COSP simulator + type(cosp_column_inputs), intent(in),target :: cospgridIN ! Host model inputs to COSP + + ! Inputs into the simulators + type(isccp_IN) :: isccpIN ! Input to the ISCCP simulator + type(misr_IN) :: misrIN ! Input to the LIDAR simulator + type(calipso_IN) :: calipsoIN ! Input to the LIDAR simulator + type(parasol_IN) :: parasolIN ! Input to the PARASOL simulator + type(cloudsat_IN) :: cloudsatIN ! Input to the CLOUDSAT radar simulator + type(modis_IN) :: modisIN ! Input to the MODIS simulator +! type(rttov_IN) :: rttovIN ! Input to the RTTOV simulator + integer,optional :: start_idx,stop_idx + logical,optional :: debug + + ! Outputs from the simulators (nested simulator output structure) + type(cosp_outputs), intent(inout) :: cospOUT + character(len=256),dimension(100) :: cosp_simulator + + ! Local variables + integer :: & + i,icol,ij,ik,nError + integer,target :: & + Npoints + logical :: & + Lisccp_subcolumn, & ! On/Off switch for subcolumn ISCCP simulator + Lmisr_subcolumn, & ! On/Off switch for subcolumn MISR simulator + Lcalipso_subcolumn, & ! On/Off switch for subcolumn CALIPSO simulator + Lparasol_subcolumn, & ! On/Off switch for subcolumn PARASOL simulator + Lcloudsat_subcolumn, & ! On/Off switch for subcolumn CLOUDSAT simulator + Lmodis_subcolumn, & ! On/Off switch for subcolumn MODIS simulator + Lrttov_subcolumn, & ! On/Off switch for subcolumn RTTOV simulator + Lisccp_column, & ! On/Off switch for column ISCCP simulator + Lmisr_column, & ! On/Off switch for column MISR simulator + Lcalipso_column, & ! On/Off switch for column CALIPSO simulator + Lparasol_column, & ! On/Off switch for column PARASOL simulator + Lcloudsat_column, & ! On/Off switch for column CLOUDSAT simulator + Lmodis_column, & ! On/Off switch for column MODIS simulator + Lrttov_column, & ! On/Off switch for column RTTOV simulator (not used) + Lradar_lidar_tcc, & ! On/Off switch from joint Calipso/Cloudsat product + Llidar_only_freq_cloud ! On/Off switch from joint Calipso/Cloudsat product + logical :: & + ok_lidar_cfad = .false., & + lrttov_cleanUp = .false. + + integer, dimension(:,:),allocatable :: & + modisRetrievedPhase,isccpLEVMATCH + real(wp), dimension(:), allocatable :: & + modisCfTotal,modisCfLiquid,modisMeanIceWaterPath, isccp_meantbclr, & + modisCfIce, modisCfHigh, modisCfMid, modisCfLow,modisMeanTauTotal, & + modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal, & + modisMeanLogTauLiquid, modisMeanLogTauIce, modisMeanSizeLiquid, & + modisMeanSizeIce, modisMeanCloudTopPressure, modisMeanLiquidWaterPath, & + radar_lidar_tcc + REAL(WP), dimension(:,:),allocatable :: & + modisRetrievedCloudTopPressure,modisRetrievedTau,modisRetrievedSize, & + misr_boxtau,misr_boxztop,misr_dist_model_layertops,isccp_boxtau, & + isccp_boxttop,isccp_boxptop,calipso_beta_mol,lidar_only_freq_cloud + REAL(WP), dimension(:,:,:),allocatable :: & + modisJointHistogram,modisJointHistogramIce,modisJointHistogramLiq, & + calipso_beta_tot,calipso_betaperp_tot, cloudsatDBZe,parasolPix_refl + real(wp),dimension(:),allocatable,target :: & + out1D_1,out1D_2,out1D_3,out1D_4,out1D_5,out1D_6 + real(wp),dimension(:,:,:),allocatable :: & + betamol_in,betamolFlip,pnormFlip,ze_totFlip + + ! Initialize error reporting for output + cosp_simulator(:)='' + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 1) Determine if using full inputs or subset + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (present(start_idx) .and. present(stop_idx)) then + ij=start_idx + ik=stop_idx + else + ij=1 + ik=cospIN%Npoints + endif + Npoints = ik-ij+1 + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 2a) Determine which simulators to run and which statistics to compute + ! - If any of the subcolumn fields are allocated, then run the subcolumn simulators. + ! - If any of the column fields are allocated, then compute the statistics for that + ! simulator, but only save the requested fields. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Start with all simulators and joint-diagnostics off + Lisccp_subcolumn = .false. + Lmisr_subcolumn = .false. + Lcalipso_subcolumn = .false. + Lparasol_subcolumn = .false. + Lcloudsat_subcolumn = .false. + Lmodis_subcolumn = .false. + Lrttov_subcolumn = .false. + Lisccp_column = .false. + Lmisr_column = .false. + Lcalipso_column = .false. + Lparasol_column = .false. + Lcloudsat_column = .false. + Lmodis_column = .false. + Lrttov_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + + ! CLOUDSAT subcolumn + if (associated(cospOUT%cloudsat_Ze_tot)) Lcloudsat_subcolumn = .true. + + ! MODIS subcolumn + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Total_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_High_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Mid_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Low_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_LogMean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean) .or. & + associated(cospOUT%modis_Liquid_Water_Path_Mean) .or. & + associated(cospOUT%modis_Ice_Water_Path_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + Lmodis_subcolumn = .true. + + ! ISCCP subcolumn + if (associated(cospOUT%isccp_boxtau) .or. & + associated(cospOUT%isccp_boxptop)) & + Lisccp_subcolumn = .true. + + ! MISR subcolumn + if (associated(cospOUT%misr_dist_model_layertops)) & + Lmisr_subcolumn = .true. + + ! CALIPOSO subcolumn + if (associated(cospOUT%calipso_tau_tot) .or. & + associated(cospOUT%calipso_beta_mol) .or. & + associated(cospOUT%calipso_temp_tot) .or. & + associated(cospOUT%calipso_betaperp_tot) .or. & + associated(cospOUT%calipso_beta_tot)) & + Lcalipso_subcolumn = .true. + + ! PARASOL subcolumn + if (associated(cospOUT%parasolPix_refl)) & + Lparasol_subcolumn = .true. + + ! RTTOV column + if (associated(cospOUT%rttov_tbs)) & + Lrttov_column = .true. + + ! Set flag to deallocate rttov types (only done on final call to simulator) + if (size(cospOUT%isccp_meantb) .eq. stop_idx) lrttov_cleanUp = .true. + + ! ISCCP column + if (associated(cospOUT%isccp_fq) .or. & + associated(cospOUT%isccp_meanalbedocld) .or. & + associated(cospOUT%isccp_meanptop) .or. & + associated(cospOUT%isccp_meantaucld) .or. & + associated(cospOUT%isccp_totalcldarea) .or. & + associated(cospOUT%isccp_meantb)) then + Lisccp_column = .true. + Lisccp_subcolumn = .true. + endif + + ! MISR column + if (associated(cospOUT%misr_cldarea) .or. & + associated(cospOUT%misr_meanztop) .or. & + associated(cospOUT%misr_fq)) then + Lmisr_column = .true. + Lmisr_subcolumn = .true. + endif + + ! CALIPSO column + if (associated(cospOUT%calipso_cfad_sr) .or. & + associated(cospOUT%calipso_lidarcld) .or. & + associated(cospOUT%calipso_lidarcldphase) .or. & + associated(cospOUT%calipso_cldlayer) .or. & + associated(cospOUT%calipso_cldlayerphase) .or. & + associated(cospOUT%calipso_lidarcldtmp)) then + Lcalipso_column = .true. + Lcalipso_subcolumn = .true. + endif + + ! PARASOL column + if (associated(cospOUT%parasolGrid_refl)) then + Lparasol_column = .true. + Lparasol_subcolumn = .true. + endif + + ! CLOUDSAT column + if (associated(cospOUT%cloudsat_cfad_ze)) then + Lcloudsat_column = .true. + Lcloudsat_subcolumn = .true. + endif + + ! MODIS column + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_High_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Mid_Mean) .or. & + associated(cospOUT%modis_Cloud_Fraction_Low_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_Total_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Water_LogMean) .or. & + associated(cospOUT%modis_Optical_Thickness_Ice_LogMean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean) .or. & + associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean) .or. & + associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean) .or. & + associated(cospOUT%modis_Liquid_Water_Path_Mean) .or. & + associated(cospOUT%modis_Ice_Water_Path_Mean) .or. & + associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then + Lmodis_column = .true. + Lmodis_subcolumn = .true. + endif + + ! Joint simulator products + if (associated(cospOUT%lidar_only_freq_cloud) .or. associated(cospOUT%radar_lidar_tcc)) then + Lcalipso_column = .true. + Lcalipso_subcolumn = .true. + Lcloudsat_column = .true. + Lcloudsat_subcolumn = .true. + Lradar_lidar_tcc = .true. + Llidar_only_freq_cloud = .true. + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 2b) Error Checking + ! Enforce bounds on input fields. If input field is out-of-bounds, report error + ! and turn off simulator + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call cosp_errorCheck(cospgridIN,cospIN,Lisccp_subcolumn,Lisccp_column, & + Lmisr_subcolumn,Lmisr_column,Lmodis_subcolumn,Lmodis_column, & + Lcloudsat_subcolumn,Lcloudsat_column,Lcalipso_subcolumn, & + Lcalipso_column,Lrttov_subcolumn,Lrttov_column, & + Lparasol_subcolumn,Lparasol_column,Lradar_lidar_tcc, & + Llidar_only_freq_cloud,cospOUT,cosp_simulator,nError) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 3) Populate instrument simulator inputs + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (Lisccp_subcolumn .or. Lmodis_subcolumn) then + isccpIN%Npoints => Npoints + isccpIN%Ncolumns => cospIN%Ncolumns + isccpIN%Nlevels => cospIN%Nlevels + isccpIN%emsfc_lw => cospIN%emsfc_lw + isccpIN%skt => cospgridIN%skt + isccpIN%qv => cospgridIN%qv + isccpIN%at => cospgridIN%at + isccpIN%frac_out => cospIN%frac_out + isccpIN%dtau => cospIN%tau_067 + isccpIN%dem => cospIN%emiss_11 + isccpIN%phalf => cospgridIN%phalf + isccpIN%sunlit => cospgridIN%sunlit + isccpIN%pfull => cospgridIN%pfull + endif + + if (Lmisr_subcolumn) then + misrIN%Npoints => Npoints + misrIN%Ncolumns => cospIN%Ncolumns + misrIN%Nlevels => cospIN%Nlevels + misrIN%dtau => cospIN%tau_067 + misrIN%sunlit => cospgridIN%sunlit + misrIN%zfull => cospgridIN%hgt_matrix + misrIN%at => cospgridIN%at + endif + + if (Lcalipso_subcolumn) then + calipsoIN%Npoints => Npoints + calipsoIN%Ncolumns => cospIN%Ncolumns + calipsoIN%Nlevels => cospIN%Nlevels + calipsoIN%beta_mol => cospIN%beta_mol + calipsoIN%betatot => cospIN%betatot + calipsoIN%betatot_liq => cospIN%betatot_liq + calipsoIN%betatot_ice => cospIN%betatot_ice + calipsoIN%tau_mol => cospIN%tau_mol + calipsoIN%tautot => cospIN%tautot + calipsoIN%tautot_liq => cospIN%tautot_liq + calipsoIN%tautot_ice => cospIN%tautot_ice + endif + + if (Lparasol_subcolumn) then + parasolIN%Npoints => Npoints + parasolIN%Nlevels => cospIN%Nlevels + parasolIN%Ncolumns => cospIN%Ncolumns + parasolIN%Nrefl => cospIN%Nrefl + parasolIN%tautot_S_liq => cospIN%tautot_S_liq + parasolIN%tautot_S_ice => cospIN%tautot_S_ice + endif + + if (Lcloudsat_subcolumn) then + cloudsatIN%Npoints => Npoints + cloudsatIN%Nlevels => cospIN%Nlevels + cloudsatIN%Ncolumns => cospIN%Ncolumns + cloudsatIN%z_vol => cospIN%z_vol_cloudsat + cloudsatIN%kr_vol => cospIN%kr_vol_cloudsat + cloudsatIN%g_vol => cospIN%g_vol_cloudsat + cloudsatIN%rcfg => cospIN%rcfg_cloudsat + cloudsatIN%hgt_matrix => cospgridIN%hgt_matrix + endif + + if (Lmodis_subcolumn) then + modisIN%Ncolumns => cospIN%Ncolumns + modisIN%Nlevels => cospIN%Nlevels + modisIN%Npoints => Npoints + modisIN%liqFrac => cospIN%fracLiq + modisIN%tau => cospIN%tau_067 + modisIN%g => cospIN%asym + modisIN%w0 => cospIN%ss_alb + modisIN%Nsunlit = count(cospgridIN%sunlit > 0) + if (modisIN%Nsunlit .gt. 0) then + allocate(modisIN%sunlit(modisIN%Nsunlit),modisIN%pres(modisIN%Nsunlit,cospIN%Nlevels+1)) + modisIN%sunlit = pack((/ (i, i = 1, Npoints ) /),mask = cospgridIN%sunlit > 0) + modisIN%pres = cospgridIN%phalf(int(modisIN%sunlit(:)),:) + endif + if (count(cospgridIN%sunlit <= 0) .gt. 0) then + allocate(modisIN%notSunlit(count(cospgridIN%sunlit <= 0))) + modisIN%notSunlit = pack((/ (i, i = 1, Npoints ) /),mask = .not. cospgridIN%sunlit > 0) + endif + endif + +! if (Lrttov_column) then +! rttovIN%nPoints => Npoints +! rttovIN%nLevels => cospIN%nLevels +! rttovIN%nSubCols => cospIN%nColumns +! rttovIN%zenang => cospgridIN%zenang +! rttovIN%co2 => cospgridIN%co2 +! rttovIN%ch4 => cospgridIN%ch4 +! rttovIN%n2o => cospgridIN%n2o +! rttovIN%co => cospgridIN%co +! rttovIN%surfem => cospgridIN%emis_sfc +! rttovIN%h_surf => cospgridIN%hgt_matrix_half(:,cospIN%Nlevels+1) +! rttovIN%u_surf => cospgridIN%u_sfc +! rttovIN%v_surf => cospgridIN%v_sfc +! rttovIN%t_skin => cospgridIN%skt +! rttovIN%p_surf => cospgridIN%phalf(:,cospIN%Nlevels+1) +! rttovIN%q2m => cospgridIN%qv(:,cospIN%Nlevels) +! rttovIN%t2m => cospgridIN%at(:,cospIN%Nlevels) +! rttovIN%lsmask => cospgridIN%land +! rttovIN%latitude => cospgridIN%lat +! rttovIN%longitude => cospgridIN%lon +! rttovIN%seaice => cospgridIN%seaice +! rttovIN%p => cospgridIN%pfull +! rttovIN%ph => cospgridIN%phalf +! rttovIN%t => cospgridIN%at +! rttovIN%q => cospgridIN%qv +! rttovIN%o3 => cospgridIN%o3 +! ! Below only needed for all-sky RTTOV calculation +! rttovIN%month => cospgridIN%month +! rttovIN%tca => cospgridIN%tca +! rttovIN%cldIce => cospgridIN%cloudIce +! rttovIN%cldLiq => cospgridIN%cloudLiq +! rttovIN%fl_rain => cospgridIN%fl_rain +! rttovIN%fl_snow => cospgridIN%fl_snow +! endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 4) Call subcolumn simulators + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! ISCCP (icarus) subcolumn simulator + if (Lisccp_subcolumn .or. Lmodis_subcolumn) then + ! Allocate space for local variables + allocate(isccpLEVMATCH(Npoints,isccpIN%Ncolumns), & + isccp_boxttop(Npoints,isccpIN%Ncolumns), & + isccp_boxptop(Npoints,isccpIN%Ncolumns), & + isccp_boxtau(Npoints,isccpIN%Ncolumns), isccp_meantbclr(Npoints)) + ! Call simulator + call icarus_subcolumn(isccpIN%npoints,isccpIN%ncolumns,isccpIN%nlevels, & + isccpIN%sunlit,isccpIN%dtau,isccpIN%dem,isccpIN%skt, & + isccpIN%emsfc_lw,isccpIN%qv,isccpIN%at,isccpIN%pfull, & + isccpIN%phalf,isccpIN%frac_out,isccpLEVMATCH, & + isccp_boxtau(:,:),isccp_boxptop(:,:), & + isccp_boxttop(:,:),isccp_meantbclr(:)) + ! Store output (if requested) + if (associated(cospOUT%isccp_boxtau)) then + cospOUT%isccp_boxtau(ij:ik,:) = isccp_boxtau + endif + if (associated(cospOUT%isccp_boxptop)) then + cospOUT%isccp_boxptop(ij:ik,:) = isccp_boxptop + endif + if (associated(cospOUT%isccp_meantbclr)) then + cospOUT%isccp_meantbclr(ij:ik) = isccp_meantbclr + endif + endif + + ! MISR subcolumn simulator + if (Lmisr_subcolumn) then + ! Allocate space for local variables + allocate(misr_boxztop(Npoints,misrIN%Ncolumns), & + misr_boxtau(Npoints,misrIN%Ncolumns), & + misr_dist_model_layertops(Npoints,numMISRHgtBins)) + ! Call simulator + call misr_subcolumn(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau, & + misrIN%zfull,misrIN%at,misrIN%sunlit,misr_boxtau, & + misr_dist_model_layertops,misr_boxztop) + ! Store output (if requested) + if (associated(cospOUT%misr_dist_model_layertops)) then + cospOUT%misr_dist_model_layertops(ij:ik,:) = misr_dist_model_layertops + endif + endif + + ! Calipso subcolumn simulator + if (Lcalipso_subcolumn) then + ! Allocate space for local variables + allocate(calipso_beta_mol(calipsoIN%Npoints,calipsoIN%Nlevels), & + calipso_beta_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels),& + calipso_betaperp_tot(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels)) + ! Call simulator + call lidar_subcolumn(calipsoIN%npoints,calipsoIN%ncolumns,calipsoIN%nlevels, & + calipsoIN%beta_mol,calipsoIN%tau_mol, & + calipsoIN%betatot,calipsoIN%tautot,calipsoIN%betatot_ice, & + calipsoIN%tautot_ice,calipsoIN%betatot_liq, & + calipsoIN%tautot_liq,calipso_beta_mol(:,:), & + calipso_beta_tot(:,:,:),calipso_betaperp_tot(:,:,:)) + ! Store output (if requested) + if (associated(cospOUT%calipso_beta_mol)) & + cospOUT%calipso_beta_mol(ij:ik,calipsoIN%Nlevels:1:-1) = calipso_beta_mol + if (associated(cospOUT%calipso_beta_tot)) & + cospOUT%calipso_beta_tot(ij:ik,:,calipsoIN%Nlevels:1:-1) = calipso_beta_tot + if (associated(cospOUT%calipso_betaperp_tot)) & + cospOUT%calipso_betaperp_tot(ij:ik,:,:) = calipso_betaperp_tot + + endif + + ! PARASOL subcolumn simulator + if (Lparasol_subcolumn) then + ! Allocate space for local variables + allocate(parasolPix_refl(parasolIN%Npoints,parasolIN%Ncolumns,PARASOL_NREFL)) + ! Call simulator + do icol=1,parasolIN%Ncolumns + call parasol_subcolumn(parasolIN%npoints, PARASOL_NREFL, & + parasolIN%tautot_S_liq(1:parasolIN%Npoints,icol), & + parasolIN%tautot_S_ice(1:parasolIN%Npoints,icol), & + parasolPix_refl(:,icol,1:PARASOL_NREFL)) + ! Store output (if requested) + if (associated(cospOUT%parasolPix_refl)) then + cospOUT%parasolPix_refl(ij:ik,icol,1:PARASOL_NREFL) = & + parasolPix_refl(:,icol,1:PARASOL_NREFL) + endif + enddo + endif + + ! Cloudsat (quickbeam) subcolumn simulator + if (Lcloudsat_subcolumn) then + ! Allocate space for local variables + allocate(cloudsatDBZe(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels)) + do icol=1,cloudsatIN%ncolumns + call quickbeam_subcolumn(cloudsatIN%rcfg,cloudsatIN%Npoints,cloudsatIN%Nlevels,& + cloudsatIN%hgt_matrix/1000._wp, & + cloudsatIN%z_vol(:,icol,:), & + cloudsatIN%kr_vol(:,icol,:), & + cloudsatIN%g_vol(:,1,:),cloudsatDBze(:,icol,:)) + enddo + ! Store output (if requested) + if (associated(cospOUT%cloudsat_Ze_tot)) then + cospOUT%cloudsat_Ze_tot(ij:ik,:,:) = cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1) + endif + endif + + if (Lmodis_subcolumn) then + if(modisiN%nSunlit > 0) then + ! Allocate space for local variables + allocate(modisRetrievedTau(modisIN%nSunlit,modisIN%nColumns), & + modisRetrievedSize(modisIN%nSunlit,modisIN%nColumns), & + modisRetrievedPhase(modisIN%nSunlit,modisIN%nColumns), & + modisRetrievedCloudTopPressure(modisIN%nSunlit,modisIN%nColumns)) + ! Call simulator + do i = 1, modisIN%nSunlit + call modis_subcolumn(modisIN%Ncolumns,modisIN%Nlevels,modisIN%pres(i,:), & + modisIN%tau(int(modisIN%sunlit(i)),:,:), & + modisIN%liqFrac(int(modisIN%sunlit(i)),:,:), & + modisIN%g(int(modisIN%sunlit(i)),:,:), & + modisIN%w0(int(modisIN%sunlit(i)),:,:), & + isccp_boxptop(int(modisIN%sunlit(i)),:), & + modisRetrievedPhase(i,:), & + modisRetrievedCloudTopPressure(i,:), & + modisRetrievedTau(i,:),modisRetrievedSize(i,:)) + end do + endif + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 5) Call column simulators + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! ISCCP + if (Lisccp_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if(.not. associated(cospOUT%isccp_meanalbedocld)) then + allocate(out1D_1(Npoints)) + cospOUT%isccp_meanalbedocld(ij:ik) => out1D_1 + endif + if(.not. associated(cospOUT%isccp_meanptop)) then + allocate(out1D_2(Npoints)) + cospOUT%isccp_meanptop(ij:ik) => out1D_2 + endif + if(.not. associated(cospOUT%isccp_meantaucld)) then + allocate(out1D_3(Npoints)) + cospOUT%isccp_meantaucld(ij:ik) => out1D_3 + endif + if(.not. associated(cospOUT%isccp_totalcldarea)) then + allocate(out1D_4(Npoints)) + cospOUT%isccp_totalcldarea(ij:ik) => out1D_4 + endif + if(.not. associated(cospOUT%isccp_meantb)) then + allocate(out1D_5(Npoints)) + cospOUT%isccp_meantb(ij:ik) => out1D_5 + endif + if(.not. associated(cospOUT%isccp_fq)) then + allocate(out1D_6(Npoints*numISCCPTauBins*numISCCPPresBins)) + cospOUT%isccp_fq(ij:ik,1:numISCCPTauBins,1:numISCCPPresBins) => out1D_6 + endif + + ! Call simulator + call icarus_column(isccpIN%npoints, isccpIN%ncolumns,isccp_boxtau(:,:), & + isccp_boxptop(:,:)/100._wp, isccpIN%sunlit,isccp_boxttop, & + cospOUT%isccp_fq(ij:ik,:,:), & + cospOUT%isccp_meanalbedocld(ij:ik), & + cospOUT%isccp_meanptop(ij:ik),cospOUT%isccp_meantaucld(ij:ik), & + cospOUT%isccp_totalcldarea(ij:ik),cospOUT%isccp_meantb(ij:ik)) + cospOUT%isccp_fq(ij:ik,:,:) = cospOUT%isccp_fq(ij:ik,:,7:1:-1) + + ! Check if there is any value slightly greater than 1 + where ((cospOUT%isccp_totalcldarea > 1.0-1.e-5) .and. & + (cospOUT%isccp_totalcldarea < 1.0+1.e-5)) + cospOUT%isccp_totalcldarea = 1.0 + endwhere + + ! Clear up memory (if necessary) + if (allocated(isccp_boxttop)) deallocate(isccp_boxttop) + if (allocated(isccp_boxptop)) deallocate(isccp_boxptop) + if (allocated(isccp_boxtau)) deallocate(isccp_boxtau) + if (allocated(isccp_meantbclr)) deallocate(isccp_meantbclr) + if (allocated(isccpLEVMATCH)) deallocate(isccpLEVMATCH) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%isccp_meanalbedocld) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%isccp_meanptop) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%isccp_meantaucld) + endif + if (allocated(out1D_4)) then + deallocate(out1D_4) + nullify(cospOUT%isccp_totalcldarea) + endif + if (allocated(out1D_5)) then + deallocate(out1D_5) + nullify(cospOUT%isccp_meantb) + endif + if (allocated(out1D_6)) then + deallocate(out1D_6) + nullify(cospOUT%isccp_fq) + endif + endif + + ! MISR + if (Lmisr_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%misr_cldarea)) then + allocate(out1D_1(Npoints)) + cospOUT%misr_cldarea(ij:ik) => out1D_1 + endif + if (.not. associated(cospOUT%misr_meanztop)) then + allocate(out1D_2(Npoints)) + cospOUT%misr_meanztop(ij:ik) => out1D_2 + endif + if (.not. associated(cospOUT%misr_fq)) then + allocate(out1D_3(Npoints*numMISRTauBins*numMISRHgtBins)) + cospOUT%misr_fq(ij:ik,1:numMISRTauBins,1:numMISRHgtBins) => out1D_3 + endif + + ! Call simulator + call misr_column(misrIN%Npoints,misrIN%Ncolumns,misr_boxztop,misrIN%sunlit,& + misr_boxtau,cospOUT%misr_cldarea(ij:ik), & + cospOUT%misr_meanztop(ij:ik),cospOUT%misr_fq(ij:ik,:,:)) + + ! Clear up memory + if (allocated(misr_boxtau)) deallocate(misr_boxtau) + if (allocated(misr_boxztop)) deallocate(misr_boxztop) + if (allocated(misr_dist_model_layertops)) deallocate(misr_dist_model_layertops) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%misr_cldarea) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%misr_meanztop) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%misr_fq) + endif + endif + + ! CALIPSO LIDAR Simulator + if (Lcalipso_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%calipso_cfad_sr)) then + allocate(out1D_1(Npoints*SR_BINS*Nlvgrid)) + cospOUT%calipso_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1 + endif + if (.not. associated(cospOUT%calipso_lidarcld)) then + allocate(out1D_2(Npoints*Nlvgrid)) + cospOUT%calipso_lidarcld(ij:ik,1:Nlvgrid) => out1D_2 + endif + if (.not. associated(cospOUT%calipso_lidarcldphase)) then + allocate(out1D_3(Npoints*Nlvgrid*6)) + cospOUT%calipso_lidarcldphase(ij:ik,1:Nlvgrid,1:6) => out1D_3 + endif + if (.not. associated(cospOUT%calipso_cldlayer)) then + allocate(out1D_4(Npoints*LIDAR_NCAT)) + cospOUT%calipso_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_4 + endif + if (.not. associated(cospOUT%calipso_cldlayerphase)) then + allocate(out1D_5(Npoints*LIDAR_NCAT*6)) + cospOUT%calipso_cldlayerphase(ij:ik,1:LIDAR_NCAT,1:6) => out1D_5 + endif + if (.not. associated(cospOUT%calipso_lidarcldtmp)) then + allocate(out1D_6(Npoints*40*5)) + cospOUT%calipso_lidarcldtmp(ij:ik,1:40,1:5) => out1D_6 + endif + + ! Call simulator + ok_lidar_cfad=.true. + call lidar_column(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels, & + Nlvgrid,SR_BINS,cospgridIN%at(:,:), & + calipso_beta_tot(:,:,:),calipso_betaperp_tot(:,:,:), & + calipso_beta_mol(:,:), & + cospgridIN%phalf(:,2:calipsoIN%Nlevels),ok_lidar_cfad, & + LIDAR_NCAT,cospOUT%calipso_cfad_sr(ij:ik,:,:), & + cospOUT%calipso_lidarcld(ij:ik,:), & + cospOUT%calipso_lidarcldphase(ij:ik,:,:), & + cospOUT%calipso_cldlayer(ij:ik,:), & + cospgridIN%hgt_matrix,cospgridIN%hgt_matrix_half, & + cospOUT%calipso_cldlayerphase(ij:ik,:,:), & + cospOUT%calipso_lidarcldtmp(ij:ik,:,:)) + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval = calipso_histBsct + + ! Free up memory (if necessary) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%calipso_cfad_sr) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%calipso_lidarcld) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%calipso_lidarcldphase) + endif + if (allocated(out1D_4)) then + deallocate(out1D_4) + nullify(cospOUT%calipso_cldlayer) + endif + if (allocated(out1D_5)) then + deallocate(out1D_5) + nullify(cospOUT%calipso_cldlayerphase) + endif + if (allocated(out1D_6)) then + deallocate(out1D_6) + nullify(cospOUT%calipso_lidarcldtmp) + endif + endif + + ! PARASOL + if (Lparasol_column) then + call parasol_column(parasolIN%Npoints,PARASOL_NREFL,parasolIN%Ncolumns, & + cospgridIN%land(:),parasolPix_refl(:,:,:), & + cospOUT%parasolGrid_refl(ij:ik,:)) + if (allocated(parasolPix_refl)) deallocate(parasolPix_refl) + endif + + ! CLOUDSAT + if (Lcloudsat_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%cloudsat_cfad_ze)) then + allocate(out1D_1(Npoints*DBZE_BINS*Nlvgrid)) + cospOUT%cloudsat_cfad_ze(ij:ik,1:DBZE_BINS,1:Nlvgrid) => out1D_1 + endif + + ! Call simulator + call quickbeam_column(cloudsatIN%Npoints,cloudsatIN%Ncolumns,cloudsatIN%Nlevels, & + Nlvgrid,cloudsatDBZe,cospgridIN%hgt_matrix, & + cospgridIN%hgt_matrix_half,cospOUT%cloudsat_cfad_ze(ij:ik,:,:)) + ! Free up memory (if necessary) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%cloudsat_cfad_ze) + endif + endif + + ! MODIS + if (Lmodis_column) then + if(modisiN%nSunlit > 0) then + ! Allocate space for local variables + allocate(modisCftotal(modisIN%nSunlit), modisCfLiquid(modisIN%nSunlit), & + modisCfIce(modisIN%nSunlit),modisCfHigh(modisIN%nSunlit), & + modisCfMid(modisIN%nSunlit),modisCfLow(modisIN%nSunlit), & + modisMeanTauTotal(modisIN%nSunlit), & + modisMeanTauLiquid(modisIN%nSunlit),modisMeanTauIce(modisIN%nSunlit), & + modisMeanLogTauTotal(modisIN%nSunlit), & + modisMeanLogTauLiquid(modisIN%nSunlit), & + modisMeanLogTauIce(modisIN%nSunlit), & + modisMeanSizeLiquid(modisIN%nSunlit), & + modisMeanSizeIce(modisIN%nSunlit), & + modisMeanCloudTopPressure(modisIN%nSunlit), & + modisMeanLiquidWaterPath(modisIN%nSunlit), & + modisMeanIceWaterPath(modisIN%nSunlit), & + modisJointHistogram(modisIN%nSunlit,numMODISTauBins,numMODISPresBins),& + modisJointHistogramIce(modisIN%nSunlit,numModisTauBins,numMODISReffIceBins),& + modisJointHistogramLiq(modisIN%nSunlit,numModisTauBins,numMODISReffLiqBins)) + ! Call simulator + call modis_column(modisIN%nSunlit, modisIN%Ncolumns,modisRetrievedPhase, & + modisRetrievedCloudTopPressure,modisRetrievedTau, & + modisRetrievedSize, modisCfTotal, modisCfLiquid, modisCfIce,& + modisCfHigh, modisCfMid, modisCfLow, modisMeanTauTotal, & + modisMeanTauLiquid, modisMeanTauIce, modisMeanLogTauTotal, & + modisMeanLogTauLiquid, modisMeanLogTauIce, & + modisMeanSizeLiquid, modisMeanSizeIce, & + modisMeanCloudTopPressure, modisMeanLiquidWaterPath, & + modisMeanIceWaterPath, modisJointHistogram, & + modisJointHistogramIce,modisJointHistogramLiq) + ! Store data (if requested) + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) then + cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfTotal + endif + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) then + cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfLiquid + endif + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) then + cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfIce + endif + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) then + cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfHigh + endif + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) then + cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfMid + endif + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) then + cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisCfLow + endif + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) then + cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanTauTotal + endif + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) then + cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanTauLiquid + endif + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) then + cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanTauIce + endif + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) then + cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%sunlit(:))-1)= & + modisMeanLogTauTotal + endif + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) then + cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanLogTauLiquid + endif + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) then + cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanLogTauIce + endif + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) then + cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanSizeLiquid + endif + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) then + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanSizeIce + endif + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) then + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanCloudTopPressure + endif + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) then + cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanLiquidWaterPath + endif + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) then + cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%sunlit(:))-1) = & + modisMeanIceWaterPath + endif + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+ & + int(modisIN%sunlit(:))-1, 1:numModisTauBins, :) = modisJointHistogram(:, :, :) + ! Reorder pressure bins in joint histogram to go from surface to TOA + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,:) = & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik,:,numMODISPresBins:1:-1) + endif + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffIce)) then + cospOUT%modis_Optical_Thickness_vs_ReffIce(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = & + modisJointHistogramIce(:,:,:) + endif + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLiq)) then + cospOUT%modis_Optical_Thickness_vs_ReffLiq(ij+int(modisIN%sunlit(:))-1, 1:numMODISTauBins,:) = & + modisJointHistogramLiq(:,:,:) + endif + + if(modisIN%nSunlit < modisIN%Npoints) then + ! Where it's night and we haven't done the retrievals the values are undefined + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(ij+int(modisIN%notSunlit(:))-1) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij+int(modisIN%notSunlit(:))-1, :, :) = R_UNDEF + end if + else + ! It's nightime everywhere - everything is undefined + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(ij:ik) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(ij:ik, :, :) = R_UNDEF + endif + ! Free up memory (if necessary) + if (allocated(modisRetrievedTau)) deallocate(modisRetrievedTau) + if (allocated(modisRetrievedSize)) deallocate(modisRetrievedSize) + if (allocated(modisRetrievedPhase)) deallocate(modisRetrievedPhase) + if (allocated(modisRetrievedCloudTopPressure)) deallocate(modisRetrievedCloudTopPressure) + if (allocated(modisCftotal)) deallocate(modisCftotal) + if (allocated(modisCfLiquid)) deallocate(modisCfLiquid) + if (allocated(modisCfIce)) deallocate(modisCfIce) + if (allocated(modisCfHigh)) deallocate(modisCfHigh) + if (allocated(modisCfMid)) deallocate(modisCfMid) + if (allocated(modisCfLow)) deallocate(modisCfLow) + if (allocated(modisMeanTauTotal)) deallocate(modisMeanTauTotal) + if (allocated(modisMeanTauLiquid)) deallocate(modisMeanTauLiquid) + if (allocated(modisMeanTauIce)) deallocate(modisMeanTauIce) + if (allocated(modisMeanLogTauTotal)) deallocate(modisMeanLogTauTotal) + if (allocated(modisMeanLogTauLiquid)) deallocate(modisMeanLogTauLiquid) + if (allocated(modisMeanLogTauIce)) deallocate(modisMeanLogTauIce) + if (allocated(modisMeanSizeLiquid)) deallocate(modisMeanSizeLiquid) + if (allocated(modisMeanSizeIce)) deallocate(modisMeanSizeIce) + if (allocated(modisMeanCloudTopPressure)) deallocate(modisMeanCloudTopPressure) + if (allocated(modisMeanLiquidWaterPath)) deallocate(modisMeanLiquidWaterPath) + if (allocated(modisMeanIceWaterPath)) deallocate(modisMeanIceWaterPath) + if (allocated(modisJointHistogram)) deallocate(modisJointHistogram) + if (allocated(modisJointHistogramIce)) deallocate(modisJointHistogramIce) + if (allocated(modisJointHistogramLiq)) deallocate(modisJointHistogramLiq) + if (allocated(isccp_boxttop)) deallocate(isccp_boxttop) + if (allocated(isccp_boxptop)) deallocate(isccp_boxptop) + if (allocated(isccp_boxtau)) deallocate(isccp_boxtau) + if (allocated(isccp_meantbclr)) deallocate(isccp_meantbclr) + if (allocated(isccpLEVMATCH)) deallocate(isccpLEVMATCH) + endif + + ! RTTOV +! if (lrttov_column) then +! call rttov_column(rttovIN%nPoints,rttovIN%nLevels,rttovIN%nSubCols,rttovIN%q, & +! rttovIN%p,rttovIN%t,rttovIN%o3,rttovIN%ph,rttovIN%h_surf, & +! rttovIN%u_surf,rttovIN%v_surf,rttovIN%p_surf,rttovIN%t_skin, & +! rttovIN%t2m,rttovIN%q2m,rttovIN%lsmask,rttovIN%longitude, & +! rttovIN%latitude,rttovIN%seaice,rttovIN%co2,rttovIN%ch4, & +! rttovIN%n2o,rttovIN%co,rttovIN%zenang,lrttov_cleanUp, & +! cospOUT%rttov_tbs(ij:ik,:),cosp_simulator(nError+1), & +! ! Optional arguments for surface emissivity calculation +! month=rttovIN%month) +! ! Optional arguments to rttov for all-sky calculation +! ! rttovIN%month, rttovIN%tca,rttovIN%cldIce,rttovIN%cldLiq, & +! ! rttovIN%fl_rain,rttovIN%fl_snow) +! endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 6) Compute multi-instrument products + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! CLOUDSAT/CALIPSO products + if (Lradar_lidar_tcc .or. Llidar_only_freq_cloud) then + + if (use_vgrid) then + allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,Nlvgrid), & + radar_lidar_tcc(cloudsatIN%Npoints)) + allocate(betamol_in(cloudsatIN%Npoints,1,cloudsatIN%Nlevels), & + betamolFlip(cloudsatIN%Npoints,1,Nlvgrid), & + pnormFlip(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid), & + Ze_totFlip(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid)) + + betamol_in(:,1,:) = calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1) + call cosp_change_vertical_grid(cloudsatIN%Npoints,1,cloudsatIN%Nlevels, & + cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1), & + cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1),betamol_in, & + Nlvgrid,vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1), & + betamolFlip(:,1,Nlvgrid:1:-1)) + + call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1), & + cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1), & + calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid, & + vgrid_zl(Nlvgrid:1:-1),vgrid_zu(Nlvgrid:1:-1),pnormFlip(:,:,Nlvgrid:1:-1)) + + call cosp_change_vertical_grid(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + cloudsatIN%Nlevels,cospgridIN%hgt_matrix(:,cloudsatIN%Nlevels:1:-1), & + cospgridIN%hgt_matrix_half(:,cloudsatIN%Nlevels:1:-1), & + cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),Nlvgrid,vgrid_zl(Nlvgrid:1:-1), & + vgrid_zu(Nlvgrid:1:-1),Ze_totFlip(:,:,Nlvgrid:1:-1),log_units=.true.) + + call cosp_lidar_only_cloud(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + Nlvgrid,pnormFlip,betamolFlip,Ze_totFlip, & + lidar_only_freq_cloud,radar_lidar_tcc) + + deallocate(betamol_in,betamolFlip,pnormFlip,ze_totFlip) + else + allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,cloudsatIN%Nlevels), & + radar_lidar_tcc(cloudsatIN%Npoints)) + call cosp_lidar_only_cloud(cloudsatIN%Npoints,cloudsatIN%Ncolumns, & + cospIN%Nlevels,calipso_beta_tot(:,:,cloudsatIN%Nlevels:1:-1), & + calipso_beta_mol(:,cloudsatIN%Nlevels:1:-1), & + cloudsatDBZe(:,:,cloudsatIN%Nlevels:1:-1),lidar_only_freq_cloud, & + radar_lidar_tcc) + endif + + ! Store, when necessary + if (associated(cospOUT%lidar_only_freq_cloud)) then + cospOUT%lidar_only_freq_cloud(ij:ik,:) = lidar_only_freq_cloud + endif + if (associated(cospOUT%radar_lidar_tcc)) then + cospOUT%radar_lidar_tcc(ij:ik) = radar_lidar_tcc + endif + + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 7) Cleanup + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (Lisccp_subcolumn .or. Lmodis_subcolumn) then + nullify(isccpIN%Npoints,isccpIN%Ncolumns,isccpIN%Nlevels,isccpIN%emsfc_lw, & + isccpIN%skt,isccpIN%qv,isccpIN%at,isccpIN%frac_out,isccpIN%dtau, & + isccpIN%dem,isccpIN%phalf,isccpIN%sunlit,isccpIN%pfull) + endif + + if (Lmisr_subcolumn) then + nullify(misrIN%Npoints,misrIN%Ncolumns,misrIN%Nlevels,misrIN%dtau,misrIN%sunlit, & + misrIN%zfull,misrIN%at) + endif + + if (Lcalipso_subcolumn) then + nullify(calipsoIN%Npoints,calipsoIN%Ncolumns,calipsoIN%Nlevels,calipsoIN%beta_mol,& + calipsoIN%betatot,calipsoIN%betatot_liq,calipsoIN%betatot_ice, & + calipsoIN%tau_mol,calipsoIN%tautot,calipsoIN%tautot_liq,calipsoIN%tautot_ice) + endif + + if (Lparasol_subcolumn) then + nullify(parasolIN%Npoints,parasolIN%Nlevels,parasolIN%Ncolumns,parasolIN%Nrefl, & + parasolIN%tautot_S_liq,parasolIN%tautot_S_ice) + endif + + if (Lcloudsat_subcolumn) then + nullify(cloudsatIN%Npoints,cloudsatIN%Nlevels,cloudsatIN%Ncolumns,cloudsatIN%rcfg,& + cloudsatIN%kr_vol,cloudsatIN%g_vol,cloudsatIN%z_vol,cloudsatIN%hgt_matrix) + endif + + if (Lmodis_subcolumn) then + nullify(modisIN%Npoints,modisIN%Ncolumns,modisIN%Nlevels,modisIN%tau,modisIN%g, & + modisIN%liqFrac,modisIN%w0) + if (allocated(modisIN%sunlit)) deallocate(modisIN%sunlit) + if (allocated(modisIN%notSunlit)) deallocate(modisIN%notSunlit) + if (allocated(modisIN%pres)) deallocate(modisIN%pres) + endif + + if (allocated(calipso_beta_tot)) deallocate(calipso_beta_tot) + if (allocated(calipso_beta_mol)) deallocate(calipso_beta_mol) + if (allocated(calipso_betaperp_tot)) deallocate(calipso_betaperp_tot) + if (allocated(cloudsatDBZe)) deallocate(cloudsatDBZe) + if (allocated(lidar_only_freq_cloud)) deallocate(lidar_only_freq_cloud) + if (allocated(radar_lidar_tcc)) deallocate(radar_lidar_tcc) + + end function COSP_SIMULATOR + ! ###################################################################################### + ! SUBROUTINE cosp_init + ! ###################################################################################### + SUBROUTINE COSP_INIT(Lisccp,Lmodis,Lmisr,Lcloudsat,Lcalipso,Lparasol,Lrttov, & + Npoints,Nlevels,cloudsat_radar_freq,cloudsat_k2, & + cloudsat_use_gas_abs,cloudsat_do_ray,isccp_top_height, & + isccp_top_height_direction,surface_radar,rcfg,rttov_Nchannels, & + rttov_Channels,rttov_platform,rttov_satellite,rttov_instrument, & + lusevgrid,luseCSATvgrid,Nvgrid,cloudsat_micro_scheme,cospOUT) + + ! INPUTS + logical,intent(in) :: Lisccp,Lmodis,Lmisr,Lcloudsat,Lcalipso,Lparasol,Lrttov + integer,intent(in) :: & + cloudsat_use_gas_abs, & ! + cloudsat_do_ray, & ! + isccp_top_height, & ! + isccp_top_height_direction, & ! + Npoints, & ! + Nlevels, & ! + Nvgrid, & ! Number of levels for new L3 grid + surface_radar, & ! + rttov_Nchannels, & ! Number of RTTOV channels + rttov_platform, & ! RTTOV platform + rttov_satellite, & ! RTTOV satellite + rttov_instrument ! RTTOV instrument + integer,intent(in),dimension(RTTOV_MAX_CHANNELS) :: & + rttov_channels ! RTTOV channels + real(wp),intent(in) :: & + cloudsat_radar_freq, & ! + cloudsat_k2 ! + logical,intent(in) :: & + lusevgrid, & ! Switch to use different vertical grid + luseCSATvgrid ! Switch to use CLOUDSAT grid spacing for new + ! vertical grid + character(len=64),intent(in) :: & + cloudsat_micro_scheme ! Microphysical scheme used by CLOUDSAT + type(cosp_outputs),intent(inout) :: cospOUT + + ! OUTPUTS + type(radar_cfg) :: rcfg + + ! Local variables + integer :: i + real(wp) :: zstep + + ! Initialize MODIS optical-depth bin boundaries for joint-histogram. (defined in cosp_config.F90) + if (.not. allocated(modis_histTau)) then + allocate(modis_histTau(ntau+1),modis_histTauEdges(2,ntau),modis_histTauCenters(ntau)) + numMODISTauBins = ntau + modis_histTau = tau_binBounds + modis_histTauEdges = tau_binEdges + modis_histTauCenters = tau_binCenters + endif + + ! Set up vertical grid used by CALIPSO and CLOUDSAT L3 + use_vgrid = lusevgrid + + if (use_vgrid) then + Nlvgrid = Nvgrid + print*,'allocation vgrid_zl zu z dans COSP_INIT' + allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid)) + ! CloudSat grid requested + if (luseCSATvgrid) zstep = 480._wp + ! Other grid requested. Constant vertical spacing with top at 20 km + if (.not. luseCSATvgrid) zstep = 20000._wp/Nvgrid + do i=1,Nvgrid + vgrid_zl(Nlvgrid-i+1) = (i-1)*zstep + vgrid_zu(Nlvgrid-i+1) = i*zstep + enddo + vgrid_z = (vgrid_zl+vgrid_zu)/2._wp + else + Nlvgrid = Nlevels + allocate(vgrid_zl(Nlvgrid),vgrid_zu(Nlvgrid),vgrid_z(Nlvgrid)) + endif + + ! Initialize simulators + if (Lisccp) call cosp_isccp_init(isccp_top_height,isccp_top_height_direction) + if (Lmodis) call cosp_modis_init() + if (Lmisr) call cosp_misr_init() + !if (Lrttov) call cosp_rttov_init(rttov_Nchannels,rttov_platform,rttov_satellite, & + ! rttov_instrument,rttov_channels) +! if (Lrttov) call cosp_rttov_init() + if (Lcloudsat) call cosp_cloudsat_init(cloudsat_radar_freq,cloudsat_k2, & + cloudsat_use_gas_abs,cloudsat_do_ray,R_UNDEF,N_HYDRO, surface_radar, & + rcfg,cloudsat_micro_scheme) + if (Lcalipso) call cosp_calipso_init() + if (Lparasol) call cosp_parasol_init() + + linitialization = .FALSE. + END SUBROUTINE COSP_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_cleanUp + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_cleanUp() + deallocate(vgrid_zl,vgrid_zu,vgrid_z) + end subroutine cosp_cleanUp + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_errorCheck + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_errorCheck(cospgridIN,cospIN,Lisccp_subcolumn,Lisccp_column,Lmisr_subcolumn,Lmisr_column, & + Lmodis_subcolumn,Lmodis_column,Lcloudsat_subcolumn,Lcloudsat_column,Lcalipso_subcolumn, & + Lcalipso_column,Lrttov_subcolumn,Lrttov_column,Lparasol_subcolumn,Lparasol_column, & + Lradar_lidar_tcc,Llidar_only_freq_cloud,cospOUT,errorMessage,nError) + ! Inputs + type(cosp_column_inputs),intent(in) :: & + cospgridIN ! Model grid inputs to COSP + type(cosp_optical_inputs),intent(in) :: & + cospIN ! Derived (optical) input to COSP + + ! Outputs + logical,intent(inout) :: & + Lisccp_subcolumn, & ! ISCCP subcolumn simulator on/off switch + Lisccp_column, & ! ISCCP column simulator on/off switch + Lmisr_subcolumn, & ! MISR subcolumn simulator on/off switch + Lmisr_column, & ! MISR column simulator on/off switch + Lmodis_subcolumn, & ! MODIS subcolumn simulator on/off switch + Lmodis_column, & ! MODIS column simulator on/off switch + Lcloudsat_subcolumn, & ! CLOUDSAT subcolumn simulator on/off switch + Lcloudsat_column, & ! CLOUDSAT column simulator on/off switch + Lcalipso_subcolumn, & ! CALIPSO subcolumn simulator on/off switch + Lcalipso_column, & ! CALIPSO column simulator on/off switch + Lparasol_subcolumn, & ! PARASOL subcolumn simulator on/off switch + Lparasol_column, & ! PARASOL column simulator on/off switch + Lrttov_subcolumn, & ! RTTOV subcolumn simulator on/off switch + Lrttov_column, & ! RTTOV column simulator on/off switch + Lradar_lidar_tcc, & ! On/Off switch for joint Calipso/Cloudsat product + Llidar_only_freq_cloud ! On/Off switch for joint Calipso/Cloudsat product + type(cosp_outputs),intent(inout) :: & + cospOUT ! COSP Outputs + character(len=256),dimension(100) :: errorMessage + integer,intent(out) :: nError + + ! Local variables + character(len=100) :: parasolErrorMessage + + nError = 0 + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! PART 1: Check input array values for out-of-bounds values. When an out-of-bound value + ! is encountered, COSP outputs that are dependent on that input are filled with + ! an undefined value (set in cosp_config.f90) and if necessary, that simulator + ! is turned off. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (any(cospgridIN%sunlit .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%sunlit contains values out of range (0 or 1)' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + if (any(cospgridIN%at .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%at contains values out of range (at<0), expected units (K)' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lrttov_subcolumn = .false. + Lcalipso_column = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospgridIN%pfull .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%pfull contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + if (any(cospgridIN%phalf .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%phalf contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lrttov_subcolumn = .false. + Lmodis_subcolumn = .false. + Lmodis_column = .false. + Lcalipso_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + endif + if (any(cospgridIN%qv .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%qv contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + if (any(cospgridIN%hgt_matrix .lt. -300)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix contains values out of range' + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lcalipso_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospgridIN%hgt_matrix_half .lt. -300)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%hgt_matrix_half contains values out of range' + Lrttov_subcolumn = .false. + Lcloudsat_column = .false. + Lcalipso_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospgridIN%land .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%land contains values out of range' + Lrttov_subcolumn = .false. + Lcalipso_column = .false. + Lparasol_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + if (any(cospgridIN%skt .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%skt contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + endif + + ! RTTOV Inputs + if (cospgridIN%zenang .lt. -90. .OR. cospgridIN%zenang .gt. 90) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%zenang contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%co2 .lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co2 contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%ch4 .lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%ch4 contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%n2o .lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%n2o contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (cospgridIN%co.lt. 0) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%co contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%o3 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%o3 contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%emis_sfc .lt. 0. .OR. cospgridIN%emis_sfc .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%emis_sfc contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%u_sfc .lt. -100. .OR. cospgridIN%u_sfc .gt. 100.)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%u_sfc contains values out of range' + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + Lrttov_subcolumn = .false. + endif + if (any(cospgridIN%v_sfc .lt. -100. .OR. cospgridIN%v_sfc .gt. 100.)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%v_sfc contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + if (any(cospgridIN%lat .lt. -90 .OR. cospgridIN%lat .gt. 90)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%lat contains values out of range' + Lrttov_subcolumn = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + + ! COSP_INPUTS + if (cospIN%emsfc_lw .lt. 0. .OR. cospIN%emsfc_lw .gt. 1.) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emsfc_lw contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + + endif + if (any(cospIN%tau_067 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_067 contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + Lmisr_subcolumn = .false. + Lmisr_column = .false. + Lmodis_subcolumn = .false. + Lmodis_column = .false. + + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_fq)) cospOUT%misr_fq(:,:,:) = R_UNDEF + if (associated(cospOUT%misr_dist_model_layertops)) cospOUT%misr_dist_model_layertops(:,:) = R_UNDEF + if (associated(cospOUT%misr_meanztop)) cospOUT%misr_meanztop(:) = R_UNDEF + if (associated(cospOUT%misr_cldarea)) cospOUT%misr_cldarea(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + + endif + if (any(cospIN%emiss_11 .lt. 0. .OR. cospIN%emiss_11 .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%emiss_11 contains values out of range' + Lisccp_subcolumn = .false. + Lisccp_column = .false. + if (associated(cospOUT%isccp_totalcldarea)) cospOUT%isccp_totalcldarea(:) = R_UNDEF + if (associated(cospOUT%isccp_meantb)) cospOUT%isccp_meantb(:) = R_UNDEF + if (associated(cospOUT%isccp_meantbclr)) cospOUT%isccp_meantbclr(:) = R_UNDEF + if (associated(cospOUT%isccp_meanptop)) cospOUT%isccp_meanptop(:) = R_UNDEF + if (associated(cospOUT%isccp_meantaucld)) cospOUT%isccp_meantaucld(:) = R_UNDEF + if (associated(cospOUT%isccp_meanalbedocld)) cospOUT%isccp_meanalbedocld(:) = R_UNDEF + if (associated(cospOUT%isccp_boxtau)) cospOUT%isccp_boxtau(:,:) = R_UNDEF + if (associated(cospOUT%isccp_boxptop)) cospOUT%isccp_boxptop(:,:) = R_UNDEF + if (associated(cospOUT%isccp_fq)) cospOUT%isccp_fq(:,:,:) = R_UNDEF + + endif + if (any(cospIN%asym .lt. -1. .OR. cospIN%asym .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%asym contains values out of range' + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + if (any(cospIN%ss_alb .lt. 0 .OR. cospIN%ss_alb .gt. 1)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%ss_alb contains values out of range' + Lmodis_subcolumn = .false. + Lmodis_column = .false. + if (associated(cospOUT%modis_Cloud_Fraction_Total_Mean)) & + cospOUT%modis_Cloud_Fraction_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Water_Mean)) & + cospOUT%modis_Cloud_Fraction_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Ice_Mean)) & + cospOUT%modis_Cloud_Fraction_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_High_Mean)) & + cospOUT%modis_Cloud_Fraction_High_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Mid_Mean)) & + cospOUT%modis_Cloud_Fraction_Mid_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Fraction_Low_Mean)) & + cospOUT%modis_Cloud_Fraction_Low_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_Mean)) & + cospOUT%modis_Optical_Thickness_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_Mean)) & + cospOUT%modis_Optical_Thickness_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_Mean)) & + cospOUT%modis_Optical_Thickness_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Total_LogMean)) & + cospOUT%modis_Optical_Thickness_Total_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Water_LogMean)) & + cospOUT%modis_Optical_Thickness_Water_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_Ice_LogMean)) & + cospOUT%modis_Optical_Thickness_Ice_LogMean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Water_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Particle_Size_Ice_Mean)) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Cloud_Top_Pressure_Total_Mean)) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Liquid_Water_Path_Mean)) & + cospOUT%modis_Liquid_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Ice_Water_Path_Mean)) & + cospOUT%modis_Ice_Water_Path_Mean(:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffICE)) & + cospOUT%modis_Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + if (associated(cospOUT%modis_Optical_Thickness_vs_ReffLIQ)) & + cospOUT%modis_Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + endif + if (any(cospIN%betatot .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%betatot_liq .lt. 0)) then + nError=nError+1 + errorMessage(nError) = ('ERROR: COSP input variable: cospIN%betatot_liq contains values out of range') + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%betatot_ice .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_ice contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%beta_mol .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospIN%tautot .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tautot_liq .lt. 0)) then + nError=nError+1 + errorMessage(nError) = ('ERROR: COSP input variable: cospIN%tautot_liq contains values out of range') + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tautot_ice .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_ice contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tau_mol .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + if (associated(cospOUT%calipso_cfad_sr)) cospOUT%calipso_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcld)) cospOUT%calipso_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldphase)) cospOUT%calipso_lidarcldphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayer)) cospOUT%calipso_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldlayerphase)) cospOUT%calipso_cldlayerphase(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtmp)) cospOUT%calipso_lidarcldtmp(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_srbval)) cospOUT%calipso_srbval(:) = R_UNDEF + endif + if (any(cospIN%tautot_S_liq .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_liq contains values out of range' + Lparasol_subcolumn = .false. + Lparasol_column = .false. + if (associated(cospOUT%parasolPix_refl)) cospOUT%parasolPix_refl(:,:,:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + if (any(cospIN%tautot_S_ice .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_S_ice contains values out of range' + Lparasol_subcolumn = .false. + Lparasol_column = .false. + if (associated(cospOUT%parasolPix_refl)) cospOUT%parasolPix_refl(:,:,:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + if (any(cospIN%z_vol_cloudsat .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%z_vol_cloudsat contains values out of range' + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospIN%kr_vol_cloudsat .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%kr_vol_cloudsat contains values out of range' + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (any(cospIN%g_vol_cloudsat .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%g_vol_cloudsat contains values out of range' + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (associated(cospOUT%cloudsat_Ze_tot)) cospOUT%cloudsat_Ze_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Part 2: Check input fields array size for consistency. This needs to be done for each + ! simulator + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! ISCCP + if (size(cospIN%frac_out,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. & + size(cospIN%emiss_11,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%skt) .ne. cospIN%Npoints .OR. & + size(cospgridIN%qv,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%at,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%phalf,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%sunlit) .ne. cospIN%Npoints .OR. & + size(cospgridIN%pfull,1) .ne. cospIN%Npoints) then + Lisccp_subcolumn = .false. + Lisccp_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(isccp_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%frac_out,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tau_067,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%emiss_11,2) .ne. cospIN%Ncolumns) then + Lisccp_subcolumn = .false. + Lisccp_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(isccp_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%frac_out,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%emiss_11,3) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%qv,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%at,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%pfull,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%phalf,2) .ne. cospIN%Nlevels+1) then + Lisccp_subcolumn = .false. + Lisccp_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(isccp_simulator): The number of levels in the input fields are inconsistent' + endif + + ! MISR + if (size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%sunlit) .ne. cospIN%Npoints .OR. & + size(cospgridIN%hgt_matrix,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%at,1) .ne. cospIN%Npoints) then + Lmisr_subcolumn = .false. + Lmisr_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(misr_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%tau_067,2) .ne. cospIN%Ncolumns) then + Lmisr_subcolumn = .false. + Lmisr_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(misr_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%hgt_matrix,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%at,2) .ne. cospIN%Nlevels) then + Lmisr_subcolumn = .false. + Lmisr_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(misr_simulator): The number of levels in the input fields are inconsistent' + endif + + ! MODIS + if (size(cospIN%fracLiq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_067,1) .ne. cospIN%Npoints .OR. & + size(cospIN%asym,1) .ne. cospIN%Npoints .OR. & + size(cospIN%ss_alb,1) .ne. cospIN%Npoints) then + Lmodis_subcolumn = .false. + Lmodis_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(modis_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%fracLiq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tau_067,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%asym,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%ss_alb,2) .ne. cospIN%Ncolumns) then + Lmodis_subcolumn = .false. + Lmodis_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(modis_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%fracLiq,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_067,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%asym,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%ss_alb,3) .ne. cospIN%Nlevels) then + Lmodis_subcolumn = .false. + Lmodis_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(modis_simulator): The number of levels in the input fields are inconsistent' + endif + + ! CLOUDSAT + if (size(cospIN%z_vol_cloudsat,1) .ne. cospIN%Npoints .OR. & + size(cospIN%kr_vol_cloudsat,1) .ne. cospIN%Npoints .OR. & + size(cospIN%g_vol_cloudsat,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%hgt_matrix,1) .ne. cospIN%Npoints) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%z_vol_cloudsat,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%kr_vol_cloudsat,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%g_vol_cloudsat,2) .ne. cospIN%Ncolumns) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%z_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%kr_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%g_vol_cloudsat,3) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%hgt_matrix,2) .ne. cospIN%Nlevels) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(cloudsat_simulator): The number of levels in the input fields are inconsistent' + endif + + ! CALIPSO + if (size(cospIN%beta_mol,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_liq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_ice,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_mol,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_liq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_ice,1) .ne. cospIN%Npoints) then + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(calipso_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%betatot,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%betatot_liq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%betatot_ice,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_liq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_ice,2) .ne. cospIN%Ncolumns) then + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(calipso_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%beta_mol,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_liq,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_ice,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_mol,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_liq,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_ice,3) .ne. cospIN%Nlevels) then + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(calipso_simulator): The number of levels in the input fields are inconsistent' + endif + + ! PARASOL + if (size(cospIN%tautot_S_liq,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_S_ice,1) .ne. cospIN%Npoints) then + Lparasol_subcolumn = .false. + Lparasol_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(parasol_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%tautot_S_liq,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_S_ice,2) .ne. cospIN%Ncolumns) then + Lparasol_subcolumn = .false. + Lparasol_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(parasol_simulator): The number of levels in the input fields are inconsistent' + endif + + ! RTTOV + if (size(cospgridIN%pfull,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%at,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%qv,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%hgt_matrix_half,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%u_sfc) .ne. cospIN%Npoints .OR. & + size(cospgridIN%v_sfc) .ne. cospIN%Npoints .OR. & + size(cospgridIN%skt) .ne. cospIN%Npoints .OR. & + size(cospgridIN%phalf,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%qv,1) .ne. cospIN%Npoints .OR. & + size(cospgridIN%land) .ne. cospIN%Npoints .OR. & + size(cospgridIN%lat) .ne. cospIN%Npoints) then + Lrttov_subcolumn = .false. + Lrttov_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(rttov_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospgridIN%pfull,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%at,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%qv,2) .ne. cospIN%Nlevels .OR. & + size(cospgridIN%hgt_matrix_half,2) .ne. cospIN%Nlevels+1 .OR. & + size(cospgridIN%phalf,2) .ne. cospIN%Nlevels+1 .OR. & + size(cospgridIN%qv,2) .ne. cospIN%Nlevels) then + Lrttov_subcolumn = .false. + Lrttov_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(rttov_simulator): The number of levels in the input fields are inconsistent' + endif + + end subroutine cosp_errorCheck + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_calipso_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_calipso_interface.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_calipso_interface.F90 (revision 3358) @@ -0,0 +1,84 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_CALIPSO_INTERFACE + USE COSP_KINDS, ONLY: wp + USE MOD_LIDAR_SIMULATOR, ONLY: alpha,beta,gamma + IMPLICIT NONE + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE calipso_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type calipso_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + + real(wp),dimension(:,:),pointer :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol ! Molecular optical depth + real(wp),dimension(:,:,:),pointer :: & + betatot, & ! + tautot, & ! Optical thickess integrated from top + betatot_ice, & ! Backscatter coefficient for ice particles + betatot_liq, & ! Backscatter coefficient for liquid particles + tautot_ice, & ! Total optical thickness of ice + tautot_liq ! Total optical thickness of liq + real(wp),dimension(:,:,:,:),pointer :: & + taupart + end type calipso_IN + +CONTAINS + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_calipso_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_calipso_init() + + ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the + ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles + ! derived from CALIPSO-GOCCP observations at 120m vertical grid + ! (Cesana and Chepfer, JGR, 2013). + ! + ! Relationship between ATBice and ATBperp,ice for ice particles: + ! ATBperp,ice = Alpha*ATBice + ! Relationship between ATBice and ATBperp,ice for liquid particles: + ! ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice + Alpha = 0.2904_wp + Beta = 0.4099_wp + Gamma = 0.009_wp + + end subroutine cosp_calipso_init + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_CALIPSO_INTERFACE Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_cloudsat_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_cloudsat_interface.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_cloudsat_interface.F90 (revision 3358) @@ -0,0 +1,147 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_CLOUDSAT_INTERFACE + USE MOD_COSP_CONFIG, ONLY: DBZE_BINS,CFAD_ZE_MIN,CFAD_ZE_WIDTH,SR_BINS,DBZE_MAX, & + DBZE_MIN + USE COSP_KINDS, ONLY: wp + USE quickbeam, ONLY: quickbeam_init,radar_cfg,Re_MAX_BIN,Re_BIN_LENGTH + IMPLICIT NONE + + ! Directory where LUTs will be stored + character(len=120) :: RADAR_SIM_LUT_DIRECTORY = './' + logical :: RADAR_SIM_LOAD_scale_LUTs_flag = .false. + logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false. + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cloudsat_IN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type cloudsat_IN + integer,pointer :: & + Npoints, & ! Number of horizontal grid-points + Nlevels, & ! Number of vertical levels + Ncolumns ! Number of subcolumns + real(wp),pointer :: & + hgt_matrix(:,:), & ! Height of hydrometeors (km) + z_vol(:,:,:), & ! Effective reflectivity factor (mm^6/m^3) + kr_vol(:,:,:), & ! Attenuation coefficient hydro (dB/km) + g_vol(:,:,:), & ! Attenuation coefficient gases (dB/km) + g_to_vol_in(:,:) ! Gaseous atteunation, radar to vol (dB) + type(radar_cfg),pointer :: rcfg ! Radar simulator configuration + end type cloudsat_IN + +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_cloudsat_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CLOUDSAT_INIT(radar_freq,k2,use_gas_abs,do_ray,undef,nhydro, & + surface_radar,rcfg,cloudsat_micro_scheme,load_LUT) + ! INPUTS + real(wp),intent(in) :: & + radar_freq, & ! Radar frequency (GHz) + k2, & ! |K|^2, the dielectric constant + undef ! Undefined + integer,intent(in) :: & + use_gas_abs, & ! 1 = do gaseous abs calcs, 0=no gasesous absorbtion calculated, + ! 2 = calculate absorption for first profile on all profiles + do_ray, & ! + nhydro, & ! + surface_radar + logical,intent(in),optional :: & + load_LUT + character(len=64),intent(in) :: & + cloudsat_micro_scheme + + ! OUTPUTS + type(radar_cfg) :: & + rcfg ! + + ! LOCAL VARIABLES + character(len=240) :: LUT_file_name + logical :: local_load_LUT + integer :: j + + if (present(load_LUT)) then + local_load_LUT = load_LUT + else + local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag + endif + + write(*,*) 'RADAR_SIM microphysics scheme is set to: ',& + trim(cloudsat_micro_scheme) + + ! LUT file name + LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // & + trim(cloudsat_micro_scheme) + + ! Initialize for NEW radar-configurarion derived type (radar_cfg) + rcfg%freq = radar_freq + rcfg%k2 = k2 + rcfg%use_gas_abs = use_gas_abs + rcfg%do_ray = do_ray + rcfg%nhclass = nhydro + rcfg%load_scale_LUTs = local_load_LUT + rcfg%update_scale_LUTs = .false. + rcfg%scale_LUT_file_name = LUT_file_name + rcfg%N_scale_flag = .false. + rcfg%fc = undef + rcfg%rho_eff = undef + rcfg%Z_scale_flag = .false. + rcfg%Ze_scaled = 0._wp + rcfg%Zr_scaled = 0._wp + rcfg%kr_scaled = 0._wp + + ! Set up Re bin "structure" for z_scaling + rcfg%base_list(1)=0 + do j=1,Re_MAX_BIN + rcfg%step_list(j)=0.1_wp+0.1_wp*((j-1)**1.5) + if(rcfg%step_list(j)>Re_BIN_LENGTH) then + rcfg%step_list(j)=Re_BIN_LENGTH + endif + if(j>1) then + rcfg%base_list(j)=rcfg%base_list(j-1)+floor(Re_BIN_LENGTH/rcfg%step_list(j-1)) + endif + enddo + + ! Set flag denoting position of radar + if (surface_radar == 1) then + rcfg%radar_at_layer_one = .false. + else + rcfg%radar_at_layer_one = .true. + endif + + END SUBROUTINE COSP_CLOUDSAT_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_CLOUDSAT_INTERFACE Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_config.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_config.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_config.F90 (revision 3358) @@ -0,0 +1,340 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added definitions of ISCCP axes +! Oct 2008 - H. Chepfer - Added PARASOL_NREFL +! Jun 2010 - R. Marchand - Modified to support quickbeam V3, added ifdef for +! hydrometeor definitions +! May 2015 - D. Swales - Tidied up. Set up appropriate fields during initialization. +! June 2015- D. Swales - Moved hydrometeor class variables to hydro_class_init in +! the module quickbeam_optics. +! Mar 2016 - D. Swales - Added scops_ccfrac. Was previously hardcoded in prec_scops.f90. +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +MODULE MOD_COSP_CONFIG + USE COSP_KINDS, ONLY: wp,dp + USE mod_phys_lmdz_para + IMPLICIT NONE + + ! ##################################################################################### + ! Common COSP information + ! ##################################################################################### + character(len=32) :: & + COSP_VERSION ! COSP Version ID (set in cosp_interface_init) + real(wp),parameter :: & + R_UNDEF = -1.0E30, & ! Missing value + R_GROUND = -1.0E20, & ! Flag for below ground results + scops_ccfrac = 0.05 ! Fraction of column (or subcolumn) covered with convective + ! precipitation (default is 5%). *NOTE* This quantity may vary + ! between modeling centers. + logical :: & + use_vgrid ! True=Use new grid for L3 CLOUDAT and CALIPSO + integer,parameter :: & + SR_BINS = 15, & ! Number of bins (backscattering coefficient) in CALOPSO LIDAR simulator. + N_HYDRO = 9 ! Number of hydrometeor classes used by quickbeam radar simulator. + + ! #################################################################################### + ! Joint histogram bin-boundaries + ! tau is used by ISCCP and MISR + ! pres is used by ISCCP + ! hgt is used by MISR + ! ReffLiq is used by MODIS + ! ReffIce is used by MODIS + ! *NOTE* ALL JOINT-HISTOGRAM BIN BOUNDARIES ARE DECLARED AND DEFINED HERE IN + ! COSP_CONFIG, WITH THE EXCEPTION OF THE TAU AXIS USED BY THE MODIS SIMULATOR, + ! WHICH IS SET DURING INITIALIZATION IN COSP_INTERFACE_INIT. + ! #################################################################################### + ! Optical depth bin axis + integer,parameter :: & + ntau=7 + real(wp),parameter,dimension(ntau+1) :: & + tau_binBounds = (/0.0, 0.3, 1.3, 3.6, 9.4, 23., 60., 10000./) + real(wp),parameter,dimension(ntau) :: & + tau_binCenters = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/) + real(wp),parameter,dimension(2,ntau) :: & + tau_binEdges = reshape(source=(/0.0, 0.3, 0.3, 1.3, 1.3, 3.6, 3.6, & + 9.4, 9.4, 23.0, 23.0, 60.0, 60.0, 100000.0/), & + shape=(/2,ntau/)) + + ! Optical depth bin axes (ONLY USED BY MODIS SIMULATOR IN v1.4) + integer :: l,k + integer,parameter :: & + ntauV1p4 = 6 + real(wp),parameter,dimension(ntauV1p4+1) :: & + tau_binBoundsV1p4 = (/0.3, 1.3, 3.6, 9.4, 23., 60., 10000./) + real(wp),parameter,dimension(2,ntauV1p4) :: & + tau_binEdgesV1p4 = reshape(source =(/tau_binBoundsV1p4(1),((tau_binBoundsV1p4(k),l=1,2), & + k=2,ntauV1p4),100000._wp/),shape = (/2,ntauV1p4/)) + real(wp),parameter,dimension(ntauV1p4) :: & + tau_binCentersV1p4 = (tau_binEdgesV1p4(1,:)+tau_binEdgesV1p4(2,:))/2._wp + + ! Cloud-top height pressure bin axis + integer,parameter :: & + npres = 7 + real(wp),parameter,dimension(npres+1) :: & + pres_binBounds = (/0., 180., 310., 440., 560., 680., 800., 10000./) + real(wp),parameter,dimension(npres) :: & + pres_binCenters = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./) + real(wp),parameter,dimension(2,npres) :: & + pres_binEdges = reshape(source=(/100000.0, 80000.0, 80000.0, 68000.0, 68000.0, & + 56000.0, 56000.0, 44000.0, 44000.0, 31000.0, & + 31000.0, 18000.0, 18000.0, 0.0/), & + shape=(/2,npres/)) + + ! Cloud-top height bin axis #1 + integer,parameter :: & + nhgt = 16 + real(wp),parameter,dimension(nhgt+1) :: & + hgt_binBounds = (/-.99,0.,0.5,1.,1.5,2.,2.5,3.,4.,5.,7.,9.,11.,13.,15.,17.,99./) + real(wp),parameter,dimension(nhgt) :: & + hgt_binCenters = 1000*(/0.,0.25,0.75,1.25,1.75,2.25,2.75,3.5,4.5,6.,8.,10.,12., & + 14.5,16.,18./) + real(wp),parameter,dimension(2,nhgt) :: & + hgt_binEdges = 1000.0*reshape(source=(/-99.0, 0.0, 0.0, 0.5, 0.5, 1.0, 1.0, 1.5, & + 1.5, 2.0, 2.0, 2.5, 2.5, 3.0, 3.0, 4.0, & + 4.0, 5.0, 5.0, 7.0, 7.0, 9.0, 9.0,11.0, & + 11.0,13.0,13.0,15.0,15.0,17.0,17.0,99.0/),& + shape=(/2,nhgt/)) + + ! Liquid and Ice particle bins for MODIS joint histogram of optical-depth and particle + ! size + integer :: i,j + integer,parameter :: & + nReffLiq = 6, & ! Number of bins for tau/ReffLiq joint-histogram + nReffIce = 6 ! Number of bins for tau/ReffICE joint-histogram + real(wp),parameter,dimension(nReffLiq+1) :: & + reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/) + real(wp),parameter,dimension(nReffIce+1) :: & + reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/) + real(wp),parameter,dimension(2,nReffICE) :: & + reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k), & + l=1,2),k=2,nReffICE),reffICE_binBounds(nReffICE+1)/), & + shape = (/2,nReffICE/)) + real(wp),parameter,dimension(2,nReffLIQ) :: & + reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k), & + l=1,2),k=2,nReffLIQ),reffLIQ_binBounds(nReffICE+1)/), & + shape = (/2,nReffLIQ/)) + real(wp),parameter,dimension(nReffICE) :: & + reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2._wp + real(wp),parameter,dimension(nReffLIQ) :: & + reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2._wp + + ! #################################################################################### + ! Constants used by RTTOV. + ! #################################################################################### + integer,parameter :: & + RTTOV_MAX_CHANNELS = 20 + character(len=256),parameter :: & + rttovDir = '/Projects/Clouds/dswales/RTTOV/rttov_11.3/' + + ! #################################################################################### + ! Constants used by the PARASOL simulator. + ! #################################################################################### + integer,parameter :: & + PARASOL_NREFL = 5, & ! Number of angles in LUT + PARASOL_NTAU = 7 ! Number of optical depths in LUT + real(wp),parameter,dimension(PARASOL_NREFL) :: & + PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/) + REAL(WP),parameter,dimension(PARASOL_NTAU) :: & + PARASOL_TAU = (/0., 1., 5., 10., 20., 50., 100./) + + ! LUTs + REAL(WP),parameter,dimension(PARASOL_NREFL,PARASOL_NTAU) :: & + ! LUT for liquid particles + rlumA = reshape(source=(/ 0.03, 0.03, 0.03, 0.03, 0.03, & + 0.090886, 0.072185, 0.058410, 0.052498, 0.034730, & + 0.283965, 0.252596, 0.224707, 0.175844, 0.064488, & + 0.480587, 0.436401, 0.367451, 0.252916, 0.081667, & + 0.695235, 0.631352, 0.509180, 0.326551, 0.098215, & + 0.908229, 0.823924, 0.648152, 0.398581, 0.114411, & + 1.0, 0.909013, 0.709554, 0.430405, 0.121567/), & + shape=(/PARASOL_NREFL,PARASOL_NTAU/)), & + ! LUT for ice particles + rlumB = reshape(source=(/ 0.03, 0.03, 0.03, 0.03, 0.03, & + 0.092170, 0.087082, 0.083325, 0.084935, 0.054157, & + 0.311941, 0.304293, 0.285193, 0.233450, 0.089911, & + 0.511298, 0.490879, 0.430266, 0.312280, 0.107854, & + 0.712079, 0.673565, 0.563747, 0.382376, 0.124127, & + 0.898243, 0.842026, 0.685773, 0.446371, 0.139004, & + 0.976646, 0.912966, 0.737154, 0.473317, 0.145269/), & + shape=(/PARASOL_NREFL,PARASOL_NTAU/)) + + ! #################################################################################### + ! ISCCP simulator tau/CTP joint histogram information + ! #################################################################################### + integer,parameter :: & + numISCCPTauBins = ntau, & ! Number of optical depth bins + numISCCPPresBins = npres ! Number of pressure bins + real(wp),parameter,dimension(ntau+1) :: & + isccp_histTau = tau_binBounds ! Joint-histogram boundaries (optical depth) + real(wp),parameter,dimension(npres+1) :: & + isccp_histPres = pres_binBounds ! Joint-histogram boundaries (cloud pressure) + real(wp),parameter,dimension(ntau) :: & + isccp_histTauCenters = tau_binCenters ! Joint histogram bin centers (optical depth) + real(wp),parameter,dimension(npres) :: & + isccp_histPresCenters = pres_binCenters ! Joint histogram bin centers (cloud pressure) + real(wp),parameter,dimension(2,ntau) :: & + isccp_histTauEdges = tau_binEdges ! Joint histogram bin edges (optical depth) + real(wp),parameter,dimension(2,npres) :: & + isccp_histPresEdges = pres_binEdges ! Joint histogram bin edges (cloud pressure) + + ! #################################################################################### + ! MISR simulator tau/CTH joint histogram information + ! #################################################################################### + integer,parameter :: & + numMISRHgtBins = nhgt, & ! Number of cloud-top height bins + numMISRTauBins = ntau ! Number of optical depth bins + ! Joint histogram boundaries + real(wp),parameter,dimension(numMISRHgtBins+1) :: & + misr_histHgt = hgt_binBounds ! Joint-histogram boundaries (cloud height) + real(wp),parameter,dimension(numMISRTauBins+1) :: & + misr_histTau = tau_binBounds ! Joint-histogram boundaries (optical-depth) + real(wp),parameter,dimension(numMISRHgtBins) :: & + misr_histHgtCenters = hgt_binCenters ! Joint-histogram bin centers (cloud height) + real(wp),parameter,dimension(2,numMISRHgtBins) :: & + misr_histHgtEdges = hgt_BinEdges ! Joint-histogram bin edges (cloud height) + + ! #################################################################################### + ! MODIS simulator tau/CTP joint histogram information + ! #################################################################################### + integer,parameter :: & + numMODISPresBins = npres ! Number of pressure bins for joint-histogram + real(wp),parameter,dimension(numMODISPresBins + 1) :: & + modis_histPres = 100*pres_binBounds ! Joint-histogram boundaries (cloud pressure) + real(wp),parameter,dimension(2, numMODISPresBins) :: & + modis_histPresEdges = 100*pres_binEdges ! Joint-histogram bin edges (cloud pressure) + real(wp),parameter,dimension(numMODISPresBins) :: & + modis_histPresCenters = 100*pres_binCenters ! Joint-histogram bin centers (cloud pressure) + + ! For the MODIS simulator we want to preserve the ability for cospV1.4.0 to use the + ! old histogram bin boundaries for optical depth, so these are set up in initialization. + integer :: & + numMODISTauBins ! Number of tau bins for joint-histogram + real(wp),allocatable,dimension(:) :: & + modis_histTau ! Joint-histogram boundaries (optical depth) + real(wp),allocatable,dimension(:,:) :: & + modis_histTauEdges ! Joint-histogram bin edges (optical depth) + real(wp),allocatable,dimension(:) :: & + modis_histTauCenters ! Joint-histogram bin centers (optical depth) + + ! #################################################################################### + ! MODIS simulator tau/ReffICE and tau/ReffLIQ joint-histogram information + ! #################################################################################### + ! Ice + integer,parameter :: & + numMODISReffIceBins = nReffIce ! Number of bins for joint-histogram + real(wp),parameter,dimension(nReffIce+1) :: & + modis_histReffIce = reffICE_binBounds ! Effective radius bin boundaries + real(wp),parameter,dimension(nReffIce) :: & + modis_histReffIceCenters = reffICE_binCenters ! Effective radius bin centers + real(wp),parameter,dimension(2,nReffICE) :: & + modis_histReffIceEdges = reffICE_binEdges ! Effective radius bin edges + + ! Liquid + integer,parameter :: & + numMODISReffLiqBins = nReffLiq ! Number of bins for joint-histogram + real(wp),parameter,dimension(nReffLiq+1) :: & + modis_histReffLiq = reffLIQ_binBounds ! Effective radius bin boundaries + real(wp),parameter,dimension(nReffLiq) :: & + modis_histReffLiqCenters = reffICE_binCenters ! Effective radius bin centers + real(wp),parameter,dimension(2,nReffICE) :: & + modis_histReffLiqEdges = reffLIQ_binEdges ! Effective radius bin edges + + ! #################################################################################### + ! CLOUDSAT reflectivity histogram information + ! #################################################################################### + integer,parameter :: & + DBZE_BINS = 15, & ! Number of dBZe bins in histogram (cfad) + DBZE_MIN = -100, & ! Minimum value for radar reflectivity + DBZE_MAX = 80, & ! Maximum value for radar reflectivity + CFAD_ZE_MIN = -50, & ! Lower value of the first CFAD Ze bin + CFAD_ZE_WIDTH = 5 ! Bin width (dBZe) + + real(wp),parameter,dimension(DBZE_BINS+1) :: & + cloudsat_histRef = (/DBZE_MIN,(/(i, i=int(CFAD_ZE_MIN+CFAD_ZE_WIDTH), & + int(CFAD_ZE_MIN+(DBZE_BINS-1)*CFAD_ZE_WIDTH), & + int(CFAD_ZE_WIDTH))/),DBZE_MAX/) + real(wp),parameter,dimension(2,DBZE_BINS) :: & + cloudsat_binEdges = reshape(source=(/cloudsat_histRef(1),((cloudsat_histRef(k), & + l=1,2),k=2,DBZE_BINS),cloudsat_histRef(DBZE_BINS+1)/),& + shape = (/2,DBZE_BINS/)) + real(wp),parameter,dimension(DBZE_BINS) :: & + cloudsat_binCenters = (cloudsat_binEdges(1,:)+cloudsat_binEdges(2,:))/2._wp + + ! #################################################################################### + ! Parameters used by the CALIPSO LIDAR simulator + ! #################################################################################### + ! CALISPO backscatter histogram bins + real(wp),parameter :: & + S_cld = 5.0, & ! Threshold for cloud detection + S_att = 0.01, & ! + S_cld_att = 30. ! Threshold for undefined cloud phase detection + real(wp),parameter,dimension(SR_BINS+1) :: & + calipso_histBsct = (/-1.,0.01,1.2,3.0,5.0,7.0,10.0,15.0,20.0,25.0,30.0,40.0,50.0, & + 60.0,80.0,999./) ! Backscatter histogram bins + real(wp),parameter,dimension(2,SR_BINS) :: & + calipso_binEdges = reshape(source=(/calipso_histBsct(1),((calipso_histBsct(k), & + l=1,2),k=2,SR_BINS),calipso_histBsct(SR_BINS+1)/), & + shape = (/2,SR_BINS/)) + real(wp),parameter,dimension(SR_BINS) :: & + calipso_binCenters = (calipso_binEdges(1,:)+calipso_binEdges(2,:))/2._wp + + integer,parameter :: & + LIDAR_NTEMP = 40, & + LIDAR_NCAT = 4 ! Number of categories for cloudtop heights (high/mid/low/tot) + real(wp),parameter,dimension(LIDAR_NTEMP) :: & + LIDAR_PHASE_TEMP= & + (/-91.5,-88.5,-85.5,-82.5,-79.5,-76.5,-73.5,-70.5,-67.5,-64.5, & + -61.5,-58.5,-55.5,-52.5,-49.5,-46.5,-43.5,-40.5,-37.5,-34.5, & + -31.5,-28.5,-25.5,-22.5,-19.5,-16.5,-13.5,-10.5, -7.5, -4.5, & + -1.5, 1.5, 4.5, 7.5, 10.5, 13.5, 16.5, 19.5, 22.5, 25.5/) + real(wp),parameter,dimension(2,LIDAR_NTEMP) :: & + LIDAR_PHASE_TEMP_BNDS=reshape(source= & + (/-273.15, -90., -90., -87., -87., -84., -84., -81., -81., -78., & + -78., -75., -75., -72., -72., -69., -69., -66., -66., -63., & + -63., -60., -60., -57., -57., -54., -54., -51., -51., -48., & + -48., -45., -45., -42., -42., -39., -39., -36., -36., -33., & + -33., -30., -30., -27., -27., -24., -24., -21., -21., -18., & + -18., -15., -15., -12., -12., -9., -9., -6., -6., -3., & + -3., 0., 0., 3., 3., 6., 6., 9., 9., 12., & + 12., 15., 15., 18., 18., 21., 21., 24., 24., 100. /), & + shape=(/2,40/)) + + ! #################################################################################### + ! New vertical grid used by CALIPSO and CLOUDSAT L3 (set up during initialization) + ! #################################################################################### + integer :: & + Nlvgrid ! Number of levels in New grid + real(wp),dimension(:),allocatable,save :: & + vgrid_zl, & ! New grid bottoms + vgrid_zu, & ! New grid tops + vgrid_z ! New grid center + !$OMP THREADPRIVATE(vgrid_zl,vgrid_zu,vgrid_z) +END MODULE MOD_COSP_CONFIG Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_defs.h =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_defs.h (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_defs.h (revision 3358) @@ -0,0 +1,30 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_defs.h $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +!#define RTTOV rttov +!#define SYS_SX sys_sx +#define MMF_V3_SINGLE_MOMENT mmf_v3_single_moment +!#define MMF_V3p5_TWO_MOMENT mmf_v3p5_two_moment Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_errorHandling.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_errorHandling.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_errorHandling.F90 (revision 3358) @@ -0,0 +1,50 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +module mod_cosp_error + use cosp_kinds, ONLY: wp +contains + ! ###################################################################################### + ! Subroutine errorMessage_print + ! ###################################################################################### + subroutine errorMessage(message) + ! Inputs + character(len=*),intent(in) :: message + + print*,message + end subroutine errorMessage + + ! ###################################################################################### + ! END MODULE + ! ###################################################################################### +end module mod_cosp_error Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_interface_v1p4.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_interface_v1p4.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_interface_v1p4.F90 (revision 3358) @@ -0,0 +1,2543 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +#include "cosp_defs.h" +MODULE MOD_COSP_INTERFACE_v1p4 + use COSP_KINDS, only: wp,dp + use cosp_phys_constants, only: amw,amd,amO3,amCO2,amCH4,amN2O,amCO + use MOD_COSP, only: cosp_init,cosp_outputs,cosp_optical_inputs, & + cosp_column_inputs,cosp_simulator,linitialization + use mod_cosp_config, only: RTTOV_MAX_CHANNELS,N_HYDRO,numMODISTauBins,modis_histTau,& + modis_histTauEdges,modis_histTauCenters,ntau,ntauV1p4, & + tau_binBounds,tau_binEdges,tau_binCenters,R_UNDEF, & + tau_binBoundsV1p4,tau_binEdgesV1p4,tau_binCentersV1p4, & + numMISRHgtBins,SR_BINS,LIDAR_NCAT,LIDAR_NTEMP,DBZE_BINS, & + numMODISReffIceBins, numMODISPresBins,PARASOL_NREFL, & + numMODISReffLiqBins,vgrid_zl,vgrid_zu,vgrid_z, & + numISCCPTauBins,numISCCPPresBins,numMISRTauBins + use mod_quickbeam_optics,only: size_distribution,hydro_class_init,quickbeam_optics_init,& + quickbeam_optics + use cosp_optics, only: cosp_simulator_optics,lidar_optics,modis_optics, & + modis_optics_partition + use quickbeam, only: maxhclass,nRe_types,nd,mt_ntt,radar_cfg + use mod_rng, only: rng_state, init_rng + use mod_scops, only: scops + use mod_prec_scops, only: prec_scops + use mod_cosp_utils, only: cosp_precip_mxratio + + implicit none + + character(len=120),parameter :: & + RADAR_SIM_LUT_DIRECTORY = './' + logical,parameter :: & + RADAR_SIM_LOAD_scale_LUTs_flag = .false., & + RADAR_SIM_UPDATE_scale_LUTs_flag = .false. + + ! Indices to address arrays of LS and CONV hydrometeors + integer,parameter :: & + I_LSCLIQ = 1, & ! Large-scale (stratiform) liquid + I_LSCICE = 2, & ! Large-scale (stratiform) ice + I_LSRAIN = 3, & ! Large-scale (stratiform) rain + I_LSSNOW = 4, & ! Large-scale (stratiform) snow + I_CVCLIQ = 5, & ! Convective liquid + I_CVCICE = 6, & ! Convective ice + I_CVRAIN = 7, & ! Convective rain + I_CVSNOW = 8, & ! Convective snow + I_LSGRPL = 9 ! Large-scale (stratiform) groupel + + ! Stratiform and convective clouds in frac_out. + integer, parameter :: & + I_LSC = 1, & ! Large-scale clouds + I_CVC = 2 ! Convective clouds + + ! Microphysical settings for the precipitation flux to mixing ratio conversion + real(wp),parameter,dimension(N_HYDRO) :: & + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + N_ax = (/-1., -1., 8.e6, 3.e6, -1., -1., 8.e6, 3.e6, 4.e6/),& + N_bx = (/-1., -1., 0.0, 0.0, -1., -1., 0.0, 0.0, 0.0/),& + alpha_x = (/-1., -1., 0.0, 0.0, -1., -1., 0.0, 0.0, 0.0/),& + c_x = (/-1., -1., 842.0, 4.84, -1., -1., 842.0, 4.84, 94.5/),& + d_x = (/-1., -1., 0.8, 0.25, -1., -1., 0.8, 0.25, 0.5/),& + g_x = (/-1., -1., 0.5, 0.5, -1., -1., 0.5, 0.5, 0.5/),& + a_x = (/-1., -1., 524.0, 52.36, -1., -1., 524.0, 52.36, 209.44/),& + b_x = (/-1., -1., 3.0, 3.0, -1., -1., 3.0, 3.0, 3.0/),& + gamma_1 = (/-1., -1., 17.83725, 8.284701, -1., -1., 17.83725, 8.284701, 11.63230/),& + gamma_2 = (/-1., -1., 6.0, 6.0, -1., -1., 6.0, 6.0, 6.0/),& + gamma_3 = (/-1., -1., 2.0, 2.0, -1., -1., 2.0, 2.0, 2.0/),& + gamma_4 = (/-1., -1., 6.0, 6.0, -1., -1., 6.0, 6.0, 6.0/) + + ! Initialization fields + type(size_distribution) :: & + sd ! Hydrometeor description + type(radar_cfg) :: & + rcfg_cloudsat ! Radar configuration + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE COSP_CONFIG + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE COSP_CONFIG + logical :: & + Lstats, & ! Control for L3 stats output + Lwrite_output, & ! Control for output + Ltoffset, & ! Time difference between each profile and the value + ! recorded in varaible time. + Lradar_sim, & ! Radar simulator on/off switch + Llidar_sim, & ! LIDAR simulator on/off switch + Lisccp_sim, & ! ISCCP simulator on/off switch + Lmodis_sim, & ! MODIS simulatoe on/off switch + Lmisr_sim, & ! MISR simulator on/off switch + Lrttov_sim, & ! RTTOV simulator on/off switch + Lparasol_sim, & ! PARASOL simulator on/off switch + Lpctisccp, & ! ISCCP mean cloud top pressure + Lclisccp, & ! ISCCP cloud area fraction + Lboxptopisccp, & ! ISCCP CTP in each column + Lboxtauisccp, & ! ISCCP optical epth in each column + Ltauisccp, & ! ISCCP mean optical depth + Lcltisccp, & ! ISCCP total cloud fraction + Lmeantbisccp, & ! ISCCP mean all-sky 10.5micron brightness temperature + Lmeantbclrisccp, & ! ISCCP mean clear-sky 10.5micron brightness temperature + Lalbisccp, & ! ISCCP mean cloud albedo + LcfadDbze94, & ! CLOUDSAT radar reflectivity CFAD + Ldbze94, & ! CLOUDSAT radar reflectivity + LparasolRefl, & ! PARASOL reflectance + Latb532, & ! CALIPSO attenuated total backscatter (532nm) + LlidarBetaMol532, & ! CALIPSO molecular backscatter (532nm) + LcfadLidarsr532, & ! CALIPSO scattering ratio CFAD + Lclcalipso2, & ! CALIPSO cloud fraction undetected by cloudsat + Lclcalipso, & ! CALIPSO cloud area fraction + Lclhcalipso, & ! CALIPSO high-level cloud fraction + Lcllcalipso, & ! CALIPSO low-level cloud fraction + Lclmcalipso, & ! CALIPSO mid-level cloud fraction + Lcltcalipso, & ! CALIPSO total cloud fraction + Lcltlidarradar, & ! CALIPSO-CLOUDSAT total cloud fraction + Lclcalipsoliq, & ! CALIPSO liquid cloud area fraction + Lclcalipsoice, & ! CALIPSO ice cloud area fraction + Lclcalipsoun, & ! CALIPSO undetected cloud area fraction + Lclcalipsotmp, & ! CALIPSO undetected cloud area fraction + Lclcalipsotmpliq, & ! CALIPSO liquid cloud area fraction + Lclcalipsotmpice, & ! CALIPSO ice cloud area fraction + Lclcalipsotmpun, & ! CALIPSO undetected cloud area fraction + Lcltcalipsoliq, & ! CALIPSO liquid total cloud fraction + Lcltcalipsoice, & ! CALIPSO ice total cloud fraction + Lcltcalipsoun, & ! CALIPSO undetected total cloud fraction + Lclhcalipsoliq, & ! CALIPSO high-level liquid cloud fraction + Lclhcalipsoice, & ! CALIPSO high-level ice cloud fraction + Lclhcalipsoun, & ! CALIPSO high-level undetected cloud fraction + Lclmcalipsoliq, & ! CALIPSO mid-level liquid cloud fraction + Lclmcalipsoice, & ! CALIPSO mid-level ice cloud fraction + Lclmcalipsoun, & ! CALIPSO mid-level undetected cloud fraction + Lcllcalipsoliq, & ! CALIPSO low-level liquid cloud fraction + Lcllcalipsoice, & ! CALIPSO low-level ice cloud fraction + Lcllcalipsoun, & ! CALIPSO low-level undetected cloud fraction + Lcltmodis, & ! MODIS total cloud fraction + Lclwmodis, & ! MODIS liquid cloud fraction + Lclimodis, & ! MODIS ice cloud fraction + Lclhmodis, & ! MODIS high-level cloud fraction + Lclmmodis, & ! MODIS mid-level cloud fraction + Lcllmodis, & ! MODIS low-level cloud fraction + Ltautmodis, & ! MODIS total cloud optical thicknes + Ltauwmodis, & ! MODIS liquid optical thickness + Ltauimodis, & ! MODIS ice optical thickness + Ltautlogmodis, & ! MODIS total cloud optical thickness (log10 mean) + Ltauwlogmodis, & ! MODIS liquid optical thickness (log10 mean) + Ltauilogmodis, & ! MODIS ice optical thickness (log10 mean) + Lreffclwmodis, & ! MODIS liquid cloud particle size + Lreffclimodis, & ! MODIS ice particle size + Lpctmodis, & ! MODIS cloud top pressure + Llwpmodis, & ! MODIS cloud ice water path + Liwpmodis, & ! MODIS cloud liquid water path + Lclmodis, & ! MODIS cloud area fraction + LclMISR, & ! MISR cloud fraction + Lfracout, & ! SCOPS Subcolumn output + Ltbrttov ! RTTOV mean clear-sky brightness temperature +! character(len=32),dimension(:),allocatable :: out_list + character(len=32) :: out_list(78) + END TYPE COSP_CONFIG + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_vgrid + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE COSP_VGRID + logical :: & + use_vgrid, & ! Logical flag that indicates change of grid + csat_vgrid ! Flag for Cloudsat grid + integer :: & + Npoints, & ! Number of sampled points + Ncolumns, & ! Number of subgrid columns + Nlevels, & ! Number of model levels + Nlvgrid ! Number of levels of new grid + real(wp), dimension(:), pointer :: & + z, & ! Height of new level (Nlvgrid) + zl, & ! Lower boundaries of new levels (Nlvgrid) + zu, & ! Upper boundaries of new levels (Nlvgrid) + mz, & ! Height of model levels (Nlevels) + mzl, & ! Lower boundaries of model levels (Nlevels) + mzu ! Upper boundaries of model levels (Nlevels) + END TYPE COSP_VGRID + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE COSP_SUBGRID + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE COSP_SUBGRID + integer :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nlevels, & ! Number of levels + Nhydro ! Number of hydrometeor types + real(wp),dimension(:,:,:),pointer :: & + prec_frac, & ! Subgrid precip array (Npoints,Ncolumns,Nlevels) + frac_out ! Subgrid cloud array (Npoints,Ncolumns,Nlevels) + END TYPE COSP_SUBGRID + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE class_param + ! With the reorganizing of COSPv2.0, this derived type + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type class_param + ! Variables used to store hydrometeor "default" properties + real(dp),dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho + integer, dimension(maxhclass) :: dtype,col,cp,phase + + ! Radar properties + real(dp) :: freq,k2 + integer :: nhclass ! number of hydrometeor classes in use + integer :: use_gas_abs, do_ray + + ! Defines location of radar relative to hgt_matrix. + logical :: radar_at_layer_one ! If true radar is assume to be at the edge + ! of the first layer, if the first layer is the + ! surface than a ground-based radar. If the + ! first layer is the top-of-atmosphere, then + ! a space borne radar. + + ! Variables used to store Z scale factors + character(len=240) :: scale_LUT_file_name + logical :: load_scale_LUTs, update_scale_LUTs + logical, dimension(maxhclass,nRe_types) :: N_scale_flag + logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag + real(dp),dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled + real(dp),dimension(maxhclass,nd,nRe_types) :: fc, rho_eff + end type class_param + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_gridbox + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE cosp_gridbox + integer :: & + Npoints, & ! Number of gridpoints + Nlevels, & ! Number of levels + Ncolumns, & ! Number of columns + Nhydro, & ! Number of hydrometeors + Nprmts_max_hydro, & ! Max number of parameters for hydrometeor size distribution + Naero, & ! Number of aerosol species + Nprmts_max_aero, & ! Max number of parameters for aerosol size distributions + Npoints_it ! Max number of gridpoints to be processed in one iteration + + ! Time [days] + double precision :: time + double precision :: time_bnds(2) + + ! Radar ancillary info + real(wp) :: & + radar_freq, & ! Radar frequency [GHz] + k2 ! |K|^2, -1=use frequency dependent default + integer :: surface_radar, & ! surface=1, spaceborne=0 + use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0 + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay ! melting layer model off=0, on=1 + + + ! Structures used by radar simulator that need to be set only ONCE per + ! radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008 + type(class_param) :: & + hp ! Structure used by radar simulator to store Ze and N scaling constants + ! and other information + integer :: & + nsizes ! Number of discrete drop sizes (um) used to represent the distribution + + ! Lidar + integer :: & + lidar_ice_type ! Ice particle shape hypothesis in lidar calculations + ! (ice_type=0 for spheres, ice_type=1 for non spherical particles) + + ! Radar + logical :: & + use_precipitation_fluxes, & ! True if precipitation fluxes are input to the + ! algorithm + use_reff ! True if Reff is to be used by radar (memory not + ! allocated) + + ! Geolocation and point information (Npoints) + real(wp),dimension(:),pointer :: & + toffset, & ! Time offset of esch point from the value in time + longitude, & ! Longitude [degrees East] + latitude, & ! Latitude [deg North] + land, & ! Landmask [0 - Ocean, 1 - Land] + psfc, & ! Surface pressure [Pa] + sunlit, & ! 1 for day points, 0 for nightime + skt, & ! Skin temperature (K) + u_wind, & ! Eastward wind [m s-1] + v_wind ! Northward wind [m s-1] + + ! Gridbox information (Npoints,Nlevels) + real(wp),dimension(:,:),pointer :: & + zlev, & ! Height of model levels [m] + zlev_half, & ! Height at half model levels [m] (Bottom of layer) + dlev, & ! Depth of model levels [m] + p, & ! Pressure at full model levels [Pa] + ph, & ! Pressure at half model levels [Pa] + T, & ! Temperature at model levels [K] + q, & ! Relative humidity to water (%) + sh, & ! Specific humidity to water [kg/kg] + dtau_s, & ! mean 0.67 micron optical depth of stratiform clouds + dtau_c, & ! mean 0.67 micron optical depth of convective clouds + dem_s, & ! 10.5 micron longwave emissivity of stratiform clouds + dem_c, & ! 10.5 micron longwave emissivity of convective clouds + mr_ozone ! Ozone mass mixing ratio [kg/kg] + + ! TOTAL and CONV cloud fraction for SCOPS + real(wp),dimension(:,:),pointer :: & + tca, & ! Total cloud fraction + cca ! Convective cloud fraction + + ! Precipitation fluxes on model levels + real(wp),dimension(:,:),pointer :: & + rain_ls, & ! Large-scale precipitation flux of rain [kg/m2.s] + rain_cv, & ! Convective precipitation flux of rain [kg/m2.s] + snow_ls, & ! Large-scale precipitation flux of snow [kg/m2.s] + snow_cv, & ! Convective precipitation flux of snow [kg/m2.s] + grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s] + + ! Hydrometeors concentration and distribution parameters + real(wp),dimension(:,:,:),pointer :: & + mr_hydro ! Mixing ratio of each hydrometeor + ! (Npoints,Nlevels,Nhydro) [kg/kg] + real(wp),dimension(:,:),pointer :: & + dist_prmts_hydro ! Distributional parameters for hydrometeors + ! (Nprmts_max_hydro,Nhydro) + real(wp),dimension(:,:,:),pointer :: & + Reff ! Effective radius [m]. + ! (Npoints,Nlevels,Nhydro) + real(wp),dimension(:,:,:),pointer :: & + Np ! Total Number Concentration [#/kg]. + ! (Npoints,Nlevels,Nhydro) + + ! Aerosols concentration and distribution parameters + real(wp),dimension(:,:,:),pointer :: & + conc_aero ! Aerosol concentration for each species + ! (Npoints,Nlevels,Naero) + integer,dimension(:),pointer :: & + dist_type_aero ! Particle size distribution type for each aerosol species + ! (Naero) + real(wp),dimension(:,:,:,:),pointer :: & + dist_prmts_aero ! Distributional parameters for aerosols + ! (Npoints,Nlevels,Nprmts_max_aero,Naero) + ! ISCCP simulator inputs + integer :: & + ! ISCCP_TOP_HEIGHT + ! 1 = adjust top height using both a computed infrared brightness temperature and + ! the visible optical depth to adjust cloud top pressure. Note that this + ! calculation is most appropriate to compare to ISCCP data during sunlit + ! hours. + ! 2 = do not adjust top height, that is cloud top pressure is the actual cloud + ! top pressure in the model. + ! 3 = adjust top height using only the computed infrared brightness temperature. + ! Note that this calculation is most appropriate to compare to ISCCP IR only + ! algortihm (i.e. you can compare to nighttime ISCCP data with this option) + isccp_top_height, & + ! ISCCP_TOP_HEIGHT_DIRECTION + ! Direction for finding atmosphere pressure level with interpolated temperature + ! equal to the radiance determined cloud-top temperature + ! 1 = find the *lowest* altitude (highest pressure) level with interpolated + ! temperature equal to the radiance determined cloud-top temperature + ! 2 = find the *highest* altitude (lowest pressure) level with interpolated + ! temperature equal to the radiance determined cloud-top temperature + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! 1 = default setting, and matches all versions of ISCCP simulator with versions + ! numbers 3.5.1 and lower; 2 = experimental setting + isccp_top_height_direction, & + ! Overlap type (1=max, 2=rand, 3=max/rand) + isccp_overlap + real(wp) :: & + isccp_emsfc_lw ! 10.5 micron emissivity of surface (fraction) + + ! RTTOV inputs/options + integer :: & + plat, & ! Satellite platform + sat, & ! Satellite + inst, & ! Instrument + Nchan ! Number of channels to be computed + integer, dimension(:), pointer :: & + Ichan ! Channel numbers + real(wp),dimension(:), pointer :: & + Surfem ! Surface emissivity + real(wp) :: & + ZenAng, & ! Satellite Zenith Angles + co2, & ! CO2 mixing ratio + ch4, & ! CH4 mixing ratio + n2o, & ! N2O mixing ratio + co ! CO mixing ratio + END TYPE cosp_gridbox + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_modis + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type cosp_modis + integer,pointer :: & ! + Npoints ! Number of gridpoints + real(wp),pointer,dimension(:) :: & ! + Cloud_Fraction_Total_Mean, & ! L3 MODIS retrieved cloud fraction (total) + Cloud_Fraction_Water_Mean, & ! L3 MODIS retrieved cloud fraction (liq) + Cloud_Fraction_Ice_Mean, & ! L3 MODIS retrieved cloud fraction (ice) + Cloud_Fraction_High_Mean, & ! L3 MODIS retrieved cloud fraction (high) + Cloud_Fraction_Mid_Mean, & ! L3 MODIS retrieved cloud fraction (middle) + Cloud_Fraction_Low_Mean, & ! L3 MODIS retrieved cloud fraction (low ) + Optical_Thickness_Total_Mean, & ! L3 MODIS retrieved optical thickness (tot) + Optical_Thickness_Water_Mean, & ! L3 MODIS retrieved optical thickness (liq) + Optical_Thickness_Ice_Mean, & ! L3 MODIS retrieved optical thickness (ice) + Optical_Thickness_Total_LogMean, & ! L3 MODIS retrieved log10 optical thickness + Optical_Thickness_Water_LogMean, & ! L3 MODIS retrieved log10 optical thickness + Optical_Thickness_Ice_LogMean, & ! L3 MODIS retrieved log10 optical thickness + Cloud_Particle_Size_Water_Mean, & ! L3 MODIS retrieved particle size (liquid) + Cloud_Particle_Size_Ice_Mean, & ! L3 MODIS retrieved particle size (ice) + Cloud_Top_Pressure_Total_Mean, & ! L3 MODIS retrieved cloud top pressure + Liquid_Water_Path_Mean, & ! L3 MODIS retrieved liquid water path + Ice_Water_Path_Mean ! L3 MODIS retrieved ice water path + real(wp),pointer,dimension(:,:,:) :: & + Optical_Thickness_vs_Cloud_Top_Pressure, & ! Tau/Pressure joint histogram + Optical_Thickness_vs_ReffICE, & ! Tau/ReffICE joint histogram + Optical_Thickness_vs_ReffLIQ ! Tau/ReffLIQ joint histogram + + end type cosp_modis + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_misr + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE COSP_MISR + integer,pointer :: & + Npoints, & ! Number of gridpoints + Ntau, & ! Number of tau intervals + Nlevels ! Number of cth levels + real(wp),dimension(:,:,:),pointer :: & ! + fq_MISR ! Fraction of the model grid box covered by each of the MISR + ! cloud types + real(wp),dimension(:,:),pointer :: & ! + MISR_dist_model_layertops ! + real(wp),dimension(:),pointer :: & ! + MISR_meanztop, & ! Mean MISR cloud top height + MISR_cldarea ! Mean MISR cloud cover area + END TYPE COSP_MISR + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_rttov + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE COSP_RTTOV + ! Dimensions + integer,pointer :: & + Npoints, & ! Number of gridpoints + Nchan ! Number of channels + + ! Brightness temperatures (Npoints,Nchan) + real(wp),pointer :: tbs(:,:) + END TYPE COSP_RTTOV + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_isccp + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE COSP_ISCCP + integer,pointer ::& + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + real(wp),dimension(:),pointer :: & + totalcldarea, & ! The fraction of model grid box columns with cloud somewhere in + ! them. + meantb, & ! Mean all-sky 10.5 micron brightness temperature. + meantbclr, & ! Mean clear-sky 10.5 micron brightness temperature. + meanptop, & ! Mean cloud top pressure (mb). + meantaucld, & ! Mean optical thickness. + meanalbedocld ! Mean cloud albedo. + real(wp),dimension(:,:),pointer ::& + boxtau, & ! Optical thickness in each column . + boxptop ! Cloud top pressure (mb) in each column. + real(wp),dimension(:,:,:),pointer :: & + fq_isccp ! The fraction of the model grid box covered by each of the 49 + ! ISCCP D level cloud types. + END TYPE COSP_ISCCP + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_sglidar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type cosp_sglidar + integer,pointer :: & + Npoints, & ! Number of sampled points + Ncolumns, & ! Number of subgrid columns + Nlevels, & ! Number of model levels + Nhydro, & ! Number of hydrometeors + Nrefl ! Number of parasol reflectances + real(wp),dimension(:,:),pointer :: & + beta_mol, & ! Molecular backscatter + temp_tot + real(wp),dimension(:,:,:),pointer :: & + betaperp_tot, & ! Total backscattered signal + beta_tot, & ! Total backscattered signal + tau_tot, & ! Optical thickness integrated from top to level z + refl ! PARASOL reflectances + end type cosp_sglidar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_lidarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type cosp_lidarstats + integer,pointer :: & + Npoints, & ! Number of sampled points + Ncolumns, & ! Number of subgrid columns + Nlevels, & ! Number of model levels + Nhydro, & ! Number of hydrometeors + Nrefl ! Number of parasol reflectances + real(wp), dimension(:,:,:),pointer :: & + lidarcldphase, & ! 3D "lidar" phase cloud fraction + cldlayerphase, & ! low, mid, high-level lidar phase cloud cover + lidarcldtmp, & ! 3D "lidar" phase cloud temperature + cfad_sr ! CFAD of scattering ratio + real(wp), dimension(:,:),pointer :: & + lidarcld, & ! 3D "lidar" cloud fraction + cldlayer, & ! low, mid, high-level, total lidar cloud cover + parasolrefl + real(wp), dimension(:),pointer :: & + srbval ! SR bins in cfad_sr + end type cosp_lidarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_sgradar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type cosp_sgradar + ! Dimensions + integer,pointer :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nlevels, & ! Number of levels + Nhydro ! Number of hydrometeors + real(wp),dimension(:,:),pointer :: & + att_gas ! 2-way attenuation by gases [dBZ] (Npoints,Nlevels) + real(wp),dimension(:,:,:),pointer :: & + Ze_tot ! Effective reflectivity factor (Npoints,Ncolumns,Nlevels) + end type cosp_sgradar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_radarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type cosp_radarstats + integer,pointer :: & + Npoints, & ! Number of sampled points + Ncolumns, & ! Number of subgrid columns + Nlevels, & ! Number of model levels + Nhydro ! Number of hydrometeors + real(wp), dimension(:,:,:), pointer :: & + cfad_ze ! Ze CFAD(Npoints,dBZe_bins,Nlevels) + real(wp),dimension(:),pointer :: & + radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale (Npoints) + real(wp), dimension(:,:),pointer :: & + lidar_only_freq_cloud !(Npoints,Nlevels) + end type cosp_radarstats + +contains + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE COSP_INTERFACE (v1.4) + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_interface_v1p4(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar, & + isccp,misr,modis,rttov,stradar,stlidar) + ! Inputs + integer, intent(in) :: overlap ! Overlap type in SCOPS: 1=max, + ! 2=rand, 3=max/rand + integer, intent(in) :: Ncolumns ! Number of columns + type(cosp_config), intent(in) :: cfg ! Configuration options + type(cosp_vgrid),target,intent(in) :: vgrid ! Information on vertical grid of + ! stats + type(cosp_subgrid), intent(inout) :: sgx ! Subgrid info + type(cosp_sgradar), intent(inout) :: sgradar ! Output from radar simulator (pixel) + type(cosp_sglidar), intent(inout) :: sglidar ! Output from lidar simulator (pixel) + type(cosp_isccp), intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr), intent(inout) :: misr ! Output from MISR simulator + type(cosp_modis), intent(inout) :: modis ! Output from MODIS simulator + type(cosp_rttov), intent(inout) :: rttov ! Output from RTTOV + type(cosp_radarstats), intent(inout) :: stradar ! Summary statistics from cloudsat + ! simulator (gridbox) + type(cosp_lidarstats), intent(inout) :: stlidar ! Output from LIDAR simulator (gridbox) + type(cosp_gridbox),intent(inout),target :: gbx ! COSP gridbox type from v1.4 + ! Shares memory with new type + + ! Outputs from COSP2 + type(cosp_outputs),target :: cospOUT ! NEW derived type output that contains all + ! simulator information + ! Local variables + integer :: i + integer :: & + num_chunks, & ! Number of iterations to make + start_idx, & ! Starting index when looping over points + end_idx, & ! Ending index when looping over points + Nptsperit ! Number of points for current iteration + logical :: & + lsingle=.true., & ! True if using MMF_v3_single_moment CLOUDSAT microphysical scheme (default) + ldouble=.false. ! True if using MMF_v3.5_two_moment CLOUDSAT microphysical scheme + type(cosp_optical_inputs) :: & + cospIN ! COSP optical (or derived?) fields needed by simulators + type(cosp_column_inputs) :: & + cospstateIN ! COSP model fields needed by simulators + character(len=256),dimension(100) :: cosp_status + +#ifdef MMF_V3_SINGLE_MOMENT + character(len=64) :: & + cloudsat_micro_scheme = 'MMF_v3_single_moment' +#endif +#ifdef MMF_V3p5_TWO_MOMENT + character(len=64) :: & + cloudsat_micro_scheme = 'MMF_v3.5_two_moment' +#endif + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Initialize COSP + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Initialize MODIS optical-depth bin boundaries for joint-histogram. (defined in cosp_config.F90) + if (.not. allocated(modis_histTau)) then + allocate(modis_histTau(ntauV1p4+1),modis_histTauEdges(2,ntauV1p4),modis_histTauCenters(ntauV1p4)) + numMODIStauBins = ntauV1p4+1 + modis_histTau = tau_binBoundsV1p4 + modis_histTauEdges = tau_binEdgesV1p4 + modis_histTauCenters = tau_binCentersV1p4 + endif + + print*,'allocated(vgrid_zl)',allocated(vgrid_zl) + if (.not. allocated(vgrid_zl) .or. .not. allocated(vgrid_zu) .or. .not. allocated(vgrid_z)) then + + ! Initialize quickbeam_optics, also if two-moment radar microphysics scheme is wanted... + if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment') then + ldouble = .true. + lsingle = .false. + endif + + ! Initialize the distributional parameters for hydrometeors in radar simulator + call hydro_class_init(lsingle,ldouble,sd) + + ! Initialize COSP simulator + call COSP_INIT(cfg%Lisccp_sim,cfg%Lmodis_sim,cfg%Lmisr_sim,cfg%Lradar_sim, & + cfg%Llidar_sim,cfg%Lparasol_sim,cfg%Lrttov_sim,gbx%Npoints,gbx%Nlevels, & + gbx%radar_freq,gbx%k2,gbx%use_gas_abs,gbx%do_ray,gbx%isccp_top_height, & + gbx%isccp_top_height_direction,gbx%surface_radar,rcfg_cloudsat,gbx%Nchan, & + gbx%Ichan,gbx%plat,gbx%sat,gbx%inst,vgrid%use_vgrid,vgrid%csat_vgrid, & + vgrid%Nlvgrid,cloudsat_micro_scheme,cospOUT) + endif + + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Construct output type for cosp + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call construct_cosp_outputs(cfg%Lpctisccp,cfg%Lclisccp,cfg%Lboxptopisccp, & + cfg%Lboxtauisccp,cfg%Ltauisccp,cfg%Lcltisccp, & + cfg%Lmeantbisccp,cfg%Lmeantbclrisccp,cfg%Lalbisccp, & + cfg%LclMISR,cfg%Lcltmodis,cfg%Lclwmodis,cfg%Lclimodis, & + cfg%Lclhmodis,cfg%Lclmmodis,cfg%Lcllmodis,cfg%Ltautmodis,& + cfg%Ltauwmodis,cfg%Ltauimodis,cfg%Ltautlogmodis, & + cfg%Ltauwlogmodis,cfg%Ltauilogmodis,cfg%Lreffclwmodis, & + cfg%Lreffclimodis,cfg%Lpctmodis,cfg%Llwpmodis, & + cfg%Liwpmodis,cfg%Lclmodis,cfg%Latb532, & + cfg%LlidarBetaMol532,cfg%LcfadLidarsr532,cfg%Lclcalipso2,& + cfg%Lclcalipso,cfg%Lclhcalipso,cfg%Lcllcalipso, & + cfg%Lclmcalipso,cfg%Lcltcalipso,cfg%Lcltlidarradar, & + cfg%Lclcalipsoliq,cfg%Lclcalipsoice,cfg%Lclcalipsoun, & + cfg%Lclcalipsotmp,cfg%Lclcalipsotmpliq, & + cfg%Lclcalipsotmpice,cfg%Lclcalipsotmpun, & + cfg%Lcltcalipsoliq,cfg%Lcltcalipsoice,cfg%Lcltcalipsoun, & + cfg%Lclhcalipsoliq,cfg%Lclhcalipsoice,cfg%Lclhcalipsoun, & + cfg%Lclmcalipsoliq,cfg%Lclmcalipsoice,cfg%Lclmcalipsoun, & + cfg%Lcllcalipsoliq,cfg%Lcllcalipsoice,cfg%Lcllcalipsoun, & + cfg%LcfadDbze94,cfg%Ldbze94,cfg%Lparasolrefl, & + cfg%Ltbrttov,gbx%Npoints,gbx%Ncolumns,gbx%Nlevels, & + vgrid%Nlvgrid,gbx%Nchan,cospOUT) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Break COSP into chunks, only applicable when gbx%Npoints_it > gbx%Npoints + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + num_chunks = gbx%Npoints/gbx%Npoints_it+1 + do i=1,num_chunks + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Determine indices for "chunking" (again, if necessary) + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (num_chunks .eq. 1) then + start_idx = 1 + end_idx = gbx%Npoints + Nptsperit = gbx%Npoints + else + start_idx = (i-1)*gbx%Npoints_it+1 + end_idx = i*gbx%Npoints_it + if (end_idx .gt. gbx%Npoints) end_idx=gbx%Npoints + Nptsperit = end_idx-start_idx+1 + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Allocate space + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (i .eq. 1) then + call construct_cospIN(Nptsperit,gbx%ncolumns,gbx%nlevels,cospIN) + call construct_cospstateIN(Nptsperit,gbx%nlevels,gbx%nchan,cospstateIN) + endif + if (i .eq. num_chunks) then + call destroy_cospIN(cospIN) + call destroy_cospstateIN(cospstateIN) + call construct_cospIN(Nptsperit,gbx%ncolumns,gbx%nlevels,cospIN) + call construct_cospstateIN(Nptsperit,gbx%nlevels,gbx%nchan,cospstateIN) + endif + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Generate subcolumns and compute optical inputs to COSP. + ! This subroutine essentially contains all of the pieces of code that were removed + ! from the simulators during the v2.0 reconstruction. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call subsample_and_optics(overlap,gbx,sgx,cfg,Nptsperit,start_idx,end_idx,cospIN, & + cospstateIN) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Call COSPv2.0 + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + cosp_status = COSP_SIMULATOR(cospIN, cospstateIN, cospOUT, start_idx,end_idx,.false.) + enddo + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Free up memory + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call destroy_cospIN(cospIN) + call destroy_cospstateIN(cospstateIN) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Copy new output to old output types. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! MISR + if (cfg%Lmisr_sim) then + if (cfg%LclMISR) misr%fq_MISR = cospOUT%misr_fq + ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so + ! they are still computed. Should probably have a logical to control these + ! outputs in cosp_config. In the meantime, only assign v1.4.0 outputs to + ! v2.0 outputs IF a MISR diagnostic was requested. + if (cfg%LclMISR) misr%MISR_meanztop = cospOUT%misr_meanztop + if (cfg%LclMISR) misr%MISR_cldarea = cospOUT%misr_cldarea + if (cfg%LclMISR) misr%MISR_dist_model_layertops = cospOUT%misr_dist_model_layertops + endif + + ! ISCCP + if (cfg%Lisccp_sim) then + if (cfg%Lboxtauisccp) isccp%boxtau = cospOUT%isccp_boxtau + if (cfg%Lboxptopisccp) isccp%boxptop = cospOUT%isccp_boxptop + if (cfg%Lclisccp) isccp%fq_isccp = cospOUT%isccp_fq + if (cfg%Lcltisccp) isccp%totalcldarea = cospOUT%isccp_totalcldarea + if (cfg%Lmeantbisccp) isccp%meantb = cospOUT%isccp_meantb + if (cfg%Lmeantbclrisccp) isccp%meantbclr = cospOUT%isccp_meantbclr + if (cfg%Lpctisccp) isccp%meanptop = cospOUT%isccp_meanptop + if (cfg%Ltauisccp) isccp%meantaucld = cospOUT%isccp_meantaucld + if (cfg%Lalbisccp) isccp%meanalbedocld = cospOUT%isccp_meanalbedocld + endif + + ! MODIS + if (cfg%Lmodis_sim) then + if (cfg%Lcltmodis) modis%Cloud_Fraction_Total_Mean = & + cospOUT%modis_Cloud_Fraction_Total_Mean + if (cfg%Lclwmodis) modis%Cloud_Fraction_Water_Mean = & + cospOUT%modis_Cloud_Fraction_Water_Mean + if (cfg%Lclimodis) modis%Cloud_Fraction_Ice_Mean = & + cospOUT%modis_Cloud_Fraction_Ice_Mean + if (cfg%Lclhmodis) modis%Cloud_Fraction_High_Mean = & + cospOUT%modis_Cloud_Fraction_High_Mean + if (cfg%Lclmmodis) modis%Cloud_Fraction_Mid_Mean = & + cospOUT%modis_Cloud_Fraction_Mid_Mean + if (cfg%Lcllmodis) modis%Cloud_Fraction_Low_Mean = & + cospOUT%modis_Cloud_Fraction_Low_Mean + if (cfg%Ltautmodis) modis%Optical_Thickness_Total_Mean = & + cospOUT%modis_Optical_Thickness_Total_Mean + if (cfg%Ltauwmodis) modis%Optical_Thickness_Water_Mean = & + cospOUT%modis_Optical_Thickness_Water_Mean + if (cfg%Ltauimodis) modis%Optical_Thickness_Ice_Mean = & + cospOUT%modis_Optical_Thickness_Ice_Mean + if (cfg%Ltautlogmodis) modis%Optical_Thickness_Total_LogMean = & + cospOUT%modis_Optical_Thickness_Total_LogMean + if (cfg%Ltauwlogmodis) modis%Optical_Thickness_Water_LogMean = & + cospOUT%modis_Optical_Thickness_Water_LogMean + if (cfg%Ltauilogmodis) modis%Optical_Thickness_Ice_LogMean = & + cospOUT%modis_Optical_Thickness_Ice_LogMean + if (cfg%Lreffclwmodis) modis%Cloud_Particle_Size_Water_Mean = & + cospOUT%modis_Cloud_Particle_Size_Water_Mean + if (cfg%Lreffclimodis) modis%Cloud_Particle_Size_Ice_Mean = & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean + if (cfg%Lpctmodis) modis%Cloud_Top_Pressure_Total_Mean = & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean + if (cfg%Llwpmodis) modis%Liquid_Water_Path_Mean = & + cospOUT%modis_Liquid_Water_Path_Mean + if (cfg%Liwpmodis) modis%Ice_Water_Path_Mean = & + cospOUT%modis_Ice_Water_Path_Mean + if (cfg%Lclmodis) then + modis%Optical_Thickness_vs_Cloud_Top_Pressure = & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure + modis%Optical_Thickness_vs_ReffICE = cospOUT%modis_Optical_Thickness_vs_ReffICE + modis%Optical_Thickness_vs_ReffLIQ = cospOUT%modis_Optical_Thickness_vs_ReffLIQ + endif + endif + + ! PARASOL + if (cfg%Lparasol_sim) then + if (cfg%Lparasolrefl) sglidar%refl = cospOUT%parasolPix_refl + if (cfg%Lparasolrefl) stlidar%parasolrefl = cospOUT%parasolGrid_refl + endif + + ! RTTOV + if (cfg%Lrttov_sim) then + if (cfg%Ltbrttov) rttov%tbs = cospOUT%rttov_tbs + endif + + ! CALIPSO + if (cfg%Llidar_sim) then + ! *NOTE* In COSPv2.0 all outputs are ordered from TOA-2-SFC, but in COSPv1.4 this is + ! not true. To maintain the outputs of v1.4, the affected fields are flipped. + + if (cfg%LlidarBetaMol532) then + sglidar%beta_mol = cospOUT%calipso_beta_mol!(:,sglidar%Nlevels:1:-1) + endif + if (cfg%Latb532) then + !cospOUT%calipso_beta_tot = cospOUT%calipso_beta_tot(:,:,sglidar%Nlevels:1:-1) + sglidar%beta_tot = cospOUT%calipso_beta_tot + endif + if (cfg%LcfadLidarsr532) then + stlidar%srbval = cospOUT%calipso_srbval + stlidar%cfad_sr = cospOUT%calipso_cfad_sr(:,:,vgrid%Nlvgrid:1:-1) + sglidar%betaperp_tot = cospOUT%calipso_betaperp_tot(:,:,sglidar%Nlevels:1:-1) + endif + + if (cfg%Lclcalipso) then + stlidar%lidarcld = cospOUT%calipso_lidarcld(:,stlidar%Nlevels:1:-1) + endif + if (cfg%Lclhcalipso .or. cfg%Lclmcalipso .or. cfg%Lcllcalipso .or. cfg%Lcltcalipso) then + stlidar%cldlayer = cospOUT%calipso_cldlayer + endif + if (cfg%Lclcalipsoice .or. cfg%Lclcalipsoliq .or. cfg%Lclcalipsoun) then + stlidar%lidarcldphase = cospOUT%calipso_lidarcldphase(:,vgrid%Nlvgrid:1:-1,:) + endif + if (cfg%Lcllcalipsoice .or. cfg%Lclmcalipsoice .or. cfg%Lclhcalipsoice .or. & + cfg%Lcltcalipsoice .or. cfg%Lcllcalipsoliq .or. cfg%Lclmcalipsoliq .or. & + cfg%Lclhcalipsoliq .or. cfg%Lcltcalipsoliq .or. cfg%Lcllcalipsoun .or. & + cfg%Lclmcalipsoun .or. cfg%Lclhcalipsoun .or. cfg%Lcltcalipsoun) then + stlidar%cldlayerphase = cospOUT%calipso_cldlayerphase + endif + if (cfg%Lclcalipsotmp .or. cfg%Lclcalipsotmpliq .or. cfg%Lclcalipsoice .or. cfg%Lclcalipsotmpun) then + stlidar%lidarcldtmp = cospOUT%calipso_lidarcldtmp + endif + ! Fields present, but not controlled by logical switch + if (any([cfg%Lclcalipsoliq,cfg%Lclcalipsoice,cfg%Lclcalipsoun,cfg%Lclcalipsotmp, & + cfg%Lclcalipsotmpliq,cfg%Lclcalipsotmpice,cfg%Lclcalipsotmpun,cfg%Lclhcalipsoliq,& + cfg%Lcllcalipsoliq,cfg%Lclmcalipsoliq,cfg%Lcltcalipsoliq,cfg%Lclhcalipsoice,& + cfg%Lcllcalipsoice,cfg%Lclmcalipsoice,cfg%Lcltcalipsoice,cfg%Lclhcalipsoun,& + cfg%Lcllcalipsoun,cfg%Lclmcalipsoun,cfg%Lcltcalipsoun])) then + sglidar%temp_tot = cospOUT%calipso_temp_tot(:,sglidar%Nlevels:1:-1) + sglidar%tau_tot = cospOUT%calipso_tau_tot(:,:,sglidar%Nlevels:1:-1) + endif + endif + + ! Cloudsat + if (cfg%Lradar_sim) then + ! *NOTE* In COSP2 all outputs are ordered from TOA-2-SFC, but in COSPv1.4 this is + ! not true. To maintain the outputs of v1.4, the affected fields are flipped. + if (cfg%Ldbze94) then + sgradar%Ze_tot = cospOUT%cloudsat_Ze_tot!(:,:,sgradar%Nlevels:1:-1) + endif + if (cfg%LcfadDbze94) then + stradar%cfad_ze = cospOUT%cloudsat_cfad_ze(:,:,stradar%Nlevels:1:-1) + endif + endif + + ! Combined instrument products + if (cfg%Lclcalipso2) then + stradar%lidar_only_freq_cloud = cospOUT%lidar_only_freq_cloud(:,stradar%Nlevels:1:-1) + endif + if (cfg%Lcltlidarradar) stradar%radar_lidar_tcc = cospOUT%radar_lidar_tcc + + ! Subcolumns + sgx%frac_out = sgx%frac_out(:,:,sgx%Nlevels:1:-1) + + ! Clean-up memory + call destroy_cosp_outputs(cospOUT) + deallocate(vgrid_zl,vgrid_zu,vgrid_z) + + end subroutine cosp_interface_v1p4 + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE subsample_and_optics + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine subsample_and_optics(overlap,gbx,sgx,cfg,npoints,start_idx,end_idx,cospIN,cospgridIN) + + ! Inputs + integer, intent(in) :: overlap ! Overlap type in SCOPS: 1=max, 2=rand, 3=max/rand + type(cosp_gridbox),intent(in) :: gbx ! Grid box description + type(cosp_config),intent(in) :: cfg ! Configuration information + type(cosp_subgrid),intent(inout) :: sgx ! Sub-grid scale description + integer,intent(in) :: & + npoints, & ! Number of points + start_idx, & ! Starting index for subsetting input data. + end_idx ! Ending index for subsetting input data. + ! Outputs + type(cosp_optical_inputs),intent(inout) :: & + cospIN ! Optical (or derived) fields needed by simulators + type(cosp_column_inputs),intent(inout) :: & + cospgridIN ! Model fields needed by simulators + + ! Local variables + integer :: i,j,k,ij + real(wp),dimension(npoints,gbx%Nlevels) :: column_frac_out,column_prec_out + real(wp),dimension(:,:), allocatable :: frac_ls,frac_cv,prec_ls,prec_cv,ls_p_rate,& + cv_p_rate,g_vol + real(wp),dimension(:,:,:),allocatable :: hm_matrix,re_matrix, & + Np_matrix,MODIS_cloudWater,MODIS_cloudIce, & + MODIS_watersize,MODIS_iceSize, & + MODIS_opticalThicknessLiq, & + MODIS_opticalThicknessIce + real(wp),dimension(:,:,:,:),allocatable :: mr_hydro,Reff,Np + type(rng_state),allocatable,dimension(:) :: rngs ! Seeds for random number generator + integer,dimension(:),allocatable :: seed + logical :: cmpGases=.true. + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Initialize COSP inputs + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + cospIN%tautot_S_liq = 0._wp + cospIN%tautot_S_ice = 0._wp + cospIN%emsfc_lw = gbx%isccp_emsfc_lw + cospIN%rcfg_cloudsat = rcfg_cloudsat + cospgridIN%hgt_matrix(1:nPoints,1:gbx%Nlevels) = gbx%zlev(start_idx:end_idx,gbx%Nlevels:1:-1) + cospgridIN%hgt_matrix_half(1:nPoints,1:gbx%Nlevels) = gbx%zlev_half(start_idx:end_idx,gbx%Nlevels:1:-1) + cospgridIN%sunlit(1:nPoints) = gbx%sunlit(start_idx:end_idx) + cospgridIN%skt(1:nPoints) = gbx%skt(start_idx:end_idx) + cospgridIN%land(1:nPoints) = gbx%land(start_idx:end_idx) + cospgridIN%qv(1:nPoints,1:gbx%Nlevels) = gbx%sh(start_idx:end_idx,gbx%Nlevels:1:-1) + cospgridIN%at(1:nPoints,1:gbx%Nlevels) = gbx%T(start_idx:end_idx,gbx%Nlevels:1:-1) + cospgridIN%pfull(1:nPoints,1:gbx%Nlevels) = gbx%p(start_idx:end_idx,gbx%Nlevels:1:-1) + cospgridIN%o3(1:nPoints,1:gbx%Nlevels) = gbx%mr_ozone(start_idx:end_idx,gbx%Nlevels:1:-1)*(amd/amO3)*1e6 + cospgridIN%u_sfc(1:nPoints) = gbx%u_wind(start_idx:end_idx) + cospgridIN%v_sfc(1:nPoints) = gbx%v_wind(start_idx:end_idx) + cospgridIN%emis_sfc = gbx%surfem + cospgridIN%lat(1:nPoints) = gbx%latitude(start_idx:end_idx) + cospgridIN%lon(1:nPoints) = gbx%longitude(start_idx:end_idx) + cospgridIN%month = 2 ! This is needed by RTTOV only for the surface emissivity calculation. + cospgridIN%co2 = gbx%co2*(amd/amCO2)*1e6 + cospgridIN%ch4 = gbx%ch4*(amd/amCH4)*1e6 + cospgridIN%n2o = gbx%n2o*(amd/amN2O)*1e6 + cospgridIN%co = gbx%co*(amd/amCO)*1e6 + cospgridIN%zenang = gbx%zenang + cospgridIN%phalf(:,1) = 0._wp + cospgridIN%phalf(:,2:gbx%Nlevels+1) = gbx%ph(start_idx:end_idx,gbx%Nlevels:1:-1) + if (gbx%Ncolumns .gt. 1) then + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Random number generator + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + allocate(rngs(Npoints),seed(Npoints)) + seed(:)=0 + seed = int(gbx%psfc) ! In case of Npoints=1 + if (Npoints .gt. 1) seed=int((gbx%psfc(start_idx:end_idx)-minval(gbx%psfc(start_idx:end_idx)))/ & + (maxval(gbx%psfc(start_idx:end_idx))-minval(gbx%psfc(start_idx:end_idx)))*100000) + 1 + call init_rng(rngs, seed) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Generate subcolumns for clouds (SCOPS) and precipitation type (PREC_SCOPS) + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Call SCOPS + if (gbx%Ncolumns .gt. 1) then + call scops(npoints,gbx%Nlevels,gbx%Ncolumns,rngs, & + gbx%tca(start_idx:end_idx,gbx%Nlevels:1:-1), & + gbx%cca(start_idx:end_idx,gbx%Nlevels:1:-1),overlap, & + sgx%frac_out(start_idx:end_idx,:,:),0) + deallocate(seed,rngs) + else + sgx%frac_out(start_idx:end_idx,:,:) = 1 + endif + cospIN%frac_out=sgx%frac_out(start_idx:end_idx,:,:) + + ! Sum up precipitation rates + allocate(ls_p_rate(npoints,gbx%Nlevels),cv_p_rate(npoints,gbx%Nlevels)) + if(gbx%use_precipitation_fluxes) then + ls_p_rate(:,gbx%Nlevels:1:-1) = gbx%rain_ls(start_idx:end_idx,1:gbx%Nlevels) + & + gbx%snow_ls(start_idx:end_idx,1:gbx%Nlevels) + & + gbx%grpl_ls(start_idx:end_idx,1:gbx%Nlevels) + cv_p_rate(:,gbx%Nlevels:1:-1) = gbx%rain_cv(start_idx:end_idx,1:gbx%Nlevels) + & + gbx%snow_cv(start_idx:end_idx,1:gbx%Nlevels) + else + ls_p_rate(:,gbx%Nlevels:1:-1) = & + gbx%mr_hydro(start_idx:end_idx,1:gbx%Nlevels,I_LSRAIN) + & + gbx%mr_hydro(start_idx:end_idx,1:gbx%Nlevels,I_LSSNOW) + & + gbx%mr_hydro(start_idx:end_idx,1:gbx%Nlevels,I_LSGRPL) + cv_p_rate(:,gbx%Nlevels:1:-1) = & + gbx%mr_hydro(start_idx:end_idx,1:gbx%Nlevels,I_CVRAIN) + & + gbx%mr_hydro(start_idx:end_idx,1:gbx%Nlevels,I_CVSNOW) + endif + + ! Call PREC_SCOPS + call prec_scops(npoints,gbx%Nlevels,gbx%Ncolumns,ls_p_rate,cv_p_rate, & + sgx%frac_out(start_idx:end_idx,:,:), & + sgx%prec_frac(start_idx:end_idx,:,:)) + deallocate(ls_p_rate,cv_p_rate) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Compute precipitation fraction in each gridbox + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Allocate + allocate(frac_ls(npoints,gbx%Nlevels),prec_ls(npoints,gbx%Nlevels), & + frac_cv(npoints,gbx%Nlevels),prec_cv(npoints,gbx%Nlevels)) + + ! Initialize + frac_ls(1:npoints,1:gbx%Nlevels) = 0._wp + prec_ls(1:npoints,1:gbx%Nlevels) = 0._wp + frac_cv(1:npoints,1:gbx%Nlevels) = 0._wp + prec_cv(1:npoints,1:gbx%Nlevels) = 0._wp + do j=1,npoints,1 + do k=1,gbx%Nlevels,1 + do i=1,gbx%Ncolumns,1 + if (sgx%frac_out(start_idx+j-1,i,gbx%Nlevels+1-k) == I_LSC) & + frac_ls(j,k) = frac_ls(j,k)+1._wp + if (sgx%frac_out(start_idx+j-1,i,gbx%Nlevels+1-k) == I_CVC) & + frac_cv(j,k) = frac_cv(j,k)+1._wp + if (sgx%prec_frac(start_idx+j-1,i,gbx%Nlevels+1-k) .eq. 1) & + prec_ls(j,k) = prec_ls(j,k)+1._wp + if (sgx%prec_frac(start_idx+j-1,i,gbx%Nlevels+1-k) .eq. 2) & + prec_cv(j,k) = prec_cv(j,k)+1._wp + if (sgx%prec_frac(start_idx+j-1,i,gbx%Nlevels+1-k) .eq. 3) & + prec_cv(j,k) = prec_cv(j,k)+1._wp + if (sgx%prec_frac(start_idx+j-1,i,gbx%Nlevels+1-k) .eq. 3) & + prec_ls(j,k) = prec_ls(j,k)+1._wp + enddo + frac_ls(j,k)=frac_ls(j,k)/gbx%Ncolumns + frac_cv(j,k)=frac_cv(j,k)/gbx%Ncolumns + prec_ls(j,k)=prec_ls(j,k)/gbx%Ncolumns + prec_cv(j,k)=prec_cv(j,k)/gbx%Ncolumns + enddo + enddo + + ! Flip SCOPS output from TOA-to-SFC to SFC-to-TOA + sgx%frac_out(start_idx:end_idx,:,1:gbx%Nlevels) = & + sgx%frac_out(start_idx:end_idx,:,gbx%Nlevels:1:-1) + sgx%prec_frac(start_idx:end_idx,:,1:gbx%Nlevels) = & + sgx%prec_frac(start_idx:end_idx,:,gbx%Nlevels:1:-1) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Compute mixing ratios, effective radii and precipitation fluxes for clouds + ! and precipitation + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + allocate(mr_hydro(npoints, gbx%Ncolumns, gbx%Nlevels, gbx%Nhydro), & + Reff( npoints, gbx%Ncolumns, gbx%Nlevels, gbx%Nhydro), & + Np( npoints, gbx%Ncolumns, gbx%Nlevels, gbx%Nhydro)) + mr_hydro(:,:,:,:) = 0._wp + Reff(:,:,:,:) = 0._wp + Np(:,:,:,:) = 0._wp + do k=1,gbx%Ncolumns + ! Subcolumn cloud fraction + column_frac_out = sgx%frac_out(start_idx:end_idx,k,:) + + ! LS clouds + where (column_frac_out == I_LSC) + mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(start_idx:end_idx,:,I_LSCLIQ) + mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(start_idx:end_idx,:,I_LSCICE) + Reff(:,k,:,I_LSCLIQ) = gbx%Reff(start_idx:end_idx,:,I_LSCLIQ) + Reff(:,k,:,I_LSCICE) = gbx%Reff(start_idx:end_idx,:,I_LSCICE) + Np(:,k,:,I_LSCLIQ) = gbx%Np(start_idx:end_idx,:,I_LSCLIQ) + Np(:,k,:,I_LSCICE) = gbx%Np(start_idx:end_idx,:,I_LSCICE) + ! CONV clouds + elsewhere (column_frac_out == I_CVC) + mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(start_idx:end_idx,:,I_CVCLIQ) + mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(start_idx:end_idx,:,I_CVCICE) + Reff(:,k,:,I_CVCLIQ) = gbx%Reff(start_idx:end_idx,:,I_CVCLIQ) + Reff(:,k,:,I_CVCICE) = gbx%Reff(start_idx:end_idx,:,I_CVCICE) + Np(:,k,:,I_CVCLIQ) = gbx%Np(start_idx:end_idx,:,I_CVCLIQ) + Np(:,k,:,I_CVCICE) = gbx%Np(start_idx:end_idx,:,I_CVCICE) + end where + + ! Subcolumn precipitation + column_prec_out = sgx%prec_frac(start_idx:end_idx,k,:) + + ! LS Precipitation + where ((column_prec_out == 1) .or. (column_prec_out == 3) ) + Reff(:,k,:,I_LSRAIN) = gbx%Reff(start_idx:end_idx,:,I_LSRAIN) + Reff(:,k,:,I_LSSNOW) = gbx%Reff(start_idx:end_idx,:,I_LSSNOW) + Reff(:,k,:,I_LSGRPL) = gbx%Reff(start_idx:end_idx,:,I_LSGRPL) + Np(:,k,:,I_LSRAIN) = gbx%Np(start_idx:end_idx,:,I_LSRAIN) + Np(:,k,:,I_LSSNOW) = gbx%Np(start_idx:end_idx,:,I_LSSNOW) + Np(:,k,:,I_LSGRPL) = gbx%Np(start_idx:end_idx,:,I_LSGRPL) + ! CONV precipitation + elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3)) + Reff(:,k,:,I_CVRAIN) = gbx%Reff(start_idx:end_idx,:,I_CVRAIN) + Reff(:,k,:,I_CVSNOW) = gbx%Reff(start_idx:end_idx,:,I_CVSNOW) + Np(:,k,:,I_CVRAIN) = gbx%Np(start_idx:end_idx,:,I_CVRAIN) + Np(:,k,:,I_CVSNOW) = gbx%Np(start_idx:end_idx,:,I_CVSNOW) + end where + enddo + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Convert the mixing ratio and precipitation fluxes from gridbox mean to + ! the fraction-based values + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + do k=1,gbx%Nlevels + do j=1,npoints + ! Clouds + if (frac_ls(j,k) .ne. 0.) then + mr_hydro(j,:,k,I_LSCLIQ) = mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k) + mr_hydro(j,:,k,I_LSCICE) = mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k) + endif + if (frac_cv(j,k) .ne. 0.) then + mr_hydro(j,:,k,I_CVCLIQ) = mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k) + mr_hydro(j,:,k,I_CVCICE) = mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k) + endif + ! Precipitation + if (gbx%use_precipitation_fluxes) then + if (prec_ls(j,k) .ne. 0.) then + gbx%rain_ls(start_idx+j-1,k) = gbx%rain_ls(start_idx+j-1,k)/prec_ls(j,k) + gbx%snow_ls(start_idx+j-1,k) = gbx%snow_ls(start_idx+j-1,k)/prec_ls(j,k) + gbx%grpl_ls(start_idx+j-1,k) = gbx%grpl_ls(start_idx+j-1,k)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + gbx%rain_cv(start_idx+j-1,k) = gbx%rain_cv(start_idx+j-1,k)/prec_cv(j,k) + gbx%snow_cv(start_idx+j-1,k) = gbx%snow_cv(start_idx+j-1,k)/prec_cv(j,k) + endif + else + if (prec_ls(j,k) .ne. 0.) then + mr_hydro(j,:,k,I_LSRAIN) = mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k) + mr_hydro(j,:,k,I_LSSNOW) = mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k) + mr_hydro(j,:,k,I_LSGRPL) = mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + mr_hydro(j,:,k,I_CVRAIN) = mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k) + mr_hydro(j,:,k,I_CVSNOW) = mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k) + endif + endif + enddo + enddo + deallocate(frac_ls,prec_ls,frac_cv,prec_cv) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Convert precipitation fluxes to mixing ratios + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (gbx%use_precipitation_fluxes) then + call cosp_precip_mxratio(npoints, gbx%Nlevels, gbx%Ncolumns, & + gbx%p(start_idx:end_idx,:),gbx%T(start_idx:end_idx,:),& + sgx%prec_frac(start_idx:end_idx,:,:), 1._wp, & + n_ax(I_LSRAIN), n_bx(I_LSRAIN), alpha_x(I_LSRAIN), & + c_x(I_LSRAIN), d_x(I_LSRAIN), g_x(I_LSRAIN), & + a_x(I_LSRAIN), b_x(I_LSRAIN), gamma_1(I_LSRAIN), & + gamma_2(I_LSRAIN),gamma_3(I_LSRAIN),gamma_4(I_LSRAIN),& + gbx%rain_ls(start_idx:end_idx,:), & + mr_hydro(:,:,:,I_LSRAIN),Reff(:,:,:,I_LSRAIN)) + call cosp_precip_mxratio(npoints, gbx%Nlevels, gbx%Ncolumns, & + gbx%p(start_idx:end_idx,:),gbx%T(start_idx:end_idx,:),& + sgx%prec_frac(start_idx:end_idx,:,:), 1._wp, & + n_ax(I_LSSNOW), n_bx(I_LSSNOW), alpha_x(I_LSSNOW), & + c_x(I_LSSNOW), d_x(I_LSSNOW), g_x(I_LSSNOW), & + a_x(I_LSSNOW), b_x(I_LSSNOW), gamma_1(I_LSSNOW), & + gamma_2(I_LSSNOW),gamma_3(I_LSSNOW),gamma_4(I_LSSNOW),& + gbx%snow_ls(start_idx:end_idx,:), & + mr_hydro(:,:,:,I_LSSNOW),Reff(:,:,:,I_LSSNOW)) + call cosp_precip_mxratio(npoints, gbx%Nlevels, gbx%Ncolumns, & + gbx%p(start_idx:end_idx,:),gbx%T(start_idx:end_idx,:),& + sgx%prec_frac(start_idx:end_idx,:,:), 2._wp, & + n_ax(I_CVRAIN), n_bx(I_CVRAIN), alpha_x(I_CVRAIN), & + c_x(I_CVRAIN), d_x(I_CVRAIN), g_x(I_CVRAIN), & + a_x(I_CVRAIN), b_x(I_CVRAIN), gamma_1(I_CVRAIN), & + gamma_2(I_CVRAIN),gamma_3(I_CVRAIN),gamma_4(I_CVRAIN),& + gbx%rain_cv(start_idx:end_idx,:), & + mr_hydro(:,:,:,I_CVRAIN),Reff(:,:,:,I_CVRAIN)) + call cosp_precip_mxratio(npoints, gbx%Nlevels, gbx%Ncolumns, & + gbx%p(start_idx:end_idx,:),gbx%T(start_idx:end_idx,:),& + sgx%prec_frac(start_idx:end_idx,:,:), 2._wp, & + n_ax(I_CVSNOW), n_bx(I_CVSNOW), alpha_x(I_CVSNOW), & + c_x(I_CVSNOW), d_x(I_CVSNOW), g_x(I_CVSNOW), & + a_x(I_CVSNOW), b_x(I_CVSNOW), gamma_1(I_CVSNOW), & + gamma_2(I_CVSNOW),gamma_3(I_CVSNOW),gamma_4(I_CVSNOW),& + gbx%snow_cv(start_idx:end_idx,:), & + mr_hydro(:,:,:,I_CVSNOW),Reff(:,:,:,I_CVSNOW)) + call cosp_precip_mxratio(npoints, gbx%Nlevels, gbx%Ncolumns, & + gbx%p(start_idx:end_idx,:),gbx%T(start_idx:end_idx,:),& + sgx%prec_frac(start_idx:end_idx,:,:), 1._wp, & + n_ax(I_LSGRPL), n_bx(I_LSGRPL), alpha_x(I_LSGRPL), & + c_x(I_LSGRPL), d_x(I_LSGRPL), g_x(I_LSGRPL), & + a_x(I_LSGRPL), b_x(I_LSGRPL), gamma_1(I_LSGRPL), & + gamma_2(I_LSGRPL),gamma_3(I_LSGRPL),gamma_4(I_LSGRPL),& + gbx%grpl_ls(start_idx:end_idx,:), & + mr_hydro(:,:,:,I_LSGRPL),Reff(:,:,:,I_LSGRPL)) + endif + else + allocate(mr_hydro(npoints, 1, gbx%Nlevels, gbx%Nhydro), & + Reff(npoints, 1, gbx%Nlevels, gbx%Nhydro), & + Np(npoints, 1, gbx%Nlevels, gbx%Nhydro)) + mr_hydro(:,1,:,:) = gbx%mr_hydro(start_idx:end_idx,:,:) + Reff(:,1,:,:) = gbx%Reff(start_idx:end_idx,:,:) + Np(:,1,:,:) = gbx%Np(start_idx:end_idx,:,:) + where(gbx%dtau_s(start_idx:end_idx,:) .gt. 0) + sgx%frac_out(start_idx:end_idx,1,:) = 1 + endwhere + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 11 micron emissivity + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call cosp_simulator_optics(npoints,gbx%Ncolumns,gbx%Nlevels, & + sgx%frac_out(start_idx:end_idx,:,gbx%Nlevels:1:-1), & + gbx%dem_c(start_idx:end_idx,gbx%Nlevels:1:-1), & + gbx%dem_s(start_idx:end_idx,gbx%Nlevels:1:-1), & + cospIN%emiss_11) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 0.67 micron optical depth + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + call cosp_simulator_optics(npoints,gbx%Ncolumns,gbx%Nlevels, & + sgx%frac_out(start_idx:end_idx,:,gbx%Nlevels:1:-1), & + gbx%dtau_c(start_idx:end_idx,gbx%Nlevels:1:-1), & + gbx%dtau_s(start_idx:end_idx,gbx%Nlevels:1:-1), & + cospIN%tau_067) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! LIDAR Polarized optics + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Llidar_sim) then + call lidar_optics(npoints,gbx%Ncolumns,gbx%Nlevels,4,gbx%lidar_ice_type, & + mr_hydro(:,:,cospIN%Nlevels:1:-1,I_LSCLIQ), & + mr_hydro(:,:,cospIN%Nlevels:1:-1,I_LSCICE), & + mr_hydro(:,:,cospIN%Nlevels:1:-1,I_CVCLIQ), & + mr_hydro(:,:,cospIN%Nlevels:1:-1,I_CVCICE), & + gbx%Reff(start_idx:end_idx,cospIN%Nlevels:1:-1,I_LSCLIQ), & + gbx%Reff(start_idx:end_idx,cospIN%Nlevels:1:-1,I_LSCICE), & + gbx%Reff(start_idx:end_idx,cospIN%Nlevels:1:-1,I_CVCLIQ), & + gbx%Reff(start_idx:end_idx,cospIN%Nlevels:1:-1,I_CVCICE), & + cospgridIN%pfull,cospgridIN%phalf,cospgridIN%at, & + cospIN%beta_mol,cospIN%betatot,cospIN%tau_mol,cospIN%tautot, & + cospIN%tautot_S_liq,cospIN%tautot_S_ice, & + betatot_ice = cospIN%betatot_ice, & + betatot_liq=cospIN%betatot_liq,tautot_ice=cospIN%tautot_ice, & + tautot_liq = cospIN%tautot_liq) + endif + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! CLOUDSAT RADAR OPTICS + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Lradar_sim) then + allocate(g_vol(nPoints,gbx%Nlevels)) + do ij=1,gbx%Ncolumns + if (ij .eq. 1) then + cmpGases = .true. + call quickbeam_optics(sd, rcfg_cloudsat,npoints,gbx%Nlevels, R_UNDEF, & + mr_hydro(:,ij,gbx%Nlevels:1:-1,1:N_HYDRO)*1000._wp, & + Reff(:,ij,gbx%Nlevels:1:-1,1:N_HYDRO)*1.e6_wp, & + Np(:,ij,gbx%Nlevels:1:-1,1:N_HYDRO), & + gbx%p(start_idx:end_idx,gbx%Nlevels:1:-1), & + gbx%T(start_idx:end_idx,gbx%Nlevels:1:-1), & + gbx%sh(start_idx:end_idx,gbx%Nlevels:1:-1),cmpGases, & + cospIN%z_vol_cloudsat(1:npoints,ij,:), & + cospIN%kr_vol_cloudsat(1:npoints,ij,:), & + cospIN%g_vol_cloudsat(1:npoints,ij,:),g_vol_out=g_vol) + else + cmpGases = .false. + call quickbeam_optics(sd, rcfg_cloudsat,npoints,gbx%Nlevels, R_UNDEF, & + mr_hydro(:,ij,gbx%Nlevels:1:-1,1:N_HYDRO)*1000._wp, & + Reff(:,ij,gbx%Nlevels:1:-1,1:N_HYDRO)*1.e6_wp, & + Np(:,ij,gbx%Nlevels:1:-1,1:N_HYDRO), & + gbx%p(start_idx:end_idx,gbx%Nlevels:1:-1), & + gbx%T(start_idx:end_idx,gbx%Nlevels:1:-1), & + gbx%sh(start_idx:end_idx,gbx%Nlevels:1:-1),cmpGases, & + cospIN%z_vol_cloudsat(1:npoints,ij,:), & + cospIN%kr_vol_cloudsat(1:npoints,ij,:), & + cospIN%g_vol_cloudsat(1:npoints,ij,:),g_vol_in=g_vol) + end if + enddo + end if + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! MODIS optics + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Lmodis_sim) then + ! Allocate memory + allocate(MODIS_cloudWater(npoints,gbx%Ncolumns,gbx%Nlevels), & + MODIS_cloudIce(npoints,gbx%Ncolumns,gbx%Nlevels), & + MODIS_waterSize(npoints,gbx%Ncolumns,gbx%Nlevels), & + MODIS_iceSize(npoints,gbx%Ncolumns,gbx%Nlevels), & + MODIS_opticalThicknessLiq(npoints,gbx%Ncolumns,gbx%Nlevels), & + MODIS_opticalThicknessIce(npoints,gbx%Ncolumns,gbx%Nlevels)) + ! Cloud water + call cosp_simulator_optics(npoints,gbx%Ncolumns,gbx%Nlevels, & + sgx%frac_out(start_idx:end_idx,:,:),mr_hydro(:,:,:,I_CVCLIQ), & + mr_hydro(:,:,:,I_LSCLIQ),MODIS_cloudWater(:, :, gbx%Nlevels:1:-1)) + ! Cloud ice + call cosp_simulator_optics(npoints,gbx%Ncolumns,gbx%Nlevels, & + sgx%frac_out(start_idx:end_idx,:,:),mr_hydro(:,:,:,I_CVCICE), & + mr_hydro(:,:,:,I_LSCICE),MODIS_cloudIce(:, :, gbx%Nlevels:1:-1)) + ! Water droplet size + call cosp_simulator_optics(npoints,gbx%Ncolumns,gbx%Nlevels, & + sgx%frac_out(start_idx:end_idx,:,:),reff(:,:,:,I_CVCLIQ), & + reff(:,:,:,I_LSCLIQ),MODIS_waterSize(:, :, gbx%Nlevels:1:-1)) + ! Ice crystal size + call cosp_simulator_optics(npoints,gbx%Ncolumns,gbx%Nlevels, & + sgx%frac_out(start_idx:end_idx,:,:),reff(:,:,:,I_CVCICE), & + reff(:,:,:,I_LSCICE),MODIS_iceSize(:, :, gbx%Nlevels:1:-1)) + ! Partition optical thickness into liquid and ice parts + call modis_optics_partition(npoints,gbx%Nlevels,gbx%Ncolumns,MODIS_cloudWater, & + MODIS_cloudIce,MODIS_waterSize,MODIS_iceSize,cospIN%tau_067, & + MODIS_opticalThicknessLiq, MODIS_opticalThicknessIce) + ! Compute assymetry parameter and single scattering albedo + call modis_optics(npoints,gbx%Nlevels,gbx%Ncolumns,MODIS_opticalThicknessLiq, & + MODIS_waterSize*1.0e6_wp,MODIS_opticalThicknessIce,MODIS_iceSize*1.0e6_wp, & + cospIN%fracLiq, cospIN%asym, cospIN%ss_alb) + + ! Deallocate memory + deallocate(MODIS_cloudWater,MODIS_cloudIce,MODIS_WaterSize,MODIS_iceSize, & + MODIS_opticalThicknessLiq,MODIS_opticalThicknessIce,mr_hydro, & + Reff,Np) + end if + + end subroutine subsample_and_optics + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_gridbox + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_cosp_gridbox(time,time_bnds,radar_freq,surface_radar, & + use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,& + Naero,Nprmts_max_aero,Npoints_it,lidar_ice_type, & + isccp_top_height,isccp_top_height_direction, & + isccp_overlap,isccp_emsfc_lw, & + use_precipitation_fluxes,use_reff,Plat,Sat,Inst, & + Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co, & + y,load_LUT) + ! Inputs + double precision,intent(in) :: & + time, & ! Time since start of run [days] + time_bnds(2) ! Time boundaries + integer,intent(in) :: & + surface_radar, & ! surface=1,spaceborne=0 + use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first + ! column everywhere + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay, & ! melting layer model off=0, on=1 + Npoints, & ! Number of gridpoints + Nlevels, & ! Number of levels + Ncolumns, & ! Number of columns + Nhydro, & ! Number of hydrometeors + Nprmts_max_hydro, & ! Max number of parameters for hydrometeor size + ! distributions + Naero, & ! Number of aerosol species + Nprmts_max_aero, & ! Max number of parameters for aerosol size distributions + Npoints_it, & ! Number of gridpoints processed in one iteration + lidar_ice_type, & ! Ice particle shape in lidar calculations (0=ice-spheres ; + ! 1=ice-non-spherical) + isccp_top_height , & ! + isccp_top_height_direction, & ! + isccp_overlap, & ! + Plat, & ! RTTOV satellite platform + Sat, & ! RTTOV satellite + Inst, & ! RTTOV instrument + Nchan ! RTTOV number of channels + integer,intent(in),dimension(Nchan) :: & + Ichan + real(wp),intent(in) :: & + radar_freq, & ! Radar frequency [GHz] + k2, & ! |K|^2, -1=use frequency dependent default + isccp_emsfc_lw, & ! 11microm surface emissivity + co2, & ! CO2 + ch4, & ! CH4 + n2o, & ! N2O + co, & ! CO + ZenAng ! RTTOV zenith abgle + real(wp),intent(in),dimension(Nchan) :: & + SurfEm + logical,intent(in) :: & + use_precipitation_fluxes,& + use_reff + logical,intent(in),optional :: load_LUT + + ! Outputs + type(cosp_gridbox),intent(out) :: y + + ! local variables + logical :: local_load_LUT + + if (present(load_LUT)) then + local_load_LUT = load_LUT + else + local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag + endif + + ! Dimensions and scalars + y%radar_freq = radar_freq + y%surface_radar = surface_radar + y%use_mie_tables = use_mie_tables + y%use_gas_abs = use_gas_abs + y%do_ray = do_ray + y%melt_lay = melt_lay + y%k2 = k2 + y%Npoints = Npoints + y%Nlevels = Nlevels + y%Ncolumns = Ncolumns + y%Nhydro = Nhydro + y%Nprmts_max_hydro = Nprmts_max_hydro + y%Naero = Naero + y%Nprmts_max_aero = Nprmts_max_aero + y%Npoints_it = Npoints_it + y%lidar_ice_type = lidar_ice_type + y%isccp_top_height = isccp_top_height + y%isccp_top_height_direction = isccp_top_height_direction + y%isccp_overlap = isccp_overlap + y%isccp_emsfc_lw = isccp_emsfc_lw + y%use_precipitation_fluxes = use_precipitation_fluxes + y%use_reff = use_reff + y%time = time + y%time_bnds = time_bnds + + ! RTTOV parameters + y%Plat = Plat + y%Sat = Sat + y%Inst = Inst + y%Nchan = Nchan + y%ZenAng = ZenAng + y%co2 = co2 + y%ch4 = ch4 + y%n2o = n2o + y%co = co + + ! Gridbox information (Npoints,Nlevels) + allocate(y%zlev(Npoints,Nlevels),y%zlev_half(Npoints,Nlevels), & + y%dlev(Npoints,Nlevels),y%p(Npoints,Nlevels),y%ph(Npoints,Nlevels), & + y%T(Npoints,Nlevels),y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), & + y%dtau_s(Npoints,Nlevels),y%dtau_c(Npoints,Nlevels), & + y%dem_s(Npoints,Nlevels),y%dem_c(Npoints,Nlevels),y%tca(Npoints,Nlevels), & + y%cca(Npoints,Nlevels),y%rain_ls(Npoints,Nlevels), & + y%rain_cv(Npoints,Nlevels),y%grpl_ls(Npoints,Nlevels), & + y%snow_ls(Npoints,Nlevels),y%snow_cv(Npoints,Nlevels), & + y%mr_ozone(Npoints,Nlevels)) + + ! Surface information and geolocation (Npoints) + allocate(y%toffset(Npoints),y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints),& + y%land(Npoints),y%sunlit(Npoints),y%skt(Npoints),y%u_wind(Npoints), & + y%v_wind(Npoints)) + + ! Hydrometeors concentration and distribution parameters + allocate(y%mr_hydro(Npoints,Nlevels,Nhydro),y%Reff(Npoints,Nlevels,Nhydro), & + y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro),y%Np(Npoints,Nlevels,Nhydro)) + + ! Aerosols concentration and distribution parameters + allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), & + y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero)) + + ! RTTOV channels and sfc. emissivity + allocate(y%ichan(Nchan),y%surfem(Nchan)) + y%ichan = ichan + y%surfem = surfem + + ! Initialize + y%zlev = 0.0 + y%zlev_half = 0.0 + y%dlev = 0.0 + y%p = 0.0 + y%ph = 0.0 + y%T = 0.0 + y%q = 0.0 + y%sh = 0.0 + y%dtau_s = 0.0 + y%dtau_c = 0.0 + y%dem_s = 0.0 + y%dem_c = 0.0 + y%tca = 0.0 + y%cca = 0.0 + y%rain_ls = 0.0 + y%rain_cv = 0.0 + y%grpl_ls = 0.0 + y%snow_ls = 0.0 + y%snow_cv = 0.0 + y%Reff = 0.0 + y%Np = 0.0 + y%mr_ozone = 0.0 + y%u_wind = 0.0 + y%v_wind = 0.0 + y%toffset = 0.0 + y%longitude = 0.0 + y%latitude = 0.0 + y%psfc = 0.0 + y%land = 0.0 + y%sunlit = 0.0 + y%skt = 0.0 + y%mr_hydro = 0.0 + y%dist_prmts_hydro = 0.0 + y%conc_aero = 0.0 + y%dist_type_aero = 0 + y%dist_prmts_aero = 0.0 + + END SUBROUTINE CONSTRUCT_cosp_gridbox + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_gridbox + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE destroy_cosp_gridbox(y,save_LUT) + + type(cosp_gridbox),intent(inout) :: y + logical,intent(in),optional :: save_LUT + + logical :: local_save_LUT + if (present(save_LUT)) then + local_save_LUT = save_LUT + else + local_save_LUT = RADAR_SIM_UPDATE_scale_LUTs_flag + endif + + ! save any updates to radar simulator LUT + if (local_save_LUT) call save_scale_LUTs(y%hp) + + deallocate(y%zlev,y%zlev_half,y%dlev,y%p,y%ph,y%T,y%q,y%sh,y%dtau_s,y%dtau_c,y%dem_s,& + y%dem_c,y%toffset,y%longitude,y%latitude,y%psfc,y%land,y%tca,y%cca, & + y%mr_hydro,y%dist_prmts_hydro,y%conc_aero,y%dist_type_aero, & + y%dist_prmts_aero,y%rain_ls,y%rain_cv,y%snow_ls,y%snow_cv,y%grpl_ls, & + y%sunlit,y%skt,y%Reff,y%Np,y%ichan,y%surfem,y%mr_ozone,y%u_wind,y%v_wind) + + END SUBROUTINE destroy_cosp_gridbox + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_subgrid + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y) + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nlevels ! Number of levels + ! Outputs + type(cosp_subgrid),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + + ! Allocate + allocate(y%frac_out(Npoints,Ncolumns,Nlevels)) + if (Ncolumns > 1) then + allocate(y%prec_frac(Npoints,Ncolumns,Nlevels)) + else ! CRM mode, not needed + allocate(y%prec_frac(1,1,1)) + endif + + ! Initialize + y%prec_frac = 0._wp + y%frac_out = 0._wp + END SUBROUTINE CONSTRUCT_COSP_SUBGRID + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE save_scale_LUTs + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine save_scale_LUTs(hp) + type(class_param), intent(inout) :: hp + logical :: LUT_file_exists + integer :: i,j,k,ind + + inquire(file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', & + exist=LUT_file_exists) + + OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& + form='unformatted',err= 99,access='DIRECT',recl=28) + + write(*,*) 'Creating or Updating radar LUT file: ', & + trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + do i=1,maxhclass + do j=1,mt_ntt + do k=1,nRe_types + ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) + if(.not.LUT_file_exists .or. hp%Z_scale_added_flag(i,j,k)) then + hp%Z_scale_added_flag(i,j,k)=.false. + write(12,rec=ind) hp%Z_scale_flag(i,j,k), & + hp%Ze_scaled(i,j,k), & + hp%Zr_scaled(i,j,k), & + hp%kr_scaled(i,j,k) + endif + enddo + enddo + enddo + close(unit=12) + return + +99 write(*,*) 'Error: Unable to create/update radar LUT file: ', & + trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + return + end subroutine save_scale_LUTs + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !SUBROUTINE construct_cosp_vgrid + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x) + type(cosp_gridbox),intent(in) :: gbx ! Gridbox information + integer,intent(in) :: Nlvgrid ! Number of new levels + logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid + logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested + type(cosp_vgrid),intent(out) :: x + + ! Local variables + integer :: i + real :: zstep + + x%use_vgrid = use_vgrid + x%csat_vgrid = cloudsat + + ! Dimensions + x%Npoints = gbx%Npoints + x%Ncolumns = gbx%Ncolumns + x%Nlevels = gbx%Nlevels + + ! --- Allocate arrays --- + if (use_vgrid) then + x%Nlvgrid = Nlvgrid + else + x%Nlvgrid = gbx%Nlevels + endif + allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid)) + allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels)) + + ! --- Model vertical levels --- + ! Use height levels of first model gridbox + x%mz = gbx%zlev(1,:) + x%mzl = gbx%zlev_half(1,:) + x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels) + x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels)) + + if (use_vgrid) then + ! --- Initialise to zero --- + x%z = 0.0 + x%zl = 0.0 + x%zu = 0.0 + if (cloudsat) then ! --- CloudSat grid requested --- + zstep = 480.0 + else + ! Other grid requested. Constant vertical spacing with top at 20 km + zstep = 20000.0/x%Nlvgrid + endif + do i=1,x%Nlvgrid + x%zl(i) = (i-1)*zstep + x%zu(i) = i*zstep + enddo + x%z = (x%zl + x%zu)/2.0 + else + x%z = x%mz + x%zl = x%mzl + x%zu = x%mzu + endif + + END SUBROUTINE CONSTRUCT_COSP_VGRID + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_sgradar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine construct_cosp_sgradar(Npoints,Ncolumns,Nlevels,Nhydro,x) + integer,target, intent(in) :: Npoints ! Number of sampled points + integer,target, intent(in) :: Ncolumns ! Number of subgrid columns + integer,target, intent(in) :: Nlevels ! Number of model levels + integer,target, intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_sgradar), intent(out) :: x + + ! Dimensions + x%Npoints => Npoints + x%Ncolumns => Ncolumns + x%Nlevels => Nlevels + x%Nhydro => Nhydro + + ! Allocate + allocate(x%att_gas(Npoints,Nlevels),x%Ze_tot(Npoints,Ncolumns,Nlevels)) + + ! Initialize + x%att_gas = 0._wp + x%Ze_tot = 0._wp + + end subroutine construct_cosp_sgradar + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_radarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine construct_cosp_radarstats(Npoints,Ncolumns,Nlevels,Nhydro,x) + integer,target, intent(in) :: Npoints ! Number of sampled points + integer,target, intent(in) :: Ncolumns ! Number of subgrid columns + integer,target, intent(in) :: Nlevels ! Number of model levels + integer,target, intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_radarstats),intent(out) :: x + + ! Dimensions + x%Npoints => Npoints + x%Ncolumns => Ncolumns + x%Nlevels => Nlevels + x%Nhydro => Nhydro + + ! Allocate + allocate(x%cfad_ze(Npoints,DBZE_BINS,Nlevels),x%lidar_only_freq_cloud(Npoints,Nlevels), & + x%radar_lidar_tcc(Npoints)) + + ! Initialize + x%cfad_ze = 0._wp + x%lidar_only_freq_cloud = 0._wp + x%radar_lidar_tcc = 0._wp + + end subroutine construct_cosp_radarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_subgrid + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cosp_subgrid(y) + type(cosp_subgrid),intent(inout) :: y + deallocate(y%prec_frac, y%frac_out) + end subroutine destroy_cosp_subgrid + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_sgradar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cosp_sgradar(x) + type(cosp_sgradar),intent(inout) :: x + + deallocate(x%att_gas,x%Ze_tot) + + end subroutine destroy_cosp_sgradar + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_radarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cosp_radarstats(x) + type(cosp_radarstats),intent(inout) :: x + + deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc) + + end subroutine destroy_cosp_radarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_sglidar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine construct_cosp_sglidar(Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + ! Inputs + integer,intent(in),target :: & + Npoints, & ! Number of sampled points + Ncolumns, & ! Number of subgrid columns + Nlevels, & ! Number of model levels + Nhydro, & ! Number of hydrometeors + Nrefl ! Number of parasol reflectances ! parasol + ! Outputs + type(cosp_sglidar),intent(out) :: x + + ! Dimensions + x%Npoints => Npoints + x%Ncolumns => Ncolumns + x%Nlevels => Nlevels + x%Nhydro => Nhydro + x%Nrefl => Nrefl + + ! Allocate + allocate(x%beta_mol(x%Npoints,x%Nlevels), x%beta_tot(x%Npoints,x%Ncolumns,x%Nlevels), & + x%tau_tot(x%Npoints,x%Ncolumns,x%Nlevels),x%refl(x%Npoints,x%Ncolumns,x%Nrefl), & + x%temp_tot(x%Npoints,x%Nlevels),x%betaperp_tot(x%Npoints,x%Ncolumns,x%Nlevels)) + + ! Initialize + x%beta_mol = 0._wp + x%beta_tot = 0._wp + x%tau_tot = 0._wp + x%refl = 0._wp + x%temp_tot = 0._wp + x%betaperp_tot = 0._wp + end subroutine construct_cosp_sglidar + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_lidarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine construct_cosp_lidarstats(Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + ! Inputs + integer,intent(in),target :: & + Npoints, & ! Number of sampled points + Ncolumns, & ! Number of subgrid columns + Nlevels, & ! Number of model levels + Nhydro, & ! Number of hydrometeors + Nrefl ! Number of parasol reflectances + ! Outputs + type(cosp_lidarstats),intent(out) :: x + + ! Dimensions + x%Npoints => Npoints + x%Ncolumns => Ncolumns + x%Nlevels => Nlevels + x%Nhydro => Nhydro + x%Nrefl => Nrefl + + ! Allocate + allocate(x%srbval(SR_BINS),x%cfad_sr(x%Npoints,SR_BINS,x%Nlevels), & + x%lidarcld(x%Npoints,x%Nlevels), x%cldlayer(x%Npoints,LIDAR_NCAT),& + x%parasolrefl(x%Npoints,x%Nrefl),x%lidarcldphase(x%Npoints,x%Nlevels,6),& + x%lidarcldtmp(x%Npoints,LIDAR_NTEMP,5),x%cldlayerphase(x%Npoints,LIDAR_NCAT,6)) + + ! Initialize + x%srbval = 0._wp + x%cfad_sr = 0._wp + x%lidarcld = 0._wp + x%cldlayer = 0._wp + x%parasolrefl = 0._wp + x%lidarcldphase = 0._wp + x%cldlayerphase = 0._wp + x%lidarcldtmp = 0._wp + + end subroutine construct_cosp_lidarstats + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_lidarstats + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cosp_lidarstats(x) + type(cosp_lidarstats),intent(inout) :: x + + deallocate(x%srbval,x%cfad_sr,x%lidarcld,x%cldlayer,x%parasolrefl,x%cldlayerphase, & + x%lidarcldtmp,x%lidarcldphase) + + end subroutine destroy_cosp_lidarstats + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_sglidar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cosp_sglidar(x) + type(cosp_sglidar),intent(inout) :: x + + deallocate(x%beta_mol,x%beta_tot,x%tau_tot,x%refl,x%temp_tot,x%betaperp_tot) + end subroutine destroy_cosp_sglidar + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_isccp + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_ISCCP(Npoints,Ncolumns,Nlevels,x) + integer,target, intent(in) :: Npoints ! Number of sampled points + integer,target, intent(in) :: Ncolumns ! Number of subgrid columns + integer,target, intent(in) :: Nlevels ! Number of model levels + type(cosp_isccp), intent(out) :: x ! Output + + x%Npoints => Npoints + x%Ncolumns => Ncolumns + x%Nlevels => Nlevels + x%Npoints => Npoints + x%Ncolumns => Ncolumns + x%Nlevels => Nlevels + + ! Allocate + allocate(x%fq_isccp(Npoints,7,7),x%totalcldarea(Npoints),x%meanptop(Npoints), & + x%meantaucld(Npoints),x%meantb(Npoints),x%meantbclr(Npoints), & + x%meanalbedocld(Npoints),x%boxtau(Npoints,Ncolumns), & + x%boxptop(Npoints,Ncolumns)) + + ! Initialize + x%fq_isccp = 0._wp + x%totalcldarea = 0._wp + x%meanptop = 0._wp + x%meantaucld = 0._wp + x%meantb = 0._wp + x%meantbclr = 0._wp + x%meanalbedocld= 0._wp + x%boxtau = 0._wp + x%boxptop = 0._wp + + END SUBROUTINE CONSTRUCT_COSP_ISCCP + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_isccp + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE destroy_cosp_isccp(x) + type(cosp_isccp),intent(inout) :: x + + deallocate(x%fq_isccp,x%totalcldarea,x%meanptop,x%meantaucld,x%meantb,x%meantbclr, & + x%meanalbedocld,x%boxtau,x%boxptop) + END SUBROUTINE destroy_cosp_isccp + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_misr + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_MISR(Npoints,x) + integer, intent(in),target :: Npoints ! Number of gridpoints + type(cosp_misr), intent(out) :: x + + ! Local variables + integer,target :: & + Ntau=7,Ncth=numMISRHgtBins + + x%Npoints => Npoints + x%Ntau => Ntau + x%Nlevels => Ncth + + ! Allocate + allocate(x%fq_MISR(x%Npoints,x%Ntau,x%Nlevels),x%MISR_meanztop(x%Npoints), & + x%MISR_cldarea(x%Npoints),x%MISR_dist_model_layertops(x%Npoints,x%Nlevels)) + + ! Initialize + x%fq_MISR = 0._wp + x%MISR_meanztop = 0._wp + x%MISR_cldarea = 0._wp + x%MISR_dist_model_layertops = 0._wp + + END SUBROUTINE CONSTRUCT_COSP_MISR + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_misr + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE destroy_cosp_misr(x) + type(cosp_misr),intent(inout) :: x + + if (associated(x%fq_MISR)) deallocate(x%fq_MISR) + if (associated(x%MISR_meanztop)) deallocate(x%MISR_meanztop) + if (associated(x%MISR_cldarea)) deallocate(x%MISR_cldarea) + if (associated(x%MISR_dist_model_layertops)) deallocate(x%MISR_dist_model_layertops) + + END SUBROUTINE destroy_cosp_misr + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_modis + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_MODIS(nPoints, x) + integer,target, intent(in) :: Npoints ! Number of sampled points + type(cosp_MODIS), intent(out) :: x + + x%nPoints => nPoints + + ! Allocate gridmean variables + allocate(x%Cloud_Fraction_Total_Mean(Npoints),x%Cloud_Fraction_Water_Mean(Npoints), & + x%Cloud_Fraction_Ice_Mean(Npoints),x%Cloud_Fraction_High_Mean(Npoints), & + x%Cloud_Fraction_Mid_Mean(Npoints),x%Cloud_Fraction_Low_Mean(Npoints), & + x%Optical_Thickness_Total_Mean(Npoints), & + x%Optical_Thickness_Water_Mean(Npoints), & + x%Optical_Thickness_Ice_Mean(Npoints), & + x%Optical_Thickness_Total_LogMean(Npoints), & + x%Optical_Thickness_Water_LogMean(Npoints), & + x%Optical_Thickness_Ice_LogMean(Npoints), & + x%Cloud_Particle_Size_Water_Mean(Npoints), & + x%Cloud_Particle_Size_Ice_Mean(Npoints), & + x%Cloud_Top_Pressure_Total_Mean(Npoints),x%Liquid_Water_Path_Mean(Npoints), & + x%Ice_Water_Path_Mean(Npoints), & + x%Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,ntauV1p4+1,numMODISPresBins),& + x%Optical_Thickness_vs_ReffICE(nPoints,ntauV1p4+1,numMODISReffIceBins),& + x%Optical_Thickness_vs_ReffLIQ(nPoints,ntauV1p4+1,numMODISReffLiqBins)) + x%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF + x%Optical_Thickness_vs_ReffICE(:,:,:) = R_UNDEF + x%Optical_Thickness_vs_ReffLIQ(:,:,:) = R_UNDEF + END SUBROUTINE CONSTRUCT_COSP_MODIS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_modis + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE destroy_cosp_modis(x) + type(cosp_MODIS),intent(inout) :: x + + ! Free space used by cosp_modis variable. + if(associated(x%Cloud_Fraction_Total_Mean)) deallocate(x%Cloud_Fraction_Total_Mean) + if(associated(x%Cloud_Fraction_Water_Mean)) deallocate(x%Cloud_Fraction_Water_Mean) + if(associated(x%Cloud_Fraction_Ice_Mean)) deallocate(x%Cloud_Fraction_Ice_Mean) + if(associated(x%Cloud_Fraction_High_Mean)) deallocate(x%Cloud_Fraction_High_Mean) + if(associated(x%Cloud_Fraction_Mid_Mean)) deallocate(x%Cloud_Fraction_Mid_Mean) + if(associated(x%Cloud_Fraction_Low_Mean)) deallocate(x%Cloud_Fraction_Low_Mean) + if(associated(x%Liquid_Water_Path_Mean)) deallocate(x%Liquid_Water_Path_Mean) + if(associated(x%Ice_Water_Path_Mean)) deallocate(x%Ice_Water_Path_Mean) + if(associated(x%Optical_Thickness_Total_Mean)) & + deallocate(x%Optical_Thickness_Total_Mean) + if(associated(x%Optical_Thickness_Water_Mean)) & + deallocate(x%Optical_Thickness_Water_Mean) + if(associated(x%Optical_Thickness_Ice_Mean)) & + deallocate(x%Optical_Thickness_Ice_Mean) + if(associated(x%Optical_Thickness_Total_LogMean)) & + deallocate(x%Optical_Thickness_Total_LogMean) + if(associated(x%Optical_Thickness_Water_LogMean)) & + deallocate(x%Optical_Thickness_Water_LogMean) + if(associated(x%Optical_Thickness_Ice_LogMean)) & + deallocate(x%Optical_Thickness_Ice_LogMean) + if(associated(x%Cloud_Particle_Size_Water_Mean)) & + deallocate(x%Cloud_Particle_Size_Water_Mean) + if(associated(x%Cloud_Particle_Size_Ice_Mean)) & + deallocate(x%Cloud_Particle_Size_Ice_Mean) + if(associated(x%Cloud_Top_Pressure_Total_Mean)) & + deallocate(x%Cloud_Top_Pressure_Total_Mean) + if(associated(x%Optical_Thickness_vs_Cloud_Top_Pressure)) & + deallocate(x%Optical_Thickness_vs_Cloud_Top_Pressure) + if(associated(x%Optical_Thickness_vs_ReffICE)) & + deallocate(x%Optical_Thickness_vs_ReffICE) + if(associated(x%Optical_Thickness_vs_ReffLIQ)) & + deallocate(x%Optical_Thickness_vs_ReffLIQ) + END SUBROUTINE destroy_cosp_modis + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cosp_rttov + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_RTTOV(Npoints,Nchan,x) + integer, intent(in) :: Npoints ! Number of sampled points + integer, intent(in) :: Nchan ! Number of channels + type(cosp_rttov), intent(out) :: x + + ! Allocate + allocate(x%tbs(Npoints,Nchan)) + + ! Initialize + x%tbs = 0.0 + END SUBROUTINE CONSTRUCT_COSP_RTTOV + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_rttov + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE destroy_cosp_rttov(x) + type(cosp_rttov),intent(inout) :: x + + ! Deallocate + deallocate(x%tbs) + END SUBROUTINE destroy_cosp_rttov + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_ + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cosp_vgrid(x) + type(cosp_vgrid),intent(inout) :: x + deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu) + end subroutine destroy_cosp_vgrid + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cospIN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine construct_cospIN(npoints,ncolumns,nlevels,y) + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal gridpoints + ncolumns, & ! Number of subcolumns + nlevels ! Number of vertical levels + ! Outputs + type(cosp_optical_inputs),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + y%Npart = 4 + y%Nrefl = PARASOL_NREFL + + allocate(y%tau_067(npoints, ncolumns,nlevels),& + y%emiss_11(npoints, ncolumns,nlevels),& + y%frac_out(npoints, ncolumns,nlevels),& + y%betatot(npoints, ncolumns,nlevels),& + y%betatot_ice(npoints, ncolumns,nlevels),& + y%fracLiq(npoints, ncolumns,nlevels),& + y%betatot_liq(npoints, ncolumns,nlevels),& + y%tautot(npoints, ncolumns,nlevels),& + y%tautot_ice(npoints, ncolumns,nlevels),& + y%tautot_liq(npoints, ncolumns,nlevels),& + y%z_vol_cloudsat(npoints, ncolumns,nlevels),& + y%kr_vol_cloudsat(npoints,ncolumns,nlevels),& + y%g_vol_cloudsat(npoints, ncolumns,nlevels),& + y%asym(npoints, ncolumns,nlevels),& + y%ss_alb(npoints, ncolumns,nlevels),& + y%beta_mol(npoints, nlevels),& + y%tau_mol(npoints, nlevels),& + y%tautot_S_ice(npoints, ncolumns ),& + y%tautot_S_liq(npoints, ncolumns)) + end subroutine construct_cospIN + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cospstateIN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine construct_cospstateIN(npoints,nlevels,nchan,y) + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal gridpoints + nlevels, & ! Number of vertical levels + nchan ! Number of channels + ! Outputs + type(cosp_column_inputs),intent(out) :: y + + allocate(y%sunlit(npoints),y%skt(npoints),y%land(npoints),y%at(npoints,nlevels), & + y%pfull(npoints,nlevels),y%phalf(npoints,nlevels+1),y%qv(npoints,nlevels), & + y%o3(npoints,nlevels),y%hgt_matrix(npoints,nlevels),y%u_sfc(npoints), & + y%v_sfc(npoints),y%lat(npoints),y%lon(nPoints),y%emis_sfc(nchan), & + y%cloudIce(nPoints,nLevels),y%cloudLiq(nPoints,nLevels), & + y%fl_snow(nPoints,nLevels),y%fl_rain(nPoints,nLevels),y%seaice(npoints), & + y%tca(nPoints,nLevels),y%hgt_matrix_half(npoints,nlevels+1)) + + end subroutine construct_cospstateIN + + ! ###################################################################################### + ! SUBROUTINE construct_cosp_outputs + ! + ! This subroutine allocates output fields based on input logical flag switches. + ! ###################################################################################### + subroutine construct_cosp_outputs(Lpctisccp,Lclisccp,& + Lboxptopisccp,Lboxtauisccp,Ltauisccp,Lcltisccp, & + Lmeantbisccp,Lmeantbclrisccp,Lalbisccp,LclMISR, & + Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis, & + Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis, & + Ltautlogmodis,Ltauwlogmodis,Ltauilogmodis, & + Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & + Liwpmodis,Lclmodis,Latb532,LlidarBetaMol532, & + LcfadLidarsr532,Lclcalipso2, & + Lclcalipso,Lclhcalipso,Lcllcalipso,Lclmcalipso, & + Lcltcalipso,Lcltlidarradar,Lclcalipsoliq, & + Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp, & + Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, & + Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, & + Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, & + Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, & + Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, & + LcfadDbze94,Ldbze94,Lparasolrefl,Ltbrttov, & + Npoints,Ncolumns,Nlevels,Nlvgrid,Nchan,x) + ! Inputs + logical,intent(in) :: & + Lpctisccp, & ! ISCCP mean cloud top pressure + Lclisccp, & ! ISCCP cloud area fraction + Lboxptopisccp, & ! ISCCP CTP in each column + Lboxtauisccp, & ! ISCCP optical epth in each column + Ltauisccp, & ! ISCCP mean optical depth + Lcltisccp, & ! ISCCP total cloud fraction + Lmeantbisccp, & ! ISCCP mean all-sky 10.5micron brightness temperature + Lmeantbclrisccp, & ! ISCCP mean clear-sky 10.5micron brightness temperature + Lalbisccp, & ! ISCCP mean cloud albedo + LclMISR, & ! MISR cloud fraction + Lcltmodis, & ! MODIS total cloud fraction + Lclwmodis, & ! MODIS liquid cloud fraction + Lclimodis, & ! MODIS ice cloud fraction + Lclhmodis, & ! MODIS high-level cloud fraction + Lclmmodis, & ! MODIS mid-level cloud fraction + Lcllmodis, & ! MODIS low-level cloud fraction + Ltautmodis, & ! MODIS total cloud optical thicknes + Ltauwmodis, & ! MODIS liquid optical thickness + Ltauimodis, & ! MODIS ice optical thickness + Ltautlogmodis, & ! MODIS total cloud optical thickness (log10 mean) + Ltauwlogmodis, & ! MODIS liquid optical thickness (log10 mean) + Ltauilogmodis, & ! MODIS ice optical thickness (log10 mean) + Lreffclwmodis, & ! MODIS liquid cloud particle size + Lreffclimodis, & ! MODIS ice particle size + Lpctmodis, & ! MODIS cloud top pressure + Llwpmodis, & ! MODIS cloud liquid water path + Liwpmodis, & ! MODIS cloud ice water path + Lclmodis, & ! MODIS cloud area fraction + Latb532, & ! CALIPSO attenuated total backscatter (532nm) + LlidarBetaMol532, & ! CALIPSO molecular backscatter (532nm) + LcfadLidarsr532, & ! CALIPSO scattering ratio CFAD + Lclcalipso2, & ! CALIPSO cloud fraction undetected by cloudsat + Lclcalipso, & ! CALIPSO cloud area fraction + Lclhcalipso, & ! CALIPSO high-level cloud fraction + Lcllcalipso, & ! CALIPSO low-level cloud fraction + Lclmcalipso, & ! CALIPSO mid-level cloud fraction + Lcltcalipso, & ! CALIPSO total cloud fraction + Lcltlidarradar, & ! CALIPSO-CLOUDSAT total cloud fraction + Lclcalipsoliq, & ! CALIPSO liquid cloud area fraction + Lclcalipsoice, & ! CALIPSO ice cloud area fraction + Lclcalipsoun, & ! CALIPSO undetected cloud area fraction + Lclcalipsotmp, & ! CALIPSO undetected cloud area fraction + Lclcalipsotmpliq, & ! CALIPSO liquid cloud area fraction + Lclcalipsotmpice, & ! CALIPSO ice cloud area fraction + Lclcalipsotmpun, & ! CALIPSO undetected cloud area fraction + Lcltcalipsoliq, & ! CALIPSO liquid total cloud fraction + Lcltcalipsoice, & ! CALIPSO ice total cloud fraction + Lcltcalipsoun, & ! CALIPSO undetected total cloud fraction + Lclhcalipsoliq, & ! CALIPSO high-level liquid cloud fraction + Lclhcalipsoice, & ! CALIPSO high-level ice cloud fraction + Lclhcalipsoun, & ! CALIPSO high-level undetected cloud fraction + Lclmcalipsoliq, & ! CALIPSO mid-level liquid cloud fraction + Lclmcalipsoice, & ! CALIPSO mid-level ice cloud fraction + Lclmcalipsoun, & ! CALIPSO mid-level undetected cloud fraction + Lcllcalipsoliq, & ! CALIPSO low-level liquid cloud fraction + Lcllcalipsoice, & ! CALIPSO low-level ice cloud fraction + Lcllcalipsoun, & ! CALIPSO low-level undetected cloud fraction + LcfadDbze94, & ! CLOUDSAT radar reflectivity CFAD + Ldbze94, & ! CLOUDSAT radar reflectivity + LparasolRefl, & ! PARASOL reflectance + Ltbrttov ! RTTOV mean clear-sky brightness temperature + + integer,intent(in) :: & + Npoints, & ! Number of sampled points + Ncolumns, & ! Number of subgrid columns + Nlevels, & ! Number of model levels + Nlvgrid, & ! Number of levels in L3 stats computation + Nchan ! Number of RTTOV channels + + ! Outputs + type(cosp_outputs),intent(out) :: & + x ! COSP output structure + + ! ISCCP simulator outputs + if (Lboxtauisccp) allocate(x%isccp_boxtau(Npoints,Ncolumns)) + if (Lboxptopisccp) allocate(x%isccp_boxptop(Npoints,Ncolumns)) + if (Lclisccp) allocate(x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins)) + if (Lcltisccp) allocate(x%isccp_totalcldarea(Npoints)) + if (Lpctisccp) allocate(x%isccp_meanptop(Npoints)) + if (Ltauisccp) allocate(x%isccp_meantaucld(Npoints)) + if (Lmeantbisccp) allocate(x%isccp_meantb(Npoints)) + if (Lmeantbclrisccp) allocate(x%isccp_meantbclr(Npoints)) + if (Lalbisccp) allocate(x%isccp_meanalbedocld(Npoints)) + + ! MISR simulator + if (LclMISR) then + allocate(x%misr_fq(Npoints,numMISRTauBins,numMISRHgtBins)) + ! *NOTE* These 3 fields are not output, but were part of the v1.4.0 cosp_misr, so + ! they are still computed. Should probably have a logical to control these + ! outputs. + allocate(x%misr_dist_model_layertops(Npoints,numMISRHgtBins)) + allocate(x%misr_meanztop(Npoints)) + allocate(x%misr_cldarea(Npoints)) + endif + + ! MODIS simulator + if (Lcltmodis) allocate(x%modis_Cloud_Fraction_Total_Mean(Npoints)) + if (Lclwmodis) allocate(x%modis_Cloud_Fraction_Water_Mean(Npoints)) + if (Lclimodis) allocate(x%modis_Cloud_Fraction_Ice_Mean(Npoints)) + if (Lclhmodis) allocate(x%modis_Cloud_Fraction_High_Mean(Npoints)) + if (Lclmmodis) allocate(x%modis_Cloud_Fraction_Mid_Mean(Npoints)) + if (Lcllmodis) allocate(x%modis_Cloud_Fraction_Low_Mean(Npoints)) + if (Ltautmodis) allocate(x%modis_Optical_Thickness_Total_Mean(Npoints)) + if (Ltauwmodis) allocate(x%modis_Optical_Thickness_Water_Mean(Npoints)) + if (Ltauimodis) allocate(x%modis_Optical_Thickness_Ice_Mean(Npoints)) + if (Ltautlogmodis) allocate(x%modis_Optical_Thickness_Total_LogMean(Npoints)) + if (Ltauwlogmodis) allocate(x%modis_Optical_Thickness_Water_LogMean(Npoints)) + if (Ltauilogmodis) allocate(x%modis_Optical_Thickness_Ice_LogMean(Npoints)) + if (Lreffclwmodis) allocate(x%modis_Cloud_Particle_Size_Water_Mean(Npoints)) + if (Lreffclimodis) allocate(x%modis_Cloud_Particle_Size_Ice_Mean(Npoints)) + if (Lpctmodis) allocate(x%modis_Cloud_Top_Pressure_Total_Mean(Npoints)) + if (Llwpmodis) allocate(x%modis_Liquid_Water_Path_Mean(Npoints)) + if (Liwpmodis) allocate(x%modis_Ice_Water_Path_Mean(Npoints)) + if (Lclmodis) then + allocate(x%modis_Optical_Thickness_vs_Cloud_Top_Pressure(nPoints,numModisTauBins,numMODISPresBins)) + allocate(x%modis_Optical_thickness_vs_ReffLIQ(nPoints,numMODISTauBins,numMODISReffLiqBins)) + allocate(x%modis_Optical_Thickness_vs_ReffICE(nPoints,numMODISTauBins,numMODISReffIceBins)) + endif + + ! LIDAR simulator + if (LlidarBetaMol532) allocate(x%calipso_beta_mol(Npoints,Nlevels)) + if (Latb532) allocate(x%calipso_beta_tot(Npoints,Ncolumns,Nlevels)) + if (LcfadLidarsr532) then + allocate(x%calipso_srbval(SR_BINS+1)) + allocate(x%calipso_cfad_sr(Npoints,SR_BINS,Nlvgrid)) + allocate(x%calipso_betaperp_tot(Npoints,Ncolumns,Nlevels)) + endif + if (Lclcalipso) allocate(x%calipso_lidarcld(Npoints,Nlvgrid)) + if (Lclhcalipso .or. Lclmcalipso .or. Lcllcalipso .or. Lcltcalipso) then + allocate(x%calipso_cldlayer(Npoints,LIDAR_NCAT)) + endif + if (Lclcalipsoice .or. Lclcalipsoliq .or. Lclcalipsoun) then + allocate(x%calipso_lidarcldphase(Npoints,Nlvgrid,6)) + endif + if (Lclcalipsotmp .or. Lclcalipsotmpliq .or. Lclcalipsoice .or. Lclcalipsotmpun .or. Lclcalipsotmpice) then + allocate(x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5)) + endif + if (Lcllcalipsoice .or. Lclmcalipsoice .or. Lclhcalipsoice .or. & + Lcltcalipsoice .or. Lcllcalipsoliq .or. Lclmcalipsoliq .or. & + Lclhcalipsoliq .or. Lcltcalipsoliq .or. Lcllcalipsoun .or. & + Lclmcalipsoun .or. Lclhcalipsoun .or. Lcltcalipsoun) then + allocate(x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6)) + endif + ! These 2 outputs are part of the calipso output type, but are not controlled by an + ! logical switch in the output namelist, so if all other fields are on, then allocate + if (LlidarBetaMol532 .or. Latb532 .or. LcfadLidarsr532 .or. Lclcalipso .or. & + Lclcalipsoice .or. Lclcalipsoliq .or. Lclcalipsoun .or. Lclcalipso2 .or. & + Lclhcalipso .or. Lclmcalipso .or. Lcllcalipso .or. Lcltcalipso .or. & + Lclcalipsotmp .or. Lclcalipsoice .or. Lclcalipsotmpun .or. & + Lclcalipsotmpliq .or. Lcllcalipsoice .or. Lclmcalipsoice .or. & + Lclhcalipsoice .or. Lcltcalipsoice .or. Lcllcalipsoliq .or. & + Lclmcalipsoliq .or. Lclhcalipsoliq .or. Lcltcalipsoliq .or. & + Lcllcalipsoun .or. Lclmcalipsoun .or. Lclhcalipsoun .or. Lcltcalipsoun) then + allocate(x%calipso_tau_tot(Npoints,Ncolumns,Nlevels)) + allocate(x%calipso_temp_tot(Npoints,Nlevels)) + endif + + ! PARASOL + if (Lparasolrefl) then + allocate(x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL)) + allocate(x%parasolGrid_refl(Npoints,PARASOL_NREFL)) + endif + + ! Cloudsat simulator + if (Ldbze94) allocate(x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels)) + if (LcfadDbze94) allocate(x%cloudsat_cfad_ze(Npoints,DBZE_BINS,Nlvgrid)) + + ! Combined CALIPSO/CLOUDSAT fields + if (Lclcalipso2) allocate(x%lidar_only_freq_cloud(Npoints,Nlvgrid)) + if (Lcltlidarradar) allocate(x%radar_lidar_tcc(Npoints)) + + ! RTTOV + if (Ltbrttov) allocate(x%rttov_tbs(Npoints,Nchan)) + + end subroutine construct_cosp_outputs + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cospIN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cospIN(y) + type(cosp_optical_inputs),intent(inout) :: y + + if (allocated(y%tau_067)) deallocate(y%tau_067) + if (allocated(y%emiss_11)) deallocate(y%emiss_11) + if (allocated(y%frac_out)) deallocate(y%frac_out) + if (allocated(y%beta_mol)) deallocate(y%beta_mol) + if (allocated(y%tau_mol)) deallocate(y%tau_mol) + if (allocated(y%betatot)) deallocate(y%betatot) + if (allocated(y%betatot_ice)) deallocate(y%betatot_ice) + if (allocated(y%betatot_liq)) deallocate(y%betatot_liq) + if (allocated(y%tautot)) deallocate(y%tautot) + if (allocated(y%tautot_ice)) deallocate(y%tautot_ice) + if (allocated(y%tautot_liq)) deallocate(y%tautot_liq) + if (allocated(y%tautot_S_liq)) deallocate(y%tautot_S_liq) + if (allocated(y%tautot_S_ice)) deallocate(y%tautot_S_ice) + if (allocated(y%z_vol_cloudsat)) deallocate(y%z_vol_cloudsat) + if (allocated(y%kr_vol_cloudsat)) deallocate(y%kr_vol_cloudsat) + if (allocated(y%g_vol_cloudsat)) deallocate(y%g_vol_cloudsat) + if (allocated(y%asym)) deallocate(y%asym) + if (allocated(y%ss_alb)) deallocate(y%ss_alb) + if (allocated(y%fracLiq)) deallocate(y%fracLiq) + + end subroutine destroy_cospIN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cospstateIN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cospstateIN(y) + type(cosp_column_inputs),intent(inout) :: y + + if (allocated(y%sunlit)) deallocate(y%sunlit) + if (allocated(y%skt)) deallocate(y%skt) + if (allocated(y%land)) deallocate(y%land) + if (allocated(y%at)) deallocate(y%at) + if (allocated(y%pfull)) deallocate(y%pfull) + if (allocated(y%phalf)) deallocate(y%phalf) + if (allocated(y%qv)) deallocate(y%qv) + if (allocated(y%o3)) deallocate(y%o3) + if (allocated(y%hgt_matrix)) deallocate(y%hgt_matrix) + if (allocated(y%u_sfc)) deallocate(y%u_sfc) + if (allocated(y%v_sfc)) deallocate(y%v_sfc) + if (allocated(y%lat)) deallocate(y%lat) + if (allocated(y%lon)) deallocate(y%lon) + if (allocated(y%emis_sfc)) deallocate(y%emis_sfc) + if (allocated(y%cloudIce)) deallocate(y%cloudIce) + if (allocated(y%cloudLiq)) deallocate(y%cloudLiq) + if (allocated(y%seaice)) deallocate(y%seaice) + if (allocated(y%fl_rain)) deallocate(y%fl_rain) + if (allocated(y%fl_snow)) deallocate(y%fl_snow) + if (allocated(y%tca)) deallocate(y%tca) + if (allocated(y%hgt_matrix_half)) deallocate(y%hgt_matrix_half) + + end subroutine destroy_cospstateIN + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE destroy_cosp_outputs + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine destroy_cosp_outputs(y) + type(cosp_outputs),intent(inout) :: y + + ! Deallocate and nullify + if (associated(y%calipso_beta_mol)) then + deallocate(y%calipso_beta_mol) + nullify(y%calipso_beta_mol) + endif + if (associated(y%calipso_temp_tot)) then + deallocate(y%calipso_temp_tot) + nullify(y%calipso_temp_tot) + endif + if (associated(y%calipso_betaperp_tot)) then + deallocate(y%calipso_betaperp_tot) + nullify(y%calipso_betaperp_tot) + endif + if (associated(y%calipso_beta_tot)) then + deallocate(y%calipso_beta_tot) + nullify(y%calipso_beta_tot) + endif + if (associated(y%calipso_tau_tot)) then + deallocate(y%calipso_tau_tot) + nullify(y%calipso_tau_tot) + endif + if (associated(y%calipso_lidarcldphase)) then + deallocate(y%calipso_lidarcldphase) + nullify(y%calipso_lidarcldphase) + endif + if (associated(y%calipso_cldlayerphase)) then + deallocate(y%calipso_cldlayerphase) + nullify(y%calipso_cldlayerphase) + endif + if (associated(y%calipso_lidarcldtmp)) then + deallocate(y%calipso_lidarcldtmp) + nullify(y%calipso_lidarcldtmp) + endif + if (associated(y%calipso_cldlayer)) then + deallocate(y%calipso_cldlayer) + nullify(y%calipso_cldlayer) + endif + if (associated(y%calipso_lidarcld)) then + deallocate(y%calipso_lidarcld) + nullify(y%calipso_lidarcld) + endif + if (associated(y%calipso_srbval)) then + deallocate(y%calipso_srbval) + nullify(y%calipso_srbval) + endif + if (associated(y%calipso_cfad_sr)) then + deallocate(y%calipso_cfad_sr) + nullify(y%calipso_cfad_sr) + endif + if (associated(y%parasolPix_refl)) then + deallocate(y%parasolPix_refl) + nullify(y%parasolPix_refl) + endif + if (associated(y%parasolGrid_refl)) then + deallocate(y%parasolGrid_refl) + nullify(y%parasolGrid_refl) + endif + if (associated(y%cloudsat_Ze_tot)) then + deallocate(y%cloudsat_Ze_tot) + nullify(y%cloudsat_Ze_tot) + endif + if (associated(y%cloudsat_cfad_ze)) then + deallocate(y%cloudsat_cfad_ze) + nullify(y%cloudsat_cfad_ze) + endif + if (associated(y%radar_lidar_tcc)) then + deallocate(y%radar_lidar_tcc) + nullify(y%radar_lidar_tcc) + endif + if (associated(y%lidar_only_freq_cloud)) then + deallocate(y%lidar_only_freq_cloud) + nullify(y%lidar_only_freq_cloud) + endif + if (associated(y%isccp_totalcldarea)) then + deallocate(y%isccp_totalcldarea) + nullify(y%isccp_totalcldarea) + endif + if (associated(y%isccp_meantb)) then + deallocate(y%isccp_meantb) + nullify(y%isccp_meantb) + endif + if (associated(y%isccp_meantbclr)) then + deallocate(y%isccp_meantbclr) + nullify(y%isccp_meantbclr) + endif + if (associated(y%isccp_meanptop)) then + deallocate(y%isccp_meanptop) + nullify(y%isccp_meanptop) + endif + if (associated(y%isccp_meantaucld)) then + deallocate(y%isccp_meantaucld) + nullify(y%isccp_meantaucld) + endif + if (associated(y%isccp_meanalbedocld)) then + deallocate(y%isccp_meanalbedocld) + nullify(y%isccp_meanalbedocld) + endif + if (associated(y%isccp_boxtau)) then + deallocate(y%isccp_boxtau) + nullify(y%isccp_boxtau) + endif + if (associated(y%isccp_boxptop)) then + deallocate(y%isccp_boxptop) + nullify(y%isccp_boxptop) + endif + if (associated(y%isccp_fq)) then + deallocate(y%isccp_fq) + nullify(y%isccp_fq) + endif + if (associated(y%misr_fq)) then + deallocate(y%misr_fq) + nullify(y%misr_fq) + endif + if (associated(y%misr_dist_model_layertops)) then + deallocate(y%misr_dist_model_layertops) + nullify(y%misr_dist_model_layertops) + endif + if (associated(y%misr_meanztop)) then + deallocate(y%misr_meanztop) + nullify(y%misr_meanztop) + endif + if (associated(y%misr_cldarea)) then + deallocate(y%misr_cldarea) + nullify(y%misr_cldarea) + endif + if (associated(y%rttov_tbs)) then + deallocate(y%rttov_tbs) + nullify(y%rttov_tbs) + endif + if (associated(y%modis_Cloud_Fraction_Total_Mean)) then + deallocate(y%modis_Cloud_Fraction_Total_Mean) + nullify(y%modis_Cloud_Fraction_Total_Mean) + endif + if (associated(y%modis_Cloud_Fraction_Ice_Mean)) then + deallocate(y%modis_Cloud_Fraction_Ice_Mean) + nullify(y%modis_Cloud_Fraction_Ice_Mean) + endif + if (associated(y%modis_Cloud_Fraction_Water_Mean)) then + deallocate(y%modis_Cloud_Fraction_Water_Mean) + nullify(y%modis_Cloud_Fraction_Water_Mean) + endif + if (associated(y%modis_Cloud_Fraction_High_Mean)) then + deallocate(y%modis_Cloud_Fraction_High_Mean) + nullify(y%modis_Cloud_Fraction_High_Mean) + endif + if (associated(y%modis_Cloud_Fraction_Mid_Mean)) then + deallocate(y%modis_Cloud_Fraction_Mid_Mean) + nullify(y%modis_Cloud_Fraction_Mid_Mean) + endif + if (associated(y%modis_Cloud_Fraction_Low_Mean)) then + deallocate(y%modis_Cloud_Fraction_Low_Mean) + nullify(y%modis_Cloud_Fraction_Low_Mean) + endif + if (associated(y%modis_Optical_Thickness_Total_Mean)) then + deallocate(y%modis_Optical_Thickness_Total_Mean) + nullify(y%modis_Optical_Thickness_Total_Mean) + endif + if (associated(y%modis_Optical_Thickness_Water_Mean)) then + deallocate(y%modis_Optical_Thickness_Water_Mean) + nullify(y%modis_Optical_Thickness_Water_Mean) + endif + if (associated(y%modis_Optical_Thickness_Ice_Mean)) then + deallocate(y%modis_Optical_Thickness_Ice_Mean) + nullify(y%modis_Optical_Thickness_Ice_Mean) + endif + if (associated(y%modis_Optical_Thickness_Total_LogMean)) then + deallocate(y%modis_Optical_Thickness_Total_LogMean) + nullify(y%modis_Optical_Thickness_Total_LogMean) + endif + if (associated(y%modis_Optical_Thickness_Water_LogMean)) then + deallocate(y%modis_Optical_Thickness_Water_LogMean) + nullify(y%modis_Optical_Thickness_Water_LogMean) + endif + if (associated(y%modis_Optical_Thickness_Ice_LogMean)) then + deallocate(y%modis_Optical_Thickness_Ice_LogMean) + nullify(y%modis_Optical_Thickness_Ice_LogMean) + endif + if (associated(y%modis_Cloud_Particle_Size_Water_Mean)) then + deallocate(y%modis_Cloud_Particle_Size_Water_Mean) + nullify(y%modis_Cloud_Particle_Size_Water_Mean) + endif + if (associated(y%modis_Cloud_Particle_Size_Ice_Mean)) then + deallocate(y%modis_Cloud_Particle_Size_Ice_Mean) + nullify(y%modis_Cloud_Particle_Size_Ice_Mean) + endif + if (associated(y%modis_Cloud_Top_Pressure_Total_Mean)) then + deallocate(y%modis_Cloud_Top_Pressure_Total_Mean) + nullify(y%modis_Cloud_Top_Pressure_Total_Mean) + endif + if (associated(y%modis_Liquid_Water_Path_Mean)) then + deallocate(y%modis_Liquid_Water_Path_Mean) + nullify(y%modis_Liquid_Water_Path_Mean) + endif + if (associated(y%modis_Ice_Water_Path_Mean)) then + deallocate(y%modis_Ice_Water_Path_Mean) + nullify(y%modis_Ice_Water_Path_Mean) + endif + if (associated(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure)) then + deallocate(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure) + nullify(y%modis_Optical_Thickness_vs_Cloud_Top_Pressure) + endif + if (associated(y%modis_Optical_thickness_vs_ReffLIQ)) then + deallocate(y%modis_Optical_thickness_vs_ReffLIQ) + nullify(y%modis_Optical_thickness_vs_ReffLIQ) + endif + if (associated(y%modis_Optical_thickness_vs_ReffICE)) then + deallocate(y%modis_Optical_thickness_vs_ReffICE) + nullify(y%modis_Optical_thickness_vs_ReffICE) + endif + + end subroutine destroy_cosp_outputs + + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +end module MOD_COSP_INTERFACE_v1p4 Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_isccp_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_isccp_interface.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_isccp_interface.F90 (revision 3358) @@ -0,0 +1,85 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_ISCCP_INTERFACE + USE COSP_KINDS, ONLY: wp + USE mod_icarus, ONLY: isccp_top_height,isccp_top_height_direction + IMPLICIT NONE + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE isccp_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Derived input type for ISCCP simulator + type isccp_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels, & ! Number of levels. + top_height, & ! + top_height_direction ! + integer,pointer :: & + sunlit(:) ! Sunlit points (npoints) + real(wp),pointer :: & + emsfc_lw + real(wp),pointer :: & + skt(:) ! Surface temperature (npoints) + real(wp),pointer :: & + at(:,:), & ! Temperature (npoint,nlev) + pfull(:,:), & ! Pressure (npoints,nlev) + qv(:,:) ! Specific humidity (npoints,nlev) + real(wp),pointer :: & + phalf(:,:) ! Pressure at half levels (npoints,nlev+1) + real(wp),pointer :: & + frac_out(:,:,:), & ! Cloud fraction (npoints,ncolumns,nlevels) + dtau(:,:,:), & ! Optical depth (npoints,ncolumns,nlevels) + dem(:,:,:) ! Emissivity (npoints,ncolumns,nlevels) + end type isccp_IN + +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_isccp_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_ISCCP_INIT(top_height,top_height_direction) + integer,intent(in) :: & + top_height, & + top_height_direction + + ! Cloud-top height determination + isccp_top_height = top_height + isccp_top_height_direction = top_height_direction + + END SUBROUTINE COSP_ISCCP_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_ISCCP_INTERFACE Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_kinds.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_kinds.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_kinds.F90 (revision 3358) @@ -0,0 +1,40 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE cosp_kinds + implicit none + INTEGER, PARAMETER :: sp = SELECTED_REAL_KIND( 6, 37) + INTEGER, PARAMETER :: dp = SELECTED_REAL_KIND(12,307) + INTEGER, PARAMETER :: wp = dp + +END MODULE cosp_kinds + Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_math_constants.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_math_constants.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_math_constants.F90 (revision 3358) @@ -0,0 +1,40 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE cosp_math_constants + USE cosp_kinds, only: wp + IMPLICIT NONE + REAL(wp), PARAMETER :: pi = 3.14159265358979323846264338327950288419717_wp + +END MODULE cosp_math_constants + + Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_misr_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_misr_interface.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_misr_interface.F90 (revision 3358) @@ -0,0 +1,67 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_MISR_INTERFACE + USE COSP_KINDS, ONLY: wp + + IMPLICIT NONE + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE misr_in + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type misr_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + integer,pointer :: & + sunlit(:) ! Sunlit points (npoints). + real(wp),pointer :: & + zfull(:,:), & ! Height of full model levels (i.e. midpoints). (npoints,nlev) + at(:,:) ! Temperature. (npoints,nlev) + real(wp),pointer :: & + dtau(:,:,:) ! Optical depth. (npoints,ncolumns,nlev) + + end type misr_IN + +CONTAINS + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_misr_init + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_MISR_INIT() + + END SUBROUTINE COSP_MISR_INIT + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_MISR_INTERFACE Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_modis_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_modis_interface.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_modis_interface.F90 (revision 3358) @@ -0,0 +1,113 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_Modis_INTERFACE + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: R_UNDEF + use mod_modis_sim, ONLY: num_trial_res,min_OpticalThickness,CO2Slicing_PressureLimit,& + CO2Slicing_TauLimit,phase_TauLimit,size_TauLimit,re_fill, & + phaseDiscrimination_Threshold,re_water_min, & + re_water_max,re_ice_min,re_ice_max, & + highCloudPressureLimit,lowCloudPressureLimit,phaseIsNone, & + phaseIsLiquid,phaseIsIce,phaseIsUndetermined,trial_re_w, & + trial_re_i,g_w,g_i,w0_w,w0_i, get_g_nir,get_ssa_nir + implicit none + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE modis_in + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type modis_IN + integer,pointer :: & + Npoints, & ! Number of horizontal gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels ! Number of vertical levels + integer :: & + Nsunlit ! Number of sunlit lit pixels + real(wp),allocatable,dimension(:) :: & + sunlit, & ! Sunlit scenes + notSunlit ! Dark scenes + real(wp),allocatable,dimension(:,:) :: & + pres ! Gridmean pressure at layer edges (Pa) + real(wp),pointer :: & + tau(:,:,:), & ! Subcolumn optical thickness @ 0.67 microns. + liqFrac(:,:,:), & ! Liquid water fraction + g(:,:,:), & ! Subcolumn assymetry parameter + w0(:,:,:) ! Subcolumn single-scattering albedo + end type modis_IN +contains + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROTUINE cosp_modis_init + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_MODIS_INIT() + integer :: i + + ! Retrieval parameters + min_OpticalThickness = 0.3_wp ! Minimum detectable optical thickness + CO2Slicing_PressureLimit = 70000._wp ! Cloud with higher pressures use thermal + ! methods, units Pa + CO2Slicing_TauLimit = 1._wp ! How deep into the cloud does CO2 slicing + ! see? + phase_TauLimit = 1._wp ! How deep into the cloud does the phase + ! detection see? + size_TauLimit = 2._wp ! Depth of the re retreivals + phaseDiscrimination_Threshold = 0.7_wp ! What fraction of total extincton needs to + ! be in a single category to make phase + ! discrim. work? + re_fill = -999._wp ! Fill value + re_water_min = 4._wp ! Minimum effective radius (liquid) + re_water_max = 30._wp ! Maximum effective radius (liquid) + re_ice_min = 5._wp ! Minimum effective radius (ice) + re_ice_max = 90._wp ! Minimum effective radius (ice) + highCloudPressureLimit = 44000._wp ! High cloud pressure limit (Pa) + lowCloudPressureLimit = 68000._wp ! Low cloud pressure limit (Pa) + phaseIsNone = 0 ! No cloud + phaseIsLiquid = 1 ! Liquid cloud + phaseIsIce = 2 ! Ice cloud + phaseIsUndetermined = 3 ! Undetermined cloud + + ! Precompute near-IR optical params vs size for retrieval scheme + trial_re_w(1:num_trial_res) = re_water_min + (re_water_max - re_water_min) / & + (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/) + trial_re_i(1:num_trial_res) = re_ice_min + (re_ice_max - re_ice_min) / & + (num_trial_res-1) * (/(i, i=0, num_trial_res-1)/) + + ! Initialize estimates for size retrieval + g_w(1:num_trial_res) = get_g_nir(phaseIsLiquid,trial_re_w(1:num_trial_res)) + w0_w(1:num_trial_res) = get_ssa_nir(phaseIsLiquid,trial_re_w(1:num_trial_res)) + g_i(1:num_trial_res) = get_g_nir(phaseIsIce,trial_re_i(1:num_trial_res)) + w0_i(1:num_trial_res) = get_ssa_nir(phaseIsIce,trial_re_i(1:num_trial_res)) + + END SUBROUTINE COSP_MODIS_INIT + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE MOD_COSP_Modis_INTERFACE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_Modis_INTERFACE Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_optics.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_optics.F90 (revision 3358) @@ -0,0 +1,442 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! 05/01/15 Dustin Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module cosp_optics + USE COSP_KINDS, ONLY: wp,dp + USE COSP_MATH_CONSTANTS, ONLY: pi + USE COSP_PHYS_CONSTANTS, ONLY: rholiq,km,rd,grav + USE MOD_MODIS_SIM, ONLY: get_g_nir,get_ssa_nir,phaseIsLiquid,phaseIsIce + implicit none + + real(wp),parameter :: & ! + ice_density = 0.93_wp ! Ice density used in MODIS phase partitioning + + interface cosp_simulator_optics + module procedure cosp_simulator_optics2D, cosp_simulator_optics3D + end interface cosp_simulator_optics + +contains + ! ########################################################################## + ! COSP_SIMULATOR_OPTICS + ! + ! Used by: ISCCP, MISR and MODIS simulators + ! ########################################################################## + subroutine cosp_simulator_optics2D(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT) + ! INPUTS + integer,intent(in) :: & + dim1, & ! Dimension 1 extent (Horizontal) + dim2, & ! Dimension 2 extent (Subcolumn) + dim3 ! Dimension 3 extent (Vertical) + real(wp),intent(in),dimension(dim1,dim2,dim3) :: & + flag ! Logical to determine the of merge var1IN and var2IN + real(wp),intent(in),dimension(dim1, dim3) :: & + varIN1, & ! Input field 1 + varIN2 ! Input field 2 + ! OUTPUTS + real(wp),intent(out),dimension(dim1,dim2,dim3) :: & + varOUT ! Merged output field + ! LOCAL VARIABLES + integer :: j + + varOUT(1:dim1,1:dim2,1:dim3) = 0._wp + do j=1,dim2 + where(flag(:,j,:) .eq. 1) + varOUT(:,j,:) = varIN2 + endwhere + where(flag(:,j,:) .eq. 2) + varOUT(:,j,:) = varIN1 + endwhere + enddo + end subroutine cosp_simulator_optics2D + subroutine cosp_simulator_optics3D(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT) + ! INPUTS + integer,intent(in) :: & + dim1, & ! Dimension 1 extent (Horizontal) + dim2, & ! Dimension 2 extent (Subcolumn) + dim3 ! Dimension 3 extent (Vertical) + real(wp),intent(in),dimension(dim1,dim2,dim3) :: & + flag ! Logical to determine the of merge var1IN and var2IN + real(wp),intent(in),dimension(dim1,dim2,dim3) :: & + varIN1, & ! Input field 1 + varIN2 ! Input field 2 + ! OUTPUTS + real(wp),intent(out),dimension(dim1,dim2,dim3) :: & + varOUT ! Merged output field + + varOUT(1:dim1,1:dim2,1:dim3) = 0._wp + where(flag(:,:,:) .eq. 1) + varOUT(:,:,:) = varIN2 + endwhere + where(flag(:,:,:) .eq. 2) + varOUT(:,:,:) = varIN1 + endwhere + + end subroutine cosp_simulator_optics3D + + ! ############################################################################## + ! MODIS_OPTICS_PARTITION + ! + ! For the MODIS simulator, there are times when only a sinlge optical depth + ! profile, cloud-ice and cloud-water are provided. In this case, the optical + ! depth is partitioned by phase. + ! ############################################################################## + subroutine MODIS_OPTICS_PARTITION(npoints,nlev,ncolumns,cloudWater,cloudIce,waterSize, & + iceSize,tau,tauL,tauI) + ! INPUTS + INTEGER,intent(in) :: & + npoints, & ! Number of horizontal gridpoints + nlev, & ! Number of levels + ncolumns ! Number of subcolumns + REAL(wp),intent(in),dimension(npoints,nlev,ncolumns) :: & + cloudWater, & ! Subcolumn cloud water content + cloudIce, & ! Subcolumn cloud ice content + waterSize, & ! Subcolumn cloud water effective radius + iceSize, & ! Subcolumn cloud ice effective radius + tau ! Optical thickness + + ! OUTPUTS + real(wp),intent(out),dimension(npoints,nlev,ncolumns) :: & + tauL, & ! Partitioned liquid optical thickness. + tauI ! Partitioned ice optical thickness. + ! LOCAL VARIABLES + real(wp),dimension(nlev,ncolumns) :: fracL + integer :: i + + + do i=1,npoints + where(cloudIce(i,:, :) <= 0.) + fracL(:, :) = 1._wp + elsewhere + where (cloudWater(i,:, :) <= 0.) + fracL(:, :) = 0._wp + elsewhere + ! Geometic optics limit - tau as LWP/re (proportional to LWC/re) + fracL(:, :) = (cloudWater(i,:, :)/waterSize(i,:, :)) / & + (cloudWater(i,:, :)/waterSize(i,:, :) + cloudIce(i,:, :)/(ice_density * iceSize(i,:, :)) ) + end where + end where + tauL(i,:, :) = fracL(:, :) * tau(i,:, :) + tauI(i,:, :) = tau(i,:, :) - tauL(i,:, :) + enddo + + end subroutine MODIS_OPTICS_PARTITION + ! ######################################################################################## + ! MODIS_OPTICS + ! + ! ######################################################################################## + subroutine modis_optics(nPoints,nLevels,nSubCols,tauLIQ,sizeLIQ,tauICE,sizeICE,fracLIQ, g, w0) + ! INPUTS + integer, intent(in) :: nPoints,nLevels,nSubCols + real(wp),intent(in),dimension(nPoints,nSubCols,nLevels) :: tauLIQ, sizeLIQ, tauICE, sizeICE + ! OUTPUTS + real(wp),intent(out),dimension(nPoints,nSubCols,nLevels) :: g,w0,fracLIQ + ! LOCAL VARIABLES + real(wp), dimension(nLevels) :: water_g, water_w0, ice_g, ice_w0,tau + integer :: i,j + + ! Initialize + g(1:nPoints,1:nSubCols,1:nLevels) = 0._wp + w0(1:nPoints,1:nSubCols,1:nLevels) = 0._wp + + do j =1,nPoints + do i=1,nSubCols + water_g(1:nLevels) = get_g_nir( phaseIsLiquid, sizeLIQ(j,i,1:nLevels)) + water_w0(1:nLevels) = get_ssa_nir(phaseIsLiquid, sizeLIQ(j,i,1:nLevels)) + ice_g(1:nLevels) = get_g_nir( phaseIsIce, sizeICE(j,i,1:nLevels)) + ice_w0(1:nLevels) = get_ssa_nir(phaseIsIce, sizeICE(j,i,1:nLevels)) + + ! Combine ice and water optical properties + tau(1:nLevels) = tauICE(j,i,1:nLevels) + tauLIQ(j,i,1:nLevels) + where (tau(1:nLevels) > 0) + g(j,i,1:nLevels) = (tauLIQ(j,i,1:nLevels)*water_g(1:nLevels) + tauICE(j,i,1:nLevels)*ice_g(1:nLevels)) / & + tau(1:nLevels) + w0(j,i,1:nLevels) = (tauLIQ(j,i,1:nLevels)*water_g(1:nLevels)*water_w0(1:nLevels) + tauICE(j,i,1:nLevels) * & + ice_g(1:nLevels) * ice_w0(1:nLevels)) / (g(j,i,1:nLevels) * tau(1:nLevels)) + end where + enddo + enddo + + ! Compute the total optical thickness and the proportion due to liquid in each cell + do i=1,npoints + where(tauLIQ(i,1:nSubCols,1:nLevels) + tauICE(i,1:nSubCols,1:nLevels) > 0.) + fracLIQ(i,1:nSubCols,1:nLevels) = tauLIQ(i,1:nSubCols,1:nLevels)/ & + (tauLIQ(i,1:nSubCols,1:nLevels) + tauICE(i,1:nSubCols,1:nLevels)) + elsewhere + fracLIQ(i,1:nSubCols,1:nLevels) = 0._wp + end where + enddo + + end subroutine modis_optics + + ! ###################################################################################### + ! SUBROUTINE lidar_optics + ! ###################################################################################### + subroutine lidar_optics(npoints,ncolumns,nlev,npart,ice_type,q_lsliq, q_lsice, & + q_cvliq, q_cvice,ls_radliq,ls_radice,cv_radliq,cv_radice, & + pres,presf,temp,beta_mol,betatot,tau_mol,tautot, & + tautot_S_liq,tautot_S_ice,betatot_ice,betatot_liq, & + tautot_ice,tautot_liq) + ! #################################################################################### + ! NOTE: Using "grav" from cosp_constants.f90, instead of grav=9.81, introduces + ! changes of up to 2% in atb532 adn 0.003% in parasolRefl and lidarBetaMol532. + ! This also results in small changes in the joint-histogram, cfadLidarsr532. + ! #################################################################################### + + ! INPUTS + INTEGER,intent(in) :: & + npoints, & ! Number of gridpoints + ncolumns, & ! Number of subcolumns + nlev, & ! Number of levels + npart, & ! Number of cloud meteors (stratiform_liq, stratiform_ice, conv_liq, conv_ice). + ice_type ! Ice particle shape hypothesis (0 for spheres, 1 for non-spherical) + REAL(WP),intent(in),dimension(npoints,nlev) :: & + temp, & ! Temperature of layer k + pres, & ! Pressure at full levels + ls_radliq, & ! Effective radius of LS liquid particles (meters) + ls_radice, & ! Effective radius of LS ice particles (meters) + cv_radliq, & ! Effective radius of CONV liquid particles (meters) + cv_radice ! Effective radius of CONV ice particles (meters) + REAL(WP),intent(in),dimension(npoints,ncolumns,nlev) :: & + q_lsliq, & ! LS sub-column liquid water mixing ratio (kg/kg) + q_lsice, & ! LS sub-column ice water mixing ratio (kg/kg) + q_cvliq, & ! CONV sub-column liquid water mixing ratio (kg/kg) + q_cvice ! CONV sub-column ice water mixing ratio (kg/kg) + REAL(WP),intent(in),dimension(npoints,nlev+1) :: & + presf ! Pressure at half levels + + ! OUTPUTS + REAL(WP),intent(out),dimension(npoints,ncolumns,nlev) :: & + betatot, & ! + tautot ! Optical thickess integrated from top + REAL(WP),intent(out),dimension(npoints,ncolumns,nlev) :: & + betatot_ice, & ! Backscatter coefficient for ice particles + betatot_liq, & ! Backscatter coefficient for liquid particles + tautot_ice, & ! Total optical thickness of ice + tautot_liq ! Total optical thickness of liq + REAL(WP),intent(out),dimension(npoints,nlev) :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol ! Molecular optical depth + REAL(WP),intent(out),dimension(npoints,ncolumns) :: & + tautot_S_liq, & ! TOA optical depth for liquid + tautot_S_ice ! TOA optical depth for ice + + ! LOCAL VARIABLES + REAL(WP),dimension(npart) :: rhopart + REAL(WP),dimension(npart,5) :: polpart + REAL(WP),dimension(npoints,nlev) :: rhoair,alpha_mol + REAL(WP),dimension(npoints,nlev+1) :: zheight + REAL(WP),dimension(npoints,nlev,npart) :: rad_part,kp_part,qpart + REAL(WP),dimension(npoints,ncolumns,nlev,npart) :: alpha_part,tau_part + INTEGER :: i,k,icol + + ! Local data + REAL(WP),PARAMETER :: rhoice = 0.5e+03 ! Density of ice (kg/m3) + REAL(WP),PARAMETER :: Cmol = 6.2446e-32 ! Wavelength dependent + REAL(WP),PARAMETER :: rdiffm = 0.7_wp ! Multiple scattering correction parameter + REAL(WP),PARAMETER :: Qscat = 2.0_wp ! Particle scattering efficiency at 532 nm + ! Local indicies for large-scale and convective ice and liquid + INTEGER,PARAMETER :: INDX_LSLIQ = 1 + INTEGER,PARAMETER :: INDX_LSICE = 2 + INTEGER,PARAMETER :: INDX_CVLIQ = 3 + INTEGER,PARAMETER :: INDX_CVICE = 4 + + ! Polarized optics parameterization + ! Polynomial coefficients for spherical liq/ice particles derived from Mie theory. + ! Polynomial coefficients for non spherical particles derived from a composite of + ! Ray-tracing theory for large particles (e.g. Noel et al., Appl. Opt., 2001) + ! and FDTD theory for very small particles (Yang et al., JQSRT, 2003). + ! We repeat the same coefficients for LS and CONV cloud to make code more readable + REAL(WP),PARAMETER,dimension(5) :: & + polpartCVLIQ = (/ 2.6980e-8_wp, -3.7701e-6_wp, 1.6594e-4_wp, -0.0024_wp, 0.0626_wp/), & + polpartLSLIQ = (/ 2.6980e-8_wp, -3.7701e-6_wp, 1.6594e-4_wp, -0.0024_wp, 0.0626_wp/), & + polpartCVICE0 = (/-1.0176e-8_wp, 1.7615e-6_wp, -1.0480e-4_wp, 0.0019_wp, 0.0460_wp/), & + polpartLSICE0 = (/-1.0176e-8_wp, 1.7615e-6_wp, -1.0480e-4_wp, 0.0019_wp, 0.0460_wp/), & + polpartCVICE1 = (/ 1.3615e-8_wp, -2.04206e-6_wp, 7.51799e-5_wp, 0.00078213_wp, 0.0182131_wp/), & + polpartLSICE1 = (/ 1.3615e-8_wp, -2.04206e-6_wp, 7.51799e-5_wp, 0.00078213_wp, 0.0182131_wp/) + ! ############################################################################## + + ! Liquid/ice particles + rhopart(INDX_LSLIQ) = rholiq + rhopart(INDX_LSICE) = rhoice + rhopart(INDX_CVLIQ) = rholiq + rhopart(INDX_CVICE) = rhoice + + ! LS and CONV Liquid water coefficients + polpart(INDX_LSLIQ,1:5) = polpartLSLIQ + polpart(INDX_CVLIQ,1:5) = polpartCVLIQ + ! LS and CONV Ice water coefficients + if (ice_type .eq. 0) then + polpart(INDX_LSICE,1:5) = polpartLSICE0 + polpart(INDX_CVICE,1:5) = polpartCVICE0 + endif + if (ice_type .eq. 1) then + polpart(INDX_LSICE,1:5) = polpartLSICE1 + polpart(INDX_CVICE,1:5) = polpartCVICE1 + endif + + ! Effective radius particles: + rad_part(1:npoints,1:nlev,INDX_LSLIQ) = ls_radliq(1:npoints,1:nlev) + rad_part(1:npoints,1:nlev,INDX_LSICE) = ls_radice(1:npoints,1:nlev) + rad_part(1:npoints,1:nlev,INDX_CVLIQ) = cv_radliq(1:npoints,1:nlev) + rad_part(1:npoints,1:nlev,INDX_CVICE) = cv_radice(1:npoints,1:nlev) + rad_part(1:npoints,1:nlev,1:npart) = MAX(rad_part(1:npoints,1:nlev,1:npart),0._wp) + rad_part(1:npoints,1:nlev,1:npart) = MIN(rad_part(1:npoints,1:nlev,1:npart),70.0e-6_wp) + + ! Density (clear-sky air) + rhoair(1:npoints,1:nlev) = pres(1:npoints,1:nlev)/(rd*temp(1:npoints,1:nlev)) + + ! Altitude at half pressure levels: + zheight(1:npoints,nlev+1) = 0._wp + do k=nlev,1,-1 + zheight(1:npoints,k) = zheight(1:npoints,k+1) & + -(presf(1:npoints,k)-presf(1:npoints,k+1))/(rhoair(1:npoints,k)*grav) + enddo + + ! ############################################################################## + ! *) Molecular alpha, beta and optical thickness + ! ############################################################################## + + beta_mol(1:npoints,1:nlev) = pres(1:npoints,1:nlev)/km/temp(1:npoints,1:nlev)*Cmol + alpha_mol(1:npoints,1:nlev) = 8._wp*pi/3._wp * beta_mol(1:npoints,1:nlev) + + ! Optical thickness of each layer (molecular) + tau_mol(1:npoints,1:nlev) = alpha_mol(1:npoints,1:nlev)*(zheight(1:npoints,1:nlev)-& + zheight(1:npoints,2:nlev+1)) + + ! Optical thickness from TOA to layer k (molecular) + DO k = 2,nlev + tau_mol(1:npoints,k) = tau_mol(1:npoints,k) + tau_mol(1:npoints,k-1) + ENDDO + + betatot (1:npoints,1:ncolumns,1:nlev) = spread(beta_mol(1:npoints,1:nlev), dim=2, NCOPIES=ncolumns) + tautot (1:npoints,1:ncolumns,1:nlev) = spread(tau_mol (1:npoints,1:nlev), dim=2, NCOPIES=ncolumns) + betatot_liq(1:npoints,1:ncolumns,1:nlev) = betatot(1:npoints,1:ncolumns,1:nlev) + betatot_ice(1:npoints,1:ncolumns,1:nlev) = betatot(1:npoints,1:ncolumns,1:nlev) + tautot_liq (1:npoints,1:ncolumns,1:nlev) = tautot(1:npoints,1:ncolumns,1:nlev) + tautot_ice (1:npoints,1:ncolumns,1:nlev) = tautot(1:npoints,1:ncolumns,1:nlev) + + ! ############################################################################## + ! *) Particles alpha, beta and optical thickness + ! ############################################################################## + ! Polynomials kp_lidar derived from Mie theory + do i = 1, npart + where (rad_part(1:npoints,1:nlev,i) .gt. 0.0) + kp_part(1:npoints,1:nlev,i) = & + polpart(i,1)*(rad_part(1:npoints,1:nlev,i)*1e6)**4 & + + polpart(i,2)*(rad_part(1:npoints,1:nlev,i)*1e6)**3 & + + polpart(i,3)*(rad_part(1:npoints,1:nlev,i)*1e6)**2 & + + polpart(i,4)*(rad_part(1:npoints,1:nlev,i)*1e6) & + + polpart(i,5) + elsewhere + kp_part(1:npoints,1:nlev,i) = 0._wp + endwhere + enddo + + ! Loop over all subcolumns + do icol=1,ncolumns + ! ############################################################################## + ! Mixing ratio particles in each subcolum + ! ############################################################################## + qpart(1:npoints,1:nlev,INDX_LSLIQ) = q_lsliq(1:npoints,icol,1:nlev) + qpart(1:npoints,1:nlev,INDX_LSICE) = q_lsice(1:npoints,icol,1:nlev) + qpart(1:npoints,1:nlev,INDX_CVLIQ) = q_cvliq(1:npoints,icol,1:nlev) + qpart(1:npoints,1:nlev,INDX_CVICE) = q_cvice(1:npoints,icol,1:nlev) + + ! ############################################################################## + ! Alpha and optical thickness (particles) + ! ############################################################################## + ! Alpha of particles in each subcolumn: + do i = 1, npart + where (rad_part(1:npoints,1:nlev,i) .gt. 0.0) + alpha_part(1:npoints,icol,1:nlev,i) = 3._wp/4._wp * Qscat & + * rhoair(1:npoints,1:nlev) * qpart(1:npoints,1:nlev,i) & + / (rhopart(i) * rad_part(1:npoints,1:nlev,i) ) + elsewhere + alpha_part(1:npoints,icol,1:nlev,i) = 0._wp + endwhere + enddo + + ! Optical thicknes + tau_part(1:npoints,icol,1:nlev,1:npart) = rdiffm * alpha_part(1:npoints,icol,1:nlev,1:npart) + do i = 1, npart + ! Optical thickness of each layer (particles) + tau_part(1:npoints,icol,1:nlev,i) = tau_part(1:npoints,icol,1:nlev,i) & + & * (zheight(1:npoints,1:nlev)-zheight(1:npoints,2:nlev+1) ) + ! Optical thickness from TOA to layer k (particles) + do k=2,nlev + tau_part(1:npoints,icol,k,i) = tau_part(1:npoints,icol,k,i) + tau_part(1:npoints,icol,k-1,i) + enddo + enddo + + ! ############################################################################## + ! Beta and optical thickness (total=molecular + particules) + ! ############################################################################## + + DO i = 1, npart + betatot(1:npoints,icol,1:nlev) = betatot(1:npoints,icol,1:nlev) + & + kp_part(1:npoints,1:nlev,i)*alpha_part(1:npoints,icol,1:nlev,i) + tautot(1:npoints,icol,1:nlev) = tautot(1:npoints,icol,1:nlev) + & + tau_part(1:npoints,icol,1:nlev,i) + ENDDO + + ! ############################################################################## + ! Beta and optical thickness (liquid/ice) + ! ############################################################################## + ! Ice + betatot_ice(1:npoints,icol,1:nlev) = betatot_ice(1:npoints,icol,1:nlev)+ & + kp_part(1:npoints,1:nlev,INDX_LSICE)*alpha_part(1:npoints,icol,1:nlev,INDX_LSICE)+ & + kp_part(1:npoints,1:nlev,INDX_CVICE)*alpha_part(1:npoints,icol,1:nlev,INDX_CVICE) + tautot_ice(1:npoints,icol,1:nlev) = tautot_ice(1:npoints,icol,1:nlev) + & + tau_part(1:npoints,icol,1:nlev,INDX_LSICE) + & + tau_part(1:npoints,icol,1:nlev,INDX_CVICE) + + ! Liquid + betatot_liq(1:npoints,icol,1:nlev) = betatot_liq(1:npoints,icol,1:nlev)+ & + kp_part(1:npoints,1:nlev,INDX_LSLIQ)*alpha_part(1:npoints,icol,1:nlev,INDX_LSLIQ)+ & + kp_part(1:npoints,1:nlev,INDX_CVLIQ)*alpha_part(1:npoints,icol,1:nlev,INDX_CVLIQ) + tautot_liq(1:npoints,icol,1:nlev) = tautot_liq(1:npoints,icol,1:nlev) + & + tau_part(1:npoints,icol,1:nlev,INDX_LSLIQ) + & + tau_part(1:npoints,icol,1:nlev,INDX_CVLIQ) + enddo + + ! ############################################################################## + ! Optical depths used by the PARASOL simulator + ! ############################################################################## + tautot_S_liq(1:npoints,1:ncolumns) = 0._wp + tautot_S_ice(1:npoints,1:ncolumns) = 0._wp + do icol=1,ncolumns + tautot_S_liq(1:npoints,icol) = tautot_S_liq(1:npoints,icol)+tau_part(1:npoints,icol,nlev,1)+tau_part(1:npoints,icol,nlev,3) + tautot_S_ice(1:npoints,icol) = tautot_S_ice(1:npoints,icol)+tau_part(1:npoints,icol,nlev,2)+tau_part(1:npoints,icol,nlev,4) + enddo + + end subroutine lidar_optics +end module cosp_optics Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_output_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_output_mod.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_output_mod.F90 (revision 3358) @@ -0,0 +1,446 @@ +! A.Idelkadi sept 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!! Module pour declarer et initialiser les parametres de controle des fichiers de sorties et des champs a sortir +!! La routine cosp_output_open (appelee 1 seule fois dans phy_cosp.F90) permet : +!! de creer les fichiers avec leurs grilles horizontales et verticales +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + MODULE cosp_output_mod + +! USE MOD_COSP_CONSTANTS +! USE MOD_COSP_TYPES + +! use MOD_COSP_INTERFACE_v1p4 +! use MOD_COSP_CONFIG +! use MOD_COSP_Modis_Simulator, only : cosp_modis +! use mod_modis_sim, only : numMODISReffIceBins, reffICE_binCenters, & +! numMODISReffLiqBins, reffLIQ_binCenters + USE COSP_KINDS, ONLY: wp,dp + IMPLICIT NONE +! cosp_output_mod + INTEGER :: i +!!!!!!! Controle des fichier de sorties Cosp !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + LOGICAL, DIMENSION(3), SAVE :: cosp_outfilekeys + INTEGER, DIMENSION(3), SAVE :: cosp_nidfiles +!$OMP THREADPRIVATE(cosp_outfilekeys, cosp_nidfiles) + INTEGER, DIMENSION(3), SAVE :: nhoricosp,nvert,nvertmcosp,nvertcol,nvertbze, & + nvertsratio,nvertisccp,nvertp,nverttemp,nvertmisr, & + nvertReffIce,nvertReffLiq,nverttau + REAL, DIMENSION(3), SAVE :: zoutm_cosp +!$OMP THREADPRIVATE(nhoricosp, nvert,nvertmcosp,nvertcol,nvertsratio,nvertbze,nvertisccp,nvertp,zoutm_cosp,nverttemp,nvertmisr) +!$OMP THREADPRIVATE(nvertReffIce,nvertReffLiq,nverttau) + REAL, SAVE :: zdtimemoy_cosp +!$OMP THREADPRIVATE(zdtimemoy_cosp) + CHARACTER(LEN=20), DIMENSION(3), SAVE :: cosp_outfiletypes + CHARACTER(LEN=20), DIMENSION(3), SAVE :: cosp_outfilenames + REAL, DIMENSION(3), SAVE :: cosp_ecritfiles +!$OMP THREADPRIVATE(cosp_outfiletypes, cosp_outfilenames, cosp_ecritfiles) + +!!!! Controle des variables a sortir dans les fichiers !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + TYPE ctrl_outcosp + LOGICAL,DIMENSION(3) :: cles !!! Sortir ou non le champs + CHARACTER(len=20) :: name + CHARACTER(len=150) :: description !!! Nom + CHARACTER(len=20) :: unit !!! Unite + CHARACTER(len=20),DIMENSION(3) :: cosp_typeecrit !!! Operation (ave, inst, ...) + END TYPE ctrl_outcosp + +! CALIPSO vars + TYPE(ctrl_outcosp), SAVE :: o_cllcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllcalipso", "Lidar Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmcalipso", "Lidar Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhcalipso", "Lidar High-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltcalipso", "Lidar Total Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipso", "Lidar Cloud Fraction (532 nm)", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cfad_lidarsr532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), & + "cfad_lidarsr532", "Lidar Scattering Ratio CFAD (532 nm)", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_parasol_refl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "parasol_refl", "PARASOL-like mono-directional reflectance","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_parasol_crefl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "parasol_crefl", "PARASOL-like mono-directional reflectance (integral)","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_Ncrefl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "Ncrefl", "Nb PARASOL-like mono-directional reflectance (integral)","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_atb532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), & + "atb532", "Lidar Attenuated Total Backscatter (532 nm)","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_beta_mol532 = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), & + "beta_mol532", "Lidar Molecular Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /)) +!! AI 11 2015 + TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllcalipsoice", "CALIPSO Ice-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllcalipsoliq", "CALIPSO Liq-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmcalipsoice", "CALIPSO Ice-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmcalipsoliq", "CALIPSO Liq-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhcalipsoice", "CALIPSO Ice-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhcalipsoliq", "CALIPSO Liq-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltcalipsoice", "CALIPSO Ice-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltcalipsoliq", "CALIPSO Liq-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cllcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllcalipsoun", "CALIPSO Undefined-Phase Low Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmcalipsoun", "CALIPSO Undefined-Phase Mid Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhcalipsoun", "CALIPSO Undefined-Phase High Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltcalipsoun", "CALIPSO Undefined-Phase Tot Level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsoice", "Lidar Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsoliq", "Lidar Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsoun", "Lidar Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmpice", "Lidar Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmpliq", "Lidar Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmpun", "Lidar Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmp", "Lidar Cloud Fraction", "%", (/ ('', i=1, 3) /)) + + TYPE(ctrl_outcosp), SAVE :: o_clopaquecalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !OPAQ + "clopaquecalipso", "Lidar Opaque Cloud Fraction", "%", (/ ('', i=1, 3) /)) !OPAQ + TYPE(ctrl_outcosp), SAVE :: o_clthincalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !OPAQ + "clthincalipso", "Lidar Thin Cloud Fraction", "%", (/ ('', i=1, 3) /)) !OPAQ + TYPE(ctrl_outcosp), SAVE :: o_clzopaquecalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !OPAQ + "clzopaquecalipso", "Lidar mean opacity altitude", "m", (/ ('', i=1, 3) /)) !OPAQ + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoopaque = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !OPAQ + "clcalipsoopaque", "Lidar Opaque profile Cloud Fraction", "%", (/ ('', i=1, 3) /)) !OPAQ + TYPE(ctrl_outcosp), SAVE :: o_clcalipsothin = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !OPAQ + "clcalipsothin", "Lidar Thin profile Cloud Fraction", "%", (/ ('', i=1, 3) /)) !OPAQ + TYPE(ctrl_outcosp), SAVE :: o_clcalipsozopaque = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !OPAQ + "clcalipsozopaque", "Lidar z_opaque Fraction", "%", (/ ('', i=1, 3) /)) !OPAQ + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoopacity = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !OPAQ + "clcalipsoopacity", "Lidar opacity Fraction", "%", (/ ('', i=1, 3) /)) !OPAQ + + TYPE(ctrl_outcosp), SAVE :: o_proftemp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !TIBO + "proftemp", "Temperature profiles (40 lev)", "K", (/ ('', i=1, 3) /)) !TIBO + TYPE(ctrl_outcosp), SAVE :: o_profSR = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & !TIBO + "profSR", "Lidar Scattering Ratio profiles (532 nm)", "1", (/ ('', i=1, 3) /)) !TIBO + +! Radar Cloudsat + TYPE(ctrl_outcosp), SAVE :: o_cfadDbze94 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cfadDbze94", "CloudSat Radar Reflectivity CFAD", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_dbze94 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "dbze94", "CloudSat Radar Reflectivity", "%", (/ ('', i=1, 3) /)) + +! Calipso + Cloudsat + TYPE(ctrl_outcosp), SAVE :: o_clcalipso2 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipso2", "CALIPSO Cloud Fraction Undetected by CloudSat", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltlidarradar = ctrl_outcosp((/ .TRUE., .TRUE.,.TRUE. /), & + "cltlidarradar", "Lidar and Radar Total Cloud Fraction", "%", (/ ('', i=1, 3) /)) + +! ISCCP vars + TYPE(ctrl_outcosp), SAVE :: o_sunlit = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "sunlit", "1 for day points, 0 for nightime","1",(/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clisccp2 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clisccp2", "Cloud Fraction as Calculated by the ISCCP Simulator","%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_boxtauisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), & + "boxtauisccp", "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_boxptopisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), & + "boxptopisccp", "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tclisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tclisccp", "Total Cloud Fraction as Calculated by the ISCCP Simulator", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ctpisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ctpisccp", "Mean Cloud Top Pressure as Calculated by the ISCCP Simulator", "Pa", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tauisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tauisccp", "Optical Depth as Calculated by the ISCCP Simulator", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_albisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "albisccp", "Mean Cloud Albedo as Calculated by the ISCCP Simulator", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_meantbisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), & + "meantbisccp", " Mean all-sky 10.5 micron brightness temperature as calculated & + by the ISCCP Simulator","K", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_meantbclrisccp = ctrl_outcosp((/ .FALSE., .FALSE., .FALSE. /), & + "meantbclrisccp", "Mean clear-sky 10.5 micron brightness temperature as calculated & + by the ISCCP Simulator","K", (/ ('', i=1, 3) /)) + +! MISR simulator + TYPE(ctrl_outcosp), SAVE :: o_clMISR = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clMISR", "Cloud Fraction as Calculated by the MISR Simulator","%", (/ ('', i=1, 3) /)) + +! MODIS simulator + TYPE(ctrl_outcosp), SAVE :: o_cllmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllmodis", "MODIS Low-level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmmodis", "MODIS Mid-level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhmodis", "MODIS High-level Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltmodis", "MODIS Total Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clwmodis", "MODIS Cloud Fraction water mean", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_climodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "climodis", "MODIS Cloud Fraction ice mean", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tautmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tautmodis", "MODIS Optical_Thickness_Total_Mean", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tauwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tauwmodis", "MODIS Optical_Thickness_Water_Mean", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tauimodis= ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tauimodis", "MODIS Optical_Thickness_Ice_Mean", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tautlogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tautlogmodis", "MODIS Optical_Thickness_Total_logMean", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tauwlogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tauwlogmodis", "MODIS Optical_Thickness_Water_logMean", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_tauilogmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tauilogmodis", "MODIS Optical_Thickness_Ice_logMean", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_reffclwmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "reffclwmodis", "Modis Cloud_Particle_Size_Water_Mean", "m", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_reffclimodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "reffclimodis", "Modis Cloud_Particle_Size_Ice_Mean", "m", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_pctmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "pctmodis", "Modis Cloud_Top_Pressure_Total_Mean", "Pa", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_lwpmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "lwpmodis", "Modis Liquid_Water_Path_Mean", "kg m-2", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_iwpmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "iwpmodis", "Modis Ice_Water_Path_Mean", "kg m-2", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmodis", "MODIS Cloud Area Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_crimodis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "crimodis", "Optical_Thickness_vs_ReffIce from Modis", "%", (/ ('',i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_crlmodis = ctrl_outcosp((/ .TRUE., .TRUE.,.TRUE. /), & + "crlmodis", "Optical_Thickness_vs_ReffLiq from Modis", "%", (/ ('',i=1, 3) /)) + +! Rttovs simulator + TYPE(ctrl_outcosp), SAVE :: o_tbrttov = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tbrttov", "Rttovs Cloud Area Fraction", "%", (/ ('', i=1, 3) /)) + +! Scops and others + TYPE(ctrl_outcosp), SAVE :: o_fracout = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "fracout", "Subcolumn output from SCOPS", "%", (/ ('', i=1, 3) /)) + + LOGICAL, SAVE :: cosp_varsdefined = .FALSE. ! ug PAS THREADPRIVATE ET C'EST NORMAL + REAL, SAVE :: Cosp_fill_value +!$OMP THREADPRIVATE(Cosp_fill_value) + + +CONTAINS + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!!!!!!! Ouverture des fichier et definition des axes!!!!!!!! + !! histbeg, histvert +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + + SUBROUTINE cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp, & + ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, & + ecrit_mth, ecrit_day, ecrit_hf, vgrid) + use MOD_COSP_INTERFACE_v1p4, only : cosp_vgrid +! use MOD_COSP + use mod_cosp_config, only : DBZE_BINS, SR_BINS, CFAD_ZE_MIN, PARASOL_NREFL, & + CFAD_ZE_WIDTH,vgrid_zl,vgrid_zu,vgrid_z,PARASOL_SZA, & + isccp_histPresCenters,tau_binCenters, LIDAR_NTEMP, & + LIDAR_PHASE_TEMP,misr_histHgtCenters,numMISRHgtBins, & + numMODISReffIceBins,reffICE_binCenters, & + numMODISReffLiqBins, reffLIQ_binCenters, pres_binCenters + + USE iophy + USE ioipsl + USE phys_cal_mod + USE time_phylmdz_mod, ONLY: day_ref, annee_ref, day_ini, start_time, itau_phy + USE print_control_mod, ONLY: lunout + +#ifdef CPP_XIOS + ! ug Pour les sorties XIOS + USE wxios +#endif + + IMPLICIT NONE + +!!! Variables d'entree + integer :: Nlevlmdz, Ncolumns ! Number of levels + real,dimension(Nlevlmdz) :: presnivs + real :: dtime, freq_cosp, ecrit_day, ecrit_hf, ecrit_mth + logical :: ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats +! type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + +!!! Variables locales + integer :: idayref, iff, ii + real :: zjulian,zjulian_start + real(wp),dimension(Ncolumns) :: column_ax + real(wp),dimension(DBZE_BINS) :: dbze_ax + CHARACTER(LEN=20), DIMENSION(3) :: chfreq = (/ '1day', '1d ', '3h ' /) + real(wp),parameter,dimension(SR_BINS) :: sratio_ax = (/0.005, & + 0.605,2.09,4.,6., & + 8.5,12.5,17.5,22.5,27.5,35.,45.,55.,70.,50040./) + +!!! Variables d'entree + +#ifdef CPP_XIOS + ! ug Variables utilisées pour récupérer le calendrier pour xios + INTEGER :: x_an, x_mois, x_jour + REAL :: x_heure + INTEGER :: ini_an, ini_mois, ini_jour + REAL :: ini_heure +#endif + + WRITE(lunout,*) 'Debut cosp_output_mod.F90' + print*,'cosp_varsdefined',cosp_varsdefined + ! Initialisations (Valeurs par defaut) + +!! Definition valeurs axes + do ii=1,Ncolumns + column_ax(ii) = real(ii) + enddo + + do i=1,DBZE_BINS + dbze_ax(i) = CFAD_ZE_MIN + CFAD_ZE_WIDTH*(i - 0.5) + enddo + + cosp_outfilenames(1) = 'histmthCOSP' + cosp_outfilenames(2) = 'histdayCOSP' + cosp_outfilenames(3) = 'histhfCOSP' + + cosp_outfiletypes(1) = 'ave(X)' + cosp_outfiletypes(2) = 'ave(X)' + cosp_outfiletypes(3) = 'ave(X)' + + cosp_outfilekeys(1) = ok_mensuelCOSP + cosp_outfilekeys(2) = ok_journeCOSP + cosp_outfilekeys(3) = ok_hfCOSP + + cosp_ecritfiles(1) = mth_len*86400. + cosp_ecritfiles(2) = 1.*86400. + cosp_ecritfiles(3) = 0.125*86400. + +! Lecture des parametres dans output.def ou config.def + + CALL getin('cosp_outfilenames',cosp_outfilenames) + CALL getin('cosp_outfilekeys',cosp_outfilekeys) + CALL getin('cosp_ecritfiles',cosp_ecritfiles) + CALL getin('cosp_outfiletypes',cosp_outfiletypes) + + WRITE(lunout,*)'cosp_outfilenames=',cosp_outfilenames + WRITE(lunout,*)'cosp_outfilekeys=',cosp_outfilekeys + WRITE(lunout,*)'cosp_ecritfiles=',cosp_ecritfiles + WRITE(lunout,*)'cosp_outfiletypes=',cosp_outfiletypes + + idayref = day_ref + CALL ymds2ju(annee_ref, 1, idayref, 0.0, zjulian) + CALL ymds2ju(annee_ref, 1, day_ini, start_time, zjulian_start) + +#ifdef CPP_XIOS + +! recuperer la valeur indefine Xios +! CALL xios_get_field_attr("clcalipso",default_value=Cosp_fill_value) +! Cosp_fill_value=missing_val + Cosp_fill_value=0. + print*,'Cosp_fill_value=',Cosp_fill_value + + CALL wxios_add_vaxis("height", vgrid%Nlvgrid, vgrid%z) + print*,'wxios_add_vaxis vgrid%Nlvgrid, vgrid%z',vgrid%Nlvgrid,vgrid%z + + WRITE(lunout,*) 'wxios_add_vaxis height_mlev, Nlevlmdz vgrid%mz ', & + Nlevlmdz,vgrid%mz + CALL wxios_add_vaxis("height_mlev", Nlevlmdz, vgrid%mz) + + WRITE(lunout,*) 'wxios_add_vaxis sza, PARASOL_NREFL ', & + PARASOL_NREFL, PARASOL_SZA + CALL wxios_add_vaxis("sza", PARASOL_NREFL, PARASOL_SZA) + + WRITE(lunout,*) 'wxios_add_vaxis pressure2 ',7,pres_binCenters + CALL wxios_add_vaxis("pressure2", 7, pres_binCenters) + + WRITE(lunout,*) 'wxios_add_vaxis column ',Ncolumns,column_ax + CALL wxios_add_vaxis("column", Ncolumns, column_ax) + + WRITE(lunout,*) 'wxios_add_vaxis temp LIDAR_NTEMP, LIDAR_PHASE_TEMP ', & + LIDAR_NTEMP, LIDAR_PHASE_TEMP + CALL wxios_add_vaxis("temp", LIDAR_NTEMP, LIDAR_PHASE_TEMP) + + WRITE(lunout,*) 'wxios_add_vaxis cth16 numMISRHgtBins, misr_histHgtCenters ', & + numMISRHgtBins, misr_histHgtCenters + CALL wxios_add_vaxis("cth", numMISRHgtBins, misr_histHgtCenters) + + WRITE(lunout,*) 'wxios_add_vaxis dbze DBZE_BINS, dbze_ax ', & + DBZE_BINS, dbze_ax + CALL wxios_add_vaxis("dbze", DBZE_BINS, dbze_ax) + + WRITE(lunout,*) 'wxios_add_vaxis scatratio SR_BINS, sratio_ax', & + SR_BINS, sratio_ax + CALL wxios_add_vaxis("scatratio", SR_BINS, sratio_ax) + + WRITE(lunout,*) 'wxios_add_vaxis ReffIce numMODISReffIceBins, & + reffICE_binCenters',numMODISReffIceBins, reffICE_binCenters + CALL wxios_add_vaxis("ReffIce", numMODISReffIceBins, reffICE_binCenters) + + WRITE(lunout,*) 'wxios_add_vaxis ReffLiq numMODISReffLiqBins, & + reffLIQ_binCenters', numMODISReffLiqBins, reffLIQ_binCenters + CALL wxios_add_vaxis("ReffLiq", numMODISReffLiqBins, reffLIQ_binCenters) + + WRITE(lunout,*) 'wxios_add_vaxis 7, tau_binCenters', & + 7, tau_binCenters + CALL wxios_add_vaxis("tau", 7, tau_binCenters) + +#endif + + zdtimemoy_cosp = freq_COSP ! Frequence ou l on moyenne + + DO iff=1,3 + zoutm_cosp(iff) = cosp_ecritfiles(iff) ! Frequence ou l on ecrit en seconde + + IF (cosp_outfilekeys(iff)) THEN + CALL histbeg_phy_all(cosp_outfilenames(iff),itau_phy,zjulian,& + dtime,nhoricosp(iff),cosp_nidfiles(iff)) +! print*,'histbeg_phy nhoricosp(iff),cosp_nidfiles(iff)', & +! nhoricosp(iff),cosp_nidfiles(iff) + +#ifdef CPP_XIOS + IF (.not. ok_all_xml) then + WRITE(lunout,*) 'wxios_add_file ',cosp_outfilenames(iff) + CALL wxios_add_file(cosp_outfilenames(iff),chfreq(iff),10) + ENDIF +#endif + +#ifndef CPP_IOIPSL_NO_OUTPUT +! Definition de l'axe vertical + if (use_vgrid) then +! Axe vertical Cosp 40 niveaux (en m) + CALL histvert(cosp_nidfiles(iff),"height","height","m",vgrid%Nlvgrid,vgrid%z,nvert(iff)) + else +! Axe vertical modele LMDZ presnivs + CALL histvert(cosp_nidfiles(iff),"presnivs","Vertical levels","Pa",vgrid%Nlvgrid,presnivs,nvert(iff),"down") + endif +! Axe vertical niveaux modele (en m) + CALL histvert(cosp_nidfiles(iff),"height_mlev","height_mlev","m",Nlevlmdz,vgrid%mz,nvertmcosp(iff)) + + CALL histvert(cosp_nidfiles(iff),"sza","solar_zenith_angle","degrees",PARASOL_NREFL,PARASOL_SZA,nvertp(iff)) + + CALL histvert(cosp_nidfiles(iff),"pressure2","pressure","mb",7,ISCCP_PC,nvertisccp(iff),"down") + + CALL histvert(cosp_nidfiles(iff),"column","column","count",Ncolumns,column_ax,nvertcol(iff)) !DBUG + + CALL histvert(cosp_nidfiles(iff),"temp","temperature","C",LIDAR_NTEMP,LIDAR_PHASE_TEMP,nverttemp(iff)) + + CALL histvert(cosp_nidfiles(iff),"cth","altitude","m",MISR_N_CTH,MISR_CTH,nvertmisr(iff)) + + CALL histvert(cosp_nidfiles(iff),"ReffIce","Effective_particle_size_Ice","microns",numMODISReffIceBins, reffICE_binCenters, & + nvertReffIce(iff)) + + CALL histvert(cosp_nidfiles(iff),"ReffLiq","Effective_particle_size_Liq","microns",numMODISReffLiqBins, reffLIQ_binCenters, & + nvertReffLiq(iff)) + + CALL histvert(cosp_nidfiles(iff),"dbze","equivalent_reflectivity_factor","dBZ",DBZE_BINS,dbze_ax,nvertbze(iff)) + + CALL histvert(cosp_nidfiles(iff),"scatratio","backscattering_ratio","1",SR_BINS,sratio_ax,nvertsratio(iff)) + + CALL histvert(cosp_nidfiles(iff),"tau","cloud optical depth","1",7,ISCCP_TAU,nverttau(iff)) + +!!! Valeur indefinie en cas IOIPSL + Cosp_fill_value=0. + +#endif + + ENDIF + ENDDO + + end SUBROUTINE cosp_output_open + + END MODULE cosp_output_mod Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_output_write_mod.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_output_write_mod.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_output_write_mod.F90 (revision 3358) @@ -0,0 +1,884 @@ +!!!! Abderrahmane Idelkadi aout 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Module pour definir (au 1er appel) et ecrire les variables dans les fichiers de sortie cosp +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + MODULE cosp_output_write_mod + + USE cosp_output_mod + USE MOD_COSP_INTERFACE_v1p4, ONLY: cosp_config, cosp_gridbox, cosp_sglidar, & + cosp_sgradar, cosp_isccp, cosp_lidarstats, & + cosp_radarstats, cosp_modis, cosp_misr, cosp_vgrid + USE mod_cosp_config, only : R_UNDEF, DBZE_BINS, SR_BINS, CFAD_ZE_MIN, PARASOL_NREFL, & + CFAD_ZE_WIDTH,vgrid_zl,vgrid_zu,vgrid_z,PARASOL_SZA, & + isccp_histPresCenters,tau_binCenters, LIDAR_NTEMP, & + LIDAR_PHASE_TEMP,misr_histHgtCenters,numMISRHgtBins, & + numMODISReffIceBins,reffICE_binCenters, & + numMODISReffLiqBins, reffLIQ_binCenters + + + IMPLICIT NONE + + INTEGER, SAVE :: itau_iocosp +!$OMP THREADPRIVATE(itau_iocosp) + INTEGER, save :: Nlevout, Ncolout +!$OMP THREADPRIVATE(Nlevout, Ncolout) + +! INTERFACE histwrite_cosp +! MODULE PROCEDURE histwrite2d_cosp,histwrite3d_cosp +! END INTERFACE + + CONTAINS + + SUBROUTINE cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_cosp, & + cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, & + isccp, misr, modis) + + USE ioipsl + USE time_phylmdz_mod, ONLY: itau_phy, start_time, day_step_phy + USE print_control_mod, ONLY: lunout,prt_level + +#ifdef CPP_XIOS + USE wxios, only: wxios_closedef + USE xios, only: xios_update_calendar, xios_field_is_active +#endif + IMPLICIT NONE +!!! Variables d'entree + integer :: itap, Nlevlmdz, Ncolumns, Npoints + real :: freq_COSP, dtime, missing_val, missing_cosp + type(cosp_config) :: cfg ! Control outputs + type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP + type(cosp_sglidar) :: sglidar ! Output from lidar simulator + type(cosp_sgradar) :: sgradar ! Output from radar simulator + type(cosp_isccp) :: isccp ! Output from ISCCP simulator + type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + type(cosp_radarstats) :: stradar + type(cosp_misr) :: misr ! Output from MISR + type(cosp_modis) :: modis ! Outputs from Modis + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats + +!!! Variables locales + integer :: icl,k,ip + logical :: ok_sync + integer :: itau_wcosp, iff + real, dimension(Npoints,PARASOL_NREFL) :: parasolcrefl, Ncref + +! Variables locals intermidiaires pour inverser les axes des champs 4D +! Compatibilite avec sorties CMIP + real, dimension(Npoints,Nlevout,SR_BINS) :: tmp_fi4da_cfadL + real, dimension(Npoints,Nlevout,DBZE_BINS) :: tmp_fi4da_cfadR + real, dimension(Npoints,numMISRHgtBins,7) :: tmp_fi4da_misr + +#ifdef CPP_XIOS + missing_val=missing_cosp +#else + missing_val=0. +#endif + + Nlevout = vgrid%Nlvgrid + Ncolout = Ncolumns + +! A refaire + itau_wcosp = itau_phy + itap + start_time * day_step_phy + if (prt_level >= 10) then + WRITE(lunout,*)'itau_wcosp, itap, start_time, day_step_phy =', & + itau_wcosp, itap, start_time, day_step_phy + endif + +! On le donne a cosp_output_write_mod pour que les histwrite y aient acces: + CALL set_itau_iocosp(itau_wcosp) + if (prt_level >= 10) then + WRITE(lunout,*)'itau_iocosp =',itau_iocosp + endif + + ok_sync = .TRUE. + +!DO iinit=1, iinitend +! AI sept 2014 cette boucle supprimee +! On n'ecrit pas quand itap=1 (cosp) + +! if (prt_level >= 10) then +! WRITE(lunout,*)'DO iinit=1, iinitend ',iinitend +! endif + +!!#ifdef CPP_XIOS +! !$OMP MASTER +!IF (cosp_varsdefined) THEN +! if (prt_level >= 10) then +! WRITE(lunout,*)'Apell xios_update_calendar cosp_varsdefined iinitend ', & +! cosp_varsdefined,iinitend +! endif +! CALL xios_update_calendar(itau_wcosp) +!ENDIF +! !$OMP END MASTER +! !$OMP BARRIER +!!#endif + +!!!! Sorties Calipso + if (cfg%Llidar_sim) then +!!! AI 02 2018 +! Traitement missing_val + where(stlidar%lidarcld == R_UNDEF) stlidar%lidarcld = missing_val +! where(stlidar%proftemp == R_UNDEF) stlidar%proftemp = missing_val !TIBO +! where(stlidar%profSR == R_UNDEF) stlidar%profSR = missing_val !TIBO2 + where(sglidar%beta_mol == R_UNDEF) sglidar%beta_mol = missing_val + where(sglidar%beta_tot == R_UNDEF) sglidar%beta_tot = missing_val + where(stlidar%cldlayer == R_UNDEF) stlidar%cldlayer = missing_val +! where(stlidar%cldtype == R_UNDEF) stlidar%cldtype = missing_val !OPAQ + where(stlidar%cfad_sr == R_UNDEF) stlidar%cfad_sr = missing_val +! AI 11 / 2015 + where(stlidar%parasolrefl == R_UNDEF) stlidar%parasolrefl = missing_val + where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = missing_val + where(stlidar%cldlayerphase == R_UNDEF) stlidar%cldlayerphase = missing_val + where(stlidar%lidarcldphase == R_UNDEF) stlidar%lidarcldphase = missing_val +! where(stlidar%lidarcldtype == R_UNDEF) stlidar%lidarcldtype = missing_val !OPAQ + where(stlidar%lidarcldtmp == R_UNDEF) stlidar%lidarcldtmp = missing_val + +! print*,'Appel histwrite2d_cosp' + if (cfg%Lcllcalipso) CALL histwrite2d_cosp(o_cllcalipso,stlidar%cldlayer(:,1)) + if (cfg%Lclhcalipso) CALL histwrite2d_cosp(o_clhcalipso,stlidar%cldlayer(:,3)) + if (cfg%Lclmcalipso) CALL histwrite2d_cosp(o_clmcalipso,stlidar%cldlayer(:,2)) + if (cfg%Lcltcalipso) CALL histwrite2d_cosp(o_cltcalipso,stlidar%cldlayer(:,4)) + if (cfg%Lclcalipso) CALL histwrite3d_cosp(o_clcalipso,stlidar%lidarcld,nvert) + if (cfg%Lclcalipsotmp) CALL histwrite3d_cosp(o_clcalipsotmp,stlidar%lidarcldtmp(:,:,1),nverttemp) + + if (cfg%Lcllcalipsoice) CALL histwrite2d_cosp(o_cllcalipsoice,stlidar%cldlayerphase(:,1,1)) + if (cfg%Lclhcalipsoice) CALL histwrite2d_cosp(o_clhcalipsoice,stlidar%cldlayerphase(:,3,1)) + if (cfg%Lclmcalipsoice) CALL histwrite2d_cosp(o_clmcalipsoice,stlidar%cldlayerphase(:,2,1)) + if (cfg%Lcltcalipsoice) CALL histwrite2d_cosp(o_cltcalipsoice,stlidar%cldlayerphase(:,4,1)) + if (cfg%Lclcalipsoice) CALL histwrite3d_cosp(o_clcalipsoice,stlidar%lidarcldphase(:,:,1),nvert) + if (cfg%Lclcalipsotmpice) CALL histwrite3d_cosp(o_clcalipsotmpice,stlidar%lidarcldtmp(:,:,2),nverttemp) + + if (cfg%Lcllcalipsoliq) CALL histwrite2d_cosp(o_cllcalipsoliq,stlidar%cldlayerphase(:,1,2)) + if (cfg%Lclhcalipsoliq) CALL histwrite2d_cosp(o_clhcalipsoliq,stlidar%cldlayerphase(:,3,2)) + if (cfg%Lclmcalipsoliq) CALL histwrite2d_cosp(o_clmcalipsoliq,stlidar%cldlayerphase(:,2,2)) + if (cfg%Lcltcalipsoliq) CALL histwrite2d_cosp(o_cltcalipsoliq,stlidar%cldlayerphase(:,4,2)) + if (cfg%Lclcalipsoliq) CALL histwrite3d_cosp(o_clcalipsoliq,stlidar%lidarcldphase(:,:,2),nvert) + if (cfg%Lclcalipsotmpliq) CALL histwrite3d_cosp(o_clcalipsotmpliq,stlidar%lidarcldtmp(:,:,3),nverttemp) + + if (cfg%Lcllcalipsoun) CALL histwrite2d_cosp(o_cllcalipsoun,stlidar%cldlayerphase(:,1,3)) + if (cfg%Lclhcalipsoun) CALL histwrite2d_cosp(o_clhcalipsoun,stlidar%cldlayerphase(:,3,3)) + if (cfg%Lclmcalipsoun) CALL histwrite2d_cosp(o_clmcalipsoun,stlidar%cldlayerphase(:,2,3)) + if (cfg%Lcltcalipsoun) CALL histwrite2d_cosp(o_cltcalipsoun,stlidar%cldlayerphase(:,4,3)) + if (cfg%Lclcalipsoun) CALL histwrite3d_cosp(o_clcalipsoun,stlidar%lidarcldphase(:,:,3),nvert) + if (cfg%Lclcalipsotmpun) CALL histwrite3d_cosp(o_clcalipsotmpun,stlidar%lidarcldtmp(:,:,4),nverttemp) + +! if (cfg%Lclopaquecalipso) CALL histwrite2d_cosp(o_clopaquecalipso,stlidar%cldtype(:,1)) !OPAQ +! if (cfg%Lclthincalipso) CALL histwrite2d_cosp(o_clthincalipso,stlidar%cldtype(:,2)) !OPAQ +! if (cfg%Lclzopaquecalipso) CALL histwrite2d_cosp(o_clzopaquecalipso,stlidar%cldtype(:,3)) !OPAQ + +! if (cfg%Lclcalipsoopaque) CALL histwrite3d_cosp(o_clcalipsoopaque,stlidar%lidarcldtype(:,:,1),nvert) !OPAQ +! if (cfg%Lclcalipsothin) CALL histwrite3d_cosp(o_clcalipsothin,stlidar%lidarcldtype(:,:,2),nvert) !OPAQ +! if (cfg%Lclcalipsozopaque) CALL histwrite3d_cosp(o_clcalipsozopaque,stlidar%lidarcldtype(:,:,3),nvert) !OPAQ +! if (cfg%Lclcalipsoopacity) CALL histwrite3d_cosp(o_clcalipsoopacity,stlidar%lidarcldtype(:,:,4),nvert) !OPAQ + +! if (cfg%Lproftemp) CALL histwrite3d_cosp(o_proftemp,stlidar%proftemp,nvert) !TIBO + +#ifdef CPP_XIOS + do icl=1,SR_BINS + tmp_fi4da_cfadL(:,:,icl)=stlidar%cfad_sr(:,icl,:) + enddo +! if (cfg%LcfadLidarsr532) CALL histwrite4d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr) + if (cfg%LcfadLidarsr532) CALL histwrite4d_cosp(o_cfad_lidarsr532,tmp_fi4da_cfadL) +! if (cfg%LprofSR) CALL histwrite4d_cosp(o_profSR,stlidar%profSR) !TIBO +#else + if (cfg%LcfadLidarsr532) then + do icl=1,SR_BINS + CALL histwrite3d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr(:,icl,:),nvert,icl) + enddo + endif +! if (cfg%LprofSR) then +! do icl=1,Ncolumns !TIBO +! CALL histwrite3d_cosp(o_profSR,stlidar%profSR(:,icl,:),nvert,icl) !TIBO +! enddo !TIBO +! endif +#endif + if (cfg%LparasolRefl) CALL histwrite3d_cosp(o_parasol_refl,stlidar%parasolrefl,nvertp) + + if (cfg%LparasolRefl) then + do k=1,PARASOL_NREFL + do ip=1, Npoints + if (stlidar%cldlayer(ip,4).gt.0.01.and.stlidar%parasolrefl(ip,k).ne.missing_val) then + parasolcrefl(ip,k)=(stlidar%parasolrefl(ip,k)-0.03*(1.-stlidar%cldlayer(ip,4)))/ & + stlidar%cldlayer(ip,4) + Ncref(ip,k) = 1. + else + parasolcrefl(ip,k)=missing_val + Ncref(ip,k) = 0. + endif + enddo + enddo + CALL histwrite3d_cosp(o_Ncrefl,Ncref,nvertp) + CALL histwrite3d_cosp(o_parasol_crefl,parasolcrefl,nvertp) + endif + +#ifdef CPP_XIOS + if (cfg%Latb532) CALL histwrite4d_cosp(o_atb532,sglidar%beta_tot) +#else + if (cfg%Latb532) then + do icl=1,Ncolumns + CALL histwrite3d_cosp(o_atb532,sglidar%beta_tot(:,icl,:),nvertmcosp,icl) + enddo + endif +#endif + + if (cfg%LlidarBetaMol532) CALL histwrite3d_cosp(o_beta_mol532,sglidar%beta_mol,nvertmcosp) + + endif !Lidar + +!!! Sorties Cloudsat + if (cfg%Lradar_sim) then + + where(stradar%cfad_ze == R_UNDEF) stradar%cfad_ze = missing_val +#ifdef CPP_XIOS + do icl=1,DBZE_BINS + tmp_fi4da_cfadR(:,:,icl)=stradar%cfad_ze(:,icl,:) + enddo + if (cfg%Ldbze94) CALL histwrite4d_cosp(o_dbze94,sgradar%Ze_tot) +! if (cfg%LcfadDbze94) CALL histwrite4d_cosp(o_cfadDbze94,stradar%cfad_ze) + if (cfg%LcfadDbze94) CALL histwrite4d_cosp(o_cfadDbze94,tmp_fi4da_cfadR) +#else + if (cfg%Ldbze94) then + do icl=1,Ncolumns + CALL histwrite3d_cosp(o_dbze94,sgradar%Ze_tot(:,icl,:),nvert,icl) + enddo + endif + if (cfg%LcfadDbze94) then + do icl=1,DBZE_BINS + CALL histwrite3d_cosp(o_cfadDbze94,stradar%cfad_ze(:,icl,:),nvert,icl) + enddo + endif +#endif + endif +! endif pour radar + +!!! Sorties combinees Cloudsat et Calipso + if (cfg%Llidar_sim .and. cfg%Lradar_sim) then + where(stradar%lidar_only_freq_cloud == R_UNDEF) & + stradar%lidar_only_freq_cloud = missing_val + if (cfg%Lclcalipso) CALL histwrite3d_cosp(o_clcalipso2,stradar%lidar_only_freq_cloud,nvert) + where(stradar%radar_lidar_tcc == R_UNDEF) & + stradar%radar_lidar_tcc = missing_val + if (cfg%Lcltlidarradar) CALL histwrite2d_cosp(o_cltlidarradar,stradar%radar_lidar_tcc) + endif + +!!! Sorties Isccp + if (cfg%Lisccp_sim) then + where(isccp%totalcldarea == R_UNDEF) isccp%totalcldarea = missing_val + where(isccp%meanptop == R_UNDEF) isccp%meanptop = missing_val + where(isccp%meantaucld == R_UNDEF) isccp%meantaucld = missing_val + where(isccp%meanalbedocld == R_UNDEF) isccp%meanalbedocld = missing_val + where(isccp%meantb == R_UNDEF) isccp%meantb = missing_val + where(isccp%meantbclr == R_UNDEF) isccp%meantbclr = missing_val + where(isccp%fq_isccp == R_UNDEF) isccp%fq_isccp = missing_val + where(isccp%boxtau == R_UNDEF) isccp%boxtau = missing_val + where(isccp%boxptop == R_UNDEF) isccp%boxptop = missing_val + + CALL histwrite2d_cosp(o_sunlit,gbx%sunlit) +#ifdef CPP_XIOS + if (cfg%Lclisccp) CALL histwrite4d_cosp(o_clisccp2,isccp%fq_isccp) +#else + if (cfg%Lclisccp) then + do icl=1,7 + CALL histwrite3d_cosp(o_clisccp2,isccp%fq_isccp(:,icl,:),nvertisccp,icl) + enddo + endif +#endif + + if (cfg%Lboxtauisccp) CALL histwrite3d_cosp(o_boxtauisccp,isccp%boxtau,nvertcol) + if (cfg%Lboxptopisccp) CALL histwrite3d_cosp(o_boxptopisccp,isccp%boxptop,nvertcol) + if (cfg%Lcltisccp) CALL histwrite2d_cosp(o_tclisccp,isccp%totalcldarea) + if (cfg%Lpctisccp) CALL histwrite2d_cosp(o_ctpisccp,isccp%meanptop) + if (cfg%Ltauisccp) CALL histwrite2d_cosp(o_tauisccp,isccp%meantaucld) + if (cfg%Lalbisccp) CALL histwrite2d_cosp(o_albisccp,isccp%meanalbedocld) + if (cfg%Lmeantbisccp) CALL histwrite2d_cosp(o_meantbisccp,isccp%meantb) + if (cfg%Lmeantbclrisccp) CALL histwrite2d_cosp(o_meantbclrisccp,isccp%meantbclr) + endif ! Isccp + +!!! MISR simulator + if (cfg%Lmisr_sim) then + where(misr%fq_MISR == R_UNDEF) misr%fq_MISR = missing_val + +#ifdef CPP_XIOS + do icl=1,numMISRHgtBins + tmp_fi4da_misr(:,icl,:)=misr%fq_MISR(:,:,icl) + enddo +! if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,misr%fq_MISR) + if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,tmp_fi4da_misr) +#else + if (cfg%LclMISR) then + do icl=1,7 + CALL histwrite3d_cosp(o_clMISR,misr%fq_MISR(:,icl,:),nvertmisr,icl) + enddo + endif +#endif + endif +! endif pour Misr + +!!! Modis simulator + if (cfg%Lmodis_sim) then + where(modis%Cloud_Fraction_Low_Mean == R_UNDEF) & + modis%Cloud_Fraction_Low_Mean = missing_val + where(modis%Cloud_Fraction_High_Mean == R_UNDEF) & + modis%Cloud_Fraction_High_Mean = missing_val + where(modis%Cloud_Fraction_Mid_Mean == R_UNDEF) & + modis%Cloud_Fraction_Mid_Mean = missing_val + where(modis%Cloud_Fraction_Total_Mean == R_UNDEF) & + modis%Cloud_Fraction_Total_Mean = missing_val + where(modis%Cloud_Fraction_Water_Mean == R_UNDEF) & + modis%Cloud_Fraction_Water_Mean = missing_val + where(modis%Cloud_Fraction_Ice_Mean == R_UNDEF) & + modis%Cloud_Fraction_Ice_Mean = missing_val + where(modis%Optical_Thickness_Total_Mean == R_UNDEF) & + modis%Optical_Thickness_Total_Mean = missing_val + where(modis%Optical_Thickness_Water_Mean == R_UNDEF) & + modis%Optical_Thickness_Water_Mean = missing_val + where(modis%Optical_Thickness_Ice_Mean == R_UNDEF) & + modis%Optical_Thickness_Ice_Mean = missing_val + where(modis%Cloud_Particle_Size_Water_Mean == R_UNDEF) & + modis%Cloud_Particle_Size_Water_Mean = missing_val + where(modis%Cloud_Particle_Size_Ice_Mean == R_UNDEF) & + modis%Cloud_Particle_Size_Ice_Mean = missing_val + where(modis%Cloud_Top_Pressure_Total_Mean == R_UNDEF) & + modis%Cloud_Top_Pressure_Total_Mean = missing_val + where(modis%Liquid_Water_Path_Mean == R_UNDEF) & + modis%Liquid_Water_Path_Mean = missing_val + where(modis%Ice_Water_Path_Mean == R_UNDEF) & + modis%Ice_Water_Path_Mean = missing_val + + where(modis%Optical_Thickness_Total_LogMean == R_UNDEF) & + modis%Optical_Thickness_Total_LogMean = missing_val + + where(modis%Optical_Thickness_Water_LogMean == R_UNDEF) & + modis%Optical_Thickness_Water_LogMean = missing_val + + where(modis%Optical_Thickness_Ice_LogMean == R_UNDEF) & + modis%Optical_Thickness_Ice_LogMean = missing_val + + if (cfg%Lcllmodis) CALL histwrite2d_cosp(o_cllmodis,modis%Cloud_Fraction_Low_Mean) + if (cfg%Lclhmodis) CALL histwrite2d_cosp(o_clhmodis,modis%Cloud_Fraction_High_Mean) + if (cfg%Lclmmodis) CALL histwrite2d_cosp(o_clmmodis,modis%Cloud_Fraction_Mid_Mean) + if (cfg%Lcltmodis) CALL histwrite2d_cosp(o_cltmodis,modis%Cloud_Fraction_Total_Mean) + if (cfg%Lclwmodis) CALL histwrite2d_cosp(o_clwmodis,modis%Cloud_Fraction_Water_Mean) + if (cfg%Lclimodis) CALL histwrite2d_cosp(o_climodis,modis%Cloud_Fraction_Ice_Mean) + if (cfg%Ltautmodis) CALL histwrite2d_cosp(o_tautmodis,modis%Optical_Thickness_Total_Mean) + if (cfg%Ltauwmodis) CALL histwrite2d_cosp(o_tauwmodis,modis%Optical_Thickness_Water_Mean) + if (cfg%Ltauimodis) CALL histwrite2d_cosp(o_tauimodis,modis%Optical_Thickness_Ice_Mean) + if (cfg%Ltautlogmodis) CALL histwrite2d_cosp(o_tautlogmodis,modis%Optical_Thickness_Total_LogMean) + if (cfg%Ltauwlogmodis) CALL histwrite2d_cosp(o_tauwlogmodis,modis%Optical_Thickness_Water_LogMean) + if (cfg%Ltauilogmodis) CALL histwrite2d_cosp(o_tauilogmodis,modis%Optical_Thickness_Ice_LogMean) + if (cfg%Lreffclwmodis) CALL histwrite2d_cosp(o_reffclwmodis,modis%Cloud_Particle_Size_Water_Mean) + if (cfg%Lreffclimodis) CALL histwrite2d_cosp(o_reffclimodis,modis%Cloud_Particle_Size_Ice_Mean) + if (cfg%Lpctmodis) CALL histwrite2d_cosp(o_pctmodis,modis%Cloud_Top_Pressure_Total_Mean) + if (cfg%Llwpmodis) CALL histwrite2d_cosp(o_lwpmodis,modis%Liquid_Water_Path_Mean) + if (cfg%Liwpmodis) CALL histwrite2d_cosp(o_iwpmodis,modis%Ice_Water_Path_Mean) + + where(modis%Optical_Thickness_vs_Cloud_Top_Pressure == R_UNDEF) & + modis%Optical_Thickness_vs_Cloud_Top_Pressure = missing_val + +#ifdef CPP_XIOS + if (cfg%Lclmodis) CALL histwrite4d_cosp(o_clmodis,modis%Optical_Thickness_vs_Cloud_Top_Pressure) +#else + if (cfg%Lclmodis) then + do icl=1,7 + CALL histwrite3d_cosp(o_clmodis, & + modis%Optical_Thickness_vs_Cloud_Top_Pressure(:,icl,:),nvertisccp,icl) + enddo + endif +#endif + + where(modis%Optical_Thickness_vs_ReffIce == R_UNDEF) & + modis%Optical_Thickness_vs_ReffIce = missing_val + + where(modis%Optical_Thickness_vs_ReffLiq == R_UNDEF) & + modis%Optical_Thickness_vs_ReffLiq = missing_val + +#ifdef CPP_XIOS + if (cfg%Lclmodis) CALL histwrite4d_cosp(o_crimodis,modis%Optical_Thickness_vs_ReffIce) + if (cfg%Lclmodis) CALL histwrite4d_cosp(o_crlmodis,modis%Optical_Thickness_vs_ReffLiq) +#else + if (cfg%Lclmodis) then + do icl=1,7 + CALL histwrite3d_cosp(o_crimodis, & + modis%Optical_Thickness_vs_ReffIce(:,icl,:),nvertReffIce,icl) + enddo + endif + if (cfg%Lclmodis) then + do icl=1,7 + CALL histwrite3d_cosp(o_crlmodis, & + modis%Optical_Thickness_vs_ReffLiq(:,icl,:),nvertReffLiq,icl) + enddo + endif +#endif + endif !modis + + IF(.NOT.cosp_varsdefined) THEN +!$OMP MASTER +#ifndef CPP_IOIPSL_NO_OUTPUT + DO iff=1,3 + IF (cosp_outfilekeys(iff)) THEN + CALL histend(cosp_nidfiles(iff)) + ENDIF ! cosp_outfilekeys + ENDDO ! iff +#endif +! Fermeture dans phys_output_write +!#ifdef CPP_XIOS + !On finalise l'initialisation: + !CALL wxios_closedef() +!#endif + +!$OMP END MASTER +!$OMP BARRIER + cosp_varsdefined = .TRUE. + END IF + + IF(cosp_varsdefined) THEN +! On synchronise les fichiers pour IOIPSL +#ifndef CPP_IOIPSL_NO_OUTPUT +!$OMP MASTER + DO iff=1,3 + IF (ok_sync .AND. cosp_outfilekeys(iff)) THEN + CALL histsync(cosp_nidfiles(iff)) + ENDIF + END DO +!$OMP END MASTER +#endif + ENDIF !cosp_varsdefined + + END SUBROUTINE cosp_output_write + +! ug Routine pour definir itau_iocosp depuis cosp_output_write_mod: + SUBROUTINE set_itau_iocosp(ito) + IMPLICIT NONE + INTEGER, INTENT(IN) :: ito + itau_iocosp = ito + END SUBROUTINE + + SUBROUTINE histdef2d_cosp (iff,var) + + USE ioipsl + USE dimphy + use iophy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz, ONLY: nbp_lon + USE print_control_mod, ONLY: lunout,prt_level +#ifdef CPP_XIOS + USE wxios +#endif + + IMPLICIT NONE + + INCLUDE "clesphys.h" + + INTEGER :: iff + TYPE(ctrl_outcosp) :: var + + REAL zstophym + CHARACTER(LEN=20) :: typeecrit + + ! ug On récupère le type écrit de la structure: + ! Assez moche, Ã| refaire si meilleure méthode... + IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN + typeecrit = 'once' + ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN + typeecrit = 't_min(X)' + ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN + typeecrit = 't_max(X)' + ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN + typeecrit = 'inst(X)' + ELSE + typeecrit = cosp_outfiletypes(iff) + ENDIF + + IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN + zstophym=zoutm_cosp(iff) + ELSE + zstophym=zdtimemoy_cosp + ENDIF + +#ifdef CPP_XIOS + IF (.not. ok_all_xml) then + IF ( var%cles(iff) ) THEN + if (prt_level >= 10) then + WRITE(lunout,*)'Appel wxios_add_field_to_file var%name =',var%name + endif + CALL wxios_add_field_to_file(var%name, 2, cosp_nidfiles(iff), cosp_outfilenames(iff), & + var%description, var%unit, 1, typeecrit) + ENDIF + ENDIF +#endif + +#ifndef CPP_IOIPSL_NO_OUTPUT + IF ( var%cles(iff) ) THEN + CALL histdef (cosp_nidfiles(iff), var%name, var%description, var%unit, & + nbp_lon,jj_nb,nhoricosp(iff), 1,1,1, -99, 32, & + typeecrit, zstophym,zoutm_cosp(iff)) + ENDIF +#endif + + END SUBROUTINE histdef2d_cosp + + SUBROUTINE histdef3d_cosp (iff,var,nvertsave,ncols) + USE ioipsl + USE dimphy + use iophy + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz, ONLY: nbp_lon + USE print_control_mod, ONLY: lunout,prt_level + +#ifdef CPP_XIOS + USE wxios +#endif + + + IMPLICIT NONE + + INCLUDE "clesphys.h" + + INTEGER :: iff, klevs + INTEGER, INTENT(IN), OPTIONAL :: ncols ! ug RUSTINE POUR LES variables 4D + INTEGER, INTENT(IN) :: nvertsave + TYPE(ctrl_outcosp) :: var + + REAL zstophym + CHARACTER(LEN=20) :: typeecrit, nomi + CHARACTER(LEN=20) :: nom + character(len=2) :: str2 + CHARACTER(len=20) :: nam_axvert + +! Axe vertical + IF (nvertsave.eq.nvertp(iff)) THEN + klevs=PARASOL_NREFL + nam_axvert="sza" + ELSE IF (nvertsave.eq.nvertisccp(iff)) THEN + klevs=7 + nam_axvert="pressure2" + ELSE IF (nvertsave.eq.nvertcol(iff)) THEN + klevs=Ncolout + nam_axvert="column" + ELSE IF (nvertsave.eq.nverttemp(iff)) THEN + klevs=LIDAR_NTEMP + nam_axvert="temp" + ELSE IF (nvertsave.eq.nvertmisr(iff)) THEN + klevs=numMISRHgtBins + nam_axvert="cth16" + ELSE IF (nvertsave.eq.nvertReffIce(iff)) THEN + klevs= numMODISReffIceBins + nam_axvert="ReffIce" + ELSE IF (nvertsave.eq.nvertReffLiq(iff)) THEN + klevs= numMODISReffLiqBins + nam_axvert="ReffLiq" + ELSE + klevs=Nlevout + nam_axvert="presnivs" + ENDIF + +! ug RUSTINE POUR LES Champs 4D + IF (PRESENT(ncols)) THEN + write(str2,'(i2.2)')ncols + nomi=var%name + nom="c"//str2//"_"//nomi + ELSE + nom=var%name + END IF + + ! ug On récupère le type écrit de la structure: + ! Assez moche, Ã| refaire si meilleure méthode... + IF (INDEX(var%cosp_typeecrit(iff), "once") > 0) THEN + typeecrit = 'once' + ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_min") > 0) THEN + typeecrit = 't_min(X)' + ELSE IF(INDEX(var%cosp_typeecrit(iff), "t_max") > 0) THEN + typeecrit = 't_max(X)' + ELSE IF(INDEX(var%cosp_typeecrit(iff), "inst") > 0) THEN + typeecrit = 'inst(X)' + ELSE + typeecrit = cosp_outfiletypes(iff) + ENDIF + + IF (typeecrit=='inst(X)'.OR.typeecrit=='once') THEN + zstophym=zoutm_cosp(iff) + ELSE + zstophym=zdtimemoy_cosp + ENDIF + +#ifdef CPP_XIOS + IF (.not. ok_all_xml) then + IF ( var%cles(iff) ) THEN + if (prt_level >= 10) then + WRITE(lunout,*)'Appel wxios_add_field_to_file 3d nom variable nam_axvert = ',nom, nam_axvert + endif + CALL wxios_add_field_to_file(nom, 3, cosp_nidfiles(iff), cosp_outfilenames(iff), & + var%description, var%unit, 1, typeecrit, nam_axvert) + ENDIF + ENDIF +#endif + +#ifndef CPP_IOIPSL_NO_OUTPUT + IF ( var%cles(iff) ) THEN + CALL histdef (cosp_nidfiles(iff), nom, var%description, var%unit, & + nbp_lon, jj_nb, nhoricosp(iff), klevs, 1, & + klevs, nvertsave, 32, typeecrit, & + zstophym, zoutm_cosp(iff)) + ENDIF +#endif + + END SUBROUTINE histdef3d_cosp + + SUBROUTINE histwrite2d_cosp(var,field) + USE dimphy + USE mod_phys_lmdz_para + USE ioipsl + use iophy + USE mod_grid_phy_lmdz, ONLY: nbp_lon + USE print_control_mod, ONLY: lunout,prt_level + +#ifdef CPP_XIOS + USE xios, only: xios_send_field +#endif + + IMPLICIT NONE + INCLUDE 'clesphys.h' + + TYPE(ctrl_outcosp), INTENT(IN) :: var + REAL, DIMENSION(:), INTENT(IN) :: field + + INTEGER :: iff + + REAL,DIMENSION(klon_mpi) :: buffer_omp + INTEGER, allocatable, DIMENSION(:) :: index2d + REAL :: Field2d(nbp_lon,jj_nb) + CHARACTER(LEN=20) :: nomi, nom + character(len=2) :: str2 + LOGICAL, SAVE :: firstx +!$OMP THREADPRIVATE(firstx) + + IF (prt_level >= 9) WRITE(lunout,*)'Begin histrwrite2d ',var%name + + ! On regarde si on est dans la phase de définition ou d'écriture: + IF(.NOT.cosp_varsdefined) THEN +!$OMP MASTER + !Si phase de définition.... on définit + CALL conf_cospoutputs(var%name,var%cles) + DO iff=1, 3 + IF (cosp_outfilekeys(iff)) THEN + CALL histdef2d_cosp(iff, var) + ENDIF + ENDDO +!$OMP END MASTER + ELSE + !Et sinon on.... écrit + IF (SIZE(field)/=klon) & + CALL abort_physic('iophy::histwrite2d_cosp','Field first DIMENSION not equal to klon',1) + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,Field2d) + +! La boucle sur les fichiers: + firstx=.true. + DO iff=1, 3 + IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN + ALLOCATE(index2d(nbp_lon*jj_nb)) +#ifndef CPP_IOIPSL_NO_OUTPUT + CALL histwrite(cosp_nidfiles(iff),var%name,itau_iocosp,Field2d,nbp_lon*jj_nb,index2d) +#endif + deallocate(index2d) +#ifdef CPP_XIOS + IF (.not. ok_all_xml) then + if (firstx) then + if (prt_level >= 10) then + WRITE(lunout,*)'xios_send_field variable ',var%name + endif + CALL xios_send_field(var%name, Field2d) + firstx=.false. + endif + ENDIF +#endif + ENDIF + ENDDO + +#ifdef CPP_XIOS + IF (ok_all_xml) THEN + if (prt_level >= 1) then + WRITE(lunout,*)'xios_send_field variable ',var%name + endif + CALL xios_send_field(var%name, Field2d) + ENDIF +#endif + +!$OMP END MASTER + ENDIF ! vars_defined + IF (prt_level >= 9) WRITE(lunout,*)'End histrwrite2d_cosp ',var%name + END SUBROUTINE histwrite2d_cosp + +! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE +! AI sept 2013 + SUBROUTINE histwrite3d_cosp(var, field, nverts, ncols) + USE dimphy + USE mod_phys_lmdz_para + USE ioipsl + use iophy + USE mod_grid_phy_lmdz, ONLY: nbp_lon + USE print_control_mod, ONLY: lunout,prt_level + +#ifdef CPP_XIOS + USE xios, only: xios_send_field +#endif + + + IMPLICIT NONE + INCLUDE 'clesphys.h' + + TYPE(ctrl_outcosp), INTENT(IN) :: var + REAL, DIMENSION(:,:), INTENT(IN) :: field ! --> field(klon,:) + INTEGER, INTENT(IN), OPTIONAL :: ncols ! ug RUSTINE POUR LES Champs 4D..... + INTEGER, DIMENSION(3), INTENT(IN) :: nverts + + INTEGER :: iff, k + + REAL,DIMENSION(klon_mpi,SIZE(field,2)) :: buffer_omp + REAL :: Field3d(nbp_lon,jj_nb,SIZE(field,2)) + INTEGER :: ip, n, nlev + INTEGER, ALLOCATABLE, DIMENSION(:) :: index3d + CHARACTER(LEN=20) :: nomi, nom + character(len=2) :: str2 + LOGICAL, SAVE :: firstx +!$OMP THREADPRIVATE(firstx) + + IF (prt_level >= 9) write(lunout,*)'Begin histrwrite3d ',var%name + +! ug RUSTINE POUR LES STD LEVS..... + IF (PRESENT(ncols)) THEN + write(str2,'(i2.2)')ncols + nomi=var%name + nom="c"//str2//"_"//nomi + ELSE + nom=var%name + END IF + ! On regarde si on est dans la phase de définition ou d'écriture: + IF(.NOT.cosp_varsdefined) THEN + !Si phase de définition.... on définit +!$OMP MASTER + CALL conf_cospoutputs(var%name,var%cles) + DO iff=1, 3 + IF (cosp_outfilekeys(iff)) THEN + CALL histdef3d_cosp(iff, var, nverts(iff), ncols) + ENDIF + ENDDO +!$OMP END MASTER + ELSE + !Et sinon on.... écrit + IF (SIZE(field,1)/=klon) & + CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1) + nlev=SIZE(field,2) + + + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,field3d) + +! BOUCLE SUR LES FICHIERS + firstx=.true. + DO iff=1, 3 + IF (var%cles(iff) .AND. cosp_outfilekeys(iff)) THEN + ALLOCATE(index3d(nbp_lon*jj_nb*nlev)) +#ifndef CPP_IOIPSL_NO_OUTPUT + CALL histwrite(cosp_nidfiles(iff),nom,itau_iocosp,Field3d,nbp_lon*jj_nb*nlev,index3d) +#endif + +#ifdef CPP_XIOS + IF (.not. ok_all_xml) then + IF (firstx) THEN + CALL xios_send_field(nom, Field3d(:,:,1:nlev)) + IF (prt_level >= 9) WRITE(lunout,*)'xios_send_field ',var%name + firstx=.FALSE. + ENDIF + ENDIF +#endif + deallocate(index3d) + ENDIF + ENDDO +#ifdef CPP_XIOS + IF (ok_all_xml) THEN + CALL xios_send_field(nom, Field3d(:,:,1:nlev)) + IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name + ENDIF +#endif + +!$OMP END MASTER + ENDIF ! vars_defined + IF (prt_level >= 9) write(lunout,*)'End histrwrite3d_cosp ',nom + END SUBROUTINE histwrite3d_cosp + +! ug NOUVELLE VERSION DES WRITE AVEC LA BOUCLE DO RENTREE +! AI sept 2013 + SUBROUTINE histwrite4d_cosp(var, field) + USE dimphy + USE mod_phys_lmdz_para + USE ioipsl + use iophy + USE mod_grid_phy_lmdz, ONLY: nbp_lon + USE print_control_mod, ONLY: lunout,prt_level + +#ifdef CPP_XIOS + USE xios, only: xios_send_field +#endif + + + IMPLICIT NONE + INCLUDE 'clesphys.h' + + TYPE(ctrl_outcosp), INTENT(IN) :: var + REAL, DIMENSION(:,:,:), INTENT(IN) :: field ! --> field(klon,:) + + INTEGER :: iff, k + + REAL,DIMENSION(klon_mpi,SIZE(field,2),SIZE(field,3)) :: buffer_omp + REAL :: field4d(nbp_lon,jj_nb,SIZE(field,2),SIZE(field,3)) + INTEGER :: ip, n, nlev, nlev2 + INTEGER, ALLOCATABLE, DIMENSION(:) :: index4d + CHARACTER(LEN=20) :: nomi, nom + + IF (prt_level >= 9) write(lunout,*)'Begin histrwrite4d ',var%name + + IF(cosp_varsdefined) THEN + !Et sinon on.... écrit + IF (SIZE(field,1)/=klon) & + CALL abort_physic('iophy::histwrite3d','Field first DIMENSION not equal to klon',1) + + nlev=SIZE(field,2) + nlev2=SIZE(field,3) + CALL Gather_omp(field,buffer_omp) +!$OMP MASTER + CALL grid1Dto2D_mpi(buffer_omp,field4d) + +#ifdef CPP_XIOS +! IF (ok_all_xml) THEN + CALL xios_send_field(var%name, Field4d(:,:,1:nlev,1:nlev2)) + IF (prt_level >= 1) WRITE(lunout,*)'xios_send_field ',var%name +! ENDIF +#endif + +!$OMP END MASTER + ENDIF ! vars_defined + IF (prt_level >= 9) write(lunout,*)'End histrwrite4d_cosp ',nom + END SUBROUTINE histwrite4d_cosp + + SUBROUTINE conf_cospoutputs(nam_var,cles_var) +!!! Lecture des noms et cles de sortie des variables dans config.def + ! en utilisant les routines getin de IOIPSL + use ioipsl + USE print_control_mod, ONLY: lunout,prt_level + + IMPLICIT NONE + + CHARACTER(LEN=20) :: nam_var, nnam_var + LOGICAL, DIMENSION(3) :: cles_var + +! Lecture dans config.def ou output.def de cles_var et name_var + CALL getin('cles_'//nam_var,cles_var) + CALL getin('name_'//nam_var,nam_var) + IF(prt_level>10) WRITE(lunout,*)'nam_var cles_var ',nam_var,cles_var(:) + + END SUBROUTINE conf_cospoutputs + + END MODULE cosp_output_write_mod Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_parasol_interface.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_parasol_interface.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_parasol_interface.F90 (revision 3358) @@ -0,0 +1,90 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_PARASOL_INTERFACE + USE COSP_KINDS, ONLY: WP + implicit none + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE cosp_parasol + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE PARASOL_SGX + ! Dimensions + integer :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nrefl ! Number of parasol reflectances + + ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) + real(wp),dimension(:,:,:),pointer :: & + refl ! parasol reflectances + + END TYPE PARASOL_SGX + TYPE PARASOL_GBX + integer :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nrefl ! Number of parasol reflectances + real(wp), dimension(:,:),pointer :: & + parasolrefl ! Mean parasol reflectance + + END TYPE PARASOL_GBX + TYPE COSP_PARASOL + type(PARASOL_SGX) :: PARASOL_SGX + type(PARASOL_GBX) :: PARASOL_GBX + END TYPE COSP_PARASOL + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE parasol_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE parasol_IN + integer,pointer :: & + Npoints, & ! Number of horizontal gridpoints + Nlevels, & ! Number of vertical levels + Ncolumns, & ! Number of columns + Nrefl ! Number of angles for which the reflectance is computed + real(wp),dimension(:,:),pointer :: & + tautot_S_liq, & ! Liquid water optical thickness, from TOA to SFC + tautot_S_ice ! Ice water optical thickness, from TOA to SFC + END TYPE parasol_IN + +contains + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_parasol_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_PARASOL_INIT() + + end subroutine COSP_PARASOL_INIT + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +end module MOD_COSP_PARASOL_INTERFACE Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_phys_constants.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_phys_constants.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_phys_constants.F90 (revision 3358) @@ -0,0 +1,68 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +MODULE cosp_phys_constants + USE cosp_kinds, only: wp + IMPLICIT NONE + + REAL(wp), PARAMETER :: & + tmelt = 273.15_wp, & ! Melting temperature of ice/snow [K] + rhoice = 917._wp, & ! Density of ice [kg/m3] + rholiq = 1000._wp ! Density of liquid water [kg/m3] + + ! Molecular weights + REAL(wp), PARAMETER :: & + amw = 18.01534_wp, & ! Water [g/mol] + amd = 28.9644_wp, & ! Dry air [g/mol] + amO3 = 47.9983_wp, & ! Ozone [g/mol] + amCO2 = 44.0096_wp, & ! CO2 [g/mol] + amCH4 = 16.0426_wp, & ! Methane [g/mol] + amN2O = 44.0129_wp, & ! N2O [g/mol] + amCO = 28.0102_wp ! CO [g/mol] + + ! WMO/SI value + REAL(wp), PARAMETER :: & + avo = 6.023E23_wp, & ! Avogadro constant used by ISCCP simulator [1/mol] + grav = 9.806650_wp ! Av. gravitational acceleration used by ISCCP simulator [m/s2] + + ! Thermodynamic constants for the dry and moist atmosphere + REAL(wp), PARAMETER :: & + rd = 287.04_wp, & ! Gas constant for dry air [J/K/Kg] + cpd = 1004.64_wp, & ! Specific heat at constant pressure for dry air [J/K/Kg] + rv = 461.51_wp, & ! Gas constant for water vapor [J/K/Kg] + cpv = 1869.46_wp, & ! Specific heat at constant pressure for water vapor [J/K/Kg] + km = 1.38e-23_wp ! Boltzmann constant [J/K] + +END MODULE cosp_phys_constants + + Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_read_otputkeys.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_read_otputkeys.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_read_otputkeys.F90 (revision 3358) @@ -0,0 +1,1244 @@ +!!!============================================================================= +!!! AI mars 2018 +!! Module permettant de controler les cles de sorties cosp +!! pour LMDZ +!! 1. on initialise les cles au 1er passage a cosp itap de la physique = 1 +!! 2. on garde la routine de lecture du fichier namelist cosp_out...txt pour le +!! cas non XIOS (ioipsl) +!! 3. on rajoutte une subroutine qui interoge XIOS si les champs sont demandes +!! dans les xml alors on les active et on active les simulateurs +!! correspondant +!!!============================================================================= + +module cosp_read_otputkeys + +! USE MOD_COSP_CONSTANTS +! USE MOD_COSP_TYPES + use MOD_COSP_INTERFACE_v1p4 + USE mod_phys_lmdz_para + +CONTAINS +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------- SUBROUTINE READ_COSP_OUTPUT_NL ------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE cosp_outputkeys_init(cfg) + implicit none + type(cosp_config),intent(out) :: cfg + character(len=32) :: out_list(78) + integer :: i + + + do i=1,78 + cfg%out_list(i)='' + enddo + + cfg%Llidar_sim=.false. + cfg%Lradar_sim=.false. + cfg%Lisccp_sim=.false. + cfg%Lmodis_sim=.false. + cfg%Lmisr_sim=.false. + cfg%Lrttov_sim=.false. + cfg%Lstats=.false. + cfg%Lwrite_output=.false. + cfg%Ltoffset=.false. + cfg%Lfracout=.false. + + cfg%Lcllcalipso=.FALSE. + cfg%Lclmcalipso=.FALSE. + cfg%Lclhcalipso=.FALSE. + cfg%Lcltcalipso=.FALSE. + cfg%Lcllcalipsoice=.FALSE. + cfg%Lclmcalipsoice=.FALSE. + cfg%Lclhcalipsoice=.FALSE. + cfg%Lcltcalipsoice=.FALSE. + cfg%Lcllcalipsoliq=.FALSE. + cfg%Lclmcalipsoliq=.FALSE. + cfg%Lclhcalipsoliq=.FALSE. + cfg%Lcltcalipsoliq=.FALSE. + cfg%Lcllcalipsoun=.FALSE. + cfg%Lclmcalipsoun=.FALSE. + cfg%Lclhcalipsoun=.FALSE. + cfg%Lcltcalipsoun=.FALSE. + cfg%Lclcalipso=.FALSE. + cfg%Lclcalipsoice=.FALSE. + cfg%Lclcalipsoliq=.FALSE. + cfg%Lclcalipsoun=.FALSE. + cfg%Lclcalipsotmp=.FALSE. + cfg%Lclcalipsotmpice=.FALSE. + cfg%Lclcalipsotmpliq=.FALSE. + cfg%Lclcalipsotmpun=.FALSE. + cfg%LparasolRefl=.FALSE. + cfg%LcfadLidarsr532=.FALSE. + cfg%Latb532=.FALSE. + cfg%LlidarBetaMol532=.FALSE. +! cfg%Lclopaquecalipso=.FALSE. +! cfg%Lclthincalipso=.FALSE. +! cfg%Lclzopaquecalipso=.FALSE. +! cfg%Lclcalipsoopaque=.FALSE. +! cfg%Lclcalipsothin=.FALSE. +! cfg%Lclcalipsozopaque=.FALSE. +! cfg%Lclcalipsoopacity=.FALSE. +! cfg%Lproftemp=.FALSE. +! cfg%LprofSR=.FALSE. + + cfg%LcfadDbze94=.FALSE. + cfg%Ldbze94=.FALSE. + cfg%Lcltlidarradar=.FALSE. + cfg%Lclcalipso2=.FALSE. + + cfg%Lclisccp=.FALSE. + cfg%Lboxtauisccp=.FALSE. + cfg%Lboxptopisccp=.FALSE. + cfg%Lcltisccp=.FALSE. + cfg%Lpctisccp=.FALSE. + cfg%Ltauisccp=.FALSE. + cfg%Lalbisccp=.FALSE. + cfg%Lmeantbisccp=.FALSE. + cfg%Lmeantbclrisccp=.FALSE. + + cfg%LclMISR=.FALSE. + + cfg%Lcllmodis=.FALSE. + cfg%Lclmmodis=.FALSE. + cfg%Lclhmodis=.FALSE. + cfg%Lcltmodis=.FALSE. + cfg%Lclwmodis=.FALSE. + cfg%Lclimodis=.FALSE. + cfg%Ltautmodis=.FALSE. + cfg%Ltauwmodis=.FALSE. + cfg%Ltauimodis=.FALSE. + cfg%Ltautlogmodis=.FALSE. + cfg%Ltauilogmodis=.FALSE. + cfg%Ltauwlogmodis=.FALSE. + cfg%Lreffclwmodis=.FALSE. + cfg%Lreffclimodis=.FALSE. + cfg%Lpctmodis=.FALSE. + cfg%Llwpmodis=.FALSE. + cfg%Liwpmodis=.FALSE. + cfg%Lclmodis=.FALSE. +! cfg%Lcrimodis=.FALSE. +! cfg%Lcrlmodis=.FALSE. + + cfg%Ltbrttov=.FALSE. + + end subroutine cosp_outputkeys_init + + SUBROUTINE cosp_outputkeys_test(cfg) + implicit none + type(cosp_config),intent(out) :: cfg + character(len=32) :: out_list(78) + integer :: i + + + do i=1,78 + cfg%out_list(i)='' + enddo + + cfg%Llidar_sim=.true. + cfg%Lradar_sim=.false. + cfg%Lisccp_sim=.false. + cfg%Lmodis_sim=.false. + cfg%Lmisr_sim=.false. + cfg%Lrttov_sim=.false. + cfg%Lstats=.false. + cfg%Lwrite_output=.false. + cfg%Ltoffset=.false. + cfg%Lfracout=.false. + + cfg%Lcllcalipso=.TRUE. + cfg%Lclmcalipso=.TRUE. + cfg%Lclhcalipso=.TRUE. + cfg%Lcltcalipso=.TRUE. + cfg%Lcllcalipsoice=.FALSE. + cfg%Lclmcalipsoice=.FALSE. + cfg%Lclhcalipsoice=.FALSE. + cfg%Lcltcalipsoice=.FALSE. + cfg%Lcllcalipsoliq=.FALSE. + cfg%Lclmcalipsoliq=.FALSE. + cfg%Lclhcalipsoliq=.FALSE. + cfg%Lcltcalipsoliq=.FALSE. + cfg%Lcllcalipsoun=.FALSE. + cfg%Lclmcalipsoun=.FALSE. + cfg%Lclhcalipsoun=.FALSE. + cfg%Lcltcalipsoun=.FALSE. + cfg%Lclcalipso=.FALSE. + cfg%Lclcalipsoice=.FALSE. + cfg%Lclcalipsoliq=.FALSE. + cfg%Lclcalipsoun=.FALSE. + cfg%Lclcalipsotmp=.FALSE. + cfg%Lclcalipsotmpice=.FALSE. + cfg%Lclcalipsotmpliq=.FALSE. + cfg%Lclcalipsotmpun=.FALSE. + cfg%LparasolRefl=.FALSE. + cfg%LcfadLidarsr532=.FALSE. + cfg%Latb532=.FALSE. + cfg%LlidarBetaMol532=.FALSE. +! cfg%Lclopaquecalipso=.FALSE. +! cfg%Lclthincalipso=.FALSE. +! cfg%Lclzopaquecalipso=.FALSE. +! cfg%Lclcalipsoopaque=.FALSE. +! cfg%Lclcalipsothin=.FALSE. +! cfg%Lclcalipsozopaque=.FALSE. +! cfg%Lclcalipsoopacity=.FALSE. +! cfg%Lproftemp=.FALSE. +! cfg%LprofSR=.FALSE. + + cfg%LcfadDbze94=.FALSE. + cfg%Ldbze94=.FALSE. + cfg%Lcltlidarradar=.FALSE. + cfg%Lclcalipso2=.FALSE. + + cfg%Lclisccp=.FALSE. + cfg%Lboxtauisccp=.FALSE. + cfg%Lboxptopisccp=.FALSE. + cfg%Lcltisccp=.FALSE. + cfg%Lpctisccp=.FALSE. + cfg%Ltauisccp=.FALSE. + cfg%Lalbisccp=.FALSE. + cfg%Lmeantbisccp=.FALSE. + cfg%Lmeantbclrisccp=.FALSE. + + cfg%LclMISR=.FALSE. + + cfg%Lcllmodis=.FALSE. + cfg%Lclmmodis=.FALSE. + cfg%Lclhmodis=.FALSE. + cfg%Lcltmodis=.FALSE. + cfg%Lclwmodis=.FALSE. + cfg%Lclimodis=.FALSE. + cfg%Ltautmodis=.FALSE. + cfg%Ltauwmodis=.FALSE. + cfg%Ltauimodis=.FALSE. + cfg%Ltautlogmodis=.FALSE. + cfg%Ltauilogmodis=.FALSE. + cfg%Ltauwlogmodis=.FALSE. + cfg%Lreffclwmodis=.FALSE. + cfg%Lreffclimodis=.FALSE. + cfg%Lpctmodis=.FALSE. + cfg%Llwpmodis=.FALSE. + cfg%Liwpmodis=.FALSE. + cfg%Lclmodis=.FALSE. +! cfg%Lcrimodis=.FALSE. +! cfg%Lcrlmodis=.FALSE. + + cfg%Ltbrttov=.FALSE. + + end subroutine cosp_outputkeys_test + + SUBROUTINE READ_COSP_OUTPUT_NL(itap,cosp_nl,cfg) + +#ifdef CPP_XIOS + USE xios, ONLY: xios_field_is_active +#endif + implicit none + character(len=*),intent(in) :: cosp_nl + type(cosp_config),intent(out) :: cfg + ! Local variables + integer :: i, itap + + logical, save :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, Lstats, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, & + LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, & + Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, & + Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, & + Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, & + Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, & + Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, & + Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, & + Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, & + Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfracout,LlidarBetaMol532,Ltbrttov, & + Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, & + Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & + Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, & !OPAQ (2) + Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, & !OPAQ (5) + LprofSR,Lproftemp !TIBO (2) + + namelist/COSP_OUTPUT/Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, & + LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp, & + Lcllcalipso,Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp, & + Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, & + Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, & + Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, & + Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, & + Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, & + Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, & + Lcltisccp,Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfracout,LlidarBetaMol532,Ltbrttov, & + Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, & + Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & + Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, & !OPAQ (2) + Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, & !OPAQ (5) + LprofSR,Lproftemp !TIBO (2) + + do i=1,78 + cfg%out_list(i)='' + enddo + +! Lecture du fichier namelist + IF (is_master) THEN + open(10,file=cosp_nl,status='old') + read(10,nml=cosp_output) + close(10) + ENDIF + + CALL bcast(Lradar_sim) + CALL bcast(Llidar_sim) + CALL bcast(Lisccp_sim) + CALL bcast(Lmodis_sim) + CALL bcast(Lmisr_sim) + CALL bcast(Lrttov_sim) + + CALL bcast(Lstats) + + CALL bcast(Lalbisccp) + CALL bcast(Latb532) + CALL bcast(Lboxptopisccp) + CALL bcast(Lboxtauisccp) + CALL bcast(LcfadDbze94) + CALL bcast(LcfadLidarsr532) + CALL bcast(Lclcalipso2) + CALL bcast(Lclcalipso) + CALL bcast(Lclhcalipso) + CALL bcast(Lclcalipsoliq) + CALL bcast(Lclcalipsoice) + CALL bcast(Lclcalipsoun) + CALL bcast(Lclcalipsotmp) + CALL bcast(Lclcalipsotmpliq) + CALL bcast(Lclcalipsotmpice) + CALL bcast(Lclcalipsotmpun) + CALL bcast(Lcltcalipsoliq) + CALL bcast(Lcltcalipsoice) + CALL bcast(Lcltcalipsoun) + CALL bcast(Lclhcalipsoliq) + CALL bcast(Lclhcalipsoice) + CALL bcast(Lclhcalipsoun) + CALL bcast(Lclmcalipsoliq) + CALL bcast(Lclmcalipsoice) + CALL bcast(Lclmcalipsoun) + CALL bcast(Lcllcalipsoliq) + CALL bcast(Lcllcalipsoice) + CALL bcast(Lcllcalipsoun) + CALL bcast(Lclisccp) + CALL bcast(Lcllcalipso) + CALL bcast(Lclmcalipso) + CALL bcast(Lcltcalipso) + CALL bcast(Lcltlidarradar) + CALL bcast(Lpctisccp) + CALL bcast(Ldbze94) + CALL bcast(Ltauisccp) + CALL bcast(Lcltisccp) + CALL bcast(LparasolRefl) + CALL bcast(LclMISR) + CALL bcast(Lmeantbisccp) + CALL bcast(Lmeantbclrisccp) + CALL bcast(Lfracout) + CALL bcast(LlidarBetaMol532) + CALL bcast(Lcltmodis) + CALL bcast(Lclwmodis) + CALL bcast(Lclimodis) + CALL bcast(Lclhmodis) + CALL bcast(Lclmmodis) + CALL bcast(Lcllmodis) + CALL bcast(Ltautmodis) + CALL bcast(Ltauwmodis) + CALL bcast(Ltauimodis) + CALL bcast(Ltautlogmodis) + CALL bcast(Ltauwlogmodis) + CALL bcast(Ltauilogmodis) + CALL bcast(Lreffclwmodis) + CALL bcast(Lreffclimodis) + CALL bcast(Lpctmodis) + CALL bcast(Llwpmodis) + CALL bcast(Liwpmodis) + CALL bcast(Lclmodis) + CALL bcast(Ltbrttov) + CALL bcast(Lcrimodis) + CALL bcast(Lcrlmodis) + CALL bcast(Lclopaquecalipso) !OPAQ + CALL bcast(Lclthincalipso) !OPAQ + CALL bcast(Lclzopaquecalipso) !OPAQ + CALL bcast(Lclcalipsoopaque) !OPAQ + CALL bcast(Lclcalipsothin) !OPAQ + CALL bcast(Lclcalipsozopaque) !OPAQ + CALL bcast(Lclcalipsoopacity) !OPAQ + CALL bcast(LprofSR) !TIBO + CALL bcast(Lproftemp) !TIBO + +!$OMP BARRIER + +! print*,' Cles sorties cosp :' +! print*,' Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim', & +! Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lrttov_sim + + + ! Deal with dependencies + if (.not.Lradar_sim) then + LcfadDbze94 = .false. + Lclcalipso2 = .false. + Lcltlidarradar = .false. ! Needs radar & lidar + Ldbze94 = .false. + Lclcalipso2 = .false. ! Needs radar & lidar + endif + + if (.not.Llidar_sim) then + Latb532 = .false. + LcfadLidarsr532 = .false. + Lclcalipso2 = .false. + Lclcalipso = .false. + Lclhcalipso = .false. + Lcllcalipso = .false. + Lclmcalipso = .false. + Lcltcalipso = .false. + Lcltlidarradar = .false. ! Needs radar & lidar + LparasolRefl = .false. + LlidarBetaMol532 = .false. +!! AI + Lclcalipsoliq = .false. + Lclcalipsoice = .false. + Lclcalipsoun = .false. + Lclcalipsotmp = .false. + Lclcalipsotmpun = .false. + Lclcalipsotmpliq = .false. + Lclcalipsotmpice = .false. + Lclhcalipsoliq = .false. + Lcllcalipsoliq = .false. + Lclmcalipsoliq = .false. + Lcltcalipsoliq = .false. + Lclhcalipsoice = .false. + Lcllcalipsoice = .false. + Lclmcalipsoice = .false. + Lcltcalipsoice = .false. + Lclhcalipsoun = .false. + Lcllcalipsoun = .false. + Lclmcalipsoun = .false. + Lcltcalipsoun = .false. + Lclopaquecalipso = .false. !OPAQ + Lclthincalipso = .false. !OPAQ + Lclzopaquecalipso = .false. !OPAQ + Lclcalipsoopaque = .false. !OPAQ + Lclcalipsothin = .false. !OPAQ + Lclcalipsozopaque = .false. !OPAQ + Lclcalipsoopacity = .false. !OPAQ + LprofSR = .false. !TIBO + Lproftemp = .false. !TIBO + endif + + if (.not.Lisccp_sim) then + Lalbisccp = .false. + Lboxptopisccp = .false. + Lboxtauisccp = .false. + Lclisccp = .false. + Lpctisccp = .false. + Ltauisccp = .false. + Lcltisccp = .false. + Lmeantbisccp = .false. + Lmeantbclrisccp = .false. + endif + + if (.not.Lmisr_sim) then + LclMISR = .false. + endif + if (.not.Lrttov_sim) then + Ltbrttov = .false. + endif + if ((.not.Lradar_sim).and.(.not.Llidar_sim).and. & + (.not.Lisccp_sim).and.(.not.Lmisr_sim)) then + Lfracout = .false. + Lstats = .false. + endif + if (.not.Lmodis_sim) then + Lcltmodis=.false. + Lclwmodis=.false. + Lclimodis=.false. + Lclhmodis=.false. + Lclmmodis=.false. + Lcllmodis=.false. + Ltautmodis=.false. + Ltauwmodis=.false. + Ltauimodis=.false. + Ltautlogmodis=.false. + Ltauwlogmodis=.false. + Ltauilogmodis=.false. + Lreffclwmodis=.false. + Lreffclimodis=.false. + Lpctmodis=.false. + Llwpmodis=.false. + Liwpmodis=.false. + Lclmodis=.false. + Lcrimodis=.false. + Lcrlmodis=.false. + endif + if (Lmodis_sim) Lisccp_sim = .true. + + ! Diagnostics that use Radar and Lidar + if (((Lclcalipso2).or.(Lcltlidarradar)).and.((Lradar_sim).or.(Llidar_sim))) then + Lclcalipso2 = .true. + Lcltlidarradar = .true. + Llidar_sim = .true. + Lradar_sim = .true. + endif + + if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) Lstats = .true. + + ! Copy instrument flags to cfg structure + cfg%Lradar_sim = Lradar_sim + cfg%Llidar_sim = Llidar_sim + cfg%Lisccp_sim = Lisccp_sim + cfg%Lmodis_sim = Lmodis_sim + cfg%Lmisr_sim = Lmisr_sim + cfg%Lrttov_sim = Lrttov_sim + + cfg%Lstats = Lstats + + ! Flag to control output to file + cfg%Lwrite_output = .false. + if (cfg%Lstats.or.cfg%Lmisr_sim.or.cfg%Lrttov_sim) then + cfg%Lwrite_output = .true. + endif + + ! Output diagnostics + i = 1 + if (Lalbisccp) cfg%out_list(i) = 'albisccp' + i = i+1 + if (Latb532) cfg%out_list(i) = 'atb532' + i = i+1 + if (Lboxptopisccp) cfg%out_list(i) = 'boxptopisccp' + i = i+1 + if (Lboxtauisccp) cfg%out_list(i) = 'boxtauisccp' + i = i+1 + if (LcfadDbze94) cfg%out_list(i) = 'cfadDbze94' + i = i+1 + if (LcfadLidarsr532) cfg%out_list(i) = 'cfadLidarsr532' + i = i+1 + if (Lclcalipso2) cfg%out_list(i) = 'clcalipso2' + i = i+1 + if (Lclcalipso) cfg%out_list(i) = 'clcalipso' + i = i+1 + if (Lclhcalipso) cfg%out_list(i) = 'clhcalipso' + i = i+1 + if (Lclisccp) cfg%out_list(i) = 'clisccp' + i = i+1 + if (Lcllcalipso) cfg%out_list(i) = 'cllcalipso' + i = i+1 + if (Lclmcalipso) cfg%out_list(i) = 'clmcalipso' + i = i+1 + if (Lcltcalipso) cfg%out_list(i) = 'cltcalipso' + i = i+1 + + if (Lcllcalipsoice) cfg%out_list(i) = 'cllcalipsoice' + i = i+1 + if (Lclmcalipsoice) cfg%out_list(i) = 'clmcalipsoice' + i = i+1 + if (Lclhcalipsoice) cfg%out_list(i) = 'clhcalipsoice' + i = i+1 + if (Lcltcalipsoice) cfg%out_list(i) = 'cltcalipsoice' + i = i+1 + if (Lcllcalipsoliq) cfg%out_list(i) = 'cllcalipsoliq' + i = i+1 + if (Lclmcalipsoliq) cfg%out_list(i) = 'clmcalipsoliq' + i = i+1 + if (Lclhcalipsoliq) cfg%out_list(i) = 'clhcalipsoliq' + i = i+1 + if (Lcltcalipsoliq) cfg%out_list(i) = 'cltcalipsoliq' + i = i+1 + if (Lcllcalipsoun) cfg%out_list(i) = 'cllcalipsoun' + i = i+1 + if (Lclmcalipsoun) cfg%out_list(i) = 'clmcalipsoun' + i = i+1 + if (Lclhcalipsoun) cfg%out_list(i) = 'clhcalipsoun' + i = i+1 + if (Lcltcalipsoun) cfg%out_list(i) = 'cltcalipsoun' + i = i+1 + + if (Lclcalipsoice) cfg%out_list(i) = 'clcalipsoice' + i = i+1 + if (Lclcalipsoliq) cfg%out_list(i) = 'clcalipsoliq' + i = i+1 + if (Lclcalipsoun) cfg%out_list(i) = 'clcalipsoun' + i = i+1 + + if (Lclcalipsotmp) cfg%out_list(i) = 'clcalipsotmp' + i = i+1 + if (Lclcalipsotmpice) cfg%out_list(i) = 'clcalipsotmpice' + i = i+1 + if (Lclcalipsotmpliq) cfg%out_list(i) = 'clcalipsotmpliq' + i = i+1 + if (Lclcalipsotmpun) cfg%out_list(i) = 'clcalipsotmpun' + i = i+1 + if (Lcltlidarradar) cfg%out_list(i) = 'cltlidarradar' + i = i+1 + if (Lpctisccp) cfg%out_list(i) = 'pctisccp' + i = i+1 + if (Ldbze94) cfg%out_list(i) = 'dbze94' + i = i+1 + if (Ltauisccp) cfg%out_list(i) = 'tauisccp' + i = i+1 + if (Lcltisccp) cfg%out_list(i) = 'cltisccp' + i = i+1 + if (Ltoffset) cfg%out_list(i) = 'toffset' + i = i+1 + if (LparasolRefl) cfg%out_list(i) = 'parasolRefl' + i = i+1 + if (LclMISR) cfg%out_list(i) = 'clMISR' + i = i+1 + if (Lmeantbisccp) cfg%out_list(i) = 'meantbisccp' + i = i+1 + if (Lmeantbclrisccp) cfg%out_list(i) = 'meantbclrisccp' + i = i+1 + if (Lfracout) cfg%out_list(i) = 'fracout' + i = i+1 + if (LlidarBetaMol532) cfg%out_list(i) = 'lidarBetaMol532' + i = i+1 + if (Ltbrttov) cfg%out_list(i) = 'tbrttov' + i = i+1 + if (Lcltmodis) cfg%out_list(i) = 'cltmodis' + i = i+1 + if (Lclwmodis) cfg%out_list(i) = 'clwmodis' + i = i+1 + if (Lclimodis) cfg%out_list(i) = 'climodis' + i = i+1 + if (Lclhmodis) cfg%out_list(i) = 'clhmodis' + i = i+1 + if (Lclmmodis) cfg%out_list(i) = 'clmmodis' + i = i+1 + if (Lcllmodis) cfg%out_list(i) = 'cllmodis' + i = i+1 + if (Ltautmodis) cfg%out_list(i) = 'tautmodis' + i = i+1 + if (Ltauwmodis) cfg%out_list(i) = 'tauwmodis' + i = i+1 + if (Ltauimodis) cfg%out_list(i) = 'tauimodis' + i = i+1 + if (Ltautlogmodis) cfg%out_list(i) = 'tautlogmodis' + i = i+1 + if (Ltauwlogmodis) cfg%out_list(i) = 'tauwlogmodis' + i = i+1 + if (Ltauilogmodis) cfg%out_list(i) = 'tauilogmodis' + i = i+1 + if (Lreffclwmodis) cfg%out_list(i) = 'reffclwmodis' + i = i+1 + if (Lreffclimodis) cfg%out_list(i) = 'reffclimodis' + i = i+1 + if (Lpctmodis) cfg%out_list(i) = 'pctmodis' + i = i+1 + if (Llwpmodis) cfg%out_list(i) = 'lwpmodis' + i = i+1 + if (Liwpmodis) cfg%out_list(i) = 'iwpmodis' + i = i+1 + if (Lclmodis) cfg%out_list(i) = 'clmodis' + i = i+1 + if (Lcrimodis) cfg%out_list(i) = 'crimodis' + i = i+1 + if (Lcrlmodis) cfg%out_list(i) = 'crlmodis' + + i = i+1 !OPAQ + if (Lclopaquecalipso) cfg%out_list(i) = 'clopaquecalipso' !OPAQ + i = i+1 !OPAQ + if (Lclthincalipso) cfg%out_list(i) = 'clthincalipso' !OPAQ + i = i+1 !OPAQ + if (Lclzopaquecalipso) cfg%out_list(i) = 'clzopaquecalipso' !OPAQ + i = i+1 !OPAQ + if (Lclcalipsoopaque) cfg%out_list(i) = 'clcalipsoopaque' !OPAQ + i = i+1 !OPAQ + if (Lclcalipsothin) cfg%out_list(i) = 'clcalipsothin' !OPAQ + i = i+1 !OPAQ + if (Lclcalipsozopaque) cfg%out_list(i) = 'clcalipsozopaque' !OPAQ + i = i+1 !OPAQ + if (Lclcalipsoopacity) cfg%out_list(i) = 'clcalipsoopacity' !OPAQ + i = i+1 !TIBO + if (LprofSR) cfg%out_list(i) = 'profSR' !TIBO + i = i+1 !TIBO + if (Lproftemp) cfg%out_list(i) = 'proftemp' !TIBO + + if (i /= 78) then + print *, 'COSP_IO: wrong number of output diagnostics' + print *, i,78 + stop + endif + + ! Copy diagnostic flags to cfg structure + ! ISCCP simulator + cfg%Lalbisccp = Lalbisccp + cfg%Latb532 = Latb532 + cfg%Lboxptopisccp = Lboxptopisccp + cfg%Lboxtauisccp = Lboxtauisccp + cfg%Lmeantbisccp = Lmeantbisccp + cfg%Lmeantbclrisccp = Lmeantbclrisccp + cfg%Lclisccp = Lclisccp + cfg%Lpctisccp = Lpctisccp + cfg%Ltauisccp = Ltauisccp + cfg%Lcltisccp = Lcltisccp + ! CloudSat simulator + cfg%Ldbze94 = Ldbze94 + cfg%LcfadDbze94 = LcfadDbze94 + ! CALIPSO/PARASOL simulator + cfg%LcfadLidarsr532 = LcfadLidarsr532 + cfg%Lclcalipso2 = Lclcalipso2 + cfg%Lclcalipso = Lclcalipso + cfg%Lclhcalipso = Lclhcalipso + cfg%Lcllcalipso = Lcllcalipso + cfg%Lclmcalipso = Lclmcalipso + cfg%Lcltcalipso = Lcltcalipso + cfg%Lclhcalipsoice = Lclhcalipsoice + cfg%Lcllcalipsoice = Lcllcalipsoice + cfg%Lclmcalipsoice = Lclmcalipsoice + cfg%Lcltcalipsoice = Lcltcalipsoice + cfg%Lclhcalipsoliq = Lclhcalipsoliq + cfg%Lcllcalipsoliq = Lcllcalipsoliq + cfg%Lclmcalipsoliq = Lclmcalipsoliq + cfg%Lcltcalipsoliq = Lcltcalipsoliq + cfg%Lclhcalipsoun = Lclhcalipsoun + cfg%Lcllcalipsoun = Lcllcalipsoun + cfg%Lclmcalipsoun = Lclmcalipsoun + cfg%Lcltcalipsoun = Lcltcalipsoun + cfg%Lclcalipsoice = Lclcalipsoice + cfg%Lclcalipsoliq = Lclcalipsoliq + cfg%Lclcalipsoun = Lclcalipsoun + cfg%Lclcalipsotmp = Lclcalipsotmp + cfg%Lclcalipsotmpice = Lclcalipsotmpice + cfg%Lclcalipsotmpliq = Lclcalipsotmpliq + cfg%Lclcalipsotmpun = Lclcalipsotmpun + cfg%Lcltlidarradar = Lcltlidarradar + cfg%LparasolRefl = LparasolRefl +! cfg%Lclopaquecalipso = Lclopaquecalipso !OPAQ +! cfg%Lclthincalipso = Lclthincalipso !OPAQ +! cfg%Lclzopaquecalipso = Lclzopaquecalipso !OPAQ +! cfg%Lclcalipsoopaque = Lclcalipsoopaque !OPAQ +! cfg%Lclcalipsothin = Lclcalipsothin !OPAQ +! cfg%Lclcalipsozopaque = Lclcalipsozopaque !OPAQ +! cfg%Lclcalipsoopacity = Lclcalipsoopacity !OPAQ +! cfg%LprofSR = LprofSR !TIBO +! cfg%Lproftemp = Lproftemp !TIBO + ! MISR simulator + cfg%LclMISR = LclMISR + ! Other + cfg%Ltoffset = Ltoffset + cfg%Lfracout = Lfracout + cfg%LlidarBetaMol532 = LlidarBetaMol532 + ! RTTOV + cfg%Ltbrttov = Ltbrttov + ! MODIS simulator + cfg%Lcltmodis=Lcltmodis + cfg%Lclwmodis=Lclwmodis + cfg%Lclimodis=Lclimodis + cfg%Lclhmodis=Lclhmodis + cfg%Lclmmodis=Lclmmodis + cfg%Lcllmodis=Lcllmodis + cfg%Ltautmodis=Ltautmodis + cfg%Ltauwmodis=Ltauwmodis + cfg%Ltauimodis=Ltauimodis + cfg%Ltautlogmodis=Ltautlogmodis + cfg%Ltauwlogmodis=Ltauwlogmodis + cfg%Ltauilogmodis=Ltauilogmodis + cfg%Lreffclwmodis=Lreffclwmodis + cfg%Lreffclimodis=Lreffclimodis + cfg%Lpctmodis=Lpctmodis + cfg%Llwpmodis=Llwpmodis + cfg%Liwpmodis=Liwpmodis + cfg%Lclmodis=Lclmodis +! cfg%Lcrimodis=Lcrimodis +! cfg%Lcrlmodis=Lcrlmodis + + END SUBROUTINE READ_COSP_OUTPUT_NL + + SUBROUTINE read_xiosfieldactive(cfg) + +! USE MOD_COSP_CONSTANTS +! USE MOD_COSP_TYPES +#ifdef CPP_XIOS + USE xios, ONLY: xios_field_is_active +#endif + implicit none + type(cosp_config),intent(out) :: cfg + integer :: i + +#ifdef CPP_XIOS + + logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim, Lstats, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, & + LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, & + Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, & + Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, & + Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, & + Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, & + Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, & + Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, & + Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, & + Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lfracout,LlidarBetaMol532,Ltbrttov, & + Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis, & + Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, & + Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & + Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, & + Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque,Lclcalipsoopacity, & + LprofSR,Lproftemp + + character(len=32) :: out_list(78) + + do i=1,78 + cfg%out_list(i)='' + enddo + + LcfadDbze94 = .false. + Lclcalipso2 = .false. + Lcltlidarradar = .false. ! Needs radar & lidar + Ldbze94 = .false. + Lclcalipso2 = .false. ! Needs radar & lidar + + Latb532 = .false. + LcfadLidarsr532 = .false. + Lclcalipso = .false. + Lclhcalipso = .false. + Lcllcalipso = .false. + Lclmcalipso = .false. + Lcltcalipso = .false. + LparasolRefl = .false. + LlidarBetaMol532 = .false. + Lclcalipsoliq = .false. + Lclcalipsoice = .false. + Lclcalipsoun = .false. + Lclcalipsotmp = .false. + Lclcalipsotmpun = .false. + Lclcalipsotmpliq = .false. + Lclcalipsotmpice = .false. + Lclhcalipsoliq = .false. + Lcllcalipsoliq = .false. + Lclmcalipsoliq = .false. + Lcltcalipsoliq = .false. + Lclhcalipsoice = .false. + Lcllcalipsoice = .false. + Lclmcalipsoice = .false. + Lcltcalipsoice = .false. + Lclhcalipsoun = .false. + Lcllcalipsoun = .false. + Lclmcalipsoun = .false. + Lcltcalipsoun = .false. + Lclopaquecalipso = .false. !OPAQ + Lclthincalipso = .false. !OPAQ + Lclzopaquecalipso = .false. !OPAQ + Lclcalipsoopaque = .false. !OPAQ + Lclcalipsothin = .false. !OPAQ + Lclcalipsozopaque = .false. !OPAQ + Lclcalipsoopacity = .false. !OPAQ + LprofSR = .false. !TIBO + Lproftemp = .false. !TIBO + + Lalbisccp = .false. + Lboxptopisccp = .false. + Lboxtauisccp = .false. + Lclisccp = .false. + Lpctisccp = .false. + Ltauisccp = .false. + Lcltisccp = .false. + Lmeantbisccp = .false. + Lmeantbclrisccp = .false. + + LclMISR = .false. + + Ltbrttov = .false. + + Lcltmodis=.false. + Lclwmodis=.false. + Lclimodis=.false. + Lclhmodis=.false. + Lclmmodis=.false. + Lcllmodis=.false. + Ltautmodis=.false. + Ltauwmodis=.false. + Ltauimodis=.false. + Ltautlogmodis=.false. + Ltauwlogmodis=.false. + Ltauilogmodis=.false. + Lreffclwmodis=.false. + Lreffclimodis=.false. + Lpctmodis=.false. + Llwpmodis=.false. + Liwpmodis=.false. + Lclmodis=.false. + Lcrimodis=.false. + Lcrlmodis=.false. + + Lradar_sim=.false. + Llidar_sim=.false. + Lisccp_sim=.false. + Lmodis_sim=.false. + Lmisr_sim=.false. + Lrttov_sim=.false. + + Lstats=.false. +! Ltoffset=.false. +! Lfracout=.false. +! Lwrite_output=.false. + + IF (is_master) THEN +! VEREFIER LES CHAMPS DEMANDES DANS .XML +! 2. Si champs active dans .xml alors mettre la cles de sortie en true + IF (xios_field_is_active("cllcalipso")) Lcllcalipso=.TRUE. + IF (xios_field_is_active("clmcalipso")) Lclmcalipso=.TRUE. + IF (xios_field_is_active("clhcalipso")) Lclhcalipso=.TRUE. + IF (xios_field_is_active("cltcalipso")) Lcltcalipso=.TRUE. + IF (xios_field_is_active("cllcalipsoice")) Lcllcalipsoice=.TRUE. + IF (xios_field_is_active("clmcalipsoice")) Lclmcalipsoice=.TRUE. + IF (xios_field_is_active("clhcalipsoice")) Lclhcalipsoice=.TRUE. + IF (xios_field_is_active("cltcalipsoice")) Lcltcalipsoice=.TRUE. + IF (xios_field_is_active("cllcalipsoliq")) Lcllcalipsoliq=.TRUE. + IF (xios_field_is_active("clmcalipsoliq")) Lclmcalipsoliq=.TRUE. + IF (xios_field_is_active("clhcalipsoliq")) Lclhcalipsoliq=.TRUE. + IF (xios_field_is_active("cltcalipsoliq")) Lcltcalipsoliq=.TRUE. + IF (xios_field_is_active("cllcalipsoun")) Lcllcalipsoun=.TRUE. + IF (xios_field_is_active("clmcalipsoun")) Lclmcalipsoun=.TRUE. + IF (xios_field_is_active("clhcalipsoun")) Lclhcalipsoun=.TRUE. + IF (xios_field_is_active("cltcalipsoun")) Lcltcalipsoun=.TRUE. + IF (xios_field_is_active("clcalipso")) Lclcalipso=.TRUE. + IF (xios_field_is_active("clcalipsoice")) Lclcalipsoice=.TRUE. + IF (xios_field_is_active("clcalipsoliq")) Lclcalipsoliq=.TRUE. + IF (xios_field_is_active("clcalipsoun")) Lclcalipsoun=.TRUE. + IF (xios_field_is_active("clcalipsotmp")) Lclcalipsotmp=.TRUE. + IF (xios_field_is_active("clcalipsotmpice")) Lclcalipsotmpice=.TRUE. + IF (xios_field_is_active("clcalipsotmpliq")) Lclcalipsotmpliq=.TRUE. + IF (xios_field_is_active("clcalipsotmpun")) Lclcalipsotmpun=.TRUE. + IF (xios_field_is_active("parasol_refl")) LparasolRefl=.TRUE. +! IF (xios_field_is_active("parasol_crefl")) cfg%LparasolRefl=.TRUE. +! IF (xios_field_is_active("Ncrefl")) cfg%LparasolRefl=.TRUE. + IF (xios_field_is_active("cfad_lidarsr532")) LcfadLidarsr532=.TRUE. + IF (xios_field_is_active("atb532")) Latb532=.TRUE. + IF (xios_field_is_active("beta_mol532")) LlidarBetaMol532=.TRUE. + IF (xios_field_is_active("clopaquecalipso")) Lclopaquecalipso=.TRUE. + IF (xios_field_is_active("clthincalipso")) Lclthincalipso=.TRUE. + IF (xios_field_is_active("clzopaquecalipso")) Lclzopaquecalipso=.TRUE. + IF (xios_field_is_active("clcalipsoopaque")) Lclcalipsoopaque=.TRUE. + IF (xios_field_is_active("clcalipsothin")) Lclcalipsothin=.TRUE. + IF (xios_field_is_active("clcalipsozopaque")) Lclcalipsozopaque=.TRUE. + IF (xios_field_is_active("clcalipsoopacity")) Lclcalipsoopacity=.TRUE. + IF (xios_field_is_active("proftemp")) Lproftemp=.TRUE. + IF (xios_field_is_active("profSR")) LprofSR=.TRUE. +!!!! 38 champ Calipso + + IF (xios_field_is_active("cfadDbze94")) LcfadDbze94=.TRUE. + IF (xios_field_is_active("dbze94")) Ldbze94=.TRUE. +!!! 2 champs CLOUDSAT + + IF (xios_field_is_active("cltlidarradar")) Lcltlidarradar=.TRUE. + IF (xios_field_is_active("clcalipso2")) Lclcalipso2=.TRUE. +!!! 2 champs CLOUDSAT et CALIPSO + + IF (xios_field_is_active("clisccp2")) Lclisccp=.TRUE. + IF (xios_field_is_active("boxtauisccp")) Lboxtauisccp=.TRUE. + IF (xios_field_is_active("boxptopisccp")) Lboxptopisccp=.TRUE. + IF (xios_field_is_active("tclisccp")) Lcltisccp=.TRUE. + IF (xios_field_is_active("ctpisccp")) Lpctisccp=.TRUE. + IF (xios_field_is_active("tauisccp")) Ltauisccp=.TRUE. + IF (xios_field_is_active("albisccp")) Lalbisccp=.TRUE. + IF (xios_field_is_active("meantbisccp")) Lmeantbisccp=.TRUE. + IF (xios_field_is_active("meantbclrisccp")) Lmeantbclrisccp=.TRUE. +!!! 9 champs ISCCP + + IF (xios_field_is_active("clMISR")) LclMISR=.TRUE. +!!! 1 champs MISR + + IF (xios_field_is_active("cllmodis")) Lcllmodis=.TRUE. + IF (xios_field_is_active("clmmodis")) Lclmmodis=.TRUE. + IF (xios_field_is_active("clhmodis")) Lclhmodis=.TRUE. + IF (xios_field_is_active("cltmodis")) Lcltmodis=.TRUE. + IF (xios_field_is_active("clwmodis")) Lclwmodis=.TRUE. + IF (xios_field_is_active("climodis")) Lclimodis=.TRUE. + IF (xios_field_is_active("tautmodis")) Ltautmodis=.TRUE. + IF (xios_field_is_active("tauwmodis")) Ltauwmodis=.TRUE. + IF (xios_field_is_active("tauimodis")) Ltauimodis=.TRUE. + IF (xios_field_is_active("tautlogmodis")) Ltautlogmodis=.TRUE. + IF (xios_field_is_active("tauilogmodis")) Ltauilogmodis=.TRUE. + IF (xios_field_is_active("tauwlogmodis")) Ltauwlogmodis=.TRUE. + IF (xios_field_is_active("reffclwmodis")) Lreffclwmodis=.TRUE. + IF (xios_field_is_active("reffclimodis")) Lreffclimodis=.TRUE. + IF (xios_field_is_active("pctmodis")) Lpctmodis=.TRUE. + IF (xios_field_is_active("lwpmodis")) Llwpmodis=.TRUE. + IF (xios_field_is_active("iwpmodis")) Liwpmodis=.TRUE. + IF (xios_field_is_active("clmodis")) Lclmodis=.TRUE. + IF (xios_field_is_active("crimodis")) Lcrimodis=.TRUE. + IF (xios_field_is_active("crlmodis")) Lcrlmodis=.TRUE. +!!! 20 champs MODIS +! IF (xios_field_is_active("tbrttov")) cfg%Ltbrttov=.TRUE. + +! 2. si champs demande alors activer le simulateur correspondant + IF (xios_field_is_active("cllcalipso").OR. & + xios_field_is_active("clmcalipso").OR. & + xios_field_is_active("clhcalipso").OR. & + xios_field_is_active("cltcalipso").OR. & + xios_field_is_active("cllcalipsoice").OR. & + xios_field_is_active("clmcalipsoice").OR. & + xios_field_is_active("clhcalipsoice").OR. & + xios_field_is_active("cltcalipsoice").OR. & + xios_field_is_active("cllcalipsoliq").OR. & + xios_field_is_active("clmcalipsoliq").OR. & + xios_field_is_active("clhcalipsoliq").OR. & + xios_field_is_active("cltcalipsoliq").OR. & + xios_field_is_active("cllcalipsoun").OR. & + xios_field_is_active("clmcalipsoun").OR. & + xios_field_is_active("clhcalipsoun").OR. & + xios_field_is_active("cltcalipsoun").OR. & + xios_field_is_active("clcalipso").OR. & + xios_field_is_active("clcalipsoice").OR. & + xios_field_is_active("clcalipsoliq").OR. & + xios_field_is_active("clcalipsoun").OR. & + xios_field_is_active("clcalipsotmp").OR. & + xios_field_is_active("clcalipsotmpice").OR. & + xios_field_is_active("clcalipsotmpliq").OR. & + xios_field_is_active("clcalipsotmpun").OR. & + xios_field_is_active("parasol_refl").OR. & + xios_field_is_active("cfad_lidarsr532").OR. & + xios_field_is_active("atb532").OR. & + xios_field_is_active("beta_mol532").OR. & + xios_field_is_active("clopaquecalipso").OR. & + xios_field_is_active("clthincalipso").OR. & + xios_field_is_active("clzopaquecalipso").OR. & + xios_field_is_active("clcalipsoopaque").OR. & + xios_field_is_active("clcalipsothin").OR. & + xios_field_is_active("clcalipsozopaque").OR. & + xios_field_is_active("clcalipsoopacity").OR. & + xios_field_is_active("proftemp").OR. & + xios_field_is_active("profSR")) Llidar_sim=.TRUE. + + IF (xios_field_is_active("cfadDbze94").OR. & + xios_field_is_active("dbze94")) & Lradar_sim=.TRUE. + + IF (xios_field_is_active("cltlidarradar").OR. & + xios_field_is_active("clcalipso2")) THEN + Lradar_sim=.TRUE. + Llidar_sim=.TRUE. + ENDIF + + IF (xios_field_is_active("clisccp2").OR. & + xios_field_is_active("boxtauisccp").OR. & + xios_field_is_active("boxptopisccp").OR. & + xios_field_is_active("tclisccp").OR. & + xios_field_is_active("ctpisccp").OR. & + xios_field_is_active("tauisccp").OR. & + xios_field_is_active("albisccp").OR. & + xios_field_is_active("meantbisccp").OR. & + xios_field_is_active("meantbclrisccp")) Lisccp_sim=.TRUE. + + IF (xios_field_is_active("clMISR")) Lmisr_sim=.TRUE. + + IF (xios_field_is_active("cllmodis").OR. & + xios_field_is_active("clmmodis").OR. & + xios_field_is_active("clhmodis").OR. & + xios_field_is_active("cltmodis").OR. & + xios_field_is_active("clwmodis").OR. & + xios_field_is_active("climodis").OR. & + xios_field_is_active("tautmodis").OR. & + xios_field_is_active("tauwmodis").OR. & + xios_field_is_active("tauimodis").OR. & + xios_field_is_active("tautlogmodis").OR. & + xios_field_is_active("tauilogmodis").OR. & + xios_field_is_active("tauwlogmodis").OR. & + xios_field_is_active("reffclwmodis").OR. & + xios_field_is_active("reffclimodis").OR. & + xios_field_is_active("pctmodis").OR. & + xios_field_is_active("lwpmodis").OR. & + xios_field_is_active("iwpmodis").OR. & + xios_field_is_active("clmodis").OR. & + xios_field_is_active("crimodis").OR. & + xios_field_is_active("crlmodis")) Lmodis_sim=.TRUE. + + ENDIF ! (is_master) + +!$OMP BARRIER + + CALL bcast(Lradar_sim) + CALL bcast(Llidar_sim) + CALL bcast(Lisccp_sim) + CALL bcast(Lmodis_sim) + CALL bcast(Lmisr_sim) + CALL bcast(Lrttov_sim) + + CALL bcast(Lstats) + + CALL bcast(Lalbisccp) + CALL bcast(Latb532) + CALL bcast(Lboxptopisccp) + CALL bcast(Lboxtauisccp) + CALL bcast(LcfadDbze94) + CALL bcast(LcfadLidarsr532) + CALL bcast(Lclcalipso2) + CALL bcast(Lclcalipso) + CALL bcast(Lclhcalipso) + CALL bcast(Lclcalipsoliq) + CALL bcast(Lclcalipsoice) + CALL bcast(Lclcalipsoun) + CALL bcast(Lclcalipsotmp) + CALL bcast(Lclcalipsotmpliq) + CALL bcast(Lclcalipsotmpice) + CALL bcast(Lclcalipsotmpun) + CALL bcast(Lcltcalipsoliq) + CALL bcast(Lcltcalipsoice) + CALL bcast(Lcltcalipsoun) + CALL bcast(Lclhcalipsoliq) + CALL bcast(Lclhcalipsoice) + CALL bcast(Lclhcalipsoun) + CALL bcast(Lclmcalipsoliq) + CALL bcast(Lclmcalipsoice) + CALL bcast(Lclmcalipsoun) + CALL bcast(Lcllcalipsoliq) + CALL bcast(Lcllcalipsoice) + CALL bcast(Lcllcalipsoun) + CALL bcast(Lclisccp) + CALL bcast(Lcllcalipso) + CALL bcast(Lclmcalipso) + CALL bcast(Lcltcalipso) + CALL bcast(Lcltlidarradar) + CALL bcast(Lpctisccp) + CALL bcast(Ldbze94) + CALL bcast(Ltauisccp) + CALL bcast(Lcltisccp) + CALL bcast(LparasolRefl) + CALL bcast(LclMISR) + CALL bcast(Lmeantbisccp) + CALL bcast(Lmeantbclrisccp) + CALL bcast(Lfracout) + CALL bcast(LlidarBetaMol532) + CALL bcast(Lcltmodis) + CALL bcast(Lclwmodis) + CALL bcast(Lclimodis) + CALL bcast(Lclhmodis) + CALL bcast(Lclmmodis) + CALL bcast(Lcllmodis) + CALL bcast(Ltautmodis) + CALL bcast(Ltauwmodis) + CALL bcast(Ltauimodis) + CALL bcast(Ltautlogmodis) + CALL bcast(Ltauwlogmodis) + CALL bcast(Ltauilogmodis) + CALL bcast(Lreffclwmodis) + CALL bcast(Lreffclimodis) + CALL bcast(Lpctmodis) + CALL bcast(Llwpmodis) + CALL bcast(Liwpmodis) + CALL bcast(Lclmodis) + CALL bcast(Ltbrttov) + CALL bcast(Lcrimodis) + CALL bcast(Lcrlmodis) + CALL bcast(Lclopaquecalipso) !OPAQ + CALL bcast(Lclthincalipso) !OPAQ + CALL bcast(Lclzopaquecalipso) !OPAQ + CALL bcast(Lclcalipsoopaque) !OPAQ + CALL bcast(Lclcalipsothin) !OPAQ + CALL bcast(Lclcalipsozopaque) !OPAQ + CALL bcast(Lclcalipsoopacity) !OPAQ + CALL bcast(LprofSR) !TIBO + CALL bcast(Lproftemp) !TIBO + + if (Lmodis_sim) Lisccp_sim = .true. + if ((Lradar_sim).or.(Llidar_sim).or.(Lisccp_sim)) Lstats = .true. +! IF (xios_field_is_active("tbrttov")) cfg%Lrttov_sim=.TRUE. + + ! Copy diagnostic flags to cfg structure + ! ISCCP simulator + cfg%Lalbisccp = Lalbisccp + cfg%Latb532 = Latb532 + cfg%Lboxptopisccp = Lboxptopisccp + cfg%Lboxtauisccp = Lboxtauisccp + cfg%Lmeantbisccp = Lmeantbisccp + cfg%Lmeantbclrisccp = Lmeantbclrisccp + cfg%Lclisccp = Lclisccp + cfg%Lpctisccp = Lpctisccp + cfg%Ltauisccp = Ltauisccp + cfg%Lcltisccp = Lcltisccp + +! CloudSat simulator + cfg%Ldbze94 = Ldbze94 + cfg%LcfadDbze94 = LcfadDbze94 + +! Cloudsat et Calipso + cfg%Lclcalipso2 = Lclcalipso2 + cfg%Lcltlidarradar = Lcltlidarradar + +! CALIPSO/PARASOL simulator + cfg%LcfadLidarsr532 = LcfadLidarsr532 + cfg%Lclcalipso = Lclcalipso + cfg%Lclhcalipso = Lclhcalipso + cfg%Lcllcalipso = Lcllcalipso + cfg%Lclmcalipso = Lclmcalipso + cfg%Lcltcalipso = Lcltcalipso + cfg%Lclhcalipsoice = Lclhcalipsoice + cfg%Lcllcalipsoice = Lcllcalipsoice + cfg%Lclmcalipsoice = Lclmcalipsoice + cfg%Lcltcalipsoice = Lcltcalipsoice + cfg%Lclhcalipsoliq = Lclhcalipsoliq + cfg%Lcllcalipsoliq = Lcllcalipsoliq + cfg%Lclmcalipsoliq = Lclmcalipsoliq + cfg%Lcltcalipsoliq = Lcltcalipsoliq + cfg%Lclhcalipsoun = Lclhcalipsoun + cfg%Lcllcalipsoun = Lcllcalipsoun + cfg%Lclmcalipsoun = Lclmcalipsoun + cfg%Lcltcalipsoun = Lcltcalipsoun + cfg%Lclcalipsoice = Lclcalipsoice + cfg%Lclcalipsoliq = Lclcalipsoliq + cfg%Lclcalipsoun = Lclcalipsoun + cfg%Lclcalipsotmp = Lclcalipsotmp + cfg%Lclcalipsotmpice = Lclcalipsotmpice + cfg%Lclcalipsotmpliq = Lclcalipsotmpliq + cfg%Lclcalipsotmpun = Lclcalipsotmpun + cfg%LparasolRefl = LparasolRefl +! cfg%Lclopaquecalipso = Lclopaquecalipso !OPAQ +! cfg%Lclthincalipso = Lclthincalipso !OPAQ +! cfg%Lclzopaquecalipso = Lclzopaquecalipso !OPAQ +! cfg%Lclcalipsoopaque = Lclcalipsoopaque !OPAQ +! cfg%Lclcalipsothin = Lclcalipsothin !OPAQ +! cfg%Lclcalipsozopaque = Lclcalipsozopaque !OPAQ +! cfg%Lclcalipsoopacity = Lclcalipsoopacity !OPAQ +! cfg%LprofSR = LprofSR !TIBO +! cfg%Lproftemp = Lproftemp !TIBO + cfg%LlidarBetaMol532 = LlidarBetaMol532 + +! MISR simulator + cfg%LclMISR = LclMISR + +! RTTOV + cfg%Ltbrttov = Ltbrttov + +! MODIS simulator + cfg%Lcltmodis=Lcltmodis + cfg%Lclwmodis=Lclwmodis + cfg%Lclimodis=Lclimodis + cfg%Lclhmodis=Lclhmodis + cfg%Lclmmodis=Lclmmodis + cfg%Lcllmodis=Lcllmodis + cfg%Ltautmodis=Ltautmodis + cfg%Ltauwmodis=Ltauwmodis + cfg%Ltauimodis=Ltauimodis + cfg%Ltautlogmodis=Ltautlogmodis + cfg%Ltauwlogmodis=Ltauwlogmodis + cfg%Ltauilogmodis=Ltauilogmodis + cfg%Lreffclwmodis=Lreffclwmodis + cfg%Lreffclimodis=Lreffclimodis + cfg%Lpctmodis=Lpctmodis + cfg%Llwpmodis=Llwpmodis + cfg%Liwpmodis=Liwpmodis + cfg%Lclmodis=Lclmodis +! cfg%Lcrimodis=Lcrimodis +! cfg%Lcrlmodis=Lcrlmodis + +! Others +! cfg%Lwrite_output=Lwrite_output +! cfg%Ltoffset=Ltoffset +! cfg%Lfracout=Lfracout + cfg%Lstats = Lstats + +! Copy instrument flags to cfg structure + cfg%Lradar_sim = Lradar_sim + cfg%Llidar_sim = Llidar_sim + cfg%Lisccp_sim = Lisccp_sim + cfg%Lmodis_sim = Lmodis_sim + cfg%Lmisr_sim = Lmisr_sim + cfg%Lrttov_sim = Lrttov_sim + if (cfg%Lradar_sim.or.cfg%Llidar_sim.or.cfg%Lisccp_sim.or.cfg%Lmodis_sim.or.cfg%Lmisr_sim) then + cfg%Lwrite_output=.TRUE. + endif + +#endif + + END SUBROUTINE read_xiosfieldactive + +END MODULE cosp_read_otputkeys Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_stats.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_stats.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_stats.F90 (revision 3358) @@ -0,0 +1,285 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid +! Oct 2008 - J.-L. Dufresne - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns +! in COSP_STATS +! Oct 2008 - H. Chepfer - Added PARASOL reflectance arguments +! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations +! Jan 2013 - G. Cesana - Added betaperp and temperature arguments +! - Added phase 3D/3Dtemperature/Map output variables in diag_lidar +! May 2015 - D. Swales - Modified for cosp2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_STATS + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: R_UNDEF,R_GROUND + IMPLICIT NONE +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ---------------- + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units) + implicit none + ! Input arguments + integer,intent(in) :: Npoints !# of grid points + integer,intent(in) :: Nlevels !# of levels + integer,intent(in) :: Ncolumns !# of columns + real(wp),dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) + real(wp),dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) + real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y ! Variable to be changed to a different grid + integer,intent(in) :: Nglevels !# levels in the new grid + real(wp),dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels [m] + real(wp),dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels [m] + logical,optional,intent(in) :: log_units ! log units, need to convert to linear units + ! Output + real(wp),dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid + + ! Local variables + integer :: i,j,k + logical :: lunits + integer :: l + real(wp) :: w ! Weight + real(wp) :: dbb, dtb, dbt, dtt ! Distances between edges of both grids + integer :: Nw ! Number of weights + real(wp) :: wt ! Sum of weights + real(wp),dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid + real(wp) :: yp ! Local copy of y at a particular point. + ! This allows for change of units. + + lunits=.false. + if (present(log_units)) lunits=log_units + + r = 0._wp + + do i=1,Npoints + ! Calculate tops and bottoms of new and old grids + oldgrid_bot = zhalf(i,:) + oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels) + oldgrid_top(Nlevels) = zfull(i,Nlevels) + zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric + l = 0 ! Index of level in the old grid + ! Loop over levels in the new grid + do k = 1,Nglevels + Nw = 0 ! Number of weigths + wt = 0._wp ! Sum of weights + ! Loop over levels in the old grid and accumulate total for weighted average + do + l = l + 1 + w = 0.0 ! Initialise weight to 0 + ! Distances between edges of both grids + dbb = oldgrid_bot(l) - newgrid_bot(k) + dtb = oldgrid_top(l) - newgrid_bot(k) + dbt = oldgrid_bot(l) - newgrid_top(k) + dtt = oldgrid_top(l) - newgrid_top(k) + if (dbt >= 0.0) exit ! Do next level in the new grid + if (dtb > 0.0) then + if (dbb <= 0.0) then + if (dtt <= 0) then + w = dtb + else + w = newgrid_top(k) - newgrid_bot(k) + endif + else + if (dtt <= 0) then + w = oldgrid_top(l) - oldgrid_bot(l) + else + w = -dbt + endif + endif + ! If layers overlap (w/=0), then accumulate + if (w /= 0.0) then + Nw = Nw + 1 + wt = wt + w + do j=1,Ncolumns + if (lunits) then + if (y(i,j,l) /= R_UNDEF) then + yp = 10._wp**(y(i,j,l)/10._wp) + else + yp = 0._wp + endif + else + yp = y(i,j,l) + endif + r(i,j,k) = r(i,j,k) + w*yp + enddo + endif + endif + enddo + l = l - 2 + if (l < 1) l = 0 + ! Calculate average in new grid + if (Nw > 0) then + do j=1,Ncolumns + r(i,j,k) = r(i,j,k)/wt + enddo + endif + enddo + enddo + + ! Set points under surface to R_UNDEF, and change to dBZ if necessary + do k=1,Nglevels + do j=1,Ncolumns + do i=1,Npoints + if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level + if (lunits) then + if (r(i,j,k) <= 0.0) then + r(i,j,k) = R_UNDEF + else + r(i,j,k) = 10._wp*log10(r(i,j,k)) + endif + endif + else ! Level below surface + r(i,j,k) = R_GROUND + endif + enddo + enddo + enddo + +END SUBROUTINE COSP_CHANGE_VERTICAL_GRID + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD ----------------- + ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. + ! All rights reserved. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,beta_tot, & + beta_mol,Ze_tot,lidar_only_freq_cloud,tcc) + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of horizontal gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels ! Number of vertical layers + real(wp),dimension(Npoints,Nlevels),intent(in) :: & + beta_mol ! Molecular backscatter + real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: & + beta_tot, & ! Total backscattered signal + Ze_tot ! Radar reflectivity + ! Outputs + real(wp),dimension(Npoints,Nlevels),intent(out) :: & + lidar_only_freq_cloud + real(wp),dimension(Npoints),intent(out) ::& + tcc + + ! local variables + real(wp) :: sc_ratio + real(wp),parameter :: & + s_cld=5.0, & + s_att=0.01 + integer :: flag_sat,flag_cld,pr,i,j + + lidar_only_freq_cloud = 0._wp + tcc = 0._wp + do pr=1,Npoints + do i=1,Ncolumns + flag_sat = 0 + flag_cld = 0 + do j=1,Nlevels + sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j) + if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j + if (Ze_tot(pr,i,j) .lt. -30.) then !radar can't detect cloud + if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then !lidar sense cloud + lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf + flag_cld=1 + endif + else !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.) + flag_cld=1 + endif + enddo !levels + if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1._wp + enddo !columns + enddo !points + lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns + tcc=tcc/Ncolumns + + ! Unit conversion + where(lidar_only_freq_cloud /= R_UNDEF) & + lidar_only_freq_cloud = lidar_only_freq_cloud*100._wp + where(tcc /= R_UNDEF) tcc = tcc*100._wp + + END SUBROUTINE COSP_LIDAR_ONLY_CLOUD + + ! ###################################################################################### + ! FUNCTION hist1D + ! ###################################################################################### + function hist1d(Npoints,var,nbins,bins) + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of points in input array + Nbins ! Number of bins for sorting + real(wp),intent(in),dimension(Npoints) :: & + var ! Input variable to be sorted + real(wp),intent(in),dimension(Nbins+1) :: & + bins ! Histogram bins [lowest,binTops] + ! Outputs + real(wp),dimension(Nbins) :: & + hist1d ! Output histogram + ! Local variables + integer :: ij + + do ij=2,Nbins+1 + hist1D(ij-1) = count(var .ge. bins(ij-1) .and. var .lt. bins(ij)) + if (count(var .eq. R_GROUND) .ge. 1) hist1D(ij-1)=R_UNDEF + enddo + + end function hist1D + + ! ###################################################################################### + ! SUBROUTINE hist2D + ! ###################################################################################### + subroutine hist2D(var1,var2,npts,bin1,nbin1,bin2,nbin2,jointHist) + implicit none + + ! INPUTS + integer, intent(in) :: & + npts, & ! Number of data points to be sorted + nbin1, & ! Number of bins in histogram direction 1 + nbin2 ! Number of bins in histogram direction 2 + real(wp),intent(in),dimension(npts) :: & + var1, & ! Variable 1 to be sorted into bins + var2 ! variable 2 to be sorted into bins + real(wp),intent(in),dimension(nbin1+1) :: & + bin1 ! Histogram bin 1 boundaries + real(wp),intent(in),dimension(nbin2+1) :: & + bin2 ! Histogram bin 2 boundaries + ! OUTPUTS + real(wp),intent(out),dimension(nbin1,nbin2) :: & + jointHist + + ! LOCAL VARIABLES + integer :: ij,ik + + do ij=2,nbin1+1 + do ik=2,nbin2+1 + jointHist(ij-1,ik-1)=count(var1 .ge. bin1(ij-1) .and. var1 .lt. bin1(ij) .and. & + var2 .ge. bin2(ik-1) .and. var2 .lt. bin2(ik)) + enddo + enddo + end subroutine hist2D +END MODULE MOD_COSP_STATS Index: LMDZ6/trunk/libf/phylmd/cosp2/cosp_utils.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/cosp_utils.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/cosp_utils.F90 (revision 3358) @@ -0,0 +1,89 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! May 2015 - Dustin Swales - Modified for COSPv2.0 +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_UTILS + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG + IMPLICIT NONE + +CONTAINS +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_PRECIP_MXRATIO -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_PRECIP_MXRATIO(Npoints,Nlevels,Ncolumns,p,T,prec_frac,prec_type, & + n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4, & + flux,mxratio,reff) + + ! Input arguments, (IN) + integer,intent(in) :: Npoints,Nlevels,Ncolumns + real(wp),intent(in),dimension(Npoints,Nlevels) :: p,T,flux + real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac + real(wp),intent(in) :: n_ax,n_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma1,gamma2,gamma3,gamma4,prec_type + ! Input arguments, (OUT) + real(wp),intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio + real(wp),intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff + ! Local variables + integer :: i,j,k + real(wp) :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta + + mxratio = 0.0 + + if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed + xi = d_x/(alpha_x + b_x - n_bx + 1._wp) + rho0 = 1.29_wp + sigma = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi + one_over_xip1 = 1._wp/(xi + 1._wp) + gamma_4_3_2 = 0.5_wp*gamma4/gamma3 + delta = (alpha_x + b_x + d_x - n_bx + 1._wp) + + do k=1,Nlevels + do j=1,Ncolumns + do i=1,Npoints + if ((prec_frac(i,j,k)==prec_type).or.(prec_frac(i,j,k)==3.)) then + rho = p(i,k)/(287.05_wp*T(i,k)) + mxratio(i,j,k)=(flux(i,k)*((rho/rho0)**g_x)*sigma)**one_over_xip1 + mxratio(i,j,k)=mxratio(i,j,k)/rho + ! Compute effective radius + if ((reff(i,j,k) <= 0._wp).and.(flux(i,k) /= 0._wp)) then + lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1._wp/delta) + reff(i,j,k) = gamma_4_3_2/lambda_x + endif + endif + enddo + enddo + enddo + endif +END SUBROUTINE COSP_PRECIP_MXRATIO + + +END MODULE MOD_COSP_UTILS Index: LMDZ6/trunk/libf/phylmd/cosp2/icarus.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/icarus.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/icarus.F90 (revision 3358) @@ -0,0 +1,645 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Lawrence Livemore National Security Limited Liability +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_ICARUS + USE COSP_KINDS, ONLY: wp + USE COSP_PHYS_CONSTANTS, ONLY: amd,amw,avo,grav + use MOD_COSP_STATS, ONLY: hist2D + USE MOD_COSP_CONFIG, ONLY: R_UNDEF,numISCCPTauBins,numISCCPPresBins,isccp_histTau, & + isccp_histPres + implicit none + + ! Shared Parameters + integer,parameter :: & + ncolprint = 0 ! Flag for debug printing (set as parameter to increase performance) + + ! Cloud-top height determination + integer :: & + isccp_top_height, & ! Top height adjustment method + isccp_top_height_direction ! Direction for finding atmosphere pressure level + + ! Parameters used by icarus + real(wp),parameter :: & + tauchk = -1._wp*log(0.9999999_wp), & ! Lower limit on optical depth + isccp_taumin = 0.3_wp, & ! Minimum optical depth for joint-hostogram + pstd = 1013250._wp, & ! Mean sea-level pressure (Pa) + isccp_t0 = 296._wp, & ! Mean surface temperature (K) + output_missing_value = -1.E+30 ! Missing values + +contains + ! ########################################################################## + ! ########################################################################## + SUBROUTINE ICARUS(debug,debugcol,npoints,sunlit,nlev,ncol,pfull, & + phalf,qv,cc,conv,dtau_s,dtau_c,th,thd,frac_out,skt,emsfc_lw,at,& + dem_s,dem_c,fq_isccp,totalcldarea, meanptop,meantaucld, & + meanalbedocld, meantb,meantbclr,boxtau,boxptop,levmatch) + + ! INPUTS + INTEGER,intent(in) :: & ! + npoints, & ! Number of model points in the horizontal + nlev, & ! Number of model levels in column + ncol, & ! Number of subcolumns + debug, & ! Debug flag + debugcol ! Debug column flag + INTEGER,intent(in),dimension(npoints) :: & ! + sunlit ! 1 for day points, 0 for night time + REAL(WP),intent(in) :: & ! + emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL(WP),intent(in),dimension(npoints) :: & ! + skt ! Skin Temperature (K) + REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: & ! + frac_out ! Boxes gridbox divided up into subcolumns + REAL(WP),intent(in),dimension(npoints,nlev) :: & ! + pfull, & ! Pressure of full model levels (Pascals) + qv, & ! Water vapor specific humidity (kg vapor/ kg air) + cc, & ! Cloud cover in each model level (fraction) + conv, & ! Convective cloud cover in each model + at, & ! Temperature in each model level (K) + dem_c, & ! Emissivity for convective clouds + dem_s, & ! Emissivity for stratiform clouds + dtau_c, & ! Optical depth for convective clouds + dtau_s ! Optical depth for stratiform clouds + REAL(WP),intent(in),dimension(npoints,nlev+1) :: & ! + phalf ! Pressure of half model levels (Pascals)! + integer,intent(in) :: th,thd + + ! OUTPUTS + REAL(WP),intent(out),dimension(npoints,7,7) :: & + fq_isccp ! The fraction of the model grid box covered by clouds + REAL(WP),intent(out),dimension(npoints) :: & + totalcldarea, & ! The fraction of model grid box columns with cloud present + meanptop, & ! Mean cloud top pressure (mb) - linear averaging + meantaucld, & ! Mean optical thickness + meanalbedocld, & ! Mean cloud albedo + meantb, & ! Mean all-sky 10.5 micron brightness temperature + meantbclr ! Mean clear-sky 10.5 micron brightness temperature + REAL(WP),intent(out),dimension(npoints,ncol) :: & + boxtau, & ! Optical thickness in each column + boxptop ! Cloud top pressure (mb) in each column + INTEGER,intent(out),dimension(npoints,ncol) :: & + levmatch ! Used for icarus unit testing only + + + ! INTERNAL VARIABLES + CHARACTER(len=10) :: ftn09 + REAL(WP),dimension(npoints,ncol) :: boxttop + REAL(WP),dimension(npoints,ncol,nlev) :: dtau,demIN + INTEGER :: j,ilev,ibox + INTEGER,dimension(nlev,ncol ) :: acc + + ! PARAMETERS + character ,parameter, dimension(6) :: cchar=(/' ','-','1','+','I','+'/) + character(len=1),parameter,dimension(6) :: cchar_realtops=(/ ' ',' ','1','1','I','I'/) + ! ########################################################################## + + call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dem_c,dem_s,demIN) + call cosp_simulator_optics(npoints,ncol,nlev,frac_out,dtau_c,dtau_s,dtau) + + call ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demIN,skt,emsfc_lw,qv,at, & + pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr) + + call ICARUS_COLUMN(npoints,ncol,boxtau,boxptop/100._wp,sunlit,boxttop,& + fq_isccp,meanalbedocld,meanptop,meantaucld,totalcldarea,meantb) + + ! ########################################################################## + ! OPTIONAL PRINTOUT OF DATA TO CHECK PROGRAM + ! ########################################################################## + + if (debugcol.ne.0) then + do j=1,npoints,debugcol + + ! Produce character output + do ilev=1,nlev + acc(ilev,1:ncol)=frac_out(j,1:ncol,ilev)*2 + where(levmatch(j,1:ncol) .eq. ilev) acc(ilev,1:ncol)=acc(ilev,1:ncol)+1 + enddo + + write(ftn09,11) j +11 format('ftn09.',i4.4) + open(9, FILE=ftn09, FORM='FORMATTED') + + write(9,'(a1)') ' ' + write(9,'(10i5)') (ilev,ilev=5,nlev,5) + write(9,'(a1)') ' ' + + do ibox=1,ncol + write(9,'(40(a1),1x,40(a1))') & + (cchar_realtops(acc(ilev,ibox)+1),ilev=1,nlev),& + (cchar(acc(ilev,ibox)+1),ilev=1,nlev) + end do + close(9) + + enddo + end if + + return + end SUBROUTINE ICARUS + + ! ############################################################################ + ! ############################################################################ + ! ############################################################################ + SUBROUTINE ICARUS_SUBCOLUMN(npoints,ncol,nlev,sunlit,dtau,demiN,skt,emsfc_lw,qv,at, & + pfull,phalf,frac_out,levmatch,boxtau,boxptop,boxttop,meantbclr) + ! Inputs + INTEGER, intent(in) :: & + ncol, & ! Number of subcolumns + npoints, & ! Number of horizontal gridpoints + nlev ! Number of vertical levels + INTEGER, intent(in), dimension(npoints) :: & + sunlit ! 1=day 0=night + REAL(WP),intent(in) :: & + emsfc_lw ! 10.5 micron emissivity of surface (fraction) + REAL(WP),intent(in), dimension(npoints) :: & + skt ! Skin temperature + REAL(WP),intent(in), dimension(npoints,nlev) :: & + at, & ! Temperature + pfull, & ! Presure + qv ! Specific humidity + REAL(WP),intent(in), dimension(npoints,ncol,nlev) :: & + frac_out, & ! Subcolumn cloud cover + dtau, & ! Subcolumn optical thickness + demIN ! Subcolumn emissivity + REAL(WP),intent(in), dimension(npoints,nlev+1) :: & + phalf ! Pressure at model half levels + + ! Outputs + REAL(WP),intent(inout),dimension(npoints) :: & + meantbclr ! Mean clear-sky 10.5 micron brightness temperature + REAL(WP),intent(inout),dimension(npoints,ncol) :: & + boxtau, & ! Optical thickness in each column + boxptop, & ! Cloud top pressure (mb) in each column + boxttop ! Cloud top temperature in each column + INTEGER, intent(inout),dimension(npoints,ncol) :: levmatch + + ! Local Variables + INTEGER :: & + j,ibox,ilev,k1,k2,icycle + INTEGER,dimension(npoints) :: & + nmatch,itrop + INTEGER,dimension(npoints,nlev-1) :: & + match + REAL(WP) :: & + logp,logp1,logp2,atd + REAL(WP),dimension(npoints) :: & + bb,attropmin,attrop,ptrop,atmax,btcmin,transmax,tauir,taumin,fluxtopinit,press, & + dpress,atmden,rvh20,rhoave,rh20s,rfrgn,tmpexp,tauwv,wk,trans_layers_above_clrsky, & + fluxtop_clrsky + REAL(WP),dimension(npoints,nlev) :: & + dem_wv + REAL(WP),dimension(npoints,ncol) :: & + trans_layers_above,dem,tb,emcld,fluxtop,tau,ptop + + ! #################################################################################### + ! Compute cloud optical depth for each column by summing up subcolumns + tau(1:npoints,1:ncol) = 0._wp + tau(1:npoints,1:ncol) = sum(dtau,dim=3) + + ! Set tropopause values + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + ptrop(1:npoints) = 5000._wp + attropmin(1:npoints) = 400._wp + atmax(1:npoints) = 0._wp + attrop(1:npoints) = 120._wp + itrop(1:npoints) = 1 + + do ilev=1,nlev + where(pfull(1:npoints,ilev) .lt. 40000. .and. & + pfull(1:npoints,ilev) .gt. 5000. .and. & + at(1:npoints,ilev) .lt. attropmin(1:npoints)) + ptrop(1:npoints) = pfull(1:npoints,ilev) + attropmin(1:npoints) = at(1:npoints,ilev) + attrop(1:npoints) = attropmin(1:npoints) + itrop = ilev + endwhere + enddo + + do ilev=1,nlev + atmax(1:npoints) = merge(at(1:npoints,ilev),atmax(1:npoints),& + at(1:npoints,ilev) .gt. atmax(1:npoints) .and. ilev .ge. itrop(1:npoints)) + enddo + end if + + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + ! ############################################################################ + ! Clear-sky radiance calculation + ! + ! Compute water vapor continuum emissivity this treatment follows Schwarkzopf + ! and Ramasamy JGR 1999,vol 104, pages 9467-9499. The emissivity is calculated + ! at a wavenumber of 955 cm-1, or 10.47 microns + ! ############################################################################ + do ilev=1,nlev + press(1:npoints) = pfull(1:npoints,ilev)*10._wp + dpress(1:npoints) = (phalf(1:npoints,ilev+1)-phalf(1:npoints,ilev))*10 + atmden(1:npoints) = dpress(1:npoints)/(grav*100._wp) + rvh20(1:npoints) = qv(1:npoints,ilev)*amd/amw + wk(1:npoints) = rvh20(1:npoints)*avo*atmden/amd + rhoave(1:npoints) = (press(1:npoints)/pstd)*(isccp_t0/at(1:npoints,ilev)) + rh20s(1:npoints) = rvh20(1:npoints)*rhoave(1:npoints) + rfrgn(1:npoints) = rhoave(1:npoints)-rh20s(1:npoints) + tmpexp(1:npoints) = exp(-0.02_wp*(at(1:npoints,ilev)-isccp_t0)) + tauwv(1:npoints) = wk(1:npoints)*1.e-20*((0.0224697_wp*rh20s(1:npoints)* & + tmpexp(1:npoints))+(3.41817e-7*rfrgn(1:npoints)))*0.98_wp + dem_wv(1:npoints,ilev) = 1._wp - exp( -1._wp * tauwv(1:npoints)) + enddo + + fluxtop_clrsky(1:npoints) = 0._wp + trans_layers_above_clrsky(1:npoints) = 1._wp + do ilev=1,nlev + ! Black body emission at temperature of the layer + bb(1:npoints) = 1._wp / ( exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp ) + + ! Increase TOA flux by flux emitted from layer times total transmittance in layers above + fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + & + dem_wv(1:npoints,ilev)*bb(1:npoints)*trans_layers_above_clrsky(1:npoints) + + ! Update trans_layers_above with transmissivity from this layer for next time around loop + trans_layers_above_clrsky(1:npoints) = trans_layers_above_clrsky(1:npoints)*& + (1.-dem_wv(1:npoints,ilev)) + enddo + + ! Add in surface emission + bb(1:npoints) = 1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp ) + fluxtop_clrsky(1:npoints) = fluxtop_clrsky(1:npoints) + & + emsfc_lw * bb(1:npoints)*trans_layers_above_clrsky(1:npoints) + + ! Clear Sky brightness temperature + meantbclr(1:npoints) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop_clrsky(1:npoints)))) + + ! ################################################################################# + ! All-sky radiance calculation + ! ################################################################################# + + fluxtop(1:npoints,1:ncol) = 0._wp + trans_layers_above(1:npoints,1:ncol) = 1._wp + do ilev=1,nlev + ! Black body emission at temperature of the layer + bb=1._wp/(exp(1307.27_wp/at(1:npoints,ilev)) - 1._wp) + + do ibox=1,ncol + ! Emissivity + dem(1:npoints,ibox) = merge(dem_wv(1:npoints,ilev), & + 1._wp-(1._wp-demIN(1:npoints,ibox,ilev))*(1._wp-dem_wv(1:npoints,ilev)), & + demIN(1:npoints,ibox,ilev) .eq. 0) + + ! Increase TOA flux emitted from layer + fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + dem(1:npoints,ibox)*bb*trans_layers_above(1:npoints,ibox) + + ! Update trans_layer by emitted layer from above + trans_layers_above(1:npoints,ibox) = trans_layers_above(1:npoints,ibox)*(1._wp-dem(1:npoints,ibox)) + enddo + enddo + + ! Add in surface emission + bb(1:npoints)=1._wp/( exp(1307.27_wp/skt(1:npoints)) - 1._wp ) + do ibox=1,ncol + fluxtop(1:npoints,ibox) = fluxtop(1:npoints,ibox) + emsfc_lw*bb(1:npoints)*trans_layers_above(1:npoints,ibox) + end do + + ! All Sky brightness temperature + boxttop(1:npoints,1:ncol) = 1307.27_wp/(log(1._wp+(1._wp/fluxtop(1:npoints,1:ncol)))) + + ! ################################################################################# + ! Cloud-Top Temperature + ! + ! Now that you have the top of atmosphere radiance, account for ISCCP + ! procedures to determine cloud top temperature account for partially + ! transmitting cloud recompute flux ISCCP would see assuming a single layer + ! cloud. *NOTE* choice here of 2.13, as it is primarily ice clouds which have + ! partial emissivity and need the adjustment performed in this section. If it + ! turns out that the cloud brightness temperature is greater than 260K, then + ! the liquid cloud conversion factor of 2.56 is used. *NOTE* that this is + ! discussed on pages 85-87 of the ISCCP D level documentation + ! (Rossow et al. 1996) + ! ################################################################################# + + ! Compute minimum brightness temperature and optical depth + btcmin(1:npoints) = 1._wp / ( exp(1307.27_wp/(attrop(1:npoints)-5._wp)) - 1._wp ) + + do ibox=1,ncol + transmax(1:npoints) = (fluxtop(1:npoints,ibox)-btcmin) /(fluxtop_clrsky(1:npoints)-btcmin(1:npoints)) + tauir(1:npoints) = tau(1:npoints,ibox)/2.13_wp + taumin(1:npoints) = -log(max(min(transmax(1:npoints),0.9999999_wp),0.001_wp)) + if (isccp_top_height .eq. 1) then + do j=1,npoints + if (transmax(j) .gt. 0.001 .and. transmax(j) .le. 0.9999999) then + fluxtopinit(j) = fluxtop(j,ibox) + tauir(j) = tau(j,ibox)/2.13_wp + endif + enddo + do icycle=1,2 + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk)) then + if (transmax(j) .gt. 0.001 .and. transmax(j) .le. 0.9999999) then + emcld(j,ibox) = 1._wp - exp(-1._wp * tauir(j) ) + fluxtop(j,ibox) = fluxtopinit(j) - ((1.-emcld(j,ibox))*fluxtop_clrsky(j)) + fluxtop(j,ibox)=max(1.E-06_wp,(fluxtop(j,ibox)/emcld(j,ibox))) + tb(j,ibox)= 1307.27_wp / (log(1._wp + (1._wp/fluxtop(j,ibox)))) + if (tb(j,ibox) .gt. 260.) then + tauir(j) = tau(j,ibox) / 2.56_wp + end if + end if + end if + enddo + enddo + endif + + ! Cloud-top temperature + where(tau(1:npoints,ibox) .gt. tauchk) + tb(1:npoints,ibox)= 1307.27_wp/ (log(1. + (1._wp/fluxtop(1:npoints,ibox)))) + where (isccp_top_height .eq. 1 .and. tauir(1:npoints) .lt. taumin(1:npoints)) + tb(1:npoints,ibox) = attrop(1:npoints) - 5._wp + tau(1:npoints,ibox) = 2.13_wp*taumin(1:npoints) + endwhere + endwhere + + ! Clear-sky brightness temperature + where(tau(1:npoints,ibox) .le. tauchk) + tb(1:npoints,ibox) = meantbclr(1:npoints) + endwhere + enddo + else + meantbclr(1:npoints) = output_missing_value + end if + + ! #################################################################################### + ! Cloud-Top Pressure + ! + ! The 2 methods differ according to whether or not you use the physical cloud + ! top pressure (isccp_top_height = 2) or the radiatively determined cloud top + ! pressure (isccp_top_height = 1 or 3) + ! #################################################################################### + do ibox=1,ncol + !segregate according to optical thickness + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + + ! Find level whose temperature most closely matches brightness temperature + nmatch(1:npoints)=0 + do k1=1,nlev-1 + ilev = merge(nlev-k1,k1,isccp_top_height_direction .eq. 2) + do j=1,npoints + if (ilev .ge. itrop(j) .and. & + ((at(j,ilev) .ge. tb(j,ibox) .and. & + at(j,ilev+1) .le. tb(j,ibox)) .or. & + (at(j,ilev) .le. tb(j,ibox) .and. & + at(j,ilev+1) .ge. tb(j,ibox)))) then + nmatch(j)=nmatch(j)+1 + match(j,nmatch(j))=ilev + endif + enddo + enddo + + do j=1,npoints + if (nmatch(j) .ge. 1) then + k1 = match(j,nmatch(j)) + k2 = k1 + 1 + logp1 = log(pfull(j,k1)) + logp2 = log(pfull(j,k2)) + atd = max(tauchk,abs(at(j,k2) - at(j,k1))) + logp=logp1+(logp2-logp1)*abs(tb(j,ibox)-at(j,k1))/atd + ptop(j,ibox) = exp(logp) + levmatch(j,ibox) = merge(k1,k2,abs(pfull(j,k1)-ptop(j,ibox)) .lt. abs(pfull(j,k2)-ptop(j,ibox))) + else + if (tb(j,ibox) .le. attrop(j)) then + ptop(j,ibox)=ptrop(j) + levmatch(j,ibox)=itrop(j) + end if + if (tb(j,ibox) .ge. atmax(j)) then + ptop(j,ibox)=pfull(j,nlev) + levmatch(j,ibox)=nlev + end if + end if + enddo + else + ptop(1:npoints,ibox)=0. + do ilev=1,nlev + where((ptop(1:npoints,ibox) .eq. 0. ) .and.(frac_out(1:npoints,ibox,ilev) .ne. 0)) + ptop(1:npoints,ibox)=phalf(1:npoints,ilev) + levmatch(1:npoints,ibox)=ilev + endwhere + end do + end if + where(tau(1:npoints,ibox) .le. tauchk) + ptop(1:npoints,ibox)=0._wp + levmatch(1:npoints,ibox)=0._wp + endwhere + enddo + + ! #################################################################################### + ! Compute subcolumn pressure and optical depth + ! #################################################################################### + boxtau(1:npoints,1:ncol) = output_missing_value + boxptop(1:npoints,1:ncol) = output_missing_value + do ibox=1,ncol + do j=1,npoints + if (tau(j,ibox) .gt. (tauchk) .and. ptop(j,ibox) .gt. 0.) then + if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then + boxtau(j,ibox) = tau(j,ibox) + boxptop(j,ibox) = ptop(j,ibox)!/100._wp + endif + endif + enddo + enddo + + end SUBROUTINE ICARUS_SUBCOLUMN + + ! ###################################################################################### + ! SUBROUTINE icarus_column + ! ###################################################################################### + SUBROUTINE ICARUS_column(npoints,ncol,boxtau,boxptop,sunlit,boxttop,fq_isccp, & + meanalbedocld,meanptop,meantaucld,totalcldarea,meantb) + ! Inputs + INTEGER, intent(in) :: & + ncol, & ! Number of subcolumns + npoints ! Number of horizontal gridpoints + INTEGER, intent(in),dimension(npoints) :: & + sunlit ! day=1 night=0 + REAL(WP),intent(in),dimension(npoints,ncol) :: & + boxttop, & ! Subcolumn top temperature + boxptop, & ! Subcolumn cloud top pressure + boxtau ! Subcolumn optical depth + + ! Outputs + REAL(WP),intent(inout),dimension(npoints) :: & + meanalbedocld, & ! Gridmean cloud albedo + meanptop, & ! Gridmean cloud top pressure (mb) - linear averaging + meantaucld, & ! Gridmean optical thickness + totalcldarea, & ! The fraction of model grid box columns with cloud present + meantb ! Gridmean all-sky 10.5 micron brightness temperature + REAL(WP),intent(inout),dimension(npoints,7,7) :: & + fq_isccp ! The fraction of the model grid box covered by clouds + + ! Local Variables + INTEGER :: j,ilev,ilev2 + REAL(WP),dimension(npoints,ncol) :: albedocld + LOGICAL, dimension(npoints,ncol) :: box_cloudy + + ! Variables for new joint-histogram implementation + logical,dimension(ncol) :: box_cloudy2 + + ! #################################################################################### + ! Brightness Temperature + ! #################################################################################### + if (isccp_top_height .eq. 1 .or. isccp_top_height .eq. 3) then + meantb(1:npoints)=sum(boxttop,2)/ncol + else + meantb(1:npoints) = output_missing_value + endif + + ! #################################################################################### + ! Determines ISCCP cloud type frequencies + ! + ! Now that boxptop and boxtau have been determined, determine amount of each of the + ! 49 ISCCP cloud types. Also compute grid box mean cloud top pressure and + ! optical thickness. The mean cloud top pressure and optical thickness are + ! averages over the cloudy area only. The mean cloud top pressure is a linear + ! average of the cloud top pressures. The mean cloud optical thickness is + ! computed by converting optical thickness to an albedo, averaging in albedo + ! units, then converting the average albedo back to a mean optical thickness. + ! #################################################################################### + + ! Initialize + albedocld(1:npoints,1:ncol) = 0._wp + box_cloudy(1:npoints,1:ncol) = .false. + + ! Reset frequencies + !fq_isccp = spread(spread(merge(0._wp,output_missing_value,sunlit .eq. 1 .or. isccp_top_height .eq. 3),2,7),2,7) + do ilev=1,7 + do ilev2=1,7 + do j=1,npoints ! + if (sunlit(j).eq.1 .or. isccp_top_height .eq. 3) then + fq_isccp(j,ilev,ilev2)= 0. + else + fq_isccp(j,ilev,ilev2)= output_missing_value + end if + enddo + enddo + enddo + + + ! Reset variables need for averaging cloud properties + where(sunlit .eq. 1 .or. isccp_top_height .eq. 3) + totalcldarea(1:npoints) = 0._wp + meanalbedocld(1:npoints) = 0._wp + meanptop(1:npoints) = 0._wp + meantaucld(1:npoints) = 0._wp + elsewhere + totalcldarea(1:npoints) = output_missing_value + meanalbedocld(1:npoints) = output_missing_value + meanptop(1:npoints) = output_missing_value + meantaucld(1:npoints) = output_missing_value + endwhere + + ! Compute column quantities and joint-histogram + do j=1,npoints + ! Subcolumns that are cloudy(true) and not(false) + box_cloudy2(1:ncol) = merge(.true.,.false.,boxtau(j,1:ncol) .gt. tauchk .and. boxptop(j,1:ncol) .gt. 0.) + + ! Compute joint histogram and column quantities for points that are sunlit and cloudy + if (sunlit(j) .eq.1 .or. isccp_top_height .eq. 3) then + ! Joint-histogram + call hist2D(boxtau(j,1:ncol),boxptop(j,1:ncol),ncol,isccp_histTau,numISCCPTauBins, & + isccp_histPres,numISCCPPresBins,fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins)) + fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins) = & + fq_isccp(j,1:numISCCPTauBins,1:numISCCPPresBins)/ncol + + ! Column cloud area + totalcldarea(j) = real(count(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin))/ncol + + ! Subcolumn cloud albedo + !albedocld(j,1:ncol) = merge((boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp),& + ! 0._wp,box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin) + where(box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin) + albedocld(j,1:ncol) = (boxtau(j,1:ncol)**0.895_wp)/((boxtau(j,1:ncol)**0.895_wp)+6.82_wp) + elsewhere + albedocld(j,1:ncol) = 0._wp + endwhere + + ! Column cloud albedo + meanalbedocld(j) = sum(albedocld(j,1:ncol))/ncol + + ! Column cloud top pressure + meanptop(j) = sum(boxptop(j,1:ncol),box_cloudy2(1:ncol) .and. boxtau(j,1:ncol) .gt. isccp_taumin)/ncol + endif + enddo + + ! Compute mean cloud properties. Set to mssing value in the event that totalcldarea=0 + where(totalcldarea(1:npoints) .gt. 0) + meanptop(1:npoints) = 100._wp*meanptop(1:npoints)/totalcldarea(1:npoints) + meanalbedocld(1:npoints) = meanalbedocld(1:npoints)/totalcldarea(1:npoints) + meantaucld(1:npoints) = (6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp) + elsewhere + meanptop(1:nPoints) = output_missing_value + meanalbedocld(1:nPoints) = output_missing_value + meantaucld(1:nPoints) = output_missing_value + endwhere + !meanptop(1:npoints) = merge(100._wp*meanptop(1:npoints)/totalcldarea(1:npoints),& + ! output_missing_value,totalcldarea(1:npoints) .gt. 0) + !meanalbedocld(1:npoints) = merge(meanalbedocld(1:npoints)/totalcldarea(1:npoints), & + ! output_missing_value,totalcldarea(1:npoints) .gt. 0) + !meantaucld(1:npoints) = merge((6.82_wp/((1._wp/meanalbedocld(1:npoints))-1.))**(1._wp/0.895_wp), & + ! output_missing_value,totalcldarea(1:npoints) .gt. 0) + + ! Represent in percent + where(totalcldarea .ne. output_missing_value) totalcldarea = totalcldarea*100._wp + where(fq_isccp .ne. output_missing_value) fq_isccp = fq_isccp*100._wp + + + end SUBROUTINE ICARUS_column + + subroutine cosp_simulator_optics(dim1,dim2,dim3,flag,varIN1,varIN2,varOUT) + ! INPUTS + integer,intent(in) :: & + dim1, & ! Dimension 1 extent (Horizontal) + dim2, & ! Dimension 2 extent (Subcolumn) + dim3 ! Dimension 3 extent (Vertical) + real(wp),intent(in),dimension(dim1,dim2,dim3) :: & + flag ! Logical to determine the of merge var1IN and var2IN + real(wp),intent(in),dimension(dim1, dim3) :: & + varIN1, & ! Input field 1 + varIN2 ! Input field 2 + ! OUTPUTS + real(wp),intent(out),dimension(dim1,dim2,dim3) :: & + varOUT ! Merged output field + ! LOCAL VARIABLES + integer :: j + + varOUT(1:dim1,1:dim2,1:dim3) = 0._wp + do j=1,dim2 + where(flag(:,j,:) .eq. 1) + varOUT(:,j,:) = varIN2 + endwhere + where(flag(:,j,:) .eq. 2) + varOUT(:,j,:) = varIN1 + endwhere + enddo + end subroutine cosp_simulator_optics +end module MOD_ICARUS + Index: LMDZ6/trunk/libf/phylmd/cosp2/lidar_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/lidar_simulator.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/lidar_simulator.F90 (revision 3358) @@ -0,0 +1,1026 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2007: ActSim code of M. Chiriaco and H. Chepfer rewritten by S. Bony +! +! May 2008, H. Chepfer: +! - Units of pressure inputs: Pa +! - Non Spherical particles : LS Ice NS coefficients, CONV Ice NS coefficients +! - New input: ice_type (0=ice-spheres ; 1=ice-non-spherical) +! +! June 2008, A. Bodas-Salcedo: +! - Ported to Fortran 90 and optimisation changes +! +! August 2008, J-L Dufresne: +! - Optimisation changes (sum instructions suppressed) +! +! October 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Interface with COSP v2.0: +! cloud fraction removed from inputs +! in-cloud condensed water now in input (instead of grid-averaged value) +! depolarisation diagnostic removed +! parasol (polder) reflectances (for 5 different solar zenith angles) added +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - Modification of the integration of the lidar equation. +! - change the cloud detection threshold +! +! April 2008, A. Bodas-Salcedo: +! - Bug fix in computation of pmol and pnorm of upper layer +! +! April 2008, J-L. Dufresne +! - Bug fix in computation of pmol and pnorm, thanks to Masaki Satoh: a factor 2 +! was missing. This affects the ATB values but not the cloud fraction. +! +! January 2013, G. Cesana and H. Chepfer: +! - Add the perpendicular component of the backscattered signal (pnorm_perp_tot) in the arguments +! - Add the temperature for each levels (temp) in the arguments +! - Add the computation of the perpendicular component of the backscattered lidar signal +! Reference: Cesana G. and H. Chepfer (2013): Evaluation of the cloud water phase +! in a climate model using CALIPSO-GOCCP, J. Geophys. Res., doi: 10.1002/jgrd.50376 +! +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_lidar_simulator + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: SR_BINS,S_CLD,S_ATT,S_CLD_ATT,R_UNDEF,calipso_histBsct, & + use_vgrid,vgrid_zl,vgrid_zu + USE MOD_COSP_STATS, ONLY: COSP_CHANGE_VERTICAL_GRID,hist1d + implicit none + + ! Polynomial coefficients (Alpha, Beta, Gamma) which allow to compute the + ! ATBperpendicular as a function of the ATB for ice or liquid cloud particles + ! derived from CALIPSO-GOCCP observations at 120m vertical grid + ! (Cesana and Chepfer, JGR, 2013). + ! + ! Relationship between ATBice and ATBperp,ice for ice particles: + ! ATBperp,ice = Alpha*ATBice + ! Relationship between ATBice and ATBperp,ice for liquid particles: + ! ATBperp,ice = Beta*ATBice^2 + Gamma*ATBice + real(wp) :: & + alpha,beta,gamma + +contains + ! ###################################################################################### + ! SUBROUTINE lidar_subcolumn + ! Inputs with a vertical dimensions (nlev) should ordered in along the vertical + ! dimension from TOA-2-SFC, for example: varIN(nlev) is varIN @ SFC. + ! ###################################################################################### + subroutine lidar_subcolumn(npoints,ncolumns,nlev,beta_mol,tau_mol,betatot,tautot, & + betatot_ice,tautot_ice,betatot_liq,tautot_liq, & + pmol,pnorm,pnorm_perp_tot) + + ! INPUTS + INTEGER,intent(in) :: & + npoints, & ! Number of gridpoints + ncolumns, & ! Number of subcolumns + nlev ! Number of levels + REAL(WP),intent(in),dimension(npoints,nlev) :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol ! Molecular optical depth + + REAL(WP),intent(in),dimension(npoints,ncolumns,nlev) :: & + betatot, & ! + tautot, & ! Optical thickess integrated from top + betatot_ice, & ! Backscatter coefficient for ice particles + betatot_liq, & ! Backscatter coefficient for liquid particles + tautot_ice, & ! Total optical thickness of ice + tautot_liq ! Total optical thickness of liq + + ! OUTPUTS + REAL(WP),intent(out),dimension(npoints,nlev) :: & + pmol ! Molecular attenuated backscatter lidar signal power(m^-1.sr^-1) + REAL(WP),intent(out),dimension(npoints,ncolumns,nlev) :: & + pnorm, & ! Molecular backscatter signal power (m^-1.sr^-1) + pnorm_perp_tot ! Perpendicular lidar backscattered signal power + + ! LOCAL VARIABLES + INTEGER :: k,icol + REAL(WP),dimension(npoints) :: & + tautot_lay ! + REAL(WP),dimension(npoints,ncolumns,nlev) :: & + pnorm_liq, & ! Lidar backscattered signal power for liquid + pnorm_ice, & ! Lidar backscattered signal power for ice + pnorm_perp_ice, & ! Perpendicular lidar backscattered signal power for ice + pnorm_perp_liq, & ! Perpendicular lidar backscattered signal power for liq + beta_perp_ice, & ! Perpendicular backscatter coefficient for ice + beta_perp_liq ! Perpendicular backscatter coefficient for liquid + + ! #################################################################################### + ! *) Molecular signal + ! #################################################################################### + call cmp_backsignal(nlev,npoints,beta_mol(1:npoints,1:nlev),& + tau_mol(1:npoints,1:nlev),pmol(1:npoints,1:nlev)) + + ! #################################################################################### + ! PLANE PARRALLEL FIELDS + ! #################################################################################### + do icol=1,ncolumns + ! ################################################################################# + ! *) Total Backscatter signal + ! ################################################################################# + call cmp_backsignal(nlev,npoints,betatot(1:npoints,icol,1:nlev),& + tautot(1:npoints,icol,1:nlev),pnorm(1:npoints,icol,1:nlev)) + ! ################################################################################# + ! *) Ice/Liq Backscatter signal + ! ################################################################################# + ! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq) + ! Ice only + call cmp_backsignal(nlev,npoints,betatot_ice(1:npoints,icol,1:nlev),& + tautot_ice(1:npoints,icol,1:nlev),& + pnorm_ice(1:npoints,icol,1:nlev)) + ! Liquid only + call cmp_backsignal(nlev,npoints,betatot_liq(1:npoints,icol,1:nlev),& + tautot_liq(1:npoints,icol,1:nlev),& + pnorm_liq(1:npoints,icol,1:nlev)) + enddo + + ! #################################################################################### + ! PERDENDICULAR FIELDS + ! #################################################################################### + do icol=1,ncolumns + + ! ################################################################################# + ! *) Ice/Liq Perpendicular Backscatter signal + ! ################################################################################# + ! Computation of ATBperp,ice/liq from ATBice/liq including the multiple scattering + ! contribution (Cesana and Chepfer 2013, JGR) + do k=1,nlev + ! Ice particles + pnorm_perp_ice(1:npoints,icol,k) = Alpha * pnorm_ice(1:npoints,icol,k) + + ! Liquid particles + pnorm_perp_liq(1:npoints,icol,k) = 1000._wp*Beta*pnorm_liq(1:npoints,icol,k)**2+& + Gamma*pnorm_liq(1:npoints,icol,k) + enddo + + ! ################################################################################# + ! *) Computation of beta_perp_ice/liq using the lidar equation + ! ################################################################################# + ! Ice only + call cmp_beta(nlev,npoints,pnorm_perp_ice(1:npoints,icol,1:nlev),& + tautot_ice(1:npoints,icol,1:nlev),beta_perp_ice(1:npoints,icol,1:nlev)) + + ! Liquid only + call cmp_beta(nlev,npoints,pnorm_perp_liq(1:npoints,icol,1:nlev),& + tautot_liq(1:npoints,icol,1:nlev),beta_perp_liq(1:npoints,icol,1:nlev)) + + ! ################################################################################# + ! *) Perpendicular Backscatter signal + ! ################################################################################# + ! Computation of the total perpendicular lidar signal (ATBperp for liq+ice) + ! Upper layer + WHERE(tautot(1:npoints,icol,1) .gt. 0) + pnorm_perp_tot(1:npoints,icol,1) = (beta_perp_ice(1:npoints,icol,1)+ & + beta_perp_liq(1:npoints,icol,1)- & + (beta_mol(1:npoints,1)/(1._wp+1._wp/0.0284_wp))) / & + (2._wp*tautot(1:npoints,icol,1))* & + (1._wp-exp(-2._wp*tautot(1:npoints,icol,1))) + ELSEWHERE + pnorm_perp_tot(1:npoints,icol,1) = 0._wp + ENDWHERE + + ! Other layers + do k=2,nlev + ! Optical thickness of layer k + tautot_lay(1:npoints) = tautot(1:npoints,icol,k)-tautot(1:npoints,icol,k-1) + + ! The perpendicular component of the molecular backscattered signal (Betaperp) + ! has been taken into account two times (once for liquid and once for ice). + ! We remove one contribution using + ! Betaperp=beta_mol(:,k)/(1+1/0.0284)) [bodhaine et al. 1999] in the following + ! equations: + WHERE (pnorm(1:npoints,icol,k) .eq. 0) + pnorm_perp_tot(1:npoints,icol,k)=0._wp + ELSEWHERE + where(tautot_lay(1:npoints) .gt. 0.) + pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+ & + beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/ & + 0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1))/ & + (2._wp*tautot_lay(1:npoints))* (1._wp-EXP(-2._wp*tautot_lay(1:npoints))) + elsewhere + pnorm_perp_tot(1:npoints,icol,k) = (beta_perp_ice(1:npoints,icol,k)+ & + beta_perp_liq(1:npoints,icol,k)-(beta_mol(1:npoints,k)/(1._wp+1._wp/ & + 0.0284_wp)))*EXP(-2._wp*tautot(1:npoints,icol,k-1)) + endwhere + ENDWHERE + END DO + enddo + end subroutine lidar_subcolumn + + ! ###################################################################################### + ! SUBROUTINE lidar_column + ! ###################################################################################### + subroutine lidar_column(npoints,ncol,nlevels,llm,max_bin,tmp, pnorm, & + pnorm_perp, pmol, pplay, ok_lidar_cfad, ncat, cfad2, & + lidarcld, lidarcldphase, cldlayer, zlev, zlev_half, & + cldlayerphase, lidarcldtmp) + integer,parameter :: & + nphase = 6 ! Number of cloud layer phase types + + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal grid points + ncol, & ! Number of subcolumns + nlevels, & ! Number of vertical layers (OLD grid) + llm, & ! Number of vertical layers (NEW grid) + max_bin, & ! Number of bins for SR CFADs + ncat ! Number of cloud layer types (low,mid,high,total) + real(wp),intent(in),dimension(npoints,ncol,Nlevels) :: & + pnorm, & ! Lidar ATB + pnorm_perp ! Lidar perpendicular ATB + real(wp),intent(in),dimension(npoints,Nlevels) :: & + pmol, & ! Molecular ATB + pplay, & ! Pressure on model levels (Pa) + tmp ! Temperature at each levels + logical,intent(in) :: & + ok_lidar_cfad ! True if lidar CFAD diagnostics need to be computed + real(wp),intent(in),dimension(npoints,nlevels) :: & + zlev ! Model full levels + real(wp),intent(in),dimension(npoints,nlevels+1) :: & + zlev_half ! Model half levels + + ! Outputs + real(wp),intent(inout),dimension(npoints,llm) :: & + lidarcld ! 3D "lidar" cloud fraction + real(wp),intent(inout),dimension(npoints,ncat) :: & + cldlayer ! "lidar" cloud layer fraction (low, mid, high, total) + real(wp),intent(inout),dimension(npoints,llm,nphase) :: & + lidarcldphase ! 3D "lidar" phase cloud fraction + real(wp),intent(inout),dimension(npoints,40,5) :: & + lidarcldtmp ! 3D "lidar" phase cloud fraction as a function of temp + real(wp),intent(inout),dimension(npoints,ncat,nphase) :: & + cldlayerphase ! "lidar" phase low mid high cloud fraction + real(wp),intent(inout),dimension(npoints,max_bin,llm) :: & + cfad2 ! CFADs of SR + + ! Local Variables + integer :: ic,i,j + real(wp),dimension(npoints,ncol,llm) :: & + x3d + real(wp),dimension(npoints,llm) :: & + x3d_c,pnorm_c + real(wp) :: & + xmax + real(wp),dimension(npoints,1,Nlevels) :: t_in,ph_in,betamol_in + real(wp),dimension(npoints,ncol,llm) :: pnormFlip,pnorm_perpFlip + real(wp),dimension(npoints,1,llm) :: tmpFlip,pplayFlip,betamolFlip + + ! Vertically regrid input data + if (use_vgrid) then + t_in(:,1,:)=tmp(:,nlevels:1:-1) + call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + t_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),tmpFlip(:,1,llm:1:-1)) + ph_in(:,1,:) = pplay(:,nlevels:1:-1) + call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + ph_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pplayFlip(:,1,llm:1:-1)) + betamol_in(:,1,:) = pmol(:,nlevels:1:-1) + call cosp_change_vertical_grid(Npoints,1,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + betamol_in,llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),betamolFlip(:,1,llm:1:-1)) + call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + pnorm(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnormFlip(:,:,llm:1:-1)) + call cosp_change_vertical_grid(Npoints,Ncol,Nlevels,zlev(:,nlevels:1:-1),zlev_half(:,nlevels:1:-1),& + pnorm_perp(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),vgrid_zu(llm:1:-1),pnorm_perpFlip(:,:,llm:1:-1)) + endif + + ! Initialization (The histogram bins, are set up during initialization and the + ! maximum value is used as the upper bounds.) + xmax = maxval(calipso_histBsct) + + ! Compute LIDAR scattering ratio + if (use_vgrid) then + do ic = 1, ncol + pnorm_c = pnormFlip(:,ic,:) + where ((pnorm_c .lt. xmax) .and. (betamolFlip(:,1,:) .lt. xmax) .and. & + (betamolFlip(:,1,:) .gt. 0.0 )) + x3d_c = pnorm_c/betamolFlip(:,1,:) + elsewhere + x3d_c = R_UNDEF + end where + x3d(:,ic,:) = x3d_c + enddo + ! Diagnose cloud fractions for subcolumn lidar scattering ratios + CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase,tmpFlip,x3d,pnormFlip, & + pnorm_perpFlip,pplayFlip,S_att,S_cld,S_cld_att,R_UNDEF, & + lidarcld,cldlayer,lidarcldphase,cldlayerphase,lidarcldtmp) + else + do ic = 1, ncol + pnorm_c = pnorm(:,ic,:) + where ((pnorm_c.lt.xmax) .and. (pmol.lt.xmax) .and. (pmol.gt. 0.0 )) + x3d_c = pnorm_c/pmol + elsewhere + x3d_c = R_UNDEF + end where + x3d(:,ic,:) = x3d_c + enddo + ! Diagnose cloud fractions for subcolumn lidar scattering ratios + CALL COSP_CLDFRAC(npoints,ncol,nlevels,ncat,nphase,tmp,x3d,pnorm,pnorm_perp,pplay,& + S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer,lidarcldphase, & + cldlayerphase,lidarcldtmp) + endif + + ! CFADs + if (ok_lidar_cfad) then + ! CFADs of subgrid-scale lidar scattering ratios + do i=1,Npoints + do j=1,llm + cfad2(i,:,j) = hist1D(ncol,x3d(i,:,j),SR_BINS,calipso_histBsct) + enddo + enddo + where(cfad2 .ne. R_UNDEF) cfad2=cfad2/ncol + + endif + + ! Unit conversions + where(lidarcld /= R_UNDEF) lidarcld = lidarcld*100._wp + where(cldlayer /= R_UNDEF) cldlayer = cldlayer*100._wp + where(cldlayerphase /= R_UNDEF) cldlayerphase = cldlayerphase*100._wp + where(lidarcldphase /= R_UNDEF) lidarcldphase = lidarcldphase*100._wp + where(lidarcldtmp /= R_UNDEF) lidarcldtmp = lidarcldtmp*100._wp + + end subroutine lidar_column + + ! ###################################################################################### + ! The subroutines below compute the attenuated backscatter signal and the lidar + ! backscatter coefficients using eq (1) from doi:0094-8276/08/2008GL034207 + ! ###################################################################################### + subroutine cmp_backsignal(nlev,npoints,beta,tau,pnorm) + ! INPUTS + integer, intent(in) :: nlev,npoints + real(wp),intent(in),dimension(npoints,nlev) :: beta,tau + + ! OUTPUTS + real(wp),intent(out),dimension(npoints,nlev) :: pnorm + + ! Internal Variables + real(wp), dimension(npoints) :: tautot_lay + integer :: k + + ! Uppermost layer + pnorm(:,1) = beta(:,1) / (2._wp*tau(:,1)) * (1._wp-exp(-2._wp*tau(:,1))) + + ! Other layers + do k=2,nlev + tautot_lay(:) = tau(:,k)-tau(:,k-1) + WHERE ( EXP(-2._wp*tau(:,k-1)) .gt. 0. ) + WHERE (tautot_lay(:) .gt. 0.) + pnorm(:,k) = beta(:,k)*EXP(-2._wp*tau(:,k-1)) /& + (2._wp*tautot_lay(:))*(1._wp-EXP(-2._wp*tautot_lay(:))) + ELSEWHERE + ! This must never happen, but just in case, to avoid div. by 0 + pnorm(:,k) = beta(:,k) * EXP(-2._wp*tau(:,k-1)) + END WHERE + ELSEWHERE + pnorm(:,k) = 0._wp!beta(:,k) + END WHERE + END DO + end subroutine cmp_backsignal + + subroutine cmp_beta(nlev,npoints,pnorm,tau,beta) + ! INPUTS + integer, intent(in) :: nlev,npoints + real(wp),intent(in),dimension(npoints,nlev) :: pnorm,tau + + ! OUTPUTS + real(wp),intent(out),dimension(npoints,nlev) :: beta + + ! Internal Variables + real(wp), dimension(npoints) :: tautot_lay + integer :: k + + beta(:,1) = pnorm(:,1) * (2._wp*tau(:,1))/(1._wp-exp(-2._wp*tau(:,1))) + do k=2,nlev + tautot_lay(:) = tau(:,k)-tau(:,k-1) + WHERE ( EXP(-2._wp*tau(:,k-1)) .gt. 0. ) + WHERE (tautot_lay(:) .gt. 0.) + beta(:,k) = pnorm(:,k)/ EXP(-2._wp*tau(:,k-1))* & + (2._wp*tautot_lay(:))/(1._wp-exp(-2._wp*tautot_lay(:))) + ELSEWHERE + beta(:,k)=pnorm(:,k)/EXP(-2._wp*tau(:,k-1)) + END WHERE + ELSEWHERE + beta(:,k)=pnorm(:,k) + END WHERE + ENDDO + + end subroutine cmp_beta + ! #################################################################################### + ! SUBROUTINE cosp_cldfrac + ! Conventions: Ncat must be equal to 4 + ! #################################################################################### + SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase,tmp,x,ATB,ATBperp, & + pplay,S_att,S_cld,S_cld_att,undef,lidarcld,cldlayer, & + lidarcldphase,cldlayerphase,lidarcldtemp) + ! Parameters + integer,parameter :: Ntemp=40 ! indice of the temperature vector + real(wp),parameter,dimension(Ntemp+1) :: & + tempmod = [0.0, 183.15,186.15,189.15,192.15,195.15,198.15,201.15,204.15,207.15, & + 210.15,213.15,216.15,219.15,222.15,225.15,228.15,231.15,234.15,237.15, & + 240.15,243.15,246.15,249.15,252.15,255.15,258.15,261.15,264.15,267.15, & + 270.15,273.15,276.15,279.15,282.15,285.15,288.15,291.15,294.15,297.15, & + 473.15] + + ! Polynomial coefficient of the phase discrimination line used to separate liquid from ice + ! (Cesana and Chepfer, JGR, 2013) + ! ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 + ATB*epsilon50 + zeta50 + real(wp),parameter :: & + alpha50 = 9.0322e+15_wp, & ! + beta50 = -2.1358e+12_wp, & ! + gamma50 = 173.3963e06_wp, & ! + delta50 = -3.9514e03_wp, & ! + epsilon50 = 0.2559_wp, & ! + zeta50 = -9.4776e-07_wp ! + + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels, & ! Number of vertical levels + Ncat, & ! Number of cloud layer types + Nphase ! Number of cloud layer phase types + ! [ice,liquid,undefined,false ice,false liquid,Percent of ice] + real(wp),intent(in) :: & + S_att, & ! + S_cld, & ! + S_cld_att,& ! New threshold for undefine cloud phase detection + undef ! Undefined value + real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: & + x, & ! + ATB, & ! 3D attenuated backscatter + ATBperp ! 3D attenuated backscatter (perpendicular) + real(wp),intent(in),dimension(Npoints,Nlevels) :: & + tmp, & ! Temperature + pplay ! Pressure + + ! Outputs + real(wp),intent(out),dimension(Npoints,Ntemp,5) :: & + lidarcldtemp ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq + real(wp),intent(out),dimension(Npoints,Nlevels,Nphase) :: & + lidarcldphase ! 3D cloud phase fraction + real(wp),intent(out),dimension(Npoints,Nlevels) :: & + lidarcld ! 3D cloud fraction + real(wp),intent(out),dimension(Npoints,Ncat) :: & + cldlayer ! Low, middle, high, total cloud fractions + real(wp),intent(out),dimension(Npoints,Ncat,Nphase) :: & + cldlayerphase ! Low, middle, high, total cloud fractions for ice liquid and undefine phase + + ! Local variables + integer :: & + ip, k, iz, ic, ncol, nlev, i, itemp, toplvlsat + real(wp) :: & + p1,checktemp, ATBperp_tmp,checkcldlayerphase, checkcldlayerphase2 + real(wp),dimension(Npoints,Nlevels) :: & + nsub,lidarcldphasetmp + real(wp),dimension(Npoints,Ntemp) :: & + sumlidarcldtemp,lidarcldtempind + real(wp),dimension(Npoints,Ncolumns,Ncat) :: & + cldlay,nsublay + real(wp),dimension(Npoints,Ncat) :: & + nsublayer,cldlayerphasetmp,cldlayerphasesum + real(wp),dimension(Npoints,Ncolumns,Nlevels) :: & + tmpi, & ! Temperature of ice cld + tmpl, & ! Temperature of liquid cld + tmpu, & ! Temperature of undef cld + cldy, & ! + srok ! + real(wp),dimension(Npoints,Ncolumns,Ncat,Nphase) :: & + cldlayphase ! subgrided low mid high phase cloud fraction + + ! #################################################################################### + ! 1) Initialize + ! #################################################################################### + lidarcld = 0._wp + nsub = 0._wp + cldlay = 0._wp + nsublay = 0._wp + ATBperp_tmp = 0._wp + lidarcldphase(:,:,:) = 0._wp + cldlayphase(:,:,:,:) = 0._wp + cldlayerphase(:,:,:) = 0._wp + tmpi(:,:,:) = 0._wp + tmpl(:,:,:) = 0._wp + tmpu(:,:,:) = 0._wp + cldlayerphasesum(:,:) = 0._wp + lidarcldtemp(:,:,:) = 0._wp + lidarcldtempind(:,:) = 0._wp + sumlidarcldtemp(:,:) = 0._wp + lidarcldphasetmp(:,:) = 0._wp + toplvlsat = 0 + + ! #################################################################################### + ! 2) Cloud detection + ! #################################################################################### + do k=1,Nlevels + ! Cloud detection at subgrid-scale: + where ((x(:,:,k) .gt. S_cld) .and. (x(:,:,k) .ne. undef) ) + cldy(:,:,k)=1._wp + elsewhere + cldy(:,:,k)=0._wp + endwhere + + ! Number of usefull sub-columns: + where ((x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) ) + srok(:,:,k)=1._wp + elsewhere + srok(:,:,k)=0._wp + endwhere + enddo + + ! #################################################################################### + ! 3) Grid-box 3D cloud fraction and layered cloud fractions(ISCCP pressure categories) + ! #################################################################################### + lidarcld = 0._wp + nsub = 0._wp + cldlay = 0._wp + nsublay = 0._wp + do k=1,Nlevels + do ic = 1, Ncolumns + do ip = 1, Npoints + + ! Computation of the cloud fraction as a function of the temperature instead + ! of height, for ice,liquid and all clouds + if(srok(ip,ic,k).gt.0.)then + do itemp=1,Ntemp + if( (tmp(ip,k).ge.tempmod(itemp)).and.(tmp(ip,k).lt.tempmod(itemp+1)) )then + lidarcldtempind(ip,itemp)=lidarcldtempind(ip,itemp)+1._wp + endif + enddo + endif + + if(cldy(ip,ic,k).eq.1.)then + do itemp=1,Ntemp + if( (tmp(ip,k) .ge. tempmod(itemp)).and.(tmp(ip,k) .lt. tempmod(itemp+1)) )then + lidarcldtemp(ip,itemp,1)=lidarcldtemp(ip,itemp,1)+1._wp + endif + enddo + endif + + iz=1 + p1 = pplay(ip,k) + if ( p1.gt.0. .and. p1.lt.(440._wp*100._wp)) then ! high clouds + iz=3 + else if(p1.ge.(440._wp*100._wp) .and. p1.lt.(680._wp*100._wp)) then ! mid clouds + iz=2 + endif + + cldlay(ip,ic,iz) = MAX(cldlay(ip,ic,iz),cldy(ip,ic,k)) + cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k)) + lidarcld(ip,k) = lidarcld(ip,k) + cldy(ip,ic,k) + + nsublay(ip,ic,iz) = MAX(nsublay(ip,ic,iz),srok(ip,ic,k)) + nsublay(ip,ic,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k)) + nsub(ip,k) = nsub(ip,k) + srok(ip,ic,k) + + enddo + enddo + enddo + + ! Grid-box 3D cloud fraction + where ( nsub(:,:).gt.0.0 ) + lidarcld(:,:) = lidarcld(:,:)/nsub(:,:) + elsewhere + lidarcld(:,:) = undef + endwhere + + ! Layered cloud fractions + cldlayer = 0._wp + nsublayer = 0._wp + do iz = 1, Ncat + do ic = 1, Ncolumns + cldlayer(:,iz) = cldlayer(:,iz) + cldlay(:,ic,iz) + nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz) + enddo + enddo + where (nsublayer(:,:) .gt. 0.0) + cldlayer(:,:) = cldlayer(:,:)/nsublayer(:,:) + elsewhere + cldlayer(:,:) = undef + endwhere + + ! #################################################################################### + ! 4) Grid-box 3D cloud Phase + ! #################################################################################### + + ! #################################################################################### + ! 4.1) For Cloudy pixels with 8.16km < z < 19.2km + ! #################################################################################### + do ncol=1,Ncolumns + do i=1,Npoints + do nlev=1,23 ! from 19.2km until 8.16km + p1 = pplay(1,nlev) + + ! Avoid zero values + if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then + ! Computation of the ATBperp along the phase discrimination line + ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + & + (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + & + ATB(i,ncol,nlev)*epsilon50 + zeta50 + ! ######################################################################## + ! 4.1.a) Ice: ATBperp above the phase discrimination line + ! ######################################################################## + if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds + + ! ICE with temperature above 273,15°K = Liquid (false ice) + if(tmp(i,nlev) .gt. 273.15) then ! Temperature above 273,15 K + ! Liquid: False ice corrected by the temperature to Liquid + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! False ice detection ==> added to Liquid + + tmpl(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp ! Keep the information "temperature criterium used" + ! to classify the phase cloud + cldlayphase(i,ncol,4,2) = 1. ! tot cloud + if (p1 .gt. 0. .and. p1.lt.(440._wp*100._wp)) then ! high cloud + cldlayphase(i,ncol,3,2) = 1._wp + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then ! mid cloud + cldlayphase(i,ncol,2,2) = 1._wp + else ! low cloud + cldlayphase(i,ncol,1,2) = 1._wp + endif + cldlayphase(i,ncol,4,5) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,5) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,5) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,5) = 1._wp + endif + else + ! ICE with temperature below 273,15°K + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp + tmpi(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + ! ######################################################################## + ! 4.1.b) Liquid: ATBperp below the phase discrimination line + ! ######################################################################## + else + ! Liquid with temperature above 231,15°K + if(tmp(i,nlev) .gt. 231.15_wp) then + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp + tmpl(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,2) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,2) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,2) = 1._wp + endif + else + ! Liquid with temperature below 231,15°K = Ice (false liquid) + tmpi(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liquid detection ==> added to ice + lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp + cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,4) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,4) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,4) = 1._wp + endif + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + endif ! end of discrimination condition + endif ! end of cloud condition + enddo ! end of altitude loop + + ! ############################################################################## + ! 4.2) For Cloudy pixels with 0km < z < 8.16km + ! ############################################################################## + toplvlsat = 0 + do nlev=24,Nlevels! from 8.16km until 0km + p1 = pplay(i,nlev) + + if((cldy(i,ncol,nlev) .eq. 1.) .and. (ATBperp(i,ncol,nlev) .gt. 0.) )then + ! Computation of the ATBperp of the phase discrimination line + ATBperp_tmp = (ATB(i,ncol,nlev)**5)*alpha50 + (ATB(i,ncol,nlev)**4)*beta50 + & + (ATB(i,ncol,nlev)**3)*gamma50 + (ATB(i,ncol,nlev)**2)*delta50 + & + ATB(i,ncol,nlev)*epsilon50 + zeta50 + ! ######################################################################## + ! 4.2.a) Ice: ATBperp above the phase discrimination line + ! ######################################################################## + ! ICE with temperature above 273,15°K = Liquid (false ice) + if((ATBperp(i,ncol,nlev)-ATBperp_tmp) .ge. 0.)then ! Ice clouds + if(tmp(i,nlev) .gt. 273.15)then + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp ! false ice ==> liq + tmpl(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,5) = lidarcldphase(i,nlev,5)+1._wp + cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,2) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,2) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,2) = 1._wp + endif + + cldlayphase(i,ncol,4,5) = 1. ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,5) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,5) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,5) = 1._wp + endif + else + ! ICE with temperature below 273,15°K + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp + tmpi(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt.(680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + + ! ######################################################################## + ! 4.2.b) Liquid: ATBperp below the phase discrimination line + ! ######################################################################## + else + ! Liquid with temperature above 231,15°K + if(tmp(i,nlev) .gt. 231.15)then + lidarcldphase(i,nlev,2) = lidarcldphase(i,nlev,2)+1._wp + tmpl(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,2) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,2) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,2) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,2) = 1._wp + endif + else + ! Liquid with temperature below 231,15°K = Ice (false liquid) + tmpi(i,ncol,nlev) = tmp(i,nlev) + lidarcldphase(i,nlev,1) = lidarcldphase(i,nlev,1)+1._wp ! false liq ==> ice + lidarcldphase(i,nlev,4) = lidarcldphase(i,nlev,4)+1._wp ! false liq ==> ice + cldlayphase(i,ncol,4,4) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,4) = 1._wp + ! Middle + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,4) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,4) = 1._wp + endif + + cldlayphase(i,ncol,4,1) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,1) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,1) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,1) = 1._wp + endif + endif + endif ! end of discrimination condition + + toplvlsat=0 + + ! Find the level of the highest cloud with SR>30 + if(x(i,ncol,nlev) .gt. S_cld_att) then ! SR > 30. + toplvlsat = nlev+1 + goto 99 + endif + endif ! end of cloud condition + enddo ! end of altitude loop +99 continue + + ! ############################################################################## + ! Undefined phase: For a cloud located below another cloud with SR>30 + ! see Cesana and Chepfer 2013 Sect.III.2 + ! ############################################################################## + if(toplvlsat.ne.0) then + do nlev = toplvlsat,Nlevels + p1 = pplay(i,nlev) + if(cldy(i,ncol,nlev).eq.1.)then + lidarcldphase(i,nlev,3) = lidarcldphase(i,nlev,3)+1._wp + tmpu(i,ncol,nlev) = tmp(i,nlev) + cldlayphase(i,ncol,4,3) = 1._wp ! tot cloud + ! High cloud + if (p1 .gt. 0. .and. p1 .lt. (440._wp*100._wp)) then + cldlayphase(i,ncol,3,3) = 1._wp + ! Middle cloud + else if(p1 .ge. (440._wp*100._wp) .and. p1 .lt. (680._wp*100._wp)) then + cldlayphase(i,ncol,2,3) = 1._wp + ! Low cloud + else + cldlayphase(i,ncol,1,3) = 1._wp + endif + endif + enddo + endif + toplvlsat=0 + enddo + enddo + + ! #################################################################################### + ! Computation of final cloud phase diagnosis + ! #################################################################################### + + ! Compute the Ice percentage in cloud = ice/(ice+liq) as a function of the occurrences + lidarcldphasetmp(:,:) = lidarcldphase(:,:,1)+lidarcldphase(:,:,2); + WHERE (lidarcldphasetmp(:,:) .gt. 0.) + lidarcldphase(:,:,6)=lidarcldphase(:,:,1)/lidarcldphasetmp(:,:) + ELSEWHERE + lidarcldphase(:,:,6) = undef + ENDWHERE + + ! Compute Phase 3D Cloud Fraction + !WHERE (nsub(:,Nlevels:1:-1) .gt. 0.0 ) + WHERE (nsub(:,:) .gt. 0.0 ) + lidarcldphase(:,:,1)=lidarcldphase(:,:,1)/nsub(:,:) + lidarcldphase(:,:,2)=lidarcldphase(:,:,2)/nsub(:,:) + lidarcldphase(:,:,3)=lidarcldphase(:,:,3)/nsub(:,:) + lidarcldphase(:,:,4)=lidarcldphase(:,:,4)/nsub(:,:) + lidarcldphase(:,:,5)=lidarcldphase(:,:,5)/nsub(:,:) + ELSEWHERE + lidarcldphase(:,:,1) = undef + lidarcldphase(:,:,2) = undef + lidarcldphase(:,:,3) = undef + lidarcldphase(:,:,4) = undef + lidarcldphase(:,:,5) = undef + ENDWHERE + + ! Compute Phase low mid high cloud fractions + do iz = 1, Ncat + do i=1,Nphase-3 + do ic = 1, Ncolumns + cldlayerphase(:,iz,i) = cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i) + cldlayerphasesum(:,iz) = cldlayerphasesum(:,iz) + cldlayphase(:,ic,iz,i) + enddo + enddo + enddo + do iz = 1, Ncat + do i=4,5 + do ic = 1, Ncolumns + cldlayerphase(:,iz,i) = cldlayerphase(:,iz,i) + cldlayphase(:,ic,iz,i) + enddo + enddo + enddo + + ! Compute the Ice percentage in cloud = ice/(ice+liq) + cldlayerphasetmp(:,:)=cldlayerphase(:,:,1)+cldlayerphase(:,:,2) + WHERE (cldlayerphasetmp(:,:).gt. 0.) + cldlayerphase(:,:,6)=cldlayerphase(:,:,1)/cldlayerphasetmp(:,:) + ELSEWHERE + cldlayerphase(:,:,6) = undef + ENDWHERE + + do i=1,Nphase-1 + WHERE ( cldlayerphasesum(:,:).gt.0.0 ) + cldlayerphase(:,:,i) = (cldlayerphase(:,:,i)/cldlayerphasesum(:,:)) * cldlayer(:,:) + ENDWHERE + enddo + + do i=1,Npoints + do iz=1,Ncat + checkcldlayerphase=0. + checkcldlayerphase2=0. + if (cldlayerphasesum(i,iz) .gt. 0.0 )then + do ic=1,Nphase-3 + checkcldlayerphase = checkcldlayerphase+cldlayerphase(i,iz,ic) + enddo + checkcldlayerphase2 = cldlayer(i,iz)-checkcldlayerphase + if((checkcldlayerphase2 .gt. 0.01) .or. (checkcldlayerphase2 .lt. -0.01) ) print *, checkcldlayerphase,cldlayer(i,iz) + endif + enddo + enddo + + do i=1,Nphase-1 + WHERE (nsublayer(:,:) .eq. 0.0) + cldlayerphase(:,:,i) = undef + ENDWHERE + enddo + + ! Compute Phase 3D as a function of temperature + do nlev=1,Nlevels + do ncol=1,Ncolumns + do i=1,Npoints + do itemp=1,Ntemp + if(tmpi(i,ncol,nlev).gt.0.)then + if((tmpi(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpi(i,ncol,nlev) .lt. tempmod(itemp+1)) )then + lidarcldtemp(i,itemp,2)=lidarcldtemp(i,itemp,2)+1._wp + endif + elseif(tmpl(i,ncol,nlev) .gt. 0.)then + if((tmpl(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpl(i,ncol,nlev) .lt. tempmod(itemp+1)) )then + lidarcldtemp(i,itemp,3)=lidarcldtemp(i,itemp,3)+1._wp + endif + elseif(tmpu(i,ncol,nlev) .gt. 0.)then + if((tmpu(i,ncol,nlev) .ge. tempmod(itemp)) .and. (tmpu(i,ncol,nlev) .lt. tempmod(itemp+1)) )then + lidarcldtemp(i,itemp,4)=lidarcldtemp(i,itemp,4)+1._wp + endif + endif + enddo + enddo + enddo + enddo + + ! Check temperature cloud fraction + do i=1,Npoints + do itemp=1,Ntemp + checktemp=lidarcldtemp(i,itemp,2)+lidarcldtemp(i,itemp,3)+lidarcldtemp(i,itemp,4) + !if(checktemp .NE. lidarcldtemp(i,itemp,1))then + ! print *, i,itemp + ! print *, lidarcldtemp(i,itemp,1:4) + !endif + + enddo + enddo + + ! Compute the Ice percentage in cloud = ice/(ice+liq) + sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3) + WHERE(sumlidarcldtemp(:,:) .gt. 0.) + lidarcldtemp(:,:,5)=lidarcldtemp(:,:,2)/sumlidarcldtemp(:,:) + ELSEWHERE + lidarcldtemp(:,:,5)=undef + ENDWHERE + + do i=1,4 + WHERE(lidarcldtempind(:,:) .gt. 0.) + lidarcldtemp(:,:,i) = lidarcldtemp(:,:,i)/lidarcldtempind(:,:) + ELSEWHERE + lidarcldtemp(:,:,i) = undef + ENDWHERE + enddo + + RETURN + END SUBROUTINE COSP_CLDFRAC + +end module mod_lidar_simulator Index: LMDZ6/trunk/libf/phylmd/cosp2/math_lib.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/math_lib.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/math_lib.F90 (revision 3358) @@ -0,0 +1,404 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! July 2006: John Haynes - Initial version +! May 2015: Dustin Swales - Modified for COSPv2.0 +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module math_lib + USE COSP_KINDS, ONLY: wp + use mod_cosp_error, ONLY: errorMessage + implicit none + +contains + ! ########################################################################## + ! function PATH_INTEGRAL + ! ########################################################################## + function path_integral(f,s,i1,i2) + use m_mrgrnk + use array_lib + implicit none + ! ######################################################################## + ! Purpose: + ! evalues the integral (f ds) between f(index=i1) and f(index=i2) + ! using the AVINT procedure + ! + ! Inputs: + ! [f] functional values + ! [s] abscissa values + ! [i1] index of lower limit + ! [i2] index of upper limit + ! + ! Returns: + ! result of path integral + ! + ! Notes: + ! [s] may be in forward or reverse numerical order + ! + ! Requires: + ! mrgrnk package + ! + ! Created: + ! 02/02/06 John Haynes (haynes@atmos.colostate.edu) + ! ######################################################################## + + ! INPUTS + real(wp),intent(in), dimension(:) :: & + f, & ! Functional values + s ! Abscissa values + integer, intent(in) :: & + i1, & ! Index of lower limit + i2 ! Index of upper limit + + ! OUTPUTS + real(wp) :: path_integral + + ! Internal variables + real(wp) :: sumo, deltah, val + integer :: nelm, j + integer, dimension(i2-i1+1) :: idx + real(wp), dimension(i2-i1+1) :: f_rev, s_rev + + nelm = i2-i1+1 + if (nelm > 3) then + call mrgrnk(s(i1:i2),idx) + s_rev = s(idx) + f_rev = f(idx) + call avint(f_rev(i1:i2),s_rev(i1:i2),(i2-i1+1), & + s_rev(i1),s_rev(i2), val) + path_integral = val + else + sumo = 0._wp + do j=i1,i2 + deltah = abs(s(i1+1)-s(i1)) + sumo = sumo + f(j)*deltah + enddo + path_integral = sumo + endif + + return + end function path_integral + + ! ########################################################################## + ! subroutine AVINT + ! ########################################################################## + subroutine avint ( ftab, xtab, ntab, a_in, b_in, result ) + implicit none + ! ######################################################################## + ! Purpose: + ! estimate the integral of unevenly spaced data + ! + ! Inputs: + ! [ftab] functional values + ! [xtab] abscissa values + ! [ntab] number of elements of [ftab] and [xtab] + ! [a] lower limit of integration + ! [b] upper limit of integration + ! + ! Outputs: + ! [result] approximate value of integral + ! + ! Reference: + ! From SLATEC libraries, in public domain + ! + !*********************************************************************** + ! + ! AVINT estimates the integral of unevenly spaced data. + ! + ! Discussion: + ! + ! The method uses overlapping parabolas and smoothing. + ! + ! Modified: + ! + ! 30 October 2000 + ! 4 January 2008, A. Bodas-Salcedo. Error control for XTAB taken out of + ! loop to allow vectorization. + ! + ! Reference: + ! + ! Philip Davis and Philip Rabinowitz, + ! Methods of Numerical Integration, + ! Blaisdell Publishing, 1967. + ! + ! P E Hennion, + ! Algorithm 77, + ! Interpolation, Differentiation and Integration, + ! Communications of the Association for Computing Machinery, + ! Volume 5, page 96, 1962. + ! + ! Parameters: + ! + ! Input, real ( kind = 8 ) FTAB(NTAB), the function values, + ! FTAB(I) = F(XTAB(I)). + ! + ! Input, real ( kind = 8 ) XTAB(NTAB), the abscissas at which the + ! function values are given. The XTAB's must be distinct + ! and in ascending order. + ! + ! Input, integer NTAB, the number of entries in FTAB and + ! XTAB. NTAB must be at least 3. + ! + ! Input, real ( kind = 8 ) A, the lower limit of integration. A should + ! be, but need not be, near one endpoint of the interval + ! (X(1), X(NTAB)). + ! + ! Input, real ( kind = 8 ) B, the upper limit of integration. B should + ! be, but need not be, near one endpoint of the interval + ! (X(1), X(NTAB)). + ! + ! Output, real ( kind = 8 ) RESULT, the approximate value of the integral. + ! ########################################################################## + + ! INPUTS + integer,intent(in) :: & + ntab ! Number of elements of [ftab] and [xtab] + real(wp),intent(in) :: & + a_in, & ! Lower limit of integration + b_in ! Upper limit of integration + real(wp),intent(in),dimension(ntab) :: & + ftab, & ! Functional values + xtab ! Abscissa value + + ! OUTPUTS + real(wp),intent(out) :: result ! Approximate value of integral + + ! Internal varaibles + real(wp) :: a, atemp, b, btemp,ca,cb,cc,ctemp,sum1,syl,term1,term2,term3,x1,x2,x3 + integer :: i,ihi,ilo,ind + logical :: lerror + + lerror = .false. + a = a_in + b = b_in + + if ( ntab < 3 ) then + call errorMessage('FATAL ERROR(optics/math_lib.f90:AVINT): Ntab is less than 3.') + return + end if + + do i = 2, ntab + if ( xtab(i) <= xtab(i-1) ) then + lerror = .true. + exit + end if + end do + + if (lerror) then + call errorMessage('FATAL ERROR(optics/math_lib.f90:AVINT): Xtab(i) is not greater than Xtab(i-1).') + return + end if + +!ds result = 0.0D+00 + result = 0._wp + + if ( a == b ) then + call errorMessage('WARNING(optics/math_lib.f90:AVINT): A=B => integral=0') + return + end if + + ! If B < A, temporarily switch A and B, and store sign. + if ( b < a ) then + syl = b + b = a + a = syl + ind = -1 + else + syl = a + ind = 1 + end if + + ! Bracket A and B between XTAB(ILO) and XTAB(IHI). + ilo = 1 + ihi = ntab + + do i = 1, ntab + if ( a <= xtab(i) ) then + exit + end if + ilo = ilo + 1 + end do + + ilo = max ( 2, ilo ) + ilo = min ( ilo, ntab - 1 ) + + do i = 1, ntab + if ( xtab(i) <= b ) then + exit + end if + ihi = ihi - 1 + end do + + ihi = min ( ihi, ntab - 1 ) + ihi = max ( ilo, ihi - 1 ) + + ! Carry out approximate integration from XTAB(ILO) to XTAB(IHI). + sum1 = 0._wp +!ds sum1 = 0.0D+00 + + do i = ilo, ihi + + x1 = xtab(i-1) + x2 = xtab(i) + x3 = xtab(i+1) + + term1 = ftab(i-1) / ( ( x1 - x2 ) * ( x1 - x3 ) ) + term2 = ftab(i) / ( ( x2 - x1 ) * ( x2 - x3 ) ) + term3 = ftab(i+1) / ( ( x3 - x1 ) * ( x3 - x2 ) ) + + atemp = term1 + term2 + term3 + + btemp = - ( x2 + x3 ) * term1 & + - ( x1 + x3 ) * term2 & + - ( x1 + x2 ) * term3 + + ctemp = x2 * x3 * term1 + x1 * x3 * term2 + x1 * x2 * term3 + + if ( i <= ilo ) then + ca = atemp + cb = btemp + cc = ctemp + else + ca = 0.5_wp * ( atemp + ca ) + cb = 0.5_wp * ( btemp + cb ) + cc = 0.5_wp * ( ctemp + cc ) +!ds ca = 0.5D+00 * ( atemp + ca ) +!ds cb = 0.5D+00 * ( btemp + cb ) +!ds cc = 0.5D+00 * ( ctemp + cc ) + end if + + sum1 = sum1 + ca * ( x2**3 - syl**3 ) / 3._wp & + + cb * 0.5_wp * ( x2**2 - syl**2 ) + cc * ( x2 - syl ) +!ds sum1 = sum1 + ca * ( x2**3 - syl**3 ) / 3.0D+00 & +!ds + cb * 0.5D+00 * ( x2**2 - syl**2 ) + cc * ( x2 - syl ) + + ca = atemp + cb = btemp + cc = ctemp + + syl = x2 + + end do + + result = sum1 + ca * ( b**3 - syl**3 ) / 3._wp & + + cb * 0.5_wp * ( b**2 - syl**2 ) + cc * ( b - syl ) +!ds result = sum1 + ca * ( b**3 - syl**3 ) / 3.0D+00 & +!ds + cb * 0.5D+00 * ( b**2 - syl**2 ) + cc * ( b - syl ) + + ! Restore original values of A and B, reverse sign of integral + ! because of earlier switch. + if ( ind /= 1 ) then + ind = 1 + syl = b + b = a + a = syl + result = -result + end if + + return + end subroutine avint + ! ###################################################################################### + ! SUBROUTINE gamma + ! Purpose: + ! Returns the gamma function + ! + ! Input: + ! [x] value to compute gamma function of + ! + ! Returns: + ! gamma(x) + ! + ! Coded: + ! 02/02/06 John Haynes (haynes@atmos.colostate.edu) + ! (original code of unknown origin) + ! ###################################################################################### + function gamma(x) + ! Inputs + real(wp), intent(in) :: x + + ! Outputs + real(wp) :: gamma + + ! Local variables + real(wp) :: pi,ga,z,r,gr + integer :: k,m1,m + + ! Parameters + real(wp),dimension(26),parameter :: & + g = (/1.0,0.5772156649015329, -0.6558780715202538, -0.420026350340952e-1, & + 0.1665386113822915,-0.421977345555443e-1,-0.96219715278770e-2, & + 0.72189432466630e-2,-0.11651675918591e-2, -0.2152416741149e-3, & + 0.1280502823882e-3, -0.201348547807e-4, -0.12504934821e-5, 0.11330272320e-5, & + -0.2056338417e-6, 0.61160950e-8,0.50020075e-8, -0.11812746e-8, 0.1043427e-9, & + 0.77823e-11, -0.36968e-11, 0.51e-12, -0.206e-13, -0.54e-14, 0.14e-14, 0.1e-15/) +!ds real(wp),dimension(26),parameter :: & +!ds g = (/1.0d0,0.5772156649015329d0, -0.6558780715202538d0, -0.420026350340952d-1, & +!ds 0.1665386113822915d0,-0.421977345555443d-1,-0.96219715278770d-2, & +!ds 0.72189432466630d-2,-0.11651675918591d-2, -0.2152416741149d-3, & +!ds 0.1280502823882d-3, -0.201348547807d-4, -0.12504934821d-5, 0.11330272320d-5, & +!ds -0.2056338417d-6, 0.61160950d-8,0.50020075d-8, -0.11812746d-8, 0.1043427d-9, & +!ds 0.77823d-11, -0.36968d-11, 0.51d-12, -0.206d-13, -0.54d-14, 0.14d-14, 0.1d-15/) + + pi = acos(-1._wp) + if (x ==int(x)) then + if (x > 0.0) then + ga=1._wp + m1=x-1 + do k=2,m1 + ga=ga*k + enddo + else + ga=1._wp+300 + endif + else + if (abs(x) > 1.0) then + z=abs(x) + m=int(z) + r=1._wp + do k=1,m + r=r*(z-k) + enddo + z=z-m + else + z=x + endif + gr=g(26) + do k=25,1,-1 + gr=gr*z+g(k) + enddo + ga=1._wp/(gr*z) + if (abs(x) > 1.0) then + ga=ga*r + if (x < 0.0) ga=-pi/(x*ga*sin(pi*x)) + endif + endif + gamma = ga + return + end function gamma +end module math_lib Index: LMDZ6/trunk/libf/phylmd/cosp2/mo_rng.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/mo_rng.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/mo_rng.F90 (revision 3358) @@ -0,0 +1,138 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Original version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE mod_rng + USE cosp_kinds, ONLY: dp, sp, wp + IMPLICIT NONE + + INTEGER, parameter :: ki9 = selected_int_kind(R=9) + integer :: testInt + + TYPE rng_state + INTEGER(ki9) :: seed ! 32 bit integer + END TYPE rng_state + + INTERFACE init_rng + MODULE PROCEDURE init_rng_1, init_rng_n + END INTERFACE init_rng + + INTERFACE get_rng + MODULE PROCEDURE get_rng_1, get_rng_n, get_rng_v + END INTERFACE get_rng + +CONTAINS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Set single seed + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE init_rng_1(s, seed_in) + TYPE(rng_state), INTENT(INOUT) :: s + INTEGER, INTENT(IN ) :: seed_in + s%seed = seed_in + END SUBROUTINE init_rng_1 + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Set vector of seeds + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE init_rng_n(s, seed_in) + TYPE(rng_state), DIMENSION(:), INTENT(INOUT) :: s + INTEGER, DIMENSION(:), INTENT(IN ) :: seed_in + + INTEGER :: i + DO i = 1, SIZE(seed_in) + s(i)%seed = seed_in(i) + END DO + END SUBROUTINE init_rng_n + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Create single random number from seed + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + FUNCTION get_rng_1(s) + TYPE(rng_state), INTENT(INOUT) :: s + REAL(WP) :: get_rng_1 + REAL(SP) :: r + + ! Return the next random numbers + ! Marsaglia CONG algorithm + s%seed=69069*s%seed+1234567 + ! mod 32 bit overflow + s%seed=mod(s%seed,2_ki9**30_ki9) + r = s%seed*0.931322574615479E-09 + + ! convert to range 0-1 (32 bit only) + ! DJS2016: What is being done here is an intentional integer overflow and a test to + ! see if this occured. Some compilers check for integer overflows during + ! compilation (ie. gfortan), while others do not (ie. pgi and ifort). When + ! using gfortran, you cannot use the overflow and test for overflow method, + ! so we use sizeof(someInt) to determine wheter it is on 32 bit. + !if ( i2_16*i2_16 .le. huge32 ) then + if (digits(testInt) .le. 31) then + !if (sizeof(testInt) .eq. 4) then + r=r+1 + r=r-int(r) + endif + get_rng_1 = REAL(r, KIND = WP) + + END FUNCTION get_rng_1 + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Create single random number N times + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + FUNCTION get_rng_n(s, n) RESULT (r) + integer,intent(inout) :: n + TYPE(rng_state),INTENT(INOUT) :: s + ! Return the next N random numbers + REAL(WP), DIMENSION (n) :: r + + INTEGER :: i + + DO i = 1, N + r(i) = get_rng_1(s) + END DO + END FUNCTION get_rng_n + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Create a vector of random numbers from a vector of input seeds + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + FUNCTION get_rng_v(s) RESULT (r) + ! Return the next N random numbers + TYPE(rng_state), DIMENSION(:), INTENT(INOUT) :: s + REAL(WP), DIMENSION (SIZE(S)) :: r + + INTEGER :: i + + DO i = 1, size(s) + r(i) = get_rng_1(s(i)) + END DO + END FUNCTION get_rng_v + +END MODULE mod_rng Index: LMDZ6/trunk/libf/phylmd/cosp2/modis_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/modis_simulator.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/modis_simulator.F90 (revision 3358) @@ -0,0 +1,906 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2009: Robert Pincus - Initial version +! June 2009: Steve Platnick and Robert Pincus - Simple radiative transfer for size +! retrievals +! August 2009: Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) +! November 2009: Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler +! using AM2 (GFDL) +! January 2010: Robert Pincus - Added high, middle, low cloud fractions +! May 2015: Dustin Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! Notes on using the MODIS simulator: +! *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1 +! microns, or optical thickness at 0.67 microns and ice- and liquid-water contents +! (in consistent units of your choosing) +! *) Required input also includes the optical thickness and cloud top pressure +! derived from the ISCCP simulator run with parameter top_height = 1. +! *) Cloud particle sizes are specified as radii, measured in meters, though within the +! module we use units of microns. Where particle sizes are outside the bounds used in +! the MODIS retrieval libraries (parameters re_water_min, re_ice_min, etc.) the +! simulator returns missing values (re_fill) +! +! When error conditions are encountered this code calls the function complain_and_die, +! supplied at the bottom of this module. Users probably want to replace this with +! something more graceful. +! +module mod_modis_sim + USE MOD_COSP_CONFIG, only: R_UNDEF,modis_histTau,modis_histPres,numMODISTauBins, & + numMODISPresBins,numMODISReffIceBins,numMODISReffLiqBins, & + modis_histReffIce,modis_histReffLiq + USE COSP_KINDS, ONLY: wp + use MOD_COSP_STATS, ONLY: hist2D + + implicit none + ! ########################################################################## + ! Retrieval parameters + integer, parameter :: & + num_trial_res = 15 ! Increase to make the linear pseudo-retrieval of size more accurate + + real(wp) :: & + min_OpticalThickness, & ! Minimum detectable optical thickness + CO2Slicing_PressureLimit, & ! Cloud with higher pressures use thermal methods, units Pa + CO2Slicing_TauLimit, & ! How deep into the cloud does CO2 slicing see? + phase_TauLimit, & ! How deep into the cloud does the phase detection see? + size_TauLimit, & ! Depth of the re retreivals + phaseDiscrimination_Threshold, & ! What fraction of total extincton needs to be in a single + ! category to make phase discrim. work? + re_fill, & ! + re_water_min, & ! Minimum effective radius (liquid) + re_water_max, & ! Maximum effective radius (liquid) + re_ice_min, & ! Minimum effective radius (ice) + re_ice_max, & ! Minimum effective radius (ice) + highCloudPressureLimit, & ! High cloud pressure limit (Pa) + lowCloudPressureLimit ! Low cloud pressure limit (Pa) + integer :: & + phaseIsNone, & ! + phaseIsLiquid, & ! + phaseIsIce, & ! + phaseIsUndetermined ! + + real(wp),dimension(num_trial_res) :: & + trial_re_w, & ! Near-IR optical params vs size for retrieval scheme (liquid) + trial_re_i ! Near-IR optical params vs size for retrieval scheme (ice) + real(wp),dimension(num_trial_res) :: & + g_w, & ! Assymettry parameter for size retrieval (liquid) + g_i, & ! Assymettry parameter for size retrieval (ice) + w0_w, & ! Single-scattering albedo for size retrieval (liquid) + w0_i ! Single-scattering albedo for size retrieval (ice) + ! Algorithmic parameters + real(wp),parameter :: & + ice_density = 0.93_wp ! Liquid density is 1. + +contains + ! ######################################################################################## + ! MODIS simulator using specified liquid and ice optical thickness in each layer + ! + ! Note: this simulator operates on all points; to match MODIS itself night-time + ! points should be excluded + ! + ! Note: the simulator requires as input the optical thickness and cloud top pressure + ! derived from the ISCCP simulator run with parameter top_height = 1. + ! If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing + ! and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that + ! alogrithm in this simulator we simply report the values from the ISCCP simulator. + ! ######################################################################################## + subroutine modis_subcolumn(nSubCols, nLevels, pressureLevels, optical_thickness, & + tauLiquidFraction, g, w0,isccpCloudTopPressure, & + retrievedPhase, retrievedCloudTopPressure, & + retrievedTau, retrievedSize) + + ! INPUTS + integer,intent(in) :: & + nSubCols, & ! Number of subcolumns + nLevels ! Number of levels + real(wp),dimension(nLevels+1),intent(in) :: & + pressureLevels ! Gridmean pressure at layer edges (Pa) + real(wp),dimension(nSubCols,nLevels),intent(in) :: & + optical_thickness, & ! Subcolumn optical thickness @ 0.67 microns. + tauLiquidFraction, & ! Liquid water fraction + g, & ! Subcolumn assymetry parameter + w0 ! Subcolumn single-scattering albedo + real(wp),dimension(nSubCols),intent(in) :: & + isccpCloudTopPressure ! ISCCP retrieved cloud top pressure (Pa) + + ! OUTPUTS + integer, dimension(nSubCols), intent(inout) :: & + retrievedPhase ! MODIS retrieved phase (liquid/ice/other) + real(wp),dimension(nSubCols), intent(inout) :: & + retrievedCloudTopPressure, & ! MODIS retrieved CTP (Pa) + retrievedTau, & ! MODIS retrieved optical depth (unitless) + retrievedSize ! MODIS retrieved particle size (microns) + + ! LOCAL VARIABLES + logical, dimension(nSubCols) :: & + cloudMask + real(wp) :: & + integratedLiquidFraction, & + obs_Refl_nir + real(wp),dimension(num_trial_res) :: & + predicted_Refl_nir + integer :: & + i + + ! ######################################################################################## + ! Optical depth retrieval + ! This is simply a sum over the optical thickness in each layer. + ! It should agree with the ISCCP values after min values have been excluded. + ! ######################################################################################## + retrievedTau(1:nSubCols) = sum(optical_thickness(1:nSubCols,1:nLevels), dim = 2) + + ! ######################################################################################## + ! Cloud detection + ! does optical thickness exceed detection threshold? + ! ######################################################################################## + cloudMask = retrievedTau(1:nSubCols) >= min_OpticalThickness + + do i = 1, nSubCols + if(cloudMask(i)) then + ! ################################################################################## + ! Cloud top pressure determination + ! MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal + ! methods for clouds lower than that. For CO2 slicing we report the optical-depth + ! weighted pressure, integrating to a specified optical depth. + ! This assumes linear variation in p between levels. Linear in ln(p) is probably + ! better, though we'd need to deal with the lowest pressure gracefully. + ! ################################################################################## + retrievedCloudTopPressure(i) = cloud_top_pressure(nLevels,(/ 0._wp, optical_thickness(i,1:nLevels) /), & + pressureLevels(1:nLevels),CO2Slicing_TauLimit) + + ! ################################################################################## + ! Phase determination + ! Determine fraction of total tau that's liquid when ice and water contribute about + ! equally to the extinction we can't tell what the phase is. + ! ################################################################################## + integratedLiquidFraction = weight_by_extinction(nLevels,optical_thickness(i,1:nLevels), & + tauLiquidFraction(i, 1:nLevels), & + phase_TauLimit) + if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then + retrievedPhase(i) = phaseIsLiquid + else if (integratedLiquidFraction <= 1._wp- phaseDiscrimination_Threshold) then + retrievedPhase(i) = phaseIsIce + else + retrievedPhase(i) = phaseIsUndetermined + end if + + ! ################################################################################## + ! Size determination + ! ################################################################################## + + ! Compute observed reflectance + obs_Refl_nir = compute_toa_reflectace(nLevels,optical_thickness(i,1:nLevels), g(i,1:nLevels), w0(i,1:nLevels)) + + ! Compute predicted reflectance + if(any(retrievedPhase(i) == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then + if (retrievedPhase(i) == phaseIsLiquid .OR. retrievedPhase(i) == phaseIsUndetermined) then + predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), & + g_w(1:num_trial_res), w0_w(1:num_trial_res)) + retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_w(1:num_trial_res), & + predicted_Refl_nir(1:num_trial_res), obs_Refl_nir) + else + predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), & + g_i(1:num_trial_res), w0_i(1:num_trial_res)) + retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_i(1:num_trial_res), & + predicted_Refl_nir(1:num_trial_res), obs_Refl_nir) + endif + else + retrievedSize(i) = re_fill + endif + else + ! Values when we don't think there's a cloud. + retrievedCloudTopPressure(i) = R_UNDEF + retrievedPhase(i) = phaseIsNone + retrievedSize(i) = R_UNDEF + retrievedTau(i) = R_UNDEF + end if + end do + where((retrievedSize(1:nSubCols) < 0.).and.(retrievedSize(1:nSubCols) /= R_UNDEF)) & + retrievedSize(1:nSubCols) = 1.0e-06_wp*re_fill + + ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS + ! mimics what MODIS does to first order. + ! Of course, ISCCP cloud top pressures are in mb. + where(cloudMask(1:nSubCols) .and. retrievedCloudTopPressure(1:nSubCols) > CO2Slicing_PressureLimit) & + retrievedCloudTopPressure(1:nSubCols) = isccpCloudTopPressure! * 100._wp + + end subroutine modis_subcolumn + + ! ######################################################################################## + subroutine modis_column(nPoints,nSubCols,phase, cloud_top_pressure, optical_thickness, particle_size, & + Cloud_Fraction_Total_Mean, Cloud_Fraction_Water_Mean, Cloud_Fraction_Ice_Mean, & + Cloud_Fraction_High_Mean, Cloud_Fraction_Mid_Mean, Cloud_Fraction_Low_Mean, & + Optical_Thickness_Total_Mean, Optical_Thickness_Water_Mean, Optical_Thickness_Ice_Mean, & + Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10,& + Cloud_Particle_Size_Water_Mean, Cloud_Particle_Size_Ice_Mean, Cloud_Top_Pressure_Total_Mean, & + Liquid_Water_Path_Mean, Ice_Water_Path_Mean, & + Optical_Thickness_vs_Cloud_Top_Pressure,Optical_Thickness_vs_ReffIce,Optical_Thickness_vs_ReffLiq) + + ! INPUTS + integer,intent(in) :: & + nPoints, & ! Number of horizontal gridpoints + nSubCols ! Number of subcolumns + integer,intent(in), dimension(nPoints, nSubCols) :: & + phase + real(wp),intent(in),dimension(nPoints, nSubCols) :: & + cloud_top_pressure, & + optical_thickness, & + particle_size + + ! OUTPUTS + real(wp),intent(inout),dimension(nPoints) :: & ! + Cloud_Fraction_Total_Mean, & ! + Cloud_Fraction_Water_Mean, & ! + Cloud_Fraction_Ice_Mean, & ! + Cloud_Fraction_High_Mean, & ! + Cloud_Fraction_Mid_Mean, & ! + Cloud_Fraction_Low_Mean, & ! + Optical_Thickness_Total_Mean, & ! + Optical_Thickness_Water_Mean, & ! + Optical_Thickness_Ice_Mean, & ! + Optical_Thickness_Total_MeanLog10, & ! + Optical_Thickness_Water_MeanLog10, & ! + Optical_Thickness_Ice_MeanLog10, & ! + Cloud_Particle_Size_Water_Mean, & ! + Cloud_Particle_Size_Ice_Mean, & ! + Cloud_Top_Pressure_Total_Mean, & ! + Liquid_Water_Path_Mean, & ! + Ice_Water_Path_Mean ! + real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISPresBins) :: & + Optical_Thickness_vs_Cloud_Top_Pressure + real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffIceBins) :: & + Optical_Thickness_vs_ReffIce + real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffLiqBins) :: & + Optical_Thickness_vs_ReffLiq + + ! LOCAL VARIABLES + real(wp), parameter :: & + LWP_conversion = 2._wp/3._wp * 1000._wp ! MKS units + integer :: j + logical, dimension(nPoints,nSubCols) :: & + cloudMask, & + waterCloudMask, & + iceCloudMask, & + validRetrievalMask + real(wp),dimension(nPoints,nSubCols) :: & + tauWRK,ctpWRK,reffIceWRK,reffLiqWRK + + ! ######################################################################################## + ! Include only those pixels with successful retrievals in the statistics + ! ######################################################################################## + validRetrievalMask(1:nPoints,1:nSubCols) = particle_size(1:nPoints,1:nSubCols) > 0. + cloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) /= phaseIsNone .and. & + validRetrievalMask(1:nPoints,1:nSubCols) + waterCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsLiquid .and. & + validRetrievalMask(1:nPoints,1:nSubCols) + iceCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsIce .and. & + validRetrievalMask(1:nPoints,1:nSubCols) + + ! ######################################################################################## + ! Use these as pixel counts at first + ! ######################################################################################## + Cloud_Fraction_Total_Mean(1:nPoints) = real(count(cloudMask, dim = 2)) + Cloud_Fraction_Water_Mean(1:nPoints) = real(count(waterCloudMask, dim = 2)) + Cloud_Fraction_Ice_Mean(1:nPoints) = real(count(iceCloudMask, dim = 2)) + Cloud_Fraction_High_Mean(1:nPoints) = real(count(cloudMask .and. cloud_top_pressure <= & + highCloudPressureLimit, dim = 2)) + Cloud_Fraction_Low_Mean(1:nPoints) = real(count(cloudMask .and. cloud_top_pressure > & + lowCloudPressureLimit, dim = 2)) + Cloud_Fraction_Mid_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) - Cloud_Fraction_High_Mean(1:nPoints)& + - Cloud_Fraction_Low_Mean(1:nPoints) + + ! ######################################################################################## + ! Compute column amounts. + ! ######################################################################################## + where(Cloud_Fraction_Total_Mean(1:nPoints) > 0) + Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask, dim = 2) / & + Cloud_Fraction_Total_Mean(1:nPoints) + Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, & + dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints) + elsewhere + Optical_Thickness_Total_Mean = 0._wp + Optical_Thickness_Total_MeanLog10 = 0._wp + endwhere + where(Cloud_Fraction_Water_Mean(1:nPoints) > 0) + Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / & + Cloud_Fraction_Water_Mean(1:nPoints) + Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, & + mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_Mean(1:nPoints) + Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,& + dim = 2) / Cloud_Fraction_Water_Mean(1:nPoints) + Cloud_Particle_Size_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / & + Cloud_Fraction_Water_Mean(1:nPoints) + elsewhere + Optical_Thickness_Water_Mean = 0._wp + Optical_Thickness_Water_MeanLog10 = 0._wp + Cloud_Particle_Size_Water_Mean = 0._wp + Liquid_Water_Path_Mean = 0._wp + endwhere + where(Cloud_Fraction_Ice_Mean(1:nPoints) > 0) + Optical_Thickness_Ice_Mean(1:nPoints) = sum(optical_thickness, mask = iceCloudMask, dim = 2) / & + Cloud_Fraction_Ice_Mean(1:nPoints) + Ice_Water_Path_Mean(1:nPoints) = LWP_conversion * ice_density*sum(particle_size*optical_thickness,& + mask=iceCloudMask,dim = 2) /Cloud_Fraction_Ice_Mean(1:nPoints) + Optical_Thickness_Ice_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = iceCloudMask,& + dim = 2) / Cloud_Fraction_Ice_Mean(1:nPoints) + Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask, dim = 2) / & + Cloud_Fraction_Ice_Mean(1:nPoints) + elsewhere + Optical_Thickness_Ice_Mean = 0._wp + Optical_Thickness_Ice_MeanLog10 = 0._wp + Cloud_Particle_Size_Ice_Mean = 0._wp + Ice_Water_Path_Mean = 0._wp + endwhere + Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / & + max(1, count(cloudMask, dim = 2)) + + ! ######################################################################################## + ! Normalize pixel counts to fraction. + ! ######################################################################################## + Cloud_Fraction_High_Mean(1:nPoints) = Cloud_Fraction_High_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Mid_Mean(1:nPoints) = Cloud_Fraction_Mid_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Low_Mean(1:nPoints) = Cloud_Fraction_Low_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Total_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Ice_Mean(1:nPoints) = Cloud_Fraction_Ice_Mean(1:nPoints) /nSubcols + Cloud_Fraction_Water_Mean(1:nPoints) = Cloud_Fraction_Water_Mean(1:nPoints) /nSubcols + + ! ######################################################################################## + ! Joint histograms + ! ######################################################################################## + ! Loop over all points + tauWRK(1:nPoints,1:nSubCols) = optical_thickness(1:nPoints,1:nSubCols) + ctpWRK(1:nPoints,1:nSubCols) = cloud_top_pressure(1:nPoints,1:nSubCols) + reffIceWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,iceCloudMask) + reffLiqWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,waterCloudMask) + do j=1,nPoints + + ! Fill clear and optically thin subcolumns with fill + where(.not. cloudMask(j,1:nSubCols)) + tauWRK(j,1:nSubCols) = -999._wp + ctpWRK(j,1:nSubCols) = -999._wp + endwhere + ! Joint histogram of tau/CTP + call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,& + modis_histTau,numMODISTauBins,& + modis_histPres,numMODISPresBins,& + Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numMODISTauBins,1:numMODISPresBins)) + ! Joint histogram of tau/ReffICE + call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols, & + modis_histTau,numMODISTauBins,modis_histReffIce, & + numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numMODISTauBins,1:numMODISReffIceBins)) + ! Joint histogram of tau/ReffLIQ + call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols, & + modis_histTau,numMODISTauBins,modis_histReffLiq, & + numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numMODISTauBins,1:numMODISReffLiqBins)) + + enddo + Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins) = & + Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins)/nSubCols + Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins) = & + Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins)/nSubCols + Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins) = & + Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins)/nSubCols + + + ! Unit conversion + where(Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) & + Optical_Thickness_vs_Cloud_Top_Pressure = Optical_Thickness_vs_Cloud_Top_Pressure*100._wp + where(Optical_Thickness_vs_ReffIce /= R_UNDEF) Optical_Thickness_vs_ReffIce = Optical_Thickness_vs_ReffIce*100._wp + where(Optical_Thickness_vs_ReffLiq /= R_UNDEF) Optical_Thickness_vs_ReffLiq = Optical_Thickness_vs_ReffLiq*100._wp + where(Cloud_Fraction_Total_Mean /= R_UNDEF) Cloud_Fraction_Total_Mean = Cloud_Fraction_Total_Mean*100._wp + where(Cloud_Fraction_Water_Mean /= R_UNDEF) Cloud_Fraction_Water_Mean = Cloud_Fraction_Water_Mean*100._wp + where(Cloud_Fraction_Ice_Mean /= R_UNDEF) Cloud_Fraction_Ice_Mean = Cloud_Fraction_Ice_Mean*100._wp + where(Cloud_Fraction_High_Mean /= R_UNDEF) Cloud_Fraction_High_Mean = Cloud_Fraction_High_Mean*100._wp + where(Cloud_Fraction_Mid_Mean /= R_UNDEF) Cloud_Fraction_Mid_Mean = Cloud_Fraction_Mid_Mean*100._wp + where(Cloud_Fraction_Low_Mean /= R_UNDEF) Cloud_Fraction_Low_Mean = Cloud_Fraction_Low_Mean*100._wp + + end subroutine modis_column + + ! ######################################################################################## + function cloud_top_pressure(nLevels,tauIncrement, pressure, tauLimit) + ! INPUTS + integer, intent(in) :: nLevels + real(wp),intent(in),dimension(nLevels) :: tauIncrement, pressure + real(wp),intent(in) :: tauLimit + ! OUTPUTS + real(wp) :: cloud_top_pressure + ! LOCAL VARIABLES + real(wp) :: deltaX, totalTau, totalProduct + integer :: i + + ! Find the extinction-weighted pressure. Assume that pressure varies linearly between + ! layers and use the trapezoidal rule. + totalTau = 0._wp; totalProduct = 0._wp + do i = 2, size(tauIncrement) + if(totalTau + tauIncrement(i) > tauLimit) then + deltaX = tauLimit - totalTau + totalTau = totalTau + deltaX + ! + ! Result for trapezoidal rule when you take less than a full step + ! tauIncrement is a layer-integrated value + ! + totalProduct = totalProduct & + + pressure(i-1) * deltaX & + + (pressure(i) - pressure(i-1)) * deltaX**2/(2._wp * tauIncrement(i)) + else + totalTau = totalTau + tauIncrement(i) + totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2._wp + end if + if(totalTau >= tauLimit) exit + end do + + if (totalTau > 0._wp) then + cloud_top_pressure = totalProduct/totalTau + else + cloud_top_pressure = 0._wp + endif + + end function cloud_top_pressure + + ! ######################################################################################## + function weight_by_extinction(nLevels,tauIncrement, f, tauLimit) + ! INPUTS + integer, intent(in) :: nLevels + real(wp),intent(in),dimension(nLevels) :: tauIncrement, f + real(wp),intent(in) :: tauLimit + ! OUTPUTS + real(wp) :: weight_by_extinction + ! LOCAL VARIABLES + real(wp) :: deltaX, totalTau, totalProduct + integer :: i + + ! Find the extinction-weighted value of f(tau), assuming constant f within each layer + totalTau = 0._wp; totalProduct = 0._wp + do i = 1, size(tauIncrement) + if(totalTau + tauIncrement(i) > tauLimit) then + deltaX = tauLimit - totalTau + totalTau = totalTau + deltaX + totalProduct = totalProduct + deltaX * f(i) + else + totalTau = totalTau + tauIncrement(i) + totalProduct = totalProduct + tauIncrement(i) * f(i) + end if + if(totalTau >= tauLimit) exit + end do + + if (totalTau > 0._wp) then + weight_by_extinction = totalProduct/totalTau + else + weight_by_extinction = 0._wp + endif + + end function weight_by_extinction + + ! ######################################################################################## + pure function interpolate_to_min(x, y, yobs) + ! INPUTS + real(wp),intent(in),dimension(num_trial_res) :: x, y + real(wp),intent(in) :: yobs + ! OUTPUTS + real(wp) :: interpolate_to_min + ! LOCAL VARIABLES + real(wp), dimension(num_trial_res) :: diff + integer :: nPoints, minDiffLoc, lowerBound, upperBound + + ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs) + ! y must be monotonic in x + + nPoints = size(y) + diff(1:num_trial_res) = y(1:num_trial_res) - yobs + minDiffLoc = minloc(abs(diff), dim = 1) + + if(minDiffLoc == 1) then + lowerBound = minDiffLoc + upperBound = minDiffLoc + 1 + else if(minDiffLoc == nPoints) then + lowerBound = minDiffLoc - 1 + upperBound = minDiffLoc + else + if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then + lowerBound = minDiffLoc-1 + upperBound = minDiffLoc + else + lowerBound = minDiffLoc + upperBound = minDiffLoc + 1 + end if + end if + + if(diff(lowerBound) * diff(upperBound) < 0) then + ! + ! Interpolate the root position linearly if we bracket the root + ! + interpolate_to_min = x(upperBound) - & + diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound)) + else + interpolate_to_min = re_fill + end if + + + end function interpolate_to_min + + ! ######################################################################################## + ! Optical properties + ! ######################################################################################## + elemental function get_g_nir_old (phase, re) + ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + + ! INPUTS + integer, intent(in) :: phase + real(wp),intent(in) :: re + ! OUTPUTS + real(wp) :: get_g_nir_old + ! LOCAL VARIABLES(parameters) + real(wp), dimension(3), parameter :: & + ice_coefficients = (/ 0.7432, 4.5563e-3, -2.8697e-5 /), & + small_water_coefficients = (/ 0.8027, -1.0496e-2, 1.7071e-3 /), & + big_water_coefficients = (/ 0.7931, 5.3087e-3, -7.4995e-5 /) + + ! approx. fits from MODIS Collection 5 LUT scattering calculations + if(phase == phaseIsLiquid) then + if(re < 8.) then + get_g_nir_old = fit_to_quadratic(re, small_water_coefficients) + if(re < re_water_min) get_g_nir_old = fit_to_quadratic(re_water_min, small_water_coefficients) + else + get_g_nir_old = fit_to_quadratic(re, big_water_coefficients) + if(re > re_water_max) get_g_nir_old = fit_to_quadratic(re_water_max, big_water_coefficients) + end if + else + get_g_nir_old = fit_to_quadratic(re, ice_coefficients) + if(re < re_ice_min) get_g_nir_old = fit_to_quadratic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_g_nir_old = fit_to_quadratic(re_ice_max, ice_coefficients) + end if + + end function get_g_nir_old + + ! ######################################################################################## + elemental function get_ssa_nir_old (phase, re) + ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + + ! INPUTS + integer, intent(in) :: phase + real(wp),intent(in) :: re + ! OUTPUTS + real(wp) :: get_ssa_nir_old + ! LOCAL VARIABLES (parameters) + real(wp), dimension(4), parameter :: ice_coefficients = (/ 0.9994, -4.5199e-3, 3.9370e-5, -1.5235e-7 /) + real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0008, -2.5626e-3, 1.6024e-5 /) + + ! approx. fits from MODIS Collection 5 LUT scattering calculations + if(phase == phaseIsLiquid) then + get_ssa_nir_old = fit_to_quadratic(re, water_coefficients) + if(re < re_water_min) get_ssa_nir_old = fit_to_quadratic(re_water_min, water_coefficients) + if(re > re_water_max) get_ssa_nir_old = fit_to_quadratic(re_water_max, water_coefficients) + else + get_ssa_nir_old = fit_to_cubic(re, ice_coefficients) + if(re < re_ice_min) get_ssa_nir_old = fit_to_cubic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_ssa_nir_old = fit_to_cubic(re_ice_max, ice_coefficients) + end if + + end function get_ssa_nir_old + + elemental function get_g_nir (phase, re) + ! + ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + ! + + integer, intent(in) :: phase + real(wp), intent(in) :: re + real(wp) :: get_g_nir + + real(wp), dimension(3), parameter :: ice_coefficients = (/ 0.7490, 6.5153e-3, -5.4136e-5 /), & + small_water_coefficients = (/ 1.0364, -8.8800e-2, 7.0000e-3 /) + real(wp), dimension(4), parameter :: big_water_coefficients = (/ 0.6035, 2.8993e-2, -1.1051e-3, 1.5134e-5 /) + + ! approx. fits from MODIS Collection 6 LUT scattering calculations for 3.7 µm channel size retrievals + if(phase == phaseIsLiquid) then + if(re < 7.) then + get_g_nir = fit_to_quadratic(re, small_water_coefficients) + if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients) + else + get_g_nir = fit_to_cubic(re, big_water_coefficients) + if(re > re_water_max) get_g_nir = fit_to_cubic(re_water_max, big_water_coefficients) + end if + else + get_g_nir = fit_to_quadratic(re, ice_coefficients) + if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients) + end if + + end function get_g_nir + + ! -------------------------------------------- + elemental function get_ssa_nir (phase, re) + integer, intent(in) :: phase + real(wp), intent(in) :: re + real(wp) :: get_ssa_nir + ! + ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function + ! of size for ice and water + ! Fits from Steve Platnick + ! + real(wp), dimension(4), parameter :: ice_coefficients = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/) + real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0044, -1.1397e-2, 1.3300e-4 /) + + ! approx. fits from MODIS Collection 6 LUT scattering calculations + if(phase == phaseIsLiquid) then + get_ssa_nir = fit_to_quadratic(re, water_coefficients) + if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients) + if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients) + else + get_ssa_nir = fit_to_cubic(re, ice_coefficients) + if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients) + if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients) + end if + + end function get_ssa_nir + + + + ! ######################################################################################## + pure function fit_to_cubic(x, coefficients) + ! INPUTS + real(wp), intent(in) :: x + real(wp), dimension(4), intent(in) :: coefficients + ! OUTPUTS + real(wp) :: fit_to_cubic + + fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4))) + end function fit_to_cubic + + ! ######################################################################################## + pure function fit_to_quadratic(x, coefficients) + ! INPUTS + real(wp), intent(in) :: x + real(wp), dimension(3), intent(in) :: coefficients + ! OUTPUTS + real(wp) :: fit_to_quadratic + + fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3))) + end function fit_to_quadratic + + ! ######################################################################################## + ! Radiative transfer + ! ######################################################################################## + pure function compute_toa_reflectace(nLevels,tau, g, w0) + ! This wrapper reports reflectance only and strips out non-cloudy elements from the + ! calculation + + ! INPUTS + integer,intent(in) :: nLevels + real(wp),intent(in),dimension(nLevels) :: tau, g, w0 + ! OUTPUTS + real(wp) :: compute_toa_reflectace + ! LOCAL VARIABLES + logical, dimension(nLevels) :: cloudMask + integer, dimension(count(tau(1:nLevels) > 0)) :: cloudIndicies + real(wp),dimension(count(tau(1:nLevels) > 0)) :: Refl,Trans + real(wp) :: Refl_tot, Trans_tot + integer :: i + + cloudMask(1:nLevels) = tau(1:nLevels) > 0. + cloudIndicies = pack((/ (i, i = 1, nLevels) /), mask = cloudMask) + do i = 1, size(cloudIndicies) + call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i)) + end do + + call adding_doubling(count(tau(1:nLevels) > 0),Refl(:), Trans(:), Refl_tot, Trans_tot) + + compute_toa_reflectace = Refl_tot + + end function compute_toa_reflectace + + ! ######################################################################################## + pure subroutine two_stream(tauint, gint, w0int, ref, tra) + ! Compute reflectance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + ! INPUTS + real(wp), intent(in) :: tauint, gint, w0int + ! OUTPUTS + real(wp), intent(out) :: ref, tra + ! LOCAL VARIABLES + ! for delta Eddington code + ! xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1) + integer, parameter :: beam = 2 + real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 + real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, & + rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th + + ! Compute reflectance and transmittance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + f = gint**2 + tau = (1._wp - w0int * f) * tauint + w0 = (1._wp - f) * w0int / (1._wp - w0int * f) + g = (gint - f) / (1._wp - f) + + ! delta-Eddington (Joseph et al. 1976) + gamma1 = (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp + gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp + gamma3 = (2._wp - 3._wp*g*xmu) / 4._wp + gamma4 = 1._wp - gamma3 + + if (w0int > minConservativeW0) then + ! Conservative scattering + if (beam == 1) then + rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu))) + + ref = rh / (1._wp + gamma1 * tau) + tra = 1._wp - ref + else if(beam == 2) then + ref = gamma1*tau/(1._wp + gamma1*tau) + tra = 1._wp - ref + endif + else + ! Non-conservative scattering + a1 = gamma1 * gamma4 + gamma2 * gamma3 + a2 = gamma1 * gamma3 + gamma2 * gamma4 + + rk = sqrt(gamma1**2 - gamma2**2) + + r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3) + r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3) + r3 = 2._wp * rk *(gamma3 - a2 * xmu) + r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1) + r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1) + + t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4) + t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4) + t3 = 2._wp * rk * (gamma4 + a1 * xmu) + t4 = r4 + t5 = r5 + + beta = -r5 / r4 + + e1 = min(rk * tau, 500._wp) + e2 = min(tau / xmu, 500._wp) + + if (beam == 1) then + den = r4 * exp(e1) + r5 * exp(-e1) + ref = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den + den = t4 * exp(e1) + t5 * exp(-e1) + th = exp(-e2) + tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den + elseif (beam == 2) then + ef1 = exp(-e1) + ef2 = exp(-2*e1) + ref = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2)) + tra = (2._wp*rk*ef1)/((rk+gamma1)*(1._wp-beta*ef2)) + endif + end if + end subroutine two_stream + + ! ######################################################################################## + elemental function two_stream_reflectance(tauint, gint, w0int) + ! Compute reflectance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + + ! INPUTS + real(wp), intent(in) :: tauint, gint, w0int + ! OUTPUTS + real(wp) :: two_stream_reflectance + ! LOCAL VARIABLES + ! for delta Eddington code + ! xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1) + integer, parameter :: beam = 2 + real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 + real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, & + rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den + + f = gint**2 + tau = (1._wp - w0int * f) * tauint + w0 = (1._wp - f) * w0int / (1._wp - w0int * f) + g = (gint - f) / (1._wp - f) + + ! delta-Eddington (Joseph et al. 1976) + gamma1 = (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp + gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp + gamma3 = (2._wp - 3._wp*g*xmu) / 4._wp + gamma4 = 1._wp - gamma3 + + if (w0int > minConservativeW0) then + ! Conservative scattering + if (beam == 1) then + rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu))) + two_stream_reflectance = rh / (1._wp + gamma1 * tau) + elseif (beam == 2) then + two_stream_reflectance = gamma1*tau/(1._wp + gamma1*tau) + endif + + else ! + + ! Non-conservative scattering + a1 = gamma1 * gamma4 + gamma2 * gamma3 + a2 = gamma1 * gamma3 + gamma2 * gamma4 + + rk = sqrt(gamma1**2 - gamma2**2) + + r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3) + r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3) + r3 = 2._wp * rk *(gamma3 - a2 * xmu) + r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1) + r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1) + + t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4) + t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4) + t3 = 2._wp * rk * (gamma4 + a1 * xmu) + t4 = r4 + t5 = r5 + + beta = -r5 / r4 + + e1 = min(rk * tau, 500._wp) + e2 = min(tau / xmu, 500._wp) + + if (beam == 1) then + den = r4 * exp(e1) + r5 * exp(-e1) + two_stream_reflectance = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den + elseif (beam == 2) then + ef1 = exp(-e1) + ef2 = exp(-2*e1) + two_stream_reflectance = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2)) + endif + + end if + end function two_stream_reflectance + + ! ######################################################################################## + pure subroutine adding_doubling (npts,Refl, Tran, Refl_tot, Tran_tot) + ! Use adding/doubling formulas to compute total reflectance and transmittance from + ! layer values + + ! INPUTS + integer,intent(in) :: npts + real(wp),intent(in),dimension(npts) :: Refl,Tran + ! OUTPUTS + real(wp),intent(out) :: Refl_tot, Tran_tot + ! LOCAL VARIABLES + integer :: i + real(wp), dimension(npts) :: Refl_cumulative, Tran_cumulative + + Refl_cumulative(1) = Refl(1) + Tran_cumulative(1) = Tran(1) + + do i=2, npts + ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface): + Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1._wp - Refl_cumulative(i-1) * Refl(i)) + Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1._wp - Refl_cumulative(i-1) * Refl(i)) + end do + + Refl_tot = Refl_cumulative(size(Refl)) + Tran_tot = Tran_cumulative(size(Refl)) + + end subroutine adding_doubling + +end module mod_modis_sim Index: LMDZ6/trunk/libf/phylmd/cosp2/mrgrnk.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/mrgrnk.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/mrgrnk.F90 (revision 3358) @@ -0,0 +1,645 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015: Dustin Swales - Modified for COSPv2.0 +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +Module m_mrgrnk + USE COSP_KINDS, ONLY: wp + Integer, Parameter :: kdp = selected_real_kind(15) + public :: mrgrnk + private :: kdp + private :: R_mrgrnk, I_mrgrnk, D_mrgrnk + + interface mrgrnk +! module procedure D_mrgrnk, R_mrgrnk, I_mrgrnk + module procedure R_mrgrnk, I_mrgrnk + + end interface +contains + + Subroutine D_mrgrnk (XDONT, IRNGT) + ! __________________________________________________________ + ! MRGRNK = Merge-sort ranking of an array + ! For performance reasons, the first 2 passes are taken + ! out of the standard loop, and use dedicated coding. + ! __________________________________________________________ + ! __________________________________________________________ + Real (wp), Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT + ! __________________________________________________________ + Real (wp) :: XVALA, XVALB + ! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB + ! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select + ! + ! Fill-in the index array, creating ordered couples + ! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If + ! + ! We will now have ordered subsets A - B - A - B - ... + ! and merge A and B couples into C - C - ... + ! + LMTNA = 2 + LMTNC = 4 + ! + ! First iteration. The length of the ordered subsets goes from 2 to 4 + ! + Do + If (NVAL <= 2) Exit + ! + ! Loop on merges of A and B into C + ! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit + ! + ! 1 2 3 + ! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit + ! + ! 1 3 2 + ! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 + ! + ! 3 1 2 + ! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If + ! + ! 1 2 3 4 + ! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle + ! + ! 1 3 x x + ! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then + ! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else + ! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + ! + ! 3 x x x + ! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then + ! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else + ! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else + ! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do + ! + ! The Cs become As and Bs + ! + LMTNA = 4 + Exit + End Do + ! + ! Iteration loop. Each time, the length of the ordered subsets + ! is doubled. + ! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC + ! + ! Loop on merges of A and B into C + ! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 + ! + ! Shortcut for the case when the max of A is smaller + ! than the min of B. This line may be activated when the + ! initial set is already close to sorted. + ! + ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE + ! + ! One steps in the C subset, that we build in the final rank array + ! + ! Make a copy of the rank array for the merge iteration + ! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) + ! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) + ! + Do + IWRK = IWRK + 1 + ! + ! We still have unprocessed values in both A and B + ! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then + ! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If + ! + End Do + End Do + ! + ! The Cs become As and Bs + ! + LMTNA = 2 * LMTNA + End Do + ! + Return + ! + End Subroutine D_mrgrnk + + Subroutine R_mrgrnk (XDONT, IRNGT) + ! __________________________________________________________ + ! MRGRNK = Merge-sort ranking of an array + ! For performance reasons, the first 2 passes are taken + ! out of the standard loop, and use dedicated coding. + ! __________________________________________________________ + ! _________________________________________________________ + Real(wp), Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT + ! __________________________________________________________ + Real(wp) :: XVALA, XVALB + ! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB + ! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select + ! + ! Fill-in the index array, creating ordered couples + ! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If + ! + ! We will now have ordered subsets A - B - A - B - ... + ! and merge A and B couples into C - C - ... + ! + LMTNA = 2 + LMTNC = 4 + ! + ! First iteration. The length of the ordered subsets goes from 2 to 4 + ! + Do + If (NVAL <= 2) Exit + ! + ! Loop on merges of A and B into C + ! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit + ! + ! 1 2 3 + ! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit + ! + ! 1 3 2 + ! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 + ! + ! 3 1 2 + ! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If + ! + ! 1 2 3 4 + ! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle + ! + ! 1 3 x x + ! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then + ! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else + ! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + ! + ! 3 x x x + ! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then + ! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else + ! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else + ! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do + ! + ! The Cs become As and Bs + ! + LMTNA = 4 + Exit + End Do + ! + ! Iteration loop. Each time, the length of the ordered subsets + ! is doubled. + ! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC + ! + ! Loop on merges of A and B into C + ! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 + ! + ! Shortcut for the case when the max of A is smaller + ! than the min of B. This line may be activated when the + ! initial set is already close to sorted. + ! + ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE + ! + ! One steps in the C subset, that we build in the final rank array + ! + ! Make a copy of the rank array for the merge iteration + ! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) + ! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) + ! + Do + IWRK = IWRK + 1 + ! + ! We still have unprocessed values in both A and B + ! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then + ! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If + ! + End Do + End Do + ! + ! The Cs become As and Bs + ! + LMTNA = 2 * LMTNA + End Do + ! + Return + ! + End Subroutine R_mrgrnk + Subroutine I_mrgrnk (XDONT, IRNGT) + ! __________________________________________________________ + ! MRGRNK = Merge-sort ranking of an array + ! For performance reasons, the first 2 passes are taken + ! out of the standard loop, and use dedicated coding. + ! __________________________________________________________ + ! __________________________________________________________ + Integer, Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT + ! __________________________________________________________ + Integer :: XVALA, XVALB + ! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB + ! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select + ! + ! Fill-in the index array, creating ordered couples + ! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If + ! + ! We will now have ordered subsets A - B - A - B - ... + ! and merge A and B couples into C - C - ... + ! + LMTNA = 2 + LMTNC = 4 + ! + ! First iteration. The length of the ordered subsets goes from 2 to 4 + ! + Do + If (NVAL <= 2) Exit + ! + ! Loop on merges of A and B into C + ! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit + ! + ! 1 2 3 + ! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit + ! + ! 1 3 2 + ! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 + ! + ! 3 1 2 + ! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If + ! + ! 1 2 3 4 + ! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle + ! + ! 1 3 x x + ! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then + ! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else + ! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + ! + ! 3 x x x + ! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then + ! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else + ! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else + ! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do + ! + ! The Cs become As and Bs + ! + LMTNA = 4 + Exit + End Do + ! + ! Iteration loop. Each time, the length of the ordered subsets + ! is doubled. + ! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC + ! + ! Loop on merges of A and B into C + ! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 + ! + ! Shortcut for the case when the max of A is smaller + ! than the min of B. This line may be activated when the + ! initial set is already close to sorted. + ! + ! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE + ! + ! One steps in the C subset, that we build in the final rank array + ! + ! Make a copy of the rank array for the merge iteration + ! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) + ! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) + ! + Do + IWRK = IWRK + 1 + ! + ! We still have unprocessed values in both A and B + ! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then + ! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If + ! + End Do + End Do + ! + ! The Cs become As and Bs + ! + LMTNA = 2 * LMTNA + End Do + ! + Return + ! + End Subroutine I_mrgrnk +end module m_mrgrnk Index: LMDZ6/trunk/libf/phylmd/cosp2/optics_lib.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/optics_lib.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/optics_lib.F90 (revision 3358) @@ -0,0 +1,771 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! July 2006: John Haynes - Initial version +! May 2015: Dustin Swales - Modified for COSPv2.0 +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module optics_lib + USE COSP_KINDS, ONLY: wp + use mod_cosp_error, ONLY: errorMessage + implicit none + +contains + + ! ############################################################################## + ! subroutine M_WAT + ! ############################################################################## + subroutine m_wat(freq, tk, n_r, n_i) + ! ############################################################################ + ! + ! Purpose: + ! compute complex index of refraction of liquid water + ! + ! Inputs: + ! [freq] frequency (GHz) + ! [tk] temperature (K) + ! + ! Outputs: + ! [n_r] real part index of refraction + ! [n_i] imaginary part index of refraction + ! + ! Reference: + ! Based on the work of Ray (1972) + ! + ! Coded: + ! 03/22/05 John Haynes (haynes@atmos.colostate.edu) + ! ############################################################################ + + ! INPUTS + real(wp), intent(in) :: & + freq, & ! Frequency (GHz) + tk ! Temperature (K) + + ! OUTPUTS + real(wp), intent(out) :: & + n_r, & ! Real part of index of refraction + n_i ! Imaginary part of index of refraction + + ! Internal variables + real(wp) :: ld,es,ei,a,ls,sg,tm1,cos1,sin1,e_r,e_i,pi,tc + complex(wp) :: e_comp, sq + + tc = tk - 273.15_wp + + ld = 100._wp*2.99792458E8_wp/(freq*1E9_wp) + es = 78.54_wp*(1-(4.579E-3_wp*(tc-25._wp)+1.19E-5_wp*(tc-25._wp)**2 & + -2.8E-8_wp*(tc-25._wp)**3)) + ei = 5.27137_wp+0.021647_wp*tc-0.00131198_wp*tc**2 + a = -(16.8129_wp/(tc+273._wp))+0.0609265_wp + ls = 0.00033836_wp*exp(2513.98_wp/(tc+273._wp)) + sg = 12.5664E8_wp + + tm1 = (ls/ld)**(1-a) + pi = acos(-1._wp) + cos1 = cos(0.5_wp*a*pi) + sin1 = sin(0.5_wp*a*pi) + + e_r = ei + (((es-ei)*(1.+tm1*sin1))/(1._wp+2*tm1*sin1+tm1**2)) + e_i = (((es-ei)*tm1*cos1)/(1._wp+2*tm1*sin1+tm1**2)) & + +((sg*ld)/1.885E11_wp) + +!ds e_comp = cmplx(e_r,e_i,Kind=Kind(0d0)) + e_comp = cmplx(e_r,e_i,Kind=wp) + sq = sqrt(e_comp) + + n_r = real(sq) + n_i = aimag(sq) + + return + end subroutine m_wat + + ! ############################################################################ + ! subroutine M_ICE + ! ############################################################################ + subroutine m_ice(freq,t,n_r,n_i) + ! ########################################################################## + ! + ! Purpose: + ! compute complex index of refraction of ice + ! + ! Inputs: + ! [freq] frequency (GHz) + ! [t] temperature (K) + ! + ! Outputs: + ! [n_r] real part index of refraction + ! [n_i] imaginary part index of refraction + ! + ! Reference: + ! Fortran 90 port from IDL of REFICE by Stephen G. Warren + ! + ! Modified: + ! 05/31/05 John Haynes (haynes@atmos.colostate.edu) + ! ########################################################################## + + ! INPUTS + real(wp), intent(in) :: & + freq, & ! Frequency (GHz) + t ! Temperature (K) + + ! OUTPUTS + real(wp), intent(out) :: & + n_r, & ! Real part of index of refraction + n_i ! Imaginary part of index of refraction + + ! Internal variables + integer :: i,lt1,lt2 + real(wp) :: alam,pi,t1,t2, & + x,x1,x2,y,y1,y2,ylo,yhi,tk + + + ! Parameters: + integer,parameter :: & + nwl = 468, & ! + nwlt = 62 ! + real(wp),parameter,dimension(4) :: & + temref = [272.16,268.16,253.16,213.16] + real(wp),parameter :: & ! + wlmin = 0.045, & ! + wlmax = 8.6e6, & ! + cutice = 167.0 + real(wp),parameter,dimension(nwlt) :: & + wlt = & + [0.1670e+03, 0.1778e+03, 0.1884e+03, 0.1995e+03, 0.2113e+03, 0.2239e+03, & + 0.2371e+03, 0.2512e+03, 0.2661e+03, 0.2818e+03, 0.2985e+03, 0.3162e+03, & + 0.3548e+03, 0.3981e+03, 0.4467e+03, 0.5012e+03, 0.5623e+03, 0.6310e+03, & + 0.7943e+03, 0.1000e+04, 0.1259e+04, 0.2500e+04, 0.5000e+04, 0.1000e+05, & + 0.2000e+05, 0.3200e+05, 0.3500e+05, 0.4000e+05, 0.4500e+05, 0.5000e+05, & + 0.6000e+05, 0.7000e+05, 0.9000e+05, 0.1110e+06, 0.1200e+06, 0.1300e+06, & + 0.1400e+06, 0.1500e+06, 0.1600e+06, 0.1700e+06, 0.1800e+06, 0.2000e+06, & + 0.2500e+06, 0.2900e+06, 0.3200e+06, 0.3500e+06, 0.3800e+06, 0.4000e+06, & + 0.4500e+06, 0.5000e+06, 0.6000e+06, 0.6400e+06, 0.6800e+06, 0.7200e+06, & + 0.7600e+06, 0.8000e+06, 0.8400e+06, 0.9000e+06, 0.1000e+07, 0.2000e+07, & + 0.5000e+07,0.8600e+07] + real(wp),parameter,dimension(nwl) :: & + tabim = & + [0.1640e+00, 0.1730e+00, 0.1830e+00, 0.1950e+00, 0.2080e+00, 0.2230e+00, & + 0.2400e+00, 0.2500e+00, 0.2590e+00, 0.2680e+00, 0.2790e+00, 0.2970e+00, & + 0.3190e+00, 0.3400e+00, 0.3660e+00, 0.3920e+00, 0.4160e+00, 0.4400e+00, & + 0.4640e+00, 0.4920e+00, 0.5170e+00, 0.5280e+00, 0.5330e+00, 0.5340e+00, & + 0.5310e+00, 0.5240e+00, 0.5100e+00, 0.5000e+00, 0.4990e+00, 0.4680e+00, & + 0.3800e+00, 0.3600e+00, 0.3390e+00, 0.3180e+00, 0.2910e+00, 0.2510e+00, & + 0.2440e+00, 0.2390e+00, 0.2390e+00, 0.2440e+00, 0.2470e+00, 0.2240e+00, & + 0.1950e+00, 0.1740e+00, 0.1720e+00, 0.1800e+00, 0.1940e+00, 0.2130e+00, & + 0.2430e+00, 0.2710e+00, 0.2890e+00, 0.3340e+00, 0.3440e+00, 0.3820e+00, & + 0.4010e+00, 0.4065e+00, 0.4050e+00, 0.3890e+00, 0.3770e+00, 0.3450e+00, & + 0.3320e+00, 0.3150e+00, 0.2980e+00, 0.2740e+00, 0.2280e+00, 0.1980e+00, & + 0.1720e+00, 0.1560e+00, 0.1100e+00, 0.8300e-01, 0.5800e-01, 0.2200e-01, & + 0.1000e-01, 0.3000e-02, 0.1000e-02, 0.3000e-03, 0.1000e-03, 0.3000e-04, & + 0.1000e-04, 0.3000e-05, 0.1000e-05, 0.7000e-06, 0.4000e-06, 0.2000e-06, & + 0.1000e-06, 0.6377e-07, 0.3750e-07, 0.2800e-07, 0.2400e-07, 0.2200e-07, & + 0.1900e-07, 0.1750e-07, 0.1640e-07, 0.1590e-07, 0.1325e-07, 0.8623e-08, & + 0.5504e-08, 0.3765e-08, 0.2710e-08, 0.2510e-08, 0.2260e-08, 0.2080e-08, & + 0.1910e-08, 0.1540e-08, 0.1530e-08, 0.1550e-08, 0.1640e-08, 0.1780e-08, & + 0.1910e-08, 0.2140e-08, 0.2260e-08, 0.2540e-08, 0.2930e-08, 0.3110e-08, & + 0.3290e-08, 0.3520e-08, 0.4040e-08, 0.4880e-08, 0.5730e-08, 0.6890e-08, & + 0.8580e-08, 0.1040e-07, 0.1220e-07, 0.1430e-07, 0.1660e-07, 0.1890e-07, & + 0.2090e-07, 0.2400e-07, 0.2900e-07, 0.3440e-07, 0.4030e-07, 0.4300e-07, & + 0.4920e-07, 0.5870e-07, 0.7080e-07, 0.8580e-07, 0.1020e-06, 0.1180e-06, & + 0.1340e-06, 0.1400e-06, 0.1430e-06, 0.1450e-06, 0.1510e-06, 0.1830e-06, & + 0.2150e-06, 0.2650e-06, 0.3350e-06, 0.3920e-06, 0.4200e-06, 0.4440e-06, & + 0.4740e-06, 0.5110e-06, 0.5530e-06, 0.6020e-06, 0.7550e-06, 0.9260e-06, & + 0.1120e-05, 0.1330e-05, 0.1620e-05, 0.2000e-05, 0.2250e-05, 0.2330e-05, & + 0.2330e-05, 0.2170e-05, 0.1960e-05, 0.1810e-05, 0.1740e-05, 0.1730e-05, & + 0.1700e-05, 0.1760e-05, 0.1820e-05, 0.2040e-05, 0.2250e-05, 0.2290e-05, & + 0.3040e-05, 0.3840e-05, 0.4770e-05, 0.5760e-05, 0.6710e-05, 0.8660e-05, & + 0.1020e-04, 0.1130e-04, 0.1220e-04, 0.1290e-04, 0.1320e-04, 0.1350e-04, & + 0.1330e-04, 0.1320e-04, 0.1320e-04, 0.1310e-04, 0.1320e-04, 0.1320e-04, & + 0.1340e-04, 0.1390e-04, 0.1420e-04, 0.1480e-04, 0.1580e-04, 0.1740e-04, & + 0.1980e-04, 0.2500e-04, 0.5400e-04, 0.1040e-03, 0.2030e-03, 0.2708e-03, & + 0.3511e-03, 0.4299e-03, 0.5181e-03, 0.5855e-03, 0.5899e-03, 0.5635e-03, & + 0.5480e-03, 0.5266e-03, 0.4394e-03, 0.3701e-03, 0.3372e-03, 0.2410e-03, & + 0.1890e-03, 0.1660e-03, 0.1450e-03, 0.1280e-03, 0.1030e-03, 0.8600e-04, & + 0.8220e-04, 0.8030e-04, 0.8500e-04, 0.9900e-04, 0.1500e-03, 0.2950e-03, & + 0.4687e-03, 0.7615e-03, 0.1010e-02, 0.1313e-02, 0.1539e-02, 0.1588e-02, & + 0.1540e-02, 0.1412e-02, 0.1244e-02, 0.1068e-02, 0.8414e-03, 0.5650e-03, & + 0.4320e-03, 0.3500e-03, 0.2870e-03, 0.2210e-03, 0.2030e-03, 0.2010e-03, & + 0.2030e-03, 0.2140e-03, 0.2320e-03, 0.2890e-03, 0.3810e-03, 0.4620e-03, & + 0.5480e-03, 0.6180e-03, 0.6800e-03, 0.7300e-03, 0.7820e-03, 0.8480e-03, & + 0.9250e-03, 0.9200e-03, 0.8920e-03, 0.8700e-03, 0.8900e-03, 0.9300e-03, & + 0.1010e-02, 0.1350e-02, 0.3420e-02, 0.7920e-02, 0.2000e-01, 0.3800e-01, & + 0.5200e-01, 0.6800e-01, 0.9230e-01, 0.1270e+00, 0.1690e+00, 0.2210e+00, & + 0.2760e+00, 0.3120e+00, 0.3470e+00, 0.3880e+00, 0.4380e+00, 0.4930e+00, & + 0.5540e+00, 0.6120e+00, 0.6250e+00, 0.5930e+00, 0.5390e+00, 0.4910e+00, & + 0.4380e+00, 0.3720e+00, 0.3000e+00, 0.2380e+00, 0.1930e+00, 0.1580e+00, & + 0.1210e+00, 0.1030e+00, 0.8360e-01, 0.6680e-01, 0.5400e-01, 0.4220e-01, & + 0.3420e-01, 0.2740e-01, 0.2200e-01, 0.1860e-01, 0.1520e-01, 0.1260e-01, & + 0.1060e-01, 0.8020e-02, 0.6850e-02, 0.6600e-02, 0.6960e-02, 0.9160e-02, & + 0.1110e-01, 0.1450e-01, 0.2000e-01, 0.2300e-01, 0.2600e-01, 0.2900e-01, & + 0.2930e-01, 0.3000e-01, 0.2850e-01, 0.1730e-01, 0.1290e-01, 0.1200e-01, & + 0.1250e-01, 0.1340e-01, 0.1400e-01, 0.1750e-01, 0.2400e-01, 0.3500e-01, & + 0.3800e-01, 0.4200e-01, 0.4600e-01, 0.5200e-01, 0.5700e-01, 0.6900e-01, & + 0.7000e-01, 0.6700e-01, 0.6500e-01, 0.6400e-01, 0.6200e-01, 0.5900e-01, & + 0.5700e-01, 0.5600e-01, 0.5500e-01, 0.5700e-01, 0.5800e-01, 0.5700e-01, & + 0.5500e-01, 0.5500e-01, 0.5400e-01, 0.5200e-01, 0.5200e-01, 0.5200e-01, & + 0.5200e-01, 0.5000e-01, 0.4700e-01, 0.4300e-01, 0.3900e-01, 0.3700e-01, & + 0.3900e-01, 0.4000e-01, 0.4200e-01, 0.4400e-01, 0.4500e-01, 0.4600e-01, & + 0.4700e-01, 0.5100e-01, 0.6500e-01, 0.7500e-01, 0.8800e-01, 0.1080e+00, & + 0.1340e+00, 0.1680e+00, 0.2040e+00, 0.2480e+00, 0.2800e+00, 0.3410e+00, & + 0.3790e+00, 0.4090e+00, 0.4220e+00, 0.4220e+00, 0.4030e+00, 0.3890e+00, & + 0.3740e+00, 0.3540e+00, 0.3350e+00, 0.3150e+00, 0.2940e+00, 0.2710e+00, & + 0.2460e+00, 0.1980e+00, 0.1640e+00, 0.1520e+00, 0.1420e+00, 0.1280e+00, & + 0.1250e+00, 0.1230e+00, 0.1160e+00, 0.1070e+00, 0.7900e-01, 0.7200e-01, & + 0.7600e-01, 0.7500e-01, 0.6700e-01, 0.5500e-01, 0.4500e-01, 0.2900e-01, & + 0.2750e-01, 0.2700e-01, 0.2730e-01, 0.2890e-01, 0.3000e-01, 0.3400e-01, & + 0.5300e-01, 0.7550e-01, 0.1060e+00, 0.1350e+00, 0.1761e+00, 0.2229e+00, & + 0.2746e+00, 0.3280e+00, 0.3906e+00, 0.4642e+00, 0.5247e+00, 0.5731e+00, & + 0.6362e+00, 0.6839e+00, 0.7091e+00, 0.6790e+00, 0.6250e+00, 0.5654e+00, & + 0.5433e+00, 0.5292e+00, 0.5070e+00, 0.4883e+00, 0.4707e+00, 0.4203e+00, & + 0.3771e+00, 0.3376e+00, 0.3056e+00, 0.2835e+00, 0.3170e+00, 0.3517e+00, & + 0.3902e+00, 0.4509e+00, 0.4671e+00, 0.4779e+00, 0.4890e+00, 0.4899e+00, & + 0.4873e+00, 0.4766e+00, 0.4508e+00, 0.4193e+00, 0.3880e+00, 0.3433e+00, & + 0.3118e+00, 0.2935e+00, 0.2350e+00, 0.1981e+00, 0.1865e+00, 0.1771e+00, & + 0.1620e+00, 0.1490e+00, 0.1390e+00, 0.1200e+00, 0.9620e-01, 0.8300e-01] + real(wp),parameter,dimension(nwl) :: & + wl = & + [0.4430e-01, 0.4510e-01, 0.4590e-01, 0.4680e-01, 0.4770e-01, 0.4860e-01, & + 0.4960e-01, 0.5060e-01, 0.5170e-01, 0.5280e-01, 0.5390e-01, 0.5510e-01, & + 0.5640e-01, 0.5770e-01, 0.5900e-01, 0.6050e-01, 0.6200e-01, 0.6360e-01, & + 0.6530e-01, 0.6700e-01, 0.6890e-01, 0.7080e-01, 0.7290e-01, 0.7380e-01, & + 0.7510e-01, 0.7750e-01, 0.8000e-01, 0.8270e-01, 0.8550e-01, 0.8860e-01, & + 0.9180e-01, 0.9300e-01, 0.9540e-01, 0.9920e-01, 0.1033e+00, 0.1078e+00, & + 0.1100e+00, 0.1127e+00, 0.1140e+00, 0.1181e+00, 0.1210e+00, 0.1240e+00, & + 0.1272e+00, 0.1295e+00, 0.1305e+00, 0.1319e+00, 0.1333e+00, 0.1348e+00, & + 0.1362e+00, 0.1370e+00, 0.1378e+00, 0.1387e+00, 0.1393e+00, 0.1409e+00, & + 0.1425e+00, 0.1435e+00, 0.1442e+00, 0.1450e+00, 0.1459e+00, 0.1468e+00, & + 0.1476e+00, 0.1480e+00, 0.1485e+00, 0.1494e+00, 0.1512e+00, 0.1531e+00, & + 0.1540e+00, 0.1550e+00, 0.1569e+00, 0.1580e+00, 0.1589e+00, 0.1610e+00, & + 0.1625e+00, 0.1648e+00, 0.1669e+00, 0.1692e+00, 0.1713e+00, 0.1737e+00, & + 0.1757e+00, 0.1779e+00, 0.1802e+00, 0.1809e+00, 0.1821e+00, 0.1833e+00, & + 0.1843e+00, 0.1850e+00, 0.1860e+00, 0.1870e+00, 0.1880e+00, 0.1890e+00, & + 0.1900e+00, 0.1910e+00, 0.1930e+00, 0.1950e+00, 0.2100e+00, 0.2500e+00, & + 0.3000e+00, 0.3500e+00, 0.4000e+00, 0.4100e+00, 0.4200e+00, 0.4300e+00, & + 0.4400e+00, 0.4500e+00, 0.4600e+00, 0.4700e+00, 0.4800e+00, 0.4900e+00, & + 0.5000e+00, 0.5100e+00, 0.5200e+00, 0.5300e+00, 0.5400e+00, 0.5500e+00, & + 0.5600e+00, 0.5700e+00, 0.5800e+00, 0.5900e+00, 0.6000e+00, 0.6100e+00, & + 0.6200e+00, 0.6300e+00, 0.6400e+00, 0.6500e+00, 0.6600e+00, 0.6700e+00, & + 0.6800e+00, 0.6900e+00, 0.7000e+00, 0.7100e+00, 0.7200e+00, 0.7300e+00, & + 0.7400e+00, 0.7500e+00, 0.7600e+00, 0.7700e+00, 0.7800e+00, 0.7900e+00, & + 0.8000e+00, 0.8100e+00, 0.8200e+00, 0.8300e+00, 0.8400e+00, 0.8500e+00, & + 0.8600e+00, 0.8700e+00, 0.8800e+00, 0.8900e+00, 0.9000e+00, 0.9100e+00, & + 0.9200e+00, 0.9300e+00, 0.9400e+00, 0.9500e+00, 0.9600e+00, 0.9700e+00, & + 0.9800e+00, 0.9900e+00, 0.1000e+01, 0.1010e+01, 0.1020e+01, 0.1030e+01, & + 0.1040e+01, 0.1050e+01, 0.1060e+01, 0.1070e+01, 0.1080e+01, 0.1090e+01, & + 0.1100e+01, 0.1110e+01, 0.1120e+01, 0.1130e+01, 0.1140e+01, 0.1150e+01, & + 0.1160e+01, 0.1170e+01, 0.1180e+01, 0.1190e+01, 0.1200e+01, 0.1210e+01, & + 0.1220e+01, 0.1230e+01, 0.1240e+01, 0.1250e+01, 0.1260e+01, 0.1270e+01, & + 0.1280e+01, 0.1290e+01, 0.1300e+01, 0.1310e+01, 0.1320e+01, 0.1330e+01, & + 0.1340e+01, 0.1350e+01, 0.1360e+01, 0.1370e+01, 0.1380e+01, 0.1390e+01, & + 0.1400e+01, 0.1410e+01, 0.1420e+01, 0.1430e+01, 0.1440e+01, 0.1449e+01, & + 0.1460e+01, 0.1471e+01, 0.1481e+01, 0.1493e+01, 0.1504e+01, 0.1515e+01, & + 0.1527e+01, 0.1538e+01, 0.1563e+01, 0.1587e+01, 0.1613e+01, 0.1650e+01, & + 0.1680e+01, 0.1700e+01, 0.1730e+01, 0.1760e+01, 0.1800e+01, 0.1830e+01, & + 0.1840e+01, 0.1850e+01, 0.1855e+01, 0.1860e+01, 0.1870e+01, 0.1890e+01, & + 0.1905e+01, 0.1923e+01, 0.1942e+01, 0.1961e+01, 0.1980e+01, 0.2000e+01, & + 0.2020e+01, 0.2041e+01, 0.2062e+01, 0.2083e+01, 0.2105e+01, 0.2130e+01, & + 0.2150e+01, 0.2170e+01, 0.2190e+01, 0.2220e+01, 0.2240e+01, 0.2245e+01, & + 0.2250e+01, 0.2260e+01, 0.2270e+01, 0.2290e+01, 0.2310e+01, 0.2330e+01, & + 0.2350e+01, 0.2370e+01, 0.2390e+01, 0.2410e+01, 0.2430e+01, 0.2460e+01, & + 0.2500e+01, 0.2520e+01, 0.2550e+01, 0.2565e+01, 0.2580e+01, 0.2590e+01, & + 0.2600e+01, 0.2620e+01, 0.2675e+01, 0.2725e+01, 0.2778e+01, 0.2817e+01, & + 0.2833e+01, 0.2849e+01, 0.2865e+01, 0.2882e+01, 0.2899e+01, 0.2915e+01, & + 0.2933e+01, 0.2950e+01, 0.2967e+01, 0.2985e+01, 0.3003e+01, 0.3021e+01, & + 0.3040e+01, 0.3058e+01, 0.3077e+01, 0.3096e+01, 0.3115e+01, 0.3135e+01, & + 0.3155e+01, 0.3175e+01, 0.3195e+01, 0.3215e+01, 0.3236e+01, 0.3257e+01, & + 0.3279e+01, 0.3300e+01, 0.3322e+01, 0.3345e+01, 0.3367e+01, 0.3390e+01, & + 0.3413e+01, 0.3436e+01, 0.3460e+01, 0.3484e+01, 0.3509e+01, 0.3534e+01, & + 0.3559e+01, 0.3624e+01, 0.3732e+01, 0.3775e+01, 0.3847e+01, 0.3969e+01, & + 0.4099e+01, 0.4239e+01, 0.4348e+01, 0.4387e+01, 0.4444e+01, 0.4505e+01, & + 0.4547e+01, 0.4560e+01, 0.4580e+01, 0.4719e+01, 0.4904e+01, 0.5000e+01, & + 0.5100e+01, 0.5200e+01, 0.5263e+01, 0.5400e+01, 0.5556e+01, 0.5714e+01, & + 0.5747e+01, 0.5780e+01, 0.5814e+01, 0.5848e+01, 0.5882e+01, 0.6061e+01, & + 0.6135e+01, 0.6250e+01, 0.6289e+01, 0.6329e+01, 0.6369e+01, 0.6410e+01, & + 0.6452e+01, 0.6494e+01, 0.6579e+01, 0.6667e+01, 0.6757e+01, 0.6897e+01, & + 0.7042e+01, 0.7143e+01, 0.7246e+01, 0.7353e+01, 0.7463e+01, 0.7576e+01, & + 0.7692e+01, 0.7812e+01, 0.7937e+01, 0.8065e+01, 0.8197e+01, 0.8333e+01, & + 0.8475e+01, 0.8696e+01, 0.8929e+01, 0.9091e+01, 0.9259e+01, 0.9524e+01, & + 0.9804e+01, 0.1000e+02, 0.1020e+02, 0.1031e+02, 0.1042e+02, 0.1053e+02, & + 0.1064e+02, 0.1075e+02, 0.1087e+02, 0.1100e+02, 0.1111e+02, 0.1136e+02, & + 0.1163e+02, 0.1190e+02, 0.1220e+02, 0.1250e+02, 0.1282e+02, 0.1299e+02, & + 0.1316e+02, 0.1333e+02, 0.1351e+02, 0.1370e+02, 0.1389e+02, 0.1408e+02, & + 0.1429e+02, 0.1471e+02, 0.1515e+02, 0.1538e+02, 0.1563e+02, 0.1613e+02, & + 0.1639e+02, 0.1667e+02, 0.1695e+02, 0.1724e+02, 0.1818e+02, 0.1887e+02, & + 0.1923e+02, 0.1961e+02, 0.2000e+02, 0.2041e+02, 0.2083e+02, 0.2222e+02, & + 0.2260e+02, 0.2305e+02, 0.2360e+02, 0.2460e+02, 0.2500e+02, 0.2600e+02, & + 0.2857e+02, 0.3100e+02, 0.3333e+02, 0.3448e+02, 0.3564e+02, 0.3700e+02, & + 0.3824e+02, 0.3960e+02, 0.4114e+02, 0.4276e+02, 0.4358e+02, 0.4458e+02, & + 0.4550e+02, 0.4615e+02, 0.4671e+02, 0.4736e+02, 0.4800e+02, 0.4878e+02, & + 0.5003e+02, 0.5128e+02, 0.5275e+02, 0.5350e+02, 0.5424e+02, 0.5500e+02, & + 0.5574e+02, 0.5640e+02, 0.5700e+02, 0.5746e+02, 0.5840e+02, 0.5929e+02, & + 0.6000e+02, 0.6100e+02, 0.6125e+02, 0.6250e+02, 0.6378e+02, 0.6467e+02, & + 0.6558e+02, 0.6655e+02, 0.6760e+02, 0.6900e+02, 0.7053e+02, 0.7300e+02, & + 0.7500e+02, 0.7629e+02, 0.8000e+02, 0.8297e+02, 0.8500e+02, 0.8680e+02, & + 0.9080e+02, 0.9517e+02, 0.1000e+03, 0.1200e+03, 0.1500e+03, 0.1670e+03] + real(wp),parameter,dimension(nwlt,4) :: & + tabimt = reshape(source= & + (/0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4560e-01, 0.3790e-01, 0.3140e-01, & + 0.2620e-01, 0.2240e-01, 0.1960e-01, 0.1760e-01, 0.1665e-01, 0.1620e-01, & + 0.1550e-01, 0.1470e-01, 0.1390e-01, 0.1320e-01, 0.1250e-01, 0.1180e-01, & + 0.1060e-01, 0.9540e-02, 0.8560e-02, 0.6210e-02, 0.4490e-02, 0.3240e-02, & + 0.2340e-02, 0.1880e-02, 0.1740e-02, 0.1500e-02, 0.1320e-02, 0.1160e-02, & + 0.8800e-03, 0.6950e-03, 0.4640e-03, 0.3400e-03, 0.3110e-03, 0.2940e-03, & + 0.2790e-03, 0.2700e-03, 0.2640e-03, 0.2580e-03, 0.2520e-03, 0.2490e-03, & + 0.2540e-03, 0.2640e-03, 0.2740e-03, 0.2890e-03, 0.3050e-03, 0.3150e-03, & + 0.3460e-03, 0.3820e-03, 0.4620e-03, 0.5000e-03, 0.5500e-03, 0.5950e-03, & + 0.6470e-03, 0.6920e-03, 0.7420e-03, 0.8200e-03, 0.9700e-03, 0.1950e-02, & + 0.5780e-02, 0.9700e-02, 0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4560e-01, & + 0.3790e-01, 0.3140e-01, 0.2620e-01, 0.2240e-01, 0.1960e-01, 0.1760e-01, & + 0.1665e-01, 0.1600e-01, 0.1500e-01, 0.1400e-01, 0.1310e-01, 0.1230e-01, & + 0.1150e-01, 0.1080e-01, 0.9460e-02, 0.8290e-02, 0.7270e-02, 0.4910e-02, & + 0.3300e-02, 0.2220e-02, 0.1490e-02, 0.1140e-02, 0.1060e-02, 0.9480e-03, & + 0.8500e-03, 0.7660e-03, 0.6300e-03, 0.5200e-03, 0.3840e-03, 0.2960e-03, & + 0.2700e-03, 0.2520e-03, 0.2440e-03, 0.2360e-03, 0.2300e-03, 0.2280e-03, & + 0.2250e-03, 0.2200e-03, 0.2160e-03, 0.2170e-03, 0.2200e-03, 0.2250e-03, & + 0.2320e-03, 0.2390e-03, 0.2600e-03, 0.2860e-03, 0.3560e-03, 0.3830e-03, & + 0.4150e-03, 0.4450e-03, 0.4760e-03, 0.5080e-03, 0.5400e-03, 0.5860e-03, & + 0.6780e-03, 0.1280e-02, 0.3550e-02, 0.5600e-02, 0.8300e-01, 0.6900e-01, & + 0.5700e-01, 0.4560e-01, 0.3790e-01, 0.3140e-01, 0.2620e-01, 0.2190e-01, & + 0.1880e-01, 0.1660e-01, 0.1540e-01, 0.1470e-01, 0.1350e-01, 0.1250e-01, & + 0.1150e-01, 0.1060e-01, 0.9770e-02, 0.9010e-02, 0.7660e-02, 0.6520e-02, & + 0.5540e-02, 0.3420e-02, 0.2100e-02, 0.1290e-02, 0.7930e-03, 0.5700e-03, & + 0.5350e-03, 0.4820e-03, 0.4380e-03, 0.4080e-03, 0.3500e-03, 0.3200e-03, & + 0.2550e-03, 0.2120e-03, 0.2000e-03, 0.1860e-03, 0.1750e-03, 0.1660e-03, & + 0.1560e-03, 0.1490e-03, 0.1440e-03, 0.1350e-03, 0.1210e-03, 0.1160e-03, & + 0.1160e-03, 0.1170e-03, 0.1200e-03, 0.1230e-03, 0.1320e-03, 0.1440e-03, & + 0.1680e-03, 0.1800e-03, 0.1900e-03, 0.2090e-03, 0.2160e-03, 0.2290e-03, & + 0.2400e-03, 0.2600e-03, 0.2920e-03, 0.6100e-03, 0.1020e-02, 0.1810e-02, & + 0.8300e-01, 0.6900e-01, 0.5700e-01, 0.4450e-01, 0.3550e-01, 0.2910e-01, & + 0.2440e-01, 0.1970e-01, 0.1670e-01, 0.1400e-01, 0.1235e-01, 0.1080e-01, & + 0.8900e-02, 0.7340e-02, 0.6400e-02, 0.5600e-02, 0.5000e-02, 0.4520e-02, & + 0.3680e-02, 0.2990e-02, 0.2490e-02, 0.1550e-02, 0.9610e-03, 0.5950e-03, & + 0.3690e-03, 0.2670e-03, 0.2510e-03, 0.2290e-03, 0.2110e-03, 0.1960e-03, & + 0.1730e-03, 0.1550e-03, 0.1310e-03, 0.1130e-03, 0.1060e-03, 0.9900e-04, & + 0.9300e-04, 0.8730e-04, 0.8300e-04, 0.7870e-04, 0.7500e-04, 0.6830e-04, & + 0.5600e-04, 0.4960e-04, 0.4550e-04, 0.4210e-04, 0.3910e-04, 0.3760e-04, & + 0.3400e-04, 0.3100e-04, 0.2640e-04, 0.2510e-04, 0.2430e-04, 0.2390e-04, & + 0.2370e-04, 0.2380e-04, 0.2400e-04, 0.2460e-04, 0.2660e-04, 0.4450e-04, & + 0.8700e-04, 0.1320e-03/),shape=(/nwlt,4/)) + + real(wp),parameter,dimension(nwl) :: & + tabre = & + [0.83441, 0.83676, 0.83729, 0.83771, 0.83827, 0.84038, & + 0.84719, 0.85522, 0.86047, 0.86248, 0.86157, 0.86093, & + 0.86419, 0.86916, 0.87764, 0.89296, 0.91041, 0.93089, & + 0.95373, 0.98188, 1.02334, 1.06735, 1.11197, 1.13134, & + 1.15747, 1.20045, 1.23840, 1.27325, 1.32157, 1.38958, & + 1.41644, 1.40906, 1.40063, 1.40169, 1.40934, 1.40221, & + 1.39240, 1.38424, 1.38075, 1.38186, 1.39634, 1.40918, & + 1.40256, 1.38013, 1.36303, 1.34144, 1.32377, 1.30605, & + 1.29054, 1.28890, 1.28931, 1.30190, 1.32025, 1.36302, & + 1.41872, 1.45834, 1.49028, 1.52128, 1.55376, 1.57782, & + 1.59636, 1.60652, 1.61172, 1.61919, 1.62522, 1.63404, & + 1.63689, 1.63833, 1.63720, 1.63233, 1.62222, 1.58269, & + 1.55635, 1.52453, 1.50320, 1.48498, 1.47226, 1.45991, & + 1.45115, 1.44272, 1.43498, 1.43280, 1.42924, 1.42602, & + 1.42323, 1.42143, 1.41897, 1.41660, 1.41434, 1.41216, & + 1.41006, 1.40805, 1.40423, 1.40067, 1.38004, 1.35085, & + 1.33394, 1.32492, 1.31940, 1.31854, 1.31775, 1.31702, & + 1.31633, 1.31569, 1.31509, 1.31452, 1.31399, 1.31349, & + 1.31302, 1.31257, 1.31215, 1.31175, 1.31136, 1.31099, & + 1.31064, 1.31031, 1.30999, 1.30968, 1.30938, 1.30909, & + 1.30882, 1.30855, 1.30829, 1.30804, 1.30780, 1.30756, & + 1.30733, 1.30710, 1.30688, 1.30667, 1.30646, 1.30625, & + 1.30605, 1.30585, 1.30566, 1.30547, 1.30528, 1.30509, & + 1.30491, 1.30473, 1.30455, 1.30437, 1.30419, 1.30402, & + 1.30385, 1.30367, 1.30350, 1.30333, 1.30316, 1.30299, & + 1.30283, 1.30266, 1.30249, 1.30232, 1.30216, 1.30199, & + 1.30182, 1.30166, 1.30149, 1.30132, 1.30116, 1.30099, & + 1.30082, 1.30065, 1.30048, 1.30031, 1.30014, 1.29997, & + 1.29979, 1.29962, 1.29945, 1.29927, 1.29909, 1.29891, & + 1.29873, 1.29855, 1.29837, 1.29818, 1.29800, 1.29781, & + 1.29762, 1.29743, 1.29724, 1.29705, 1.29686, 1.29666, & + 1.29646, 1.29626, 1.29605, 1.29584, 1.29563, 1.29542, & + 1.29521, 1.29499, 1.29476, 1.29453, 1.29430, 1.29406, & + 1.29381, 1.29355, 1.29327, 1.29299, 1.29272, 1.29252, & + 1.29228, 1.29205, 1.29186, 1.29167, 1.29150, 1.29130, & + 1.29106, 1.29083, 1.29025, 1.28962, 1.28891, 1.28784, & + 1.28689, 1.28623, 1.28521, 1.28413, 1.28261, 1.28137, & + 1.28093, 1.28047, 1.28022, 1.27998, 1.27948, 1.27849, & + 1.27774, 1.27691, 1.27610, 1.27535, 1.27471, 1.27404, & + 1.27329, 1.27240, 1.27139, 1.27029, 1.26901, 1.26736, & + 1.26591, 1.26441, 1.26284, 1.26036, 1.25860, 1.25815, & + 1.25768, 1.25675, 1.25579, 1.25383, 1.25179, 1.24967, & + 1.24745, 1.24512, 1.24266, 1.24004, 1.23725, 1.23270, & + 1.22583, 1.22198, 1.21548, 1.21184, 1.20790, 1.20507, & + 1.20209, 1.19566, 1.17411, 1.14734, 1.10766, 1.06739, & + 1.04762, 1.02650, 1.00357, 0.98197, 0.96503, 0.95962, & + 0.97269, 0.99172, 1.00668, 1.02186, 1.04270, 1.07597, & + 1.12954, 1.21267, 1.32509, 1.42599, 1.49656, 1.55095, & + 1.59988, 1.63631, 1.65024, 1.64278, 1.62691, 1.61284, & + 1.59245, 1.57329, 1.55770, 1.54129, 1.52654, 1.51139, & + 1.49725, 1.48453, 1.47209, 1.46125, 1.45132, 1.44215, & + 1.43366, 1.41553, 1.39417, 1.38732, 1.37735, 1.36448, & + 1.35414, 1.34456, 1.33882, 1.33807, 1.33847, 1.34053, & + 1.34287, 1.34418, 1.34634, 1.34422, 1.33453, 1.32897, & + 1.32333, 1.31800, 1.31432, 1.30623, 1.29722, 1.28898, & + 1.28730, 1.28603, 1.28509, 1.28535, 1.28813, 1.30156, & + 1.30901, 1.31720, 1.31893, 1.32039, 1.32201, 1.32239, & + 1.32149, 1.32036, 1.31814, 1.31705, 1.31807, 1.31953, & + 1.31933, 1.31896, 1.31909, 1.31796, 1.31631, 1.31542, & + 1.31540, 1.31552, 1.31455, 1.31193, 1.30677, 1.29934, & + 1.29253, 1.28389, 1.27401, 1.26724, 1.25990, 1.24510, & + 1.22241, 1.19913, 1.17150, 1.15528, 1.13700, 1.11808, & + 1.10134, 1.09083, 1.08734, 1.09254, 1.10654, 1.14779, & + 1.20202, 1.25825, 1.32305, 1.38574, 1.44478, 1.47170, & + 1.49619, 1.51652, 1.53328, 1.54900, 1.56276, 1.57317, & + 1.58028, 1.57918, 1.56672, 1.55869, 1.55081, 1.53807, & + 1.53296, 1.53220, 1.53340, 1.53289, 1.51705, 1.50097, & + 1.49681, 1.49928, 1.50153, 1.49856, 1.49053, 1.46070, & + 1.45182, 1.44223, 1.43158, 1.41385, 1.40676, 1.38955, & + 1.34894, 1.31039, 1.26420, 1.23656, 1.21663, 1.20233, & + 1.19640, 1.19969, 1.20860, 1.22173, 1.24166, 1.28175, & + 1.32784, 1.38657, 1.46486, 1.55323, 1.60379, 1.61877, & + 1.62963, 1.65712, 1.69810, 1.72065, 1.74865, 1.76736, & + 1.76476, 1.75011, 1.72327, 1.68490, 1.62398, 1.59596, & + 1.58514, 1.59917, 1.61405, 1.66625, 1.70663, 1.73713, & + 1.76860, 1.80343, 1.83296, 1.85682, 1.87411, 1.89110, & + 1.89918, 1.90432, 1.90329, 1.88744, 1.87499, 1.86702, & + 1.85361, 1.84250, 1.83225, 1.81914, 1.82268, 1.82961] + real(wp),parameter,dimension(nwlt,4) :: & + tabret = reshape( & + source =(/1.82961, 1.83258, 1.83149, & + 1.82748, 1.82224, 1.81718, 1.81204, 1.80704, 1.80250, & + 1.79834, 1.79482, 1.79214, 1.78843, 1.78601, 1.78434, & + 1.78322, 1.78248, 1.78201, 1.78170, 1.78160, 1.78190, & + 1.78300, 1.78430, 1.78520, 1.78620, 1.78660, 1.78680, & + 1.78690, 1.78700, 1.78700, 1.78710, 1.78710, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, 1.78720, & + 1.78720, 1.78720, 1.78720, 1.78720, 1.78800, & + 1.82961, 1.83258, 1.83149, 1.82748, & + 1.82224, 1.81718, 1.81204, 1.80704, 1.80250, 1.79834, & + 1.79482, 1.79214, 1.78843, 1.78601, 1.78434, 1.78322, & + 1.78248, 1.78201, 1.78170, 1.78160, 1.78190, 1.78300, & + 1.78430, 1.78520, 1.78610, 1.78630, 1.78640, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, 1.78650, & + 1.78650, 1.78650, 1.78650, 1.78720, & + 1.82961, 1.83258, 1.83149, 1.82748, 1.82224, & + 1.81718, 1.81204, 1.80704, 1.80250, 1.79834, 1.79482, & + 1.79214, 1.78843, 1.78601, 1.78434, 1.78322, 1.78248, & + 1.78201, 1.78160, 1.78140, 1.78160, 1.78220, 1.78310, & + 1.78380, 1.78390, 1.78400, 1.78400, 1.78400, 1.78400, & + 1.78400, 1.78390, 1.78380, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, 1.78370, & + 1.78370, 1.78400, 1.78450, & + 1.82961, 1.83258, 1.83149, 1.82748, 1.82224, 1.81718, & + 1.81204, 1.80704, 1.80250, 1.79834, 1.79482, 1.79214, & + 1.78843, 1.78601, 1.78434, 1.78322, 1.78248, 1.78201, & + 1.78150, 1.78070, 1.78010, 1.77890, 1.77790, 1.77730, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, 1.77720, & + 1.77720, 1.77800/),shape=(/nwlt,4/)) + + ! ##################################################################### + ! Defines wavelength dependent complex index of refraction for ice. + ! Allowable wavelength range extends from 0.045 microns to 8.6 meter + ! temperature dependence only considered beyond 167 microns. + ! + ! interpolation is done n_r vs. log(xlam) + ! n_r vs. t + ! log(n_i) vs. log(xlam) + ! log(n_i) vs. t + ! + ! Stephen G. Warren - 1983 + ! Dept. of Atmospheric Sciences + ! University of Washington + ! Seattle, Wa 98195 + ! + ! Based on + ! + ! Warren,S.G.,1984. + ! Optical constants of ice from the ultraviolet to the microwave. + ! Applied Optics,23,1206-1225 + ! + ! Reference temperatures are -1.0,-5.0,-20.0, and -60.0 deg C + ! ##################################################################### + + pi = acos(-1._wp) + n_r = 0._wp + n_i = 0._wp + tk = t + + ! Convert frequency to wavelength (um) + alam=3E5_wp/freq + if((alam < wlmin) .or. (alam > wlmax)) then + call errorMessage('FATAL ERROR(optics/optics_lib.f90:m_ice): wavelength out of bounds') + return + endif + + if (alam < cutice) then + ! Region from 0.045 microns to 167.0 microns - no temperature depend + do i=2,nwl + if(alam < wl(i)) continue + enddo + x1 = log(wl(i-1)) + x2 = log(wl(i)) + y1 = tabre(i-1) + y2 = tabre(i) + x = log(alam) + y = ((x-x1)*(y2-y1)/(x2-x1))+y1 + n_r = y + y1 = log(abs(tabim(i-1))) + y2 = log(abs(tabim(i))) + y = ((x-x1)*(y2-y1)/(x2-x1))+y1 + n_i = exp(y) + else + ! Region from 167.0 microns to 8.6 meters - temperature dependence + if(tk > temref(1)) tk=temref(1) + if(tk < temref(4)) tk=temref(4) + do i=2,4 + if(tk.ge.temref(i)) go to 12 + enddo +12 lt1 = i + lt2 = i-1 + do i=2,nwlt + if(alam.le.wlt(i)) go to 14 + enddo +14 x1 = log(wlt(i-1)) + x2 = log(wlt(i)) + y1 = tabret(i-1,lt1) + y2 = tabret(i,lt1) + x = log(alam) + ylo = ((x-x1)*(y2-y1)/(x2-x1))+y1 + y1 = tabret(i-1,lt2) + y2 = tabret(i,lt2) + yhi = ((x-x1)*(y2-y1)/(x2-x1))+y1 + t1 = temref(lt1) + t2 = temref(lt2) + y = ((tk-t1)*(yhi-ylo)/(t2-t1))+ylo + n_r = y + y1 = log(abs(tabimt(i-1,lt1))) + y2 = log(abs(tabimt(i,lt1))) + ylo = ((x-x1)*(y2-y1)/(x2-x1))+y1 + y1 = log(abs(tabimt(i-1,lt2))) + y2 = log(abs(tabimt(i,lt2))) + yhi = ((x-x1)*(y2-y1)/(x2-x1))+y1 + y = ((tk-t1)*(yhi-ylo)/(t2-t1))+ylo + n_i = exp(y) + endif + end subroutine m_ice + + ! ############################################################################ + ! subroutine MIEINT + ! ############################################################################ + Subroutine MieInt(Dx, SCm, Inp, Dqv, Dqxt, Dqsc, Dbsc, Dg, Xs1, Xs2, DPh, Error) + ! ########################################################################## + ! + ! General purpose Mie scattering routine for single particles + ! Author: R Grainger 1990 + ! History: + ! G Thomas, March 2005: Added calculation of Phase function and + ! code to ensure correct calculation of backscatter coeficient + ! Options/Extend_Source + ! + ! ########################################################################## + ! INPUTS + integer, intent(in) :: & + Inp + real(wp),intent(in) :: & + Dx ! + real(wp),intent(in),dimension(Inp) :: & + Dqv + Complex(wp),intent(in) :: & + SCm! + + ! OUTPUTS + Complex(wp),intent(out),dimension(InP) :: & + Xs1, & ! + Xs2 ! + real(wp),intent(out) :: & + Dqxt, & ! + Dqsc, & ! + Dg, & ! + Dbsc ! + real(wp),intent(out),dimension(InP) :: & + DPh + integer :: & + Error !! + + ! PARAMETERS + Integer,parameter :: & + Imaxx = 12000, & ! + Itermax = 30000, & ! Must be large enough to cope with the + ! largest possible nmx = x * abs(scm) + 15 + ! or nmx = Dx + 4.05*Dx**(1./3.) + 2.0 + Imaxnp = 10000 ! Change this as required + Real(wp),parameter :: & + RIMax=2.5, & ! Largest real part of refractive index + IRIMax = -2 ! Largest imaginary part of refractive index + + ! Internal variables + Integer :: I, NStop, NmX, N, Inp2 + Real(wp) :: Chi,Chi0,Chi1,APsi,APsi0,APsi1,Psi,Psi0,Psi1 + Real(wp),dimension(Imaxnp) :: Pi0,Pi1,Taun + Complex(wp) :: Ir,Cm,A,ANM1,APB,B,BNM1,AMB,Xi,Xi0,Xi1,Y + Complex(wp),dimension(Itermax) :: D + Complex(wp),dimension(Imaxnp) :: Sp,Sm! + + ! ACCELERATOR VARIABLES + Integer :: Tnp1,Tnm1 + Real(wp) :: Dn, Rnx,Turbo,A2 + real(wp),dimension(Imaxnp) :: S,T + Complex(wp) :: A1 + + If ((Dx.Gt.Imaxx) .Or. (InP.Gt.ImaxNP)) Then + Error = 1 + Return + EndIf + Cm = SCm + Ir = 1 / Cm + Y = Dx * Cm + If (Dx.Lt.0.02) Then + NStop = 2 + Else + If (Dx.Le.8.0) Then + NStop = Dx + 4.00*Dx**(1./3.) + 2.0 + Else + If (Dx.Lt. 4200.0) Then + NStop = Dx + 4.05*Dx**(1./3.) + 2.0 + Else + NStop = Dx + 4.00*Dx**(1./3.) + 2.0 + End If + End If + End If + NmX = Max(Real(NStop),Real(Abs(Y))) + 15. + If (Nmx .gt. Itermax) then + Error = 1 + Return + End If + Inp2 = Inp+1 +!ds D(NmX) = cmplx(0,0,Kind=Kind(0d0)) + D(NmX) = cmplx(0,0,Kind=wp) + Do N = Nmx-1,1,-1 + A1 = (N+1) / Y + D(N) = A1 - 1/(A1+D(N+1)) + End Do + Do I =1,Inp2 + Sm(I) = cmplx(0,0,Kind=wp) +!ds Sm(I) = cmplx(0,0,Kind=Kind(0d0)) + Sp(I) = cmplx(0,0,Kind=wp) +!ds Sp(I) = cmplx(0,0,Kind=Kind(0d0)) + Pi0(I) = 0 + Pi1(I) = 1 + End Do + Psi0 = Cos(Dx) + Psi1 = Sin(Dx) + Chi0 =-Sin(Dx) + Chi1 = Cos(Dx) + APsi0 = Psi0 + APsi1 = Psi1 + Xi0 = cmplx(APsi0,Chi0,Kind=wp) +!ds Xi0 = cmplx(APsi0,Chi0,Kind=Kind(0d0)) + Xi1 = cmplx(APsi1,Chi1,Kind=wp) +!ds Xi1 = cmplx(APsi1,Chi1,Kind=Kind(0d0)) + Dg = 0 + Dqsc = 0 + Dqxt = 0 + Tnp1 = 1 + Do N = 1,Nstop + DN = N + Tnp1 = Tnp1 + 2 + Tnm1 = Tnp1 - 2 + A2 = Tnp1 / (DN*(DN+1._wp)) +!ds A2 = Tnp1 / (DN*(DN+1D0)) + Turbo = (DN+1._wp) / DN +!ds Turbo = (DN+1D0) / DN + Rnx = DN/Dx + Psi = Tnm1*Psi1/Dx - Psi0 +!ds Psi = Dble(Tnm1)*Psi1/Dx - Psi0 + APsi = Psi + Chi = Tnm1*Chi1/Dx - Chi0 + Xi = cmplx(APsi,Chi,Kind=wp) +!ds Xi = cmplx(APsi,Chi,Kind=Kind(0d0)) + A = ((D(N)*Ir+Rnx)*APsi-APsi1) / ((D(N)*Ir+Rnx)* Xi- Xi1) + B = ((D(N)*Cm+Rnx)*APsi-APsi1) / ((D(N)*Cm+Rnx)* Xi- Xi1) + Dqxt = Tnp1*(A + B)+ Dqxt +!ds Dqxt = Tnp1 * Dble(A + B) + Dqxt + Dqsc = Tnp1 * (A*Conjg(A) + B*Conjg(B)) + Dqsc + If (N.Gt.1) then + Dg = Dg + (dN*dN - 1) * (ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 *(ANM1*Conjg(BNM1)) / (dN*dN - dN) +!ds Dg = Dg + (dN*dN - 1) * Dble(ANM1*Conjg(A) + BNM1 * Conjg(B)) / dN + TNM1 * Dble(ANM1*Conjg(BNM1)) / (dN*dN - dN) + End If + Anm1 = A + Bnm1 = B + APB = A2 * (A + B) + AMB = A2 * (A - B) + Do I = 1,Inp2 + If (I.GT.Inp) Then + S(I) = -Pi1(I) + Else + S(I) = Dqv(I) * Pi1(I) + End If + T(I) = S(I) - Pi0(I) + Taun(I) = N*T(I) - Pi0(I) + Sp(I) = APB * (Pi1(I) + Taun(I)) + Sp(I) + Sm(I) = AMB * (Pi1(I) - Taun(I)) + Sm(I) + Pi0(I) = Pi1(I) + Pi1(I) = S(I) + T(I)*Turbo + End Do + Psi0 = Psi1 + Psi1 = Psi + Apsi1 = Psi1 + Chi0 = Chi1 + Chi1 = Chi + Xi1 = cmplx(APsi1,Chi1,Kind=wp) +!ds Xi1 = cmplx(APsi1,Chi1,Kind=Kind(0d0)) + End Do + + If (Dg .GT.0) Dg = 2 * Dg / Dqsc + Dqsc = 2 * Dqsc / Dx**2 + Dqxt = 2 * Dqxt / Dx**2 + Do I = 1,Inp + Xs1(I) = (Sp(I)+Sm(I)) / 2 + Xs2(I) = (Sp(I)-Sm(I)) / 2 + Dph(I) = 2 * (Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc) +!ds Dph(I) = 2 * Dble(Xs1(I)*Conjg(Xs1(I)) + Xs2(I)*Conjg(Xs2(I))) / (Dx**2 * Dqsc) + End Do + Dbsc = 4 * Abs(( (Sp(Inp2)+Sm(Inp2))/2 )**2) / Dx**2 + Error = 0 + Return + End subroutine MieInt +end module optics_lib Index: LMDZ6/trunk/libf/phylmd/cosp2/parasol.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/parasol.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/parasol.F90 (revision 3358) @@ -0,0 +1,176 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - optimization for vectorization +! Version 2.0 (October 2008) +! Version 2.1 (December 2008) +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_parasol + USE COSP_KINDS, ONLY: wp + USE COSP_MATH_CONSTANTS, ONLY: pi + use mod_cosp_config, ONLY: R_UNDEF,PARASOL_NREFL,PARASOL_NTAU,PARASOL_TAU,PARASOL_SZA,rlumA,rlumB + implicit none + +contains + SUBROUTINE parasol_subcolumn(npoints,nrefl,tautot_S_liq,tautot_S_ice,refl) + ! ########################################################################## + ! Purpose: To compute Parasol reflectance signal from model-simulated profiles + ! of cloud water and cloud fraction in each sub-column of each model + ! gridbox. + ! + ! + ! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : + ! - optimization for vectorization + ! + ! Version 2.0 (October 2008) + ! Version 2.1 (December 2008) + ! ########################################################################## + + ! INPUTS + INTEGER,intent(in) :: & + npoints, & ! Number of horizontal gridpoints + nrefl ! Number of angles for which the reflectance is computed + REAL(WP),intent(inout),dimension(npoints) :: & + tautot_S_liq, & ! Liquid water optical thickness, from TOA to SFC + tautot_S_ice ! Ice water optical thickness, from TOA to SFC + ! OUTPUTS + REAL(WP),intent(inout),dimension(npoints,nrefl) :: & + refl ! Parasol reflectances + + ! LOCAL VARIABLES + REAL(WP),dimension(npoints) :: & + tautot_S, & ! Cloud optical thickness, from TOA to surface + frac_taucol_liq, & ! + frac_taucol_ice ! + + ! Look up table variables: + INTEGER :: ny,it + REAL(WP),dimension(PARASOL_NREFL) :: r_norm + REAL(WP),dimension(PARASOL_NREFL,PARASOL_NTAU-1) :: aa,ab,ba,bb + REAL(WP),dimension(npoints,5) :: rlumA_mod,rlumB_mod + + !-------------------------------------------------------------------------------- + ! Lum_norm=f(PARASOL_SZA,tau_cloud) derived from adding-doubling calculations + ! valid ONLY ABOVE OCEAN (albedo_sfce=5%) + ! valid only in one viewing direction (theta_v=30�, phi_s-phi_v=320�) + ! based on adding-doubling radiative transfer computation + ! for PARASOL_TAU values (0 to 100) and for PARASOL_SZA values (0 to 80) + ! for 2 scattering phase functions: liquid spherical, ice non spherical + + ! Initialize + rlumA_mod(1:npoints,1:5) = 0._wp + rlumB_mod(1:npoints,1:5) = 0._wp + + r_norm(1:PARASOL_NREFL)=1._wp/ cos(pi/180._wp*PARASOL_SZA(1:PARASOL_NREFL)) + + tautot_S_liq(1:npoints) = max(tautot_S_liq(1:npoints),PARASOL_TAU(1)) + tautot_S_ice(1:npoints) = max(tautot_S_ice(1:npoints),PARASOL_TAU(1)) + tautot_S(1:npoints) = tautot_S_ice(1:npoints) + tautot_S_liq(1:npoints) + + ! Relative fraction of the opt. thick due to liquid or ice clouds + WHERE (tautot_S(1:npoints) .gt. 0.) + frac_taucol_liq(1:npoints) = tautot_S_liq(1:npoints) / tautot_S(1:npoints) + frac_taucol_ice(1:npoints) = tautot_S_ice(1:npoints) / tautot_S(1:npoints) + ELSEWHERE + frac_taucol_liq(1:npoints) = 1._wp + frac_taucol_ice(1:npoints) = 0._wp + END WHERE + tautot_S(1:npoints)=MIN(tautot_S(1:npoints),PARASOL_TAU(PARASOL_NTAU)) + + ! Linear interpolation + DO ny=1,PARASOL_NTAU-1 + ! Microphysics A (liquid clouds) + aA(1:PARASOL_NREFL,ny) = (rlumA(1:PARASOL_NREFL,ny+1)-rlumA(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny)) + bA(1:PARASOL_NREFL,ny) = rlumA(1:PARASOL_NREFL,ny) - aA(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny) + ! Microphysics B (ice clouds) + aB(1:PARASOL_NREFL,ny) = (rlumB(1:PARASOL_NREFL,ny+1)-rlumB(1:PARASOL_NREFL,ny))/(PARASOL_TAU(ny+1)-PARASOL_TAU(ny)) + bB(1:PARASOL_NREFL,ny) = rlumB(1:PARASOL_NREFL,ny) - aB(1:PARASOL_NREFL,ny)*PARASOL_TAU(ny) + ENDDO + + DO it=1,PARASOL_NREFL + DO ny=1,PARASOL_NTAU-1 + WHERE (tautot_S(1:npoints) .ge. PARASOL_TAU(ny).and. & + tautot_S(1:npoints) .le. PARASOL_TAU(ny+1)) + rlumA_mod(1:npoints,it) = aA(it,ny)*tautot_S(1:npoints) + bA(it,ny) + rlumB_mod(1:npoints,it) = aB(it,ny)*tautot_S(1:npoints) + bB(it,ny) + END WHERE + END DO + END DO + + DO it=1,PARASOL_NREFL + refl(1:npoints,it) = frac_taucol_liq(1:npoints) * rlumA_mod(1:npoints,it) & + + frac_taucol_ice(1:npoints) * rlumB_mod(1:npoints,it) + ! Normalized radiance -> reflectance: + refl(1:npoints,it) = refl(1:npoints,it) * r_norm(it) + ENDDO + + RETURN + END SUBROUTINE parasol_subcolumn + ! ###################################################################################### + ! SUBROUTINE parasol_gridbox + ! ###################################################################################### + subroutine parasol_column(npoints,nrefl,ncol,land,refl,parasolrefl) + + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal grid points + ncol, & ! Number of subcolumns + nrefl ! Number of solar zenith angles for parasol reflectances + real(wp),intent(in),dimension(npoints) :: & + land ! Landmask [0 - Ocean, 1 - Land] + real(wp),intent(in),dimension(npoints,ncol,nrefl) :: & + refl ! Subgrid parasol reflectance ! parasol + + ! Outputs + real(wp),intent(out),dimension(npoints,nrefl) :: & + parasolrefl ! Grid-averaged parasol reflectance + + ! Local variables + integer :: k,ic + + ! Compute grid-box averaged Parasol reflectances + parasolrefl(:,:) = 0._wp + do k = 1, nrefl + do ic = 1, ncol + parasolrefl(:,k) = parasolrefl(:,k) + refl(:,ic,k) + enddo + enddo + + do k = 1, nrefl + parasolrefl(:,k) = parasolrefl(:,k) / float(ncol) + ! if land=1 -> parasolrefl=R_UNDEF + ! if land=0 -> parasolrefl=parasolrefl + parasolrefl(:,k) = parasolrefl(:,k) * MAX(1._wp-land(:),0.0) & + + (1._wp - MAX(1._wp-land(:),0.0))*R_UNDEF + enddo + end subroutine parasol_column + +end module mod_parasol Index: LMDZ6/trunk/libf/phylmd/cosp2/phys_cosp2.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/phys_cosp2.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/phys_cosp2.F90 (revision 3358) @@ -0,0 +1,456 @@ +! Simulateur COSP : Cfmip Observation Simulator Package + +! ISCCP, Radar (QuickBeam), Lidar et Parasol (ACTSIM), MISR, RTTOVS +!Idelkadi Abderrahmane Aout-Septembre 2009 First Version +!Idelkadi Abderrahmane Nov 2015 version v1.4.0 + + subroutine phys_cosp2( itap,dtime,freq_cosp, & + ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, & + ecrit_mth,ecrit_day,ecrit_hf, ok_all_xml, missing_val, & + Nptslmdz,Nlevlmdz,lon,lat, presnivs,overlaplmdz,sunlit, & + ref_liq,ref_ice,fracTerLic,u_wind,v_wind,phis,phi,ph,p,skt,t, & + sh,rh,tca,cca,mr_lsliq,mr_lsice,fl_lsrainI,fl_lssnowI, & + fl_ccrainI,fl_ccsnowI,mr_ozone,dtau_s,dem_s) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +!!!! Inputs : +! itap, !Increment de la physiq +! dtime, !Pas de temps physiq +! overlap, !Overlap type in SCOPS +! Npoints, !Nb de points de la grille physiq +! Nlevels, !Nb de niveaux verticaux +! Ncolumns, !Number of subcolumns +! lon,lat, !Longitudes et latitudes de la grille LMDZ +! ref_liq,ref_ice, !Rayons effectifs des particules liq et ice (en microm) +! fracTerLic, !Fraction terre a convertir en masque +! u_wind,v_wind, !Vents a 10m ??? +! phi, !Geopotentiel +! phis, !Geopotentiel sol +! ph, !pression pour chaque inter-couche +! p, !Pression aux milieux des couches +! skt,t, !Temp au sol et temp 3D +! sh, !Humidite specifique +! rh, !Humidite relatif +! tca, !Fraction nuageuse +! cca !Fraction nuageuse convective +! mr_lsliq, !Liq Cloud water content +! mr_lsice, !Ice Cloud water content +! mr_ccliq, !Convective Cloud Liquid water content +! mr_ccice, !Cloud ice water content +! fl_lsrain, !Large scale precipitation lic +! fl_lssnow, !Large scale precipitation ice +! fl_ccrain, !Convective precipitation lic +! fl_ccsnow, !Convective precipitation ice +! mr_ozone, !Concentration ozone (Kg/Kg) +! dem_s !Cloud optical emissivity +! dtau_s !Cloud optical thickness +! emsfc_lw = 1. !Surface emissivity dans radlwsw.F90 + +!!! Outputs : +! calipso2D, !Lidar Low/heigh/Mean/Total-level Cloud Fraction +! calipso3D, !Lidar Cloud Fraction (532 nm) +! cfadlidar, !Lidar Scattering Ratio CFAD (532 nm) +! parasolrefl, !PARASOL-like mono-directional reflectance +! atb, !Lidar Attenuated Total Backscatter (532 nm) +! betamol, !Lidar Molecular Backscatter (532 nm) +! cfaddbze, !Radar Reflectivity Factor CFAD (94 GHz) +! clcalipso2, !Cloud frequency of occurrence as seen by CALIPSO but not CloudSat +! dbze, !Efective_reflectivity_factor +! cltlidarradar, !Lidar and Radar Total Cloud Fraction +! clMISR, !Cloud Fraction as Calculated by the MISR Simulator +! clisccp2, !Cloud Fraction as Calculated by the ISCCP Simulator +! boxtauisccp, !Optical Depth in Each Column as Calculated by the ISCCP Simulator +! boxptopisccp, !Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator +! tclisccp, !Total Cloud Fraction as Calculated by the ISCCP Simulator +! ctpisccp, !Mean Cloud Top Pressure as Calculated by the ISCCP Simulator +! tauisccp, !Mean Optical Depth as Calculated by the ISCCP Simulator +! albisccp, !Mean Cloud Albedo as Calculated by the ISCCP Simulator +! meantbisccp, !Mean all-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator +! meantbclrisccp !Mean clear-sky 10.5 micron brightness temperature as calculated by the ISCCP Simulator + +!!! AI rajouter les nouvelles sorties +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +!! AI rajouter +!#include "cosp_defs.h" +! USE MOD_COSP_CONSTANTS +! USE MOD_COSP_TYPES +! USE MOD_COSP + USE mod_phys_lmdz_para + USE mod_grid_phy_lmdz + use ioipsl + use iophy + use cosp_output_mod + use cosp_output_write_mod +! use MOD_COSP_Modis_Simulator, only : cosp_modis +! use mod_cosp_config, only : vgrid_zl,vgrid_zu,vgrid_z + USE MOD_COSP_INTERFACE_v1p4, ONLY: cosp => cosp_interface_v1p4, & + cosp_gridbox,construct_cosp_vgrid, & + construct_cosp_gridbox, & + free_cosp_gridbox => destroy_cosp_gridbox, & + free_cosp_sgradar => destroy_cosp_sgradar, & + free_cosp_radarstats => destroy_cosp_radarstats, & + free_cosp_sglidar => destroy_cosp_sglidar, & + free_cosp_lidarstats => destroy_cosp_lidarstats, & + free_cosp_isccp => destroy_cosp_isccp, & + free_cosp_misr => destroy_cosp_misr, & + free_cosp_rttov => destroy_cosp_rttov, & + free_cosp_modis => destroy_cosp_modis, & + free_cosp_vgrid => destroy_cosp_vgrid, & + free_cosp_subgrid => destroy_cosp_subgrid, & + construct_cosp_subgrid,cosp_config,cosp_subgrid, & + cosp_sglidar,cosp_lidarstats, & + construct_cosp_lidarstats,construct_cosp_sglidar, & + cosp_isccp,construct_cosp_isccp,cosp_misr, & + construct_cosp_misr,cosp_rttov,construct_cosp_rttov,& + cosp_sgradar,cosp_radarstats, & + construct_cosp_radarstats,construct_cosp_sgradar, & + cosp_modis,construct_cosp_modis, & + cosp_vgrid,I_CVCLIQ,I_LSCLIQ,I_CVCICE,I_LSCICE, & + I_LSRAIN,I_LSSNOW,I_LSGRPL,I_CVRAIN,I_CVSNOW + + use cosp_read_otputkeys + + IMPLICIT NONE + + ! Local variables + character(len=64),PARAMETER :: cosp_input_nl='cosp_input_nl.txt' + character(len=64),PARAMETER :: cosp_output_nl='cosp_output_nl.txt' + integer, save :: isccp_topheight,isccp_topheight_direction,overlap + integer,save :: Ncolumns ! Number of subcolumns in SCOPS + integer, save :: Npoints ! Number of gridpoints +!$OMP THREADPRIVATE(Npoints) + integer, save :: Nlevels ! Number of levels + Integer :: Nptslmdz,Nlevlmdz ! Nb de points issus de physiq.F + integer, save :: Nlvgrid ! Number of levels in statistical outputs + integer, save :: Npoints_it ! Max number of gridpoints to be processed in one iteration +! integer :: i + type(cosp_config),save :: cfg ! Configuration options +!$OMP THREADPRIVATE(cfg) + type(cosp_gridbox) :: gbx ! Gridbox information. Input for COSP + type(cosp_subgrid) :: sgx ! Subgrid outputs + type(cosp_sgradar) :: sgradar ! Output from radar simulator + type(cosp_sglidar) :: sglidar ! Output from lidar simulator + type(cosp_isccp) :: isccp ! Output from ISCCP simulator +!! AI rajout modis + type(cosp_modis) :: modis ! Output from MODIS simulator +!! + type(cosp_misr) :: misr ! Output from MISR simulator +!! AI rajout rttovs + type(cosp_rttov) :: rttov ! Output from RTTOV +!! + type(cosp_vgrid) :: vgrid ! Information on vertical grid of stats + type(cosp_radarstats) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats) :: stlidar ! Summary statistics from lidar simulator + + integer :: t0,t1,count_rate,count_max + integer :: Nlon,Nlat + real(wp),save :: radar_freq,k2,ZenAng,co2,ch4,n2o,co,emsfc_lw + +!$OMP THREADPRIVATE(emsfc_lw) + integer,dimension(RTTOV_MAX_CHANNELS),save :: Channels + real(wp),dimension(RTTOV_MAX_CHANNELS),save :: Surfem + integer, save :: surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay + integer, save :: Nprmts_max_hydro,Naero,Nprmts_max_aero,lidar_ice_type + integer, save :: platform,satellite,Instrument,Nchannels + logical, save :: use_vgrid,csat_vgrid,use_precipitation_fluxes,use_reff + +! Declaration necessaires pour les sorties IOIPSL + integer :: ii + real :: ecrit_day,ecrit_hf,ecrit_mth, missing_val + logical :: ok_mensuelCOSP,ok_journeCOSP,ok_hfCOSP, ok_all_xml + + logical, save :: debut_cosp=.true. +!$OMP THREADPRIVATE(debut_cosp) + + logical, save :: first_write=.true. +!$OMP THREADPRIVATE(first_write) + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM + integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) + real,dimension(Nptslmdz,Nlevlmdz) :: height,phi,p,ph,T,sh,rh,tca,cca,mr_lsliq,mr_lsice,mr_ccliq,mr_ccice, & + fl_lsrain,fl_lssnow,fl_ccrain,fl_ccsnow,fl_lsgrpl, & + zlev,zlev_half,mr_ozone,radliq,radice,dtau_s,dem_s,ref_liq,ref_ice + real,dimension(Nptslmdz,Nlevlmdz) :: fl_lsrainI,fl_lssnowI,fl_ccrainI,fl_ccsnowI + real,dimension(Nptslmdz) :: lon,lat,skt,fracTerLic,u_wind,v_wind,phis,sunlit + real,dimension(Nlevlmdz) :: presnivs + integer :: itap,k,ip + real :: dtime,freq_cosp + real,dimension(2) :: time_bnds + + double precision :: d_dtime + double precision,dimension(2) :: d_time_bnds + + namelist/COSP_INPUT/overlap,isccp_topheight,isccp_topheight_direction, & + npoints_it,ncolumns,use_vgrid,Nlvgrid,csat_vgrid, & + radar_freq,surface_radar,use_mie_tables, & + use_gas_abs,do_ray,melt_lay,k2,Nprmts_max_hydro,Naero,Nprmts_max_aero, & + lidar_ice_type,use_precipitation_fluxes,use_reff, & + platform,satellite,Instrument,Nchannels, & + Channels,Surfem,ZenAng,co2,ch4,n2o,co + +!---------------- End of declaration of variables -------------- + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Read namelist with COSP inputs +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + + print*,'Entree phys_cosp2' + if (debut_cosp) then + NPoints=Nptslmdz + Nlevels=Nlevlmdz + +! Lecture du namelist input +! CALL read_cosp_input + IF (is_master) THEN + OPEN(10,file=cosp_input_nl,status='old') + READ(10,nml=cosp_input) + CLOSE(10) + ENDIF +!$OMP BARRIER + CALL bcast(overlap) + CALL bcast(isccp_topheight) + CALL bcast(isccp_topheight_direction) + CALL bcast(npoints_it) + CALL bcast(ncolumns) + CALL bcast(use_vgrid) + CALL bcast(Nlvgrid) + CALL bcast(csat_vgrid) + CALL bcast(radar_freq) + CALL bcast(surface_radar) + CALL bcast(use_mie_tables) + CALL bcast(use_gas_abs) + CALL bcast(do_ray) + CALL bcast(melt_lay) + CALL bcast(k2) + CALL bcast(Nprmts_max_hydro) + CALL bcast(Naero) + CALL bcast(Nprmts_max_aero) + CALL bcast(lidar_ice_type) + CALL bcast(use_precipitation_fluxes) + CALL bcast(use_reff) + CALL bcast(platform) + CALL bcast(satellite) + CALL bcast(Instrument) + CALL bcast(Nchannels) + CALL bcast(Channels) + CALL bcast(Surfem) + CALL bcast(ZenAng) + CALL bcast(co2) + CALL bcast(ch4) + CALL bcast(n2o) + CALL bcast(co) + + print*,'ok read cosp_input_nl' + +! Clefs Outputs initialisation + call cosp_outputkeys_init(cfg) +!!! call cosp_outputkeys_test(cfg) + print*,' Cles des differents simulateurs cosp a itap :',itap + print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim,Lstats', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim, & + cfg%Lrttov_sim,cfg%Lstats + + if (overlaplmdz.ne.overlap) then + print*,'Attention overlaplmdz different de overlap lu dans namelist ' + endif + print*,'Fin lecture Namelists, debut_cosp =',debut_cosp + + endif ! debut_cosp + +!!! Ici on modifie les cles logiques pour les outputs selon les champs actives dans les .xml + if ((itap.gt.1).and.(first_write))then +#ifdef CPP_XIOS + call read_xiosfieldactive(cfg) +#else + call read_cosp_output_nl(itap,cosp_output_nl,cfg) +#endif + first_write=.false. + + print*,' Cles des differents simulateurs cosp a itap :',itap + print*,'Lradar_sim,Llidar_sim,Lisccp_sim,Lmisr_sim,Lmodis_sim,Lrttov_sim,Lstats', & + cfg%Lradar_sim,cfg%Llidar_sim,cfg%Lisccp_sim,cfg%Lmisr_sim,cfg%Lmodis_sim, & + cfg%Lrttov_sim,cfg%Lstats + endif + + time_bnds(1) = dtime-dtime/2. + time_bnds(2) = dtime+dtime/2. + + d_time_bnds=time_bnds + d_dtime=dtime + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Allocate memory for gridbox type +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! AI mars 2017 +! print *, 'Allocating memory for gridbox type...' + +! Surafce emissivity + emsfc_lw = 1. + + call construct_cosp_gridbox(d_dtime,d_time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs, & + do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_topheight,isccp_topheight_direction,overlap,emsfc_lw, & + use_precipitation_fluxes,use_reff, & + Platform,Satellite,Instrument,Nchannels,ZenAng, & + channels(1:Nchannels),surfem(1:Nchannels),co2,ch4,n2o,co,gbx) + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! Here code to populate input structure +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + +! print *, 'Populating input structure...' + gbx%longitude = lon + gbx%latitude = lat + + gbx%p = p ! + gbx%ph = ph + gbx%zlev = phi/9.81 + + zlev_half(:,1) = phis(:)/9.81 + do k = 2, Nlevels + do ip = 1, Npoints + zlev_half(ip,k) = phi(ip,k)/9.81 + & + (phi(ip,k)-phi(ip,k-1))/9.81 * (ph(ip,k)-p(ip,k)) / (p(ip,k)-p(ip,k-1)) + enddo + enddo + gbx%zlev_half = zlev_half + + gbx%T = T + gbx%q = rh*100. + gbx%sh = sh +! On ne veut pas que cosp distingue les nuages stratiformes et convectifs +! on passe les contenus totaux (conv+strat) + gbx%cca = 0. !convective_cloud_amount (1) + gbx%tca = tca ! total_cloud_amount (1) + gbx%psfc = ph(:,1) !pression de surface + gbx%skt = skt !Skin temperature (K) + + do ip = 1, Npoints + if (fracTerLic(ip).ge.0.5) then + gbx%land(ip) = 1. + else + gbx%land(ip) = 0. + endif + enddo + gbx%mr_ozone = mr_ozone !mass_fraction_of_ozone_in_air (kg/kg) +! A voir l equivalent LMDZ (u10m et v10m) + gbx%u_wind = u_wind !eastward_wind (m s-1) + gbx%v_wind = v_wind !northward_wind + +! sunlit calcule a partir de la fraction d ensoleillement par jour +! do ip = 1, Npoints +! if (sunlit(ip).le.0.) then +! gbx%sunlit(ip)=0. +! else +! gbx%sunlit(ip)=1. +! endif +! enddo + gbx%sunlit=sunlit + +! A voir l equivalent LMDZ + mr_ccliq = 0.0 + mr_ccice = 0.0 + gbx%mr_hydro(:,:,I_LSCLIQ) = mr_lsliq !mixing_ratio_large_scale_cloud_liquid (kg/kg) + gbx%mr_hydro(:,:,I_LSCICE) = mr_lsice !mixing_ratio_large_scale_cloud_ic + gbx%mr_hydro(:,:,I_CVCLIQ) = mr_ccliq !mixing_ratio_convective_cloud_liquid + gbx%mr_hydro(:,:,I_CVCICE) = mr_ccice !mixing_ratio_convective_cloud_ice +! A revoir + fl_lsrain = fl_lsrainI + fl_ccrainI + fl_lssnow = fl_lssnowI + fl_ccsnowI + gbx%rain_ls = fl_lsrain !flux_large_scale_cloud_rain (kg m^-2 s^-1) + gbx%snow_ls = fl_lssnow !flux_large_scale_cloud_snow +! A voir l equivalent LMDZ + fl_lsgrpl=0. + fl_ccsnow = 0. + fl_ccrain = 0. + gbx%grpl_ls = fl_lsgrpl !flux_large_scale_cloud_graupel + gbx%rain_cv = fl_ccrain !flux_convective_cloud_rain + gbx%snow_cv = fl_ccsnow !flux_convective_cloud_snow + + gbx%Reff(:,:,I_LSCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_LSCICE) = ref_ice*1e-6 +!! AI A revoir + gbx%Reff(:,:,I_CVCLIQ) = ref_liq*1e-6 + gbx%Reff(:,:,I_CVCICE) = ref_ice*1e-6 + + ! ISCCP simulator + gbx%dtau_s = dtau_s + gbx%dtau_c = 0. + gbx%dem_s = dem_s + gbx%dem_c = 0. + +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Define new vertical grid +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! print *, 'Defining new vertical grid...' + call construct_cosp_vgrid(gbx,Nlvgrid,use_vgrid,csat_vgrid,vgrid) + print*,'Nlvgrid,use_vgrid,csat_vgrid ',Nlvgrid,use_vgrid,csat_vgrid + print*,'vgrid%z, vgrid%mz ',vgrid%z, vgrid%mz +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Allocate memory for other types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ +! print *, 'Allocating memory for other types...' + call construct_cosp_subgrid(Npoints, Ncolumns, Nlevels, sgx) + if (cfg%Lradar_sim) call construct_cosp_sgradar(Npoints,Ncolumns,Nlevels,N_HYDRO,sgradar) + if (cfg%Lradar_sim) call construct_cosp_radarstats(Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar) + if (cfg%Llidar_sim) call construct_cosp_sglidar(Npoints,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar) + if (cfg%Llidar_sim) call construct_cosp_lidarstats(Npoints,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar) + if (cfg%Lisccp_sim) call construct_cosp_isccp(Npoints,Ncolumns,Nlevels,isccp) +!! AI rajout + if (cfg%Lmodis_sim) call construct_cosp_modis(Npoints,modis) +!! + if (cfg%Lmisr_sim) call construct_cosp_misr(Npoints,misr) +! call construct_cosp_rttov(cfg,Npoints,Nchannels,rttov) + + if (debut_cosp) then + !$OMP MASTER + print *, ' Open outpts files and define axis' + call cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp, & + ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, & + ecrit_mth, ecrit_day, ecrit_hf, vgrid) + !$OMP END MASTER + !$OMP BARRIER + debut_cosp=.false. + endif ! debut_cosp + +!!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Call simulator +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print*,'call simulateur' + call cosp(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar, & + isccp,misr,modis,rttov,stradar,stlidar) + + +!!!!!!!!!!!!!!!!!! Ecreture des sorties Cosp !!!!!!!!!!!!!!r!!!!!!:!!!!! + + print *, 'Calling write output' + call cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_val, & + cfg, gbx, vgrid, sglidar, sgradar, stlidar, stradar, & + isccp, misr, modis) +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Deallocate memory in derived types +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + print *, 'Deallocating memory...' + call free_cosp_gridbox(gbx) + print *, 'free_cosp_gridbox' + call free_cosp_subgrid(sgx) + print *, 'ffree_cosp_subgrid' + call free_cosp_vgrid(vgrid) + print *, 'free_cosp_vgrid' + if (cfg%Lradar_sim) call free_cosp_sgradar(sgradar) + if (cfg%Lradar_sim) call free_cosp_radarstats(stradar) + if (cfg%Llidar_sim) call free_cosp_sglidar(sglidar) + if (cfg%Llidar_sim) call free_cosp_lidarstats(stlidar) + if (cfg%Lisccp_sim) call free_cosp_isccp(isccp) + if (cfg%Lmisr_sim) call free_cosp_misr(misr) + if (cfg%Lmodis_sim) call free_cosp_modis(modis) + if (cfg%Lrttov_sim) call free_cosp_rttov(rttov) + print *, 'End phys_cosp2' +!+++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++ + ! Time in s. Only for testing purposes +! call system_clock(t1,count_rate,count_max) +! print *,(t1-t0)*1.0/count_rate + +end subroutine phys_cosp2 Index: LMDZ6/trunk/libf/phylmd/cosp2/prec_scops.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/prec_scops.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/prec_scops.F90 (revision 3358) @@ -0,0 +1,277 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2008, Lawrence Livermore National Security Limited Liability Corporation +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015- D. Swales - Modified for COSPv2.0 +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_prec_scops + implicit none +contains + + subroutine prec_scops(npoints,nlev,ncol,ls_p_rate,cv_p_rate,frac_out,prec_frac) + + USE COSP_KINDS, ONLY: wp + use mod_cosp_config, ONLY: scops_ccfrac + + INTEGER npoints ! number of model points in the horizontal + INTEGER nlev ! number of model levels in column + INTEGER ncol ! number of subcolumns + + INTEGER j,ilev,ibox,cv_col + + REAL(WP) ls_p_rate(npoints,nlev),cv_p_rate(npoints,nlev) + + REAL(WP) frac_out(npoints,ncol,nlev) ! boxes gridbox divided up into + ! Equivalent of BOX in original version, but + ! indexed by column then row, rather than + ! by row then column + !TOA to SURFACE!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + REAL(WP) prec_frac(npoints,ncol,nlev) ! 0 -> clear sky + ! 1 -> LS precipitation + ! 2 -> CONV precipitation + ! 3 -> both + !TOA to SURFACE!!!!!!!!!!!!!!!!!! + + INTEGER flag_ls, flag_cv + INTEGER frac_out_ls(npoints,ncol),frac_out_cv(npoints,ncol) !flag variables for + ! stratiform cloud and convective cloud in the vertical column + + cv_col = scops_ccfrac*ncol + if (cv_col .eq. 0) cv_col=1 + + do ilev=1,nlev + do ibox=1,ncol + do j=1,npoints + prec_frac(j,ibox,ilev) = 0 + enddo + enddo + enddo + + do j=1,npoints + do ibox=1,ncol + frac_out_ls(j,ibox)=0 + frac_out_cv(j,ibox)=0 + flag_ls=0 + flag_cv=0 + do ilev=1,nlev + if (frac_out(j,ibox,ilev) .eq. 1) then + flag_ls=1 + endif + if (frac_out(j,ibox,ilev) .eq. 2) then + flag_cv=1 + endif + enddo !loop over nlev + if (flag_ls .eq. 1) then + frac_out_ls(j,ibox)=1 + endif + if (flag_cv .eq. 1) then + frac_out_cv(j,ibox)=1 + endif + enddo ! loop over ncol + enddo ! loop over npoints + +! initialize the top layer + do j=1,npoints + flag_ls=0 + flag_cv=0 + + if (ls_p_rate(j,1) .gt. 0.) then + do ibox=1,ncol ! possibility ONE + if (frac_out(j,ibox,1) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + if (flag_ls .eq. 0) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,2) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_ls(j,ibox) .eq. 1) then + prec_frac(j,ibox,1) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Five + do ibox=1,ncol + ! prec_frac(j,1:ncol,1) = 1 + prec_frac(j,ibox,1) = 1 + enddo ! loop over ncol + endif + endif + ! There is large scale precipitation + + if (cv_p_rate(j,1) .gt. 0.) then + do ibox=1,ncol ! possibility ONE + if (frac_out(j,ibox,1) .eq. 2) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + if (flag_cv .eq. 0) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,2) .eq. 2) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_cv(j,ibox) .eq. 1) then + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Five + do ibox=1,cv_col + if (prec_frac(j,ibox,1) .eq. 0) then + prec_frac(j,ibox,1) = 2 + else + prec_frac(j,ibox,1) = 3 + endif + enddo !loop over cv_col + endif + endif + ! There is convective precipitation + + enddo ! loop over npoints +! end of initializing the top layer + +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +! working on the levels from top to surface + do ilev=2,nlev + do j=1,npoints + flag_ls=0 + flag_cv=0 + + if (ls_p_rate(j,ilev) .gt. 0.) then + do ibox=1,ncol ! possibility ONE&TWO + if ((frac_out(j,ibox,ilev) .eq. 1) .or. ((prec_frac(j,ibox,ilev-1) .eq. 1) & + .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + if ((flag_ls .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,ilev+1) .eq. 1) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_ls(j,ibox) .eq. 1) then + prec_frac(j,ibox,ilev) = 1 + flag_ls=1 + endif + enddo ! loop over ncol + endif + if (flag_ls .eq. 0) then ! possibility Five + do ibox=1,ncol +! prec_frac(j,1:ncol,ilev) = 1 + prec_frac(j,ibox,ilev) = 1 + enddo ! loop over ncol + endif + endif ! There is large scale precipitation + + if (cv_p_rate(j,ilev) .gt. 0.) then + do ibox=1,ncol ! possibility ONE&TWO + if ((frac_out(j,ibox,ilev) .eq. 2) .or. ((prec_frac(j,ibox,ilev-1) .eq. 2) & + .or. (prec_frac(j,ibox,ilev-1) .eq. 3))) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + if ((flag_cv .eq. 0) .and. (ilev .lt. nlev)) then ! possibility THREE + do ibox=1,ncol + if (frac_out(j,ibox,ilev+1) .eq. 2) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Four + do ibox=1,ncol + if (frac_out_cv(j,ibox) .eq. 1) then + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + flag_cv=1 + endif + enddo ! loop over ncol + endif + if (flag_cv .eq. 0) then ! possibility Five + do ibox=1,cv_col + if (prec_frac(j,ibox,ilev) .eq. 0) then + prec_frac(j,ibox,ilev) = 2 + else + prec_frac(j,ibox,ilev) = 3 + endif + enddo !loop over cv_col + endif + endif ! There is convective precipitation + + enddo ! loop over npoints + enddo ! loop over nlev + + end subroutine prec_scops +end module mod_prec_scops Index: LMDZ6/trunk/libf/phylmd/cosp2/quickbeam.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/quickbeam.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/quickbeam.F90 (revision 3358) @@ -0,0 +1,387 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! 11/2005: John Haynes - Created +! 09/2006 placed into subroutine form (Roger Marchand,JMH) +! 08/2007 added equivalent volume spheres, Z and N scalling most distrubtion types (Roger Marchand) +! 01/2008 'Do while' to determine if hydrometeor(s) present in volume +! changed for vectorization purposes (A. Bodas-Salcedo) +! +! 07/2010 V3.0 ... Modified to load or save scale factors to disk as a Look-Up Table (LUT) +! ... All hydrometeor and radar simulator properties now included in hp structure +! ... hp structure should be initialized by call to radar_simulator_init prior +! ... to calling this subroutine. +! Also ... Support of Morrison 2-moment style microphyscis (Np_matrix) added +! ... Changes implement by Roj Marchand following work by Laura Fowler +! +! 10/2011 Modified ngate loop to go in either direction depending on flag +! hp%radar_at_layer_one. This affects the direction in which attenuation is summed. +! +! Also removed called to AVINT for gas and hydrometeor attenuation and replaced with simple +! summation. (Roger Marchand) +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module quickbeam + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: DBZE_BINS,DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH, & + R_UNDEF,cloudsat_histRef,use_vgrid,vgrid_zl,vgrid_zu + USE MOD_COSP_STATS, ONLY: COSP_LIDAR_ONLY_CLOUD,hist1D,COSP_CHANGE_VERTICAL_GRID + implicit none + + integer,parameter :: & + maxhclass = 20, & ! Qucikbeam maximum number of hydrometeor classes. + nRe_types = 550, & ! Quickbeam maximum number or Re size bins allowed in N and Z_scaled look up table. + nd = 85, & ! Qucikbeam number of discrete particles used in construction DSDs. + mt_ntt = 39, & ! Quickbeam number of temperatures in mie LUT. + Re_BIN_LENGTH = 10, & ! Quickbeam minimum Re interval in scale LUTs + Re_MAX_BIN = 250 ! Quickbeam maximum Re interval in scale LUTs + real(wp),parameter :: & + dmin = 0.1, & ! Quickbeam minimum size of discrete particle + dmax = 10000. ! Quickbeam maximum size of discrete particle + + !djs logical :: radar_at_layer_one ! If true radar is assume to be at the edge + ! of the first layer, if the first layer is the + ! surface than a ground-based radar. If the + ! first layer is the top-of-atmosphere, then + ! a space borne radar. + + ! ############################################################################################## + type radar_cfg + ! Radar properties + real(wp) :: freq,k2 + integer :: nhclass ! Number of hydrometeor classes in use + integer :: use_gas_abs, do_ray + logical :: radar_at_layer_one ! If true radar is assume to be at the edge + ! of the first layer, if the first layer is the + ! surface than a ground-based radar. If the + ! first layer is the top-of-atmosphere, then + ! a space borne radar. + + ! Variables used to store Z scale factors + character(len=240) :: scale_LUT_file_name + logical :: load_scale_LUTs, update_scale_LUTs + logical, dimension(maxhclass,nRe_types) :: N_scale_flag + logical, dimension(maxhclass,mt_ntt,nRe_types) :: Z_scale_flag,Z_scale_added_flag + real(wp),dimension(maxhclass,mt_ntt,nRe_types) :: Ze_scaled,Zr_scaled,kr_scaled + real(wp),dimension(maxhclass,nd,nRe_types) :: fc, rho_eff + real(wp),dimension(Re_MAX_BIN) :: base_list,step_list + + end type radar_cfg + +contains + ! ###################################################################################### + ! SUBROUTINE quickbeam_subcolumn + ! ###################################################################################### + !subroutine quickbeam_subcolumn(rcfg,nprof,ngate,hgt_matrix,z_vol,kr_vol,g_vol,& + ! a_to_vol,g_to_vol,dBZe,Ze_non,Ze_ray) + subroutine quickbeam_subcolumn(rcfg,nprof,ngate,hgt_matrix,z_vol,kr_vol,g_vol,dBZe) + + ! INPUTS + type(radar_cfg),intent(inout) :: & + rcfg ! Derived type for radar simulator setup + integer,intent(in) :: & + nprof, & ! Number of hydrometeor profiles + ngate ! Number of vertical layers + real(wp),intent(in),dimension(nprof,ngate) :: & + hgt_matrix, & ! Height of hydrometeors (km) + z_vol, & ! Effective reflectivity factor (mm^6/m^3) + kr_vol, & ! Attenuation coefficient hydro (dB/km) + g_vol ! Attenuation coefficient gases (dB/km) + + ! OUTPUTS + real(wp), intent(out),dimension(nprof,ngate) :: & +! Ze_non, & ! Radar reflectivity without attenuation (dBZ) +! Ze_ray, & ! Rayleigh reflectivity (dBZ) +! g_to_vol, & ! Gaseous atteunation, radar to vol (dB) +! a_to_vol, & ! Hydromets attenuation, radar to vol (dB) + dBZe ! Effective radar reflectivity factor (dBZ) + + ! LOCAL VARIABLES + integer :: k,pr,start_gate,end_gate,d_gate + real(wp),dimension(nprof,ngate) :: & + Ze_non, & ! Radar reflectivity without attenuation (dBZ) + Ze_ray, & ! Rayleigh reflectivity (dBZ) + g_to_vol, & ! Gaseous atteunation, radar to vol (dB) + a_to_vol, & ! Hydromets attenuation, radar to vol (dB) + z_ray ! Reflectivity factor, Rayleigh only (mm^6/m^3) + + ! Load scaling matricies from disk -- but only the first time this subroutine is called + if(rcfg%load_scale_LUTs) then + call load_scale_LUTs(rcfg) + rcfg%load_scale_LUTs=.false. + rcfg%Z_scale_added_flag = .false. ! will be set true if scaling Look Up Tables are modified during run + endif + + ! Initialization + g_to_vol = 0._wp + a_to_vol = 0._wp + + ! Loop over each range gate (ngate) ... starting with layer closest to the radar ! + if(rcfg%radar_at_layer_one) then + start_gate = 1 + end_gate = ngate + d_gate = 1 + else + start_gate = ngate + end_gate = 1 + d_gate = -1 + endif + do k=start_gate,end_gate,d_gate + ! Loop over each profile (nprof) + do pr=1,nprof + ! Attenuation due to hydrometeors between radar and volume + + ! NOTE old scheme integrates attenuation only for the layers ABOVE + ! the current layer ... i.e. 1 to k-1 rather than 1 to k ... + ! which may be a problem. ROJ + ! in the new scheme I assign half the attenuation to the current layer + if(d_gate==1) then + ! dheight calcuations assumes hgt_matrix points are the cell mid-points. + if (k>2) then + ! add to previous value to half of above layer + half of current layer + a_to_vol(pr,k)= a_to_vol(pr,k-1) + & + (kr_vol(pr,k-1)+kr_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k)) + else + a_to_vol(pr,k)= kr_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1)) + endif + else ! d_gate==-1 + if(k1) then + ! Add to previous value to half of above layer + half of current layer + g_to_vol(pr,k) = g_to_vol(pr,k-1) + & + 0.5*(g_vol(pr,k-1)+g_vol(pr,k))*(hgt_matrix(pr,k-1)-hgt_matrix(pr,k)) + else + g_to_vol(pr,k)= 0.5_wp*g_vol(pr,k)*(hgt_matrix(pr,k)-hgt_matrix(pr,k+1)) + endif + else ! d_gate==-1 + if (k 0._wp) + Ze_ray(1:nprof,1:ngate) = 10._wp*log10(z_ray(1:nprof,1:ngate)) + elsewhere + Ze_Ray(1:nprof,1:ngate) = 0._wp + endwhere +!djs Ze_ray(1:nprof,1:ngate) = merge(10._wp*log10(z_ray(1:nprof,1:ngate)), 1._wp*R_UNDEF, z_ray(1:nprof,1:ngate) > 0._wp) + else + Ze_ray(1:nprof,1:ngate) = R_UNDEF + end if + + where(z_vol(1:nprof,1:ngate) > 0._wp) + Ze_non(1:nprof,1:ngate) = 10._wp*log10(z_vol(1:nprof,1:ngate)) + dBZe(1:nprof,1:ngate) = Ze_non(1:nprof,1:ngate)-a_to_vol(1:nprof,1:ngate)-g_to_vol(1:nprof,1:ngate) + elsewhere + dBZe(1:nprof,1:ngate) = R_UNDEF + Ze_non(1:nprof,1:ngate) = R_UNDEF + end where + + ! Save any updates made + if (rcfg%update_scale_LUTs) call save_scale_LUTs(rcfg) + + end subroutine quickbeam_subcolumn + ! ###################################################################################### + ! SUBROUTINE quickbeam_column + ! ###################################################################################### + subroutine quickbeam_column(npoints,ncolumns,nlevels,llm,Ze_tot,zlev,zlev_half,cfad_ze) + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal grid points + ncolumns, & ! Number of subcolumns + nlevels, & ! Number of vertical layers in OLD grid + llm ! NUmber of vertical layers in NEW grid + real(wp),intent(in),dimension(npoints,ncolumns,Nlevels) :: & + Ze_tot ! + real(wp),intent(in),dimension(npoints,Nlevels) :: & + zlev ! Model full levels + real(wp),intent(in),dimension(npoints,Nlevels+1) :: & + zlev_half ! Model half levels + + ! Outputs + real(wp),intent(inout),dimension(npoints,DBZE_BINS,llm) :: & + cfad_ze ! + + ! Local variables + integer :: i,j + real(wp),dimension(npoints,ncolumns,llm) :: ze_totFlip + + if (use_vgrid) then + ! Regrid in the vertical + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,zlev(:,nlevels:1:-1),& + zlev_half(:,nlevels:1:-1),Ze_tot(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),& + vgrid_zu(llm:1:-1),Ze_totFlip(:,:,llm:1:-1),log_units=.true.) + + ! Effective reflectivity histogram + do i=1,Npoints + do j=1,llm + cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_totFlip(i,:,j),DBZE_BINS,cloudsat_histRef) + enddo + enddo + where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns + + else + ! Effective reflectivity histogram + do i=1,Npoints + do j=1,llm + cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_tot(i,:,j),DBZE_BINS,cloudsat_histRef) + enddo + enddo + where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns + endif + + end subroutine quickbeam_column + ! ############################################################################################## + ! ############################################################################################## + + + ! ############################################################################################## + ! ############################################################################################## + subroutine load_scale_LUTs(rcfg) + + type(radar_cfg), intent(inout) :: rcfg + logical :: LUT_file_exists + integer :: i,j,k,ind + + ! Load scale LUT from file + inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', & + exist=LUT_file_exists) + + if(.not.LUT_file_exists) then + write(*,*) '*************************************************' + write(*,*) 'Warning: Could NOT FIND radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + write(*,*) 'Will calculated LUT values as needed' + write(*,*) '*************************************************' + return + else + OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& + form='unformatted', & + err= 89, & + access='DIRECT',& + recl=28) + write(*,*) 'Loading radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + do i=1,maxhclass + do j=1,mt_ntt + do k=1,nRe_types + ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) + read(12,rec=ind) rcfg%Z_scale_flag(i,j,k), & + rcfg%Ze_scaled(i,j,k), & + rcfg%Zr_scaled(i,j,k), & + rcfg%kr_scaled(i,j,k) + enddo + enddo + enddo + close(unit=12) + return + endif + +89 write(*,*) 'Error: Found but could NOT READ radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + end subroutine load_scale_LUTs + + ! ############################################################################################## + ! ############################################################################################## + subroutine save_scale_LUTs(rcfg) + type(radar_cfg), intent(inout) :: rcfg + logical :: LUT_file_exists + integer :: i,j,k,ind + + inquire(file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', & + exist=LUT_file_exists) + + OPEN(unit=12,file=trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& + form='unformatted',err= 99,access='DIRECT',recl=28) + + write(*,*) 'Creating or Updating radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + do i=1,maxhclass + do j=1,mt_ntt + do k=1,nRe_types + ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) + if(.not.LUT_file_exists .or. rcfg%Z_scale_added_flag(i,j,k)) then + rcfg%Z_scale_added_flag(i,j,k)=.false. + write(12,rec=ind) rcfg%Z_scale_flag(i,j,k), & + rcfg%Ze_scaled(i,j,k), & + rcfg%Zr_scaled(i,j,k), & + rcfg%kr_scaled(i,j,k) + endif + enddo + enddo + enddo + close(unit=12) + return + +99 write(*,*) 'Error: Unable to create/update radar LUT file: ', & + trim(rcfg%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + return + + end subroutine save_scale_LUTs + ! ############################################################################################## + ! ############################################################################################## + subroutine quickbeam_init() + + + end subroutine quickBeam_init + ! ############################################################################################## + ! ############################################################################################## + + +end module quickbeam + + Index: LMDZ6/trunk/libf/phylmd/cosp2/quickbeam_optics.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/quickbeam_optics.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/quickbeam_optics.F90 (revision 3358) @@ -0,0 +1,1406 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2015, Regents of the University of Colorado +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History: +! May 2015: Dustin Swales - Initial version +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_quickbeam_optics + USE COSP_KINDS, ONLY: wp,dp + USE array_lib, ONLY: infind + USE math_lib, ONLY: path_integral,avint,gamma + USE optics_lib, ONLY: m_wat,m_ice,MieInt + USE cosp_math_constants, ONLY: pi + USE cosp_phys_constants, ONLY: rhoice + use quickbeam, ONLY: radar_cfg,dmin,dmax,Re_BIN_LENGTH, & + Re_MAX_BIN,nRe_types,nd,maxhclass + use mod_cosp_config, ONLY: N_HYDRO + use mod_cosp_error, ONLY: errorMessage + implicit none + + ! Derived type for particle size distribution + TYPE size_distribution + real(wp),dimension(maxhclass) :: p1,p2,p3,dmin,dmax,apm,bpm,rho + integer, dimension(maxhclass) :: dtype,phase + END TYPE size_distribution + + ! Parameters + integer,parameter :: & ! + cnt_liq = 19, & ! Liquid temperature count + cnt_ice = 20 ! Lce temperature count + + ! Initialization variables + real(wp),dimension(cnt_ice) :: mt_tti + real(wp),dimension(cnt_liq) :: mt_ttl + real(wp),dimension(nd) :: D + logical :: lQuickbeamInit + +contains + ! ###################################################################################### + ! SUBROUTINE quickbeam_optics_init + ! ###################################################################################### + subroutine quickbeam_optics_init() + integer :: j + + mt_tti = (/ ((j-1)*5-90 + 273.15, j = 1, cnt_ice) /) + mt_ttl = (/ ((j-1)*5-60 + 273.15, j = 1, cnt_liq) /) + D(1) = dmin + do j=2,nd + D(j) = D(j-1)*exp((log(dmax)-log(dmin))/(nd-1)) + enddo + lQuickbeamInit = .true. + end subroutine quickbeam_optics_init + + ! ###################################################################################### + ! SUBROUTINE QUICKBEAM_OPTICS + ! ###################################################################################### + subroutine quickbeam_optics(sd, rcfg, nprof, ngate, undef, hm_matrix, re_matrix, & + Np_matrix, p_matrix, t_matrix, sh_matrix,cmpGases, & + z_vol,kr_vol,g_vol,g_vol_in,g_vol_out) + + ! INPUTS + type(size_distribution),intent(inout) :: & + sd ! + type(radar_cfg),intent(inout) :: & + rcfg ! + integer,intent(in) :: & + nprof, & ! Number of hydrometeor profiles + ngate ! Number of vertical layers + real(wp),intent(in) :: & + undef ! Missing data value + real(wp),intent(in),dimension(nprof,ngate) :: & + p_matrix, & ! Pressure profile (hPa) + t_matrix, & ! Temperature profile (K) + sh_matrix ! Specific humidity profile (%) -- only needed if gaseous aborption calculated. + real(wp),intent(in),dimension(nprof,ngate,rcfg%nhclass) :: & + re_matrix, & ! Table of hydrometeor effective radii. 0 ==> use defaults. (units=microns) + hm_matrix ! Table of hydrometeor mixing ratios (g/kg) + real(wp),intent(inout),dimension(nprof,ngate,rcfg%nhclass) :: & + Np_matrix ! Table of hydrometeor number concentration. 0 ==> use defaults. (units = 1/kg) + logical,intent(inout) :: & + cmpGases ! Compute gaseous attenuation for all profiles + + ! OUTPUTS + real(wp),intent(out), dimension(nprof, ngate) :: & + z_vol, & ! Effective reflectivity factor (mm^6/m^3) + kr_vol, & ! Attenuation coefficient hydro (dB/km) + g_vol ! Attenuation coefficient gases (dB/km) + + ! OPTIONAL + real(wp),dimension(nprof,ngate),optional :: & + g_vol_in,g_vol_out + + ! INTERNAL VARIABLES + integer :: & + phase, ns,tp,j,k,pr,itt,iRe_type,n + logical :: & + hydro,g_vol_in_present,g_vol_out_present + real(wp) :: & + t_kelvin,Re_internal + real(wp) :: & + rho_a,kr,ze,zr,scale_factor,Re,Np,base,step + + real(wp),dimension(:),allocatable :: & + Deq, & ! Discrete drop sizes (um) + Ni, & ! Discrete concentrations (cm^-3 um^-1) + rhoi, & ! Discrete densities (kg m^-3) + xxa, & ! + Di ! Discrete drop sizes (um) + + real(wp), dimension(nprof, ngate) :: & + z_ray ! Reflectivity factor, Rayleigh only (mm^6/m^3) + + ! PARAMETERS + logical, parameter :: & ! + DO_LUT_TEST = .false., & ! + DO_NP_TEST = .false. ! + real(wp), parameter :: & + one_third = 1._wp/3._wp ! + + g_vol_in_present = present(g_vol_in) + g_vol_out_present = present(g_vol_out) + + ! Initialization + if (.not. lQuickbeamInit) call quickbeam_optics_init() + z_vol = 0._wp + z_ray = 0._wp + kr_vol = 0._wp + + do k=1,ngate ! Loop over each profile (nprof) + do pr=1,nprof + if (g_vol_in_present) then + g_vol(pr,k) = g_vol_in(pr,k) + endif + + ! Gas attenuation (only need to do this for the first subcolumn (i.e. cmpGases=true) + if (cmpGases) then + if (rcfg%use_gas_abs == 1 .or. (rcfg%use_gas_abs == 2 .and. pr .eq. 1)) then + g_vol(pr,k) = gases(p_matrix(pr,k),t_matrix(pr,k),sh_matrix(pr,k),rcfg%freq) + endif + endif + + ! Determine if hydrometeor(s) present in volume + hydro = .false. + do j=1,rcfg%nhclass + if ((hm_matrix(pr,k,j) > 1E-12) .and. (sd%dtype(j) > 0)) then + hydro = .true. + exit + endif + enddo + + t_kelvin = t_matrix(pr,k) + ! If there is hydrometeor in the volume + if (hydro) then + rho_a = (p_matrix(pr,k))/(287._wp*(t_kelvin)) + + ! Loop over hydrometeor type + do tp=1,rcfg%nhclass + Re_internal = re_matrix(pr,k,tp) + + if (hm_matrix(pr,k,tp) <= 1E-12) cycle + + ! Index into temperature dimension of scaling tables + ! These tables have regular steps -- exploit this and abandon infind + phase = sd%phase(tp) + if (phase==0) then + itt = infind(mt_ttl,t_kelvin) + else + itt = infind(mt_tti,t_kelvin) + endif + + ! Compute effective radius from number concentration and distribution parameters + if (Re_internal .eq. 0) then + call calc_Re(hm_matrix(pr,k,tp),Np_matrix(pr,k,tp),rho_a, & + sd%dtype(tp),sd%apm(tp),sd%bpm(tp),sd%rho(tp),sd%p1(tp),sd%p2(tp),sd%p3(tp),Re) + Re_internal=Re + !re_matrix(pr,k,tp)=Re + else + if (Np_matrix(pr,k,tp) > 0) then + call errorMessage('WARNING(optics/quickbeam_optics.f90): Re and Np set for the same volume & hydrometeor type. Np is being ignored.') + endif + Re = Re_internal + !Re = re_matrix(pr,k,tp) + endif + + ! Index into particle size dimension of scaling tables + iRe_type=1 + if(Re.gt.0) then + ! Determine index in to scale LUT + ! Distance between Re points (defined by "base" and "step") for + ! each interval of size Re_BIN_LENGTH + ! Integer asignment, avoids calling floor intrinsic + n=Re/Re_BIN_LENGTH + if (n>=Re_MAX_BIN) n=Re_MAX_BIN-1 + step = rcfg%step_list(n+1) + base = rcfg%base_list(n+1) + iRe_type=Re/step + if (iRe_type.lt.1) iRe_type=1 + Re=step*(iRe_type+0.5_wp) ! set value of Re to closest value allowed in LUT. + iRe_type=iRe_type+base-int(n*Re_BIN_LENGTH/step) + + ! Make sure iRe_type is within bounds + if (iRe_type.ge.nRe_types) then + !write(*,*) 'Warning: size of Re exceed value permitted ', & + ! 'in Look-Up Table (LUT). Will calculate. ' + ! No scaling allowed + iRe_type=nRe_types + rcfg%Z_scale_flag(tp,itt,iRe_type)=.false. + else + ! Set value in re_matrix to closest values in LUT + if (.not. DO_LUT_TEST) re_internal=Re + !if (.not. DO_LUT_TEST) re_matrix(pr,k,tp)=Re + endif + endif + + ! Use Ze_scaled, Zr_scaled, and kr_scaled ... if know them + ! if not we will calculate Ze, Zr, and Kr from the distribution parameters +! if( rcfg%Z_scale_flag(tp,itt,iRe_type) .and. .not. DO_LUT_TEST) then +! ! can use z scaling +! scale_factor=rho_a*hm_matrix(pr,k,tp) +! zr = rcfg%Zr_scaled(tp,itt,iRe_type) * scale_factor +! ze = rcfg%Ze_scaled(tp,itt,iRe_type) * scale_factor +! kr = rcfg%kr_scaled(tp,itt,iRe_type) * scale_factor +! else + if( (.not. rcfg%Z_scale_flag(tp,itt,iRe_type)) .or. DO_LUT_TEST) then + ! Create a discrete distribution of hydrometeors within volume + select case(sd%dtype(tp)) + case(4) + ns = 1 + allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns)) + Di = sd%p1(tp) + Ni = 0._wp + case default + ns = nd ! constant defined in simulator/quickbeam.f90 + allocate(Di(ns),Ni(ns),rhoi(ns),xxa(ns),Deq(ns)) + Di = D + Ni = 0._wp + end select + call dsd(hm_matrix(pr,k,tp),re_internal,Np_matrix(pr,k,tp), & + Di,Ni,ns,sd%dtype(tp),rho_a,t_kelvin, & + sd%dmin(tp),sd%dmax(tp),sd%apm(tp),sd%bpm(tp), & + sd%rho(tp),sd%p1(tp),sd%p2(tp),sd%p3(tp)) + + ! Calculate particle density + if (phase == 1) then + if (sd%rho(tp) < 0) then + ! Use equivalent volume spheres. + rcfg%rho_eff(tp,1:ns,iRe_type) = rhoice ! solid ice == equivalent volume approach + Deq = ( ( 6/pi*sd%apm(tp)/rhoice) ** one_third ) * ( (Di*1E-6) ** (sd%bpm(tp)/3._wp) ) * 1E6 + ! alternative is to comment out above two lines and use the following block + ! MG Mie approach - adjust density of sphere with D = D_characteristic to match particle density + ! + ! rcfg%rho_eff(tp,1:ns,iRe_type) = (6/pi)*sd%apm(tp)*(Di*1E-6)**(sd%bpm(tp)-3) !MG Mie approach + + ! as the particle size gets small it is possible that the mass to size relationship of + ! (given by power law in hclass.data) can produce impossible results + ! where the mass is larger than a solid sphere of ice. + ! This loop ensures that no ice particle can have more mass/density larger than an ice sphere. + ! do i=1,ns + ! if(rcfg%rho_eff(tp,i,iRe_type) > 917 ) then + ! rcfg%rho_eff(tp,i,iRe_type) = 917 + ! endif + ! enddo + else + ! Equivalent volume sphere (solid ice rhoice=917 kg/m^3). + rcfg%rho_eff(tp,1:ns,iRe_type) = rhoice + Deq=Di * ((sd%rho(tp)/rhoice)**one_third) + ! alternative ... coment out above two lines and use the following for MG-Mie + ! rcfg%rho_eff(tp,1:ns,iRe_type) = sd%rho(tp) !MG Mie approach + endif + else + ! I assume here that water phase droplets are spheres. + ! sd%rho should be ~ 1000 or sd%apm=524 .and. sd%bpm=3 + Deq = Di + endif + + ! Calculate effective reflectivity factor of volume + ! xxa are unused (Mie scattering and extinction efficiencies) + xxa(1:ns) = -9.9_wp + rhoi = rcfg%rho_eff(tp,1:ns,iRe_type) + call zeff(rcfg%freq,Deq,Ni,ns,rcfg%k2,t_kelvin,phase,rcfg%do_ray, & + ze,zr,kr,xxa,xxa,rhoi) + + ! Test compares total number concentration with sum of discrete samples + ! The second test, below, compares ab initio and "scaled" computations + ! of reflectivity + ! These should get broken out as a unit test that gets called on + ! data. That routine could write to std out. + + ! Test code ... compare Np value input to routine with sum of DSD + ! NOTE: if .not. DO_LUT_TEST, then you are checking the LUT approximation + ! not just the DSD representation given by Ni + if(Np_matrix(pr,k,tp)>0 .and. DO_NP_TEST ) then + Np = path_integral(Ni,Di,1,ns-1)/rho_a*1.E6_wp + ! Note: Representation is not great or small Re < 2 + if( (Np_matrix(pr,k,tp)-Np)/Np_matrix(pr,k,tp)>0.1 ) then + call errorMessage('ERROR(optics/quickbeam_optics.f90): Error: Np input does not match sum(N)') + endif + endif + + ! Clean up space + deallocate(Di,Ni,rhoi,xxa,Deq) + + ! LUT test code + ! This segment of code compares full calculation to scaling result + if ( rcfg%Z_scale_flag(tp,itt,iRe_type) .and. DO_LUT_TEST ) then + scale_factor=rho_a*hm_matrix(pr,k,tp) + ! if more than 2 dBZe difference print error message/parameters. + if ( abs(10*log10(ze) - 10*log10(rcfg%Ze_scaled(tp,itt,iRe_type) * & + scale_factor)) > 2 ) then + call errorMessage('ERROR(optics/quickbeam_optics.f90): ERROR: Roj Error?') + endif + endif + else + ! Use z scaling + scale_factor=rho_a*hm_matrix(pr,k,tp) + zr = rcfg%Zr_scaled(tp,itt,iRe_type) * scale_factor + ze = rcfg%Ze_scaled(tp,itt,iRe_type) * scale_factor + kr = rcfg%kr_scaled(tp,itt,iRe_type) * scale_factor + endif ! end z_scaling + + kr_vol(pr,k) = kr_vol(pr,k) + kr + z_vol(pr,k) = z_vol(pr,k) + ze + z_ray(pr,k) = z_ray(pr,k) + zr + + ! Construct Ze_scaled, Zr_scaled, and kr_scaled ... if we can + if ( .not. rcfg%Z_scale_flag(tp,itt,iRe_type) ) then + if (iRe_type>1) then + scale_factor=rho_a*hm_matrix(pr,k,tp) + rcfg%Ze_scaled(tp,itt,iRe_type) = ze/ scale_factor + rcfg%Zr_scaled(tp,itt,iRe_type) = zr/ scale_factor + rcfg%kr_scaled(tp,itt,iRe_type) = kr/ scale_factor + rcfg%Z_scale_flag(tp,itt,iRe_type) = .true. + rcfg%Z_scale_added_flag(tp,itt,iRe_type)=.true. + endif + endif + enddo ! end loop of tp (hydrometeor type) + endif + enddo + enddo + + ! Only need to compute gaseous absorption for the first subcolumn, so turn off after first call. + cmpGases=.false. + + where(kr_vol(:,:) <= EPSILON(kr_vol)) + ! Volume is hydrometeor-free + !z_vol(:,:) = undef + z_ray(:,:) = undef + end where + + end subroutine quickbeam_optics + ! ############################################################################################## + ! ############################################################################################## + subroutine calc_Re(Q,Np,rho_a,dtype,apm,bpm,rho_c,p1,p2,p3,Re) + ! ############################################################################################## + ! Purpose: + ! Calculates Effective Radius (1/2 distribution 3rd moment / 2nd moment). + ! + ! For some distribution types, the total number concentration (per kg), Np + ! may be optionally specified. Should be set to zero, otherwise. + ! + ! Roj Marchand July 2010 + ! + ! Inputs: + ! + ! [Q] hydrometeor mixing ratio (g/kg) ! not needed for some distribution types + ! [Np] Optional Total number concentration (per kg). 0 = use defaults (p1, p2, p3) + ! [rho_a] ambient air density (kg m^-3) + ! + ! Distribution parameters as per quickbeam documentation. + ! [dtype] distribution type + ! [apm] a parameter for mass (kg m^[-bpm]) + ! [bmp] b params for mass + ! [p1],[p2],[p3] distribution parameters + ! + ! Outputs: + ! [Re] Effective radius, 1/2 the 3rd moment/2nd moment (um) + ! + ! Created: + ! July 2010 Roj Marchand + ! Modified: + ! 12/18/14 Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov) + ! + ! ############################################################################################## + ! ############################################################################################## + + ! Inputs + real(wp), intent(in) :: Q,Np,rho_a,rho_c,p1,p2,p3 + integer, intent(in) :: dtype + real(wp), intent(inout) :: apm,bpm + + ! Outputs + real(wp), intent(out) :: Re + + ! Internal + integer :: local_dtype + real(wp) :: local_p3,local_Np,tmp1,tmp2 + real(wp) :: N0,D0,vu,dm,ld,rg,log_sigma_g ! gamma, exponential variables + + + ! If density is constant, set equivalent values for apm and bpm + if ((rho_c > 0) .and. (apm < 0)) then + apm = (pi/6)*rho_c + bpm = 3._wp + endif + + ! Exponential is same as modified gamma with vu =1 + ! if Np is specified then we will just treat as modified gamma + if(dtype .eq. 2 .and. Np .gt. 0) then + local_dtype = 1 + local_p3 = 1 + else + local_dtype = dtype + local_p3 = p3 + endif + select case(local_dtype) + + ! ---------------------------------------------------------! + ! Modified gamma ! + ! Np = total number concentration (1/kg) = Nt / rho_a ! + ! D0 = characteristic diameter (um) ! + ! dm = mean diameter (um) - first moment over zeroth moment! + ! vu = distribution width parameter ! + ! ---------------------------------------------------------! + case(1) + + if( abs(local_p3+2) < 1E-8) then + if(Np>1E-30) then + ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1) + ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane + vu = (1/(0.2714_wp + 0.00057145_wp*Np*rho_a*1E-6))**2 ! units of Nt = Np*rhoa = #/cm^3 + else + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for Np in each volume with Morrison/Martin Scheme.') + return + endif + elseif (abs(local_p3+1) > 1E-8) then + ! vu is fixed in hp structure + vu = local_p3 + else + ! vu isn't specified + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for vu for Modified Gamma distribution') + return + endif + + if( Np.eq.0 .and. p2+1 > 1E-8) then ! use default value for MEAN diameter as first default + dm = p2 ! by definition, should have units of microns + D0 = gamma(vu)/gamma(vu+1)*dm + else ! use value of Np + if(Np.eq.0) then + if( abs(p1+1) > 1E-8 ) then ! use default number concentration + local_Np = p1 ! total number concentration / pa --- units kg^-1 + else + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p1=Dm [um] or p2=Np [1/kg]) for Modified Gamma distribution') + return + endif + else + local_Np=Np; + endif + D0 = 1E6 * ( Q*1E-3*gamma(vu)/(apm*local_Np*gamma(vu+bpm)) )**(1/bpm) ! units = microns + endif + Re = 0.5_wp*D0*gamma(vu+3)/gamma(vu+2) + + ! ---------------------------------------------------------! + ! Exponential ! + ! N0 = intercept parameter (m^-4) ! + ! ld = slope parameter (um) ! + ! ---------------------------------------------------------! + case(2) + + ! Np not specified (see if statement above) + if((abs(p1+1) > 1E-8) ) then ! N0 has been specified, determine ld + N0 = p1 + tmp1 = 1._wp/(1._wp+bpm) + ld = ((apm*gamma(1+bpm)*N0)/(rho_a*Q*1E-3))**tmp1 + ld = ld/1E6 ! set units to microns^-1 + elseif (abs(p2+1) > 1E-8) then ! lambda=ld has been specified as default + ld = p2 ! should have units of microns^-1 + else + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p1=No or p2=lambda) for Exponential distribution') + return + endif + Re = 1.5_wp/ld + + ! ---------------------------------------------------------! + ! Power law ! + ! ahp = Ar parameter (m^-4 mm^-bhp) ! + ! bhp = br parameter ! + ! dmin_mm = lower bound (mm) ! + ! dmax_mm = upper bound (mm) ! + ! ---------------------------------------------------------! + case(3) + + Re=0._wp ! Not supporting LUT approach for power-law ... + if(Np>0) then + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Variable Np not supported for Power Law distribution') + return + endif + + ! ---------------------------------------------------------! + ! Monodisperse ! + ! D0 = particle diameter (um) == Re ! + ! ---------------------------------------------------------! + case(4) + + Re = p1 + if(Np>0) then + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Variable Np not supported for Monodispersed distribution') + return + endif + + ! ---------------------------------------------------------! + ! Lognormal ! + ! N0 = total number concentration (m^-3) ! + ! np = fixed number concentration (kg^-1) ! + ! rg = mean radius (um) ! + ! log_sigma_g = ln(geometric standard deviation) ! + ! ---------------------------------------------------------! + case(5) + + if( abs(local_p3+1) > 1E-8 ) then + !set natural log width + log_sigma_g = local_p3 + else + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify a value for sigma_g when using a Log-Normal distribution') + return + endif + + ! get rg ... + if( Np.eq.0 .and. (abs(p2+1) > 1E-8) ) then ! use default value of rg + rg = p2 + else + if(Np>0) then + local_Np=Np; + elseif(abs(p2+1) < 1E-8) then + local_Np=p1 + else + call errorMessage('ERROR(optics/quickbeam_optics.f90:Calc_Re): Must specify Np or default value (p2=Rg or p1=Np) for Log-Normal distribution') + endif + log_sigma_g = p3 + tmp1 = (Q*1E-3)/(2._wp**bpm*apm*local_Np) + tmp2 = exp(0.5_wp*bpm*bpm*(log_sigma_g))*exp(0.5_wp*bpm*bpm*(log_sigma_g)) + rg = ((tmp1/tmp2)**(1._wp/bpm))*1E6 + endif + Re = rg*exp(2.5_wp*(log_sigma_g*log_sigma_g)) + end select + end subroutine calc_Re + ! ############################################################################################## + ! ############################################################################################## + subroutine dsd(Q,Re,Np,D,N,nsizes,dtype,rho_a,tk,dmin,dmax,apm,bpm,rho_c,p1,p2,p3) + ! ############################################################################################## + ! Purpose: + ! Create a discrete drop size distribution + ! + ! Starting with Quickbeam V3, this routine now allows input of + ! both effective radius (Re) and total number concentration (Nt) + ! Roj Marchand July 2010 + ! + ! The version in Quickbeam v.104 was modified to allow Re but not Nt + ! This is a significantly modified form for the version + ! + ! Originally Part of QuickBeam v1.03 by John Haynes + ! http://reef.atmos.colostate.edu/haynes/radarsim + ! + ! Inputs: + ! + ! [Q] hydrometeor mixing ratio (g/kg) + ! [Re] Optional Effective Radius (microns). 0 = use defaults (p1, p2, p3) + ! + ! [D] array of discrete drop sizes (um) where we desire to know the number concentraiton n(D). + ! [nsizes] number of elements of [D] + ! + ! [dtype] distribution type + ! [rho_a] ambient air density (kg m^-3) + ! [tk] temperature (K) + ! [dmin] minimum size cutoff (um) + ! [dmax] maximum size cutoff (um) + ! [rho_c] alternate constant density (kg m^-3) + ! [p1],[p2],[p3] distribution parameters + ! + ! Input/Output: + ! [apm] a parameter for mass (kg m^[-bpm]) + ! [bmp] b params for mass + ! + ! Outputs: + ! [N] discrete concentrations (cm^-3 um^-1) + ! or, for monodisperse, a constant (1/cm^3) + ! + ! Requires: + ! function infind + ! + ! Created: + ! 11/28/05 John Haynes (haynes@atmos.colostate.edu) + ! Modified: + ! 01/31/06 Port from IDL to Fortran 90 + ! 07/07/06 Rewritten for variable DSD's + ! 10/02/06 Rewritten using scaling factors (Roger Marchand and JMH), Re added V1.04 + ! July 2020 "N Scale factors" (variable fc) removed (Roj Marchand). + ! 12/18/14 Define type REALs as double precision (dustin.swales@noaa.gov) + ! ############################################################################################## + + ! Inputs + integer, intent(in) :: & + nsizes,& ! Number of elements of [D] + dtype ! distribution type + real(wp),intent(in),dimension(nsizes) :: & + D ! Array of discrete drop sizes (um) where we desire to know the number concentraiton n(D). + real(wp),intent(in) :: & + Q, & ! Hydrometeor mixing ratio (g/kg) + Np, & ! + rho_a, & ! Ambient air density (kg m^-3) + tk, & ! Temperature (K) + dmin, & ! Minimum size cutoff (um) + dmax, & ! Maximum size cutoff (um) + rho_c, & ! Alternate constant density (kg m^-3) + p1, & ! Distribution parameter 1 + p2, & ! Distribution parameter 2 + p3 ! Distribution parameter 3 + real(wp),intent(inout) :: & + apm, & ! a parameter for mass (kg m^[-bpm]) + bpm, & ! b params for mass + Re ! Optional Effective Radius (microns) + + ! Outputs + real(wp),intent(out),dimension(nsizes) :: & + N ! Discrete concentrations (cm^-3 um^-1) + ! or, for monodisperse, a constant (1/cm^3) + + ! Internal Variables + real(wp),dimension(nsizes) :: & + fc + real(wp) :: & + N0,D0,vu,local_np,dm,ld, & ! gamma, exponential variables + dmin_mm,dmax_mm,ahp,bhp, & ! power law variables + rg,log_sigma_g, & ! lognormal variables + rho_e, & ! particle density (kg m^-3) + tmp1,tmp2,tc + integer :: & + k,lidx,uidx + + ! Convert temperature from Kelvin to Celsius + tc = tk - 273.15_wp + + ! If density is constant, store equivalent values for apm and bpm + if ((rho_c > 0) .and. (apm < 0)) then + apm = (pi/6)*rho_c + bpm = 3._wp + endif + + ! Will preferentially use Re input over Np. + ! if only Np given then calculate Re + ! if neigher than use other defaults (p1,p2,p3) following quickbeam documentation + if(Re==0 .and. Np>0) then + call calc_Re(Q,Np,rho_a,dtype,apm,bpm,rho_c,p1,p2,p3,Re) + endif + select case(dtype) + + ! ---------------------------------------------------------! + ! Modified gamma ! + ! np = total number concentration ! + ! D0 = characteristic diameter (um) ! + ! dm = mean diameter (um) - first moment over zeroth moment! + ! vu = distribution width parameter ! + ! ---------------------------------------------------------! + case(1) + + if( abs(p3+2) < 1E-8) then + if( Np>1E-30) then + ! Morrison scheme with Martin 1994 shape parameter (NOTE: vu = pc +1) + ! fixed Roj. Dec. 2010 -- after comment by S. Mcfarlane + vu = (1/(0.2714_wp + 0.00057145_wp*Np*rho_a*1E-6))**2._wp ! units of Nt = Np*rhoa = #/cm^3 + else + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for Np in each volume with Morrison/Martin Scheme.') + return + endif + elseif (abs(p3+1) > 1E-8) then + ! vu is fixed in hp structure + vu = p3 + else + ! vu isn't specified + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for vu for Modified Gamma distribution') + return + endif + + if(Re>0) then + D0 = 2._wp*Re*gamma(vu+2)/gamma(vu+3) + fc = (((D*1E-6)**(vu-1)*exp(-1*D/D0)) / & + (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm))) * 1E-12 + N = fc*rho_a*(Q*1E-3) + elseif( p2+1 > 1E-8) then ! use default value for MEAN diameter + dm = p2 + D0 = gamma(vu)/gamma(vu+1)*dm + fc = (((D*1E-6)**(vu-1)*exp(-1*D/D0)) / & + (apm*((D0*1E-6)**(vu+bpm))*gamma(vu+bpm))) * 1E-12 + N = fc*rho_a*(Q*1E-3) + elseif(abs(p3+1) > 1E-8) then! use default number concentration + local_np = p1 ! total number concentration / pa check + tmp1 = (Q*1E-3)**(1./bpm) + fc = (D*1E-6 / (gamma(vu)/(apm*local_np*gamma(vu+bpm)))**(1._wp/bpm))**vu + N = ((rho_a*local_np*fc*(D*1E-6)**(-1._wp))/(gamma(vu)*tmp1**vu) * & + exp(-1._wp*fc**(1._wp/vu)/tmp1)) * 1E-12 + else + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): No default value for Dm or Np provided!') + return + endif + + ! ---------------------------------------------------------! + ! Exponential ! + ! N0 = intercept parameter (m^-4) ! + ! ld = slope parameter (um) ! + ! ---------------------------------------------------------! + case(2) + + if(Re>0) then + ld = 1.5_wp/Re ! units 1/um + fc = (ld*1E6)**(1.+bpm)/(apm*gamma(1+bpm))*exp(-1._wp*(ld*1E6)*(D*1E-6))*1E-12 + N = fc*rho_a*(Q*1E-3) + elseif (abs(p1+1) > 1E-8) then + ! Use N0 default value + N0 = p1 + tmp1 = 1._wp/(1._wp+bpm) + fc = ((apm*gamma(1+bpm)*N0)**tmp1)*(D*1E-6) + N = (N0*exp(-1._wp*fc*(1._wp/(rho_a*Q*1E-3))**tmp1)) * 1E-12 + elseif (abs(p2+1) > 1E-8) then + ! Use default value for lambda + ld = p2 + fc = (ld*1E6)**(1._wp+bpm)/(apm*gamma(1+bpm))*exp(-1._wp*(ld*1E6)*(D*1E-6))*1E-12 + N = fc*rho_a*(Q*1E-3) + else + ! ld "parameterized" from temperature (carry over from original Quickbeam). + ld = 1220._wp*10._wp**(-0.0245_wp*tc)*1E-6 + N0 = ((ld*1E6)**(1._wp+bpm)*Q*1E-3*rho_a)/(apm*gamma(1+bpm)) + N = (N0*exp(-ld*D)) * 1E-12 + endif + + ! ---------------------------------------------------------! + ! Power law ! + ! ahp = Ar parameter (m^-4 mm^-bhp) ! + ! bhp = br parameter ! + ! dmin_mm = lower bound (mm) ! + ! dmax_mm = upper bound (mm) ! + ! ---------------------------------------------------------! + case(3) + + if(Re>0) then + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Variable Re not supported for Power-Law distribution') + return + elseif(Np>0) then + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Variable Np not supported for Power-Law distribution') + return + endif + + ! br parameter + if (abs(p1+2) < 1E-8) then + ! if p1=-2, bhp is parameterized according to Ryan (2000), + ! applicatable to cirrus clouds + if (tc < -30) then + bhp = -1.75_wp+0.09_wp*((tc+273._wp)-243.16_wp) + elseif ((tc >= -30) .and. (tc < -9)) then + bhp = -3.25_wp-0.06_wp*((tc+273._wp)-265.66_wp) + else + bhp = -2.15_wp + endif + elseif (abs(p1+3) < 1E-8) then + ! if p1=-3, bhp is parameterized according to Ryan (2000), + ! applicable to frontal clouds + if (tc < -35) then + bhp = -1.75_wp+0.09_wp*((tc+273._wp)-243.16_wp) + elseif ((tc >= -35) .and. (tc < -17.5)) then + bhp = -2.65_wp+0.09_wp*((tc+273._wp)-255.66_wp) + elseif ((tc >= -17.5) .and. (tc < -9)) then + bhp = -3.25_wp-0.06_wp*((tc+273._wp)-265.66_wp) + else + bhp = -2.15_wp + endif + else + ! Otherwise the specified value is used + bhp = p1 + endif + + ! Ar parameter + dmin_mm = dmin*1E-3 + dmax_mm = dmax*1E-3 + + ! Commented lines are original method with constant density + ! rc = 500. ! (kg/m^3) + ! tmp1 = 6*rho_a*(bhp+4) + ! tmp2 = pi*rc*(dmax_mm**(bhp+4))*(1-(dmin_mm/dmax_mm)**(bhp+4)) + ! ahp = (Q*1E-3)*1E12*tmp1/tmp2 + + ! New method is more consistent with the rest of the distributions + ! and allows density to vary with particle size + tmp1 = rho_a*(Q*1E-3)*(bhp+bpm+1) + tmp2 = apm*(dmax_mm**bhp*dmax**(bpm+1)-dmin_mm**bhp*dmin**(bpm+1)) + ahp = tmp1/tmp2 * 1E24 + ! ahp = tmp1/tmp2 + lidx = infind(D,dmin) + uidx = infind(D,dmax) + do k=lidx,uidx + N(k) = (ahp*(D(k)*1E-3)**bhp) * 1E-12 + enddo + + ! ---------------------------------------------------------! + ! Monodisperse ! + ! D0 = particle diameter (um) ! + ! ---------------------------------------------------------! + case(4) + + if (Re>0) then + D0 = Re + else + D0 = p1 + endif + + rho_e = (6._wp/pi)*apm*(D0*1E-6)**(bpm-3) + fc(1) = (6._wp/(pi*D0*D0*D0*rho_e))*1E12 + N(1) = fc(1)*rho_a*(Q*1E-3) + + ! ---------------------------------------------------------! + ! Lognormal ! + ! N0 = total number concentration (m^-3) ! + ! np = fixed number concentration (kg^-1) ! + ! rg = mean radius (um) ! + ! og_sigma_g = ln(geometric standard deviation) ! + ! ---------------------------------------------------------! + case(5) + if (abs(p1+1) < 1E-8 .or. Re>0 ) then + ! rg, log_sigma_g are given + log_sigma_g = p3 + tmp2 = (bpm*log_sigma_g)*(bpm*log_sigma_g) + if(Re.le.0) then + rg = p2 + else + !rg = Re*exp(-2.5*(log_sigma_g*log_sigma_g)) + rg =Re*exp(-2.5_wp*(log_sigma_g**2)) + + endif + + fc = 0.5_wp*((1._wp/((2._wp*rg*1E-6)**(bpm)*apm*(2._wp*pi)**(0.5_wp) * & + log_sigma_g*D*0.5_wp*1E-6))*exp(-0.5_wp*((log(0.5_wp*D/rg)/log_sigma_g)**2._wp+tmp2)))*1E-12 + N = fc*rho_a*(Q*1E-3) + + elseif (abs(p2+1) < 1E-8 .or. Np>0) then + ! Np, log_sigma_g are given + if(Np>0) then + local_Np = Np + else + local_Np = p1 + endif + + log_sigma_g = p3 + N0 = local_np*rho_a + tmp1 = (rho_a*(Q*1E-3))/(2._wp**bpm*apm*N0) + tmp2 = exp(0.5_wp*bpm*bpm*(log_sigma_g))*exp(0.5_wp*bpm*bpm*(log_sigma_g)) + rg = ((tmp1/tmp2)**(1/bpm))*1E6 + + N = 0.5_wp*(N0 / ((2._wp*pi)**(0.5_wp)*log_sigma_g*D*0.5_wp*1E-6) * & + exp((-0.5_wp*(log(0.5_wp*D/rg)/log_sigma_g)**2._wp)))*1E-12 + else + call errorMessage('FATAL ERROR(optics/quickbeam_optics.f90:dsd): Must specify a value for sigma_g') + return + endif + end select + end subroutine dsd + ! ############################################################################################## + ! ############################################################################################## + subroutine zeff(freq,D,N,nsizes,k2,tt,ice,xr,z_eff,z_ray,kr,qe,qs,rho_e) + ! ############################################################################################## + ! Purpose: + ! Simulates radar return of a volume given DSD of spheres + ! Part of QuickBeam v1.03 by John Haynes + ! http://reef.atmos.colostate.edu/haynes/radarsim + ! + ! Inputs: + ! [freq] radar frequency (GHz) + ! [D] discrete drop sizes (um) + ! [N] discrete concentrations (cm^-3 um^-1) + ! [nsizes] number of discrete drop sizes + ! [k2] |K|^2, -1=use frequency dependent default + ! [tt] hydrometeor temperature (K) + ! [ice] indicates volume consists of ice + ! [xr] perform Rayleigh calculations? + ! [qe] if using a mie table, these contain ext/sca ... + ! [qs] ... efficiencies; otherwise set to -1 + ! [rho_e] medium effective density (kg m^-3) (-1 = pure) + ! + ! Outputs: + ! [z_eff] unattenuated effective reflectivity factor (mm^6/m^3) + ! [z_ray] reflectivity factor, Rayleigh only (mm^6/m^3) + ! [kr] attenuation coefficient (db km^-1) + ! + ! Created: + ! 11/28/05 John Haynes (haynes@atmos.colostate.edu) + ! Modified: + ! 12/18/14 Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov) + ! ############################################################################################## + ! Inputs + integer, intent(in) :: & + ice, & ! Indicates volume consists of ice + xr, & ! Perform Rayleigh calculations? + nsizes ! Number of discrete drop sizes + real(wp), intent(in),dimension(nsizes) :: & + D, & ! Discrete drop sizes (um) + N, & ! Discrete concentrations (cm^-3 um^-1) + rho_e, & ! Medium effective density (kg m^-3) (-1 = pure) + qe, & ! Extinction efficiency, when using Mie tables + qs ! Scatering efficiency, when using Mie tables + real(wp),intent(in) :: & + freq, & ! Radar frequency (GHz) + tt ! Hydrometeor temperature (K) + real(wp), intent(inout) :: & + k2 ! |K|^2, -1=use frequency dependent default + + ! Outputs + real(wp), intent(out) :: & + z_eff, & ! Unattenuated effective reflectivity factor (mm^6/m^3) + z_ray, & ! Reflectivity factor, Rayleigh only (mm^6/m^3) + kr ! Attenuation coefficient (db km^-1) + + ! Internal Variables + integer :: correct_for_rho ! Correct for density flag + real(wp), dimension(nsizes) :: & + D0, & ! D in (m) + N0, & ! N in m^-3 m^-1 + sizep, & ! Size parameter + qext, & ! Extinction efficiency + qbsca, & ! Backscatter efficiency + f, & ! Ice fraction + xtemp ! + real(wp) :: & + wl, cr,eta_sum,eta_mie,const,z0_eff,z0_ray,k_sum,n_r,n_i,dqv(1),dqsc,dg,dph(1) + complex(wp) :: & + m, & ! Complex index of refraction of bulk form + Xs1(1), Xs2(1) ! + integer :: & + i, err ! + integer, parameter :: & + one=1 ! + real(wp),parameter :: & + conv_d = 1e-6, & ! Conversion factor for drop sizes (to m) + conv_n = 1e12, & ! Conversion factor for drop concentrations (to m^-3) + conv_f = 0.299792458 ! Conversion for radar frequency (to m) + complex(wp),dimension(nsizes) ::& + m0 ! Complex index of refraction + + ! Initialize + z0_ray = 0._wp + + ! Conversions + D0 = d*conv_d + N0 = n*conv_n + wl = conv_f/freq + + ! // dielectric constant |k^2| defaults + if (k2 < 0) then + k2 = 0.933_wp + if (abs(94.-freq) < 3.) k2=0.75_wp + if (abs(35.-freq) < 3.) k2=0.88_wp + if (abs(13.8-freq) < 3.) k2=0.925_wp + endif + + if (qe(1) < -9) then + + ! Get the refractive index of the bulk hydrometeors + if (ice == 0) then + call m_wat(freq,tt,n_r,n_i) + else + call m_ice(freq,tt,n_r,n_i) + endif + m = cmplx(n_r,-n_i) + m0(1:nsizes) = m + + correct_for_rho = 0 + if ((ice == 1) .and. (minval(rho_e) >= 0)) correct_for_rho = 1 + + ! Correct refractive index for ice density if needed + if (correct_for_rho == 1) then + f = rho_e/rhoice + m0 = sqrt((2+(m0*m0)+2*f*((m0*m0)-1))/(2+(m0*m0)+f*(1-(m0*m0)))) + endif + + ! Mie calculations + sizep = (pi*D0)/wl + dqv(1) = 0._wp + do i=1,nsizes + call mieint(sizep(i), m0(i), one, dqv, qext(i), dqsc, qbsca(i), & + dg, xs1, xs2, dph, err) + end do + + else + ! Mie table used + qext = qe + qbsca = qs + endif + + ! eta_mie = 0.25*sum[qbsca*pi*D^2*N(D)*deltaD] + ! <--------- eta_sum ---------> + ! z0_eff = (wl^4/!pi^5)*(1./k2)*eta_mie + eta_sum = 0._wp + if (size(D0) == 1) then + eta_sum = qbsca(1)*(n(1)*1E6)*D0(1)*D0(1) + else + xtemp = qbsca*N0*D0*D0 + call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),eta_sum) + endif + + eta_mie = eta_sum*0.25_wp*pi + const = ((wl*wl*wl*wl)/(pi*pi*pi*pi*pi))*(1._wp/k2) + + z0_eff = const*eta_mie + + ! kr = 0.25*cr*sum[qext*pi*D^2*N(D)*deltaD] + ! <---------- k_sum ---------> + k_sum = 0._wp + if (size(D0) == 1) then + k_sum = qext(1)*(n(1)*1E6)*D0(1)*D0(1) + else + xtemp = qext*N0*D0*D0 + call avint(xtemp,D0,nsizes,D0(1),D0(size(D0,1)),k_sum) + endif + ! DS2014 START: Making this calculation in double precision results in a small + ! amount of very small errors in the COSP output field,dBZE94, + ! so it will be left as is. + !cr = 10._wp/log(10._wp) + cr = 10./log(10.) + ! DS2014 STOP + kr = k_sum*0.25_wp*pi*(1000._wp*cr) + + ! z_ray = sum[D^6*N(D)*deltaD] + if (xr == 1) then + z0_ray = 0._wp + if (size(D0) == 1) then + z0_ray = (n(1)*1E6)*D0(1)*D0(1)*D0(1)*D0(1)*D0(1)*D0(1) + else + xtemp = N0*D0*D0*D0*D0*D0*D0 + call avint(xtemp,D0,nsizes,D0(1),D0(size(D0)),z0_ray) + endif + endif + + ! Convert to mm^6/m^3 + z_eff = z0_eff*1E18 ! 10.*alog10(z0_eff*1E18) + z_ray = z0_ray*1E18 ! 10.*alog10(z0_ray*1E18) + + end subroutine zeff + ! ############################################################################################## + ! ############################################################################################## + function gases(PRES_mb,T,SH,f) + ! ############################################################################################## + ! Purpose: + ! Compute 2-way gaseous attenuation through a volume in microwave + ! + ! Inputs: + ! [PRES_mb] pressure (mb) (hPa) + ! [T] temperature (K) + ! [RH] relative humidity (%) + ! [f] frequency (GHz), < 300 GHz + ! + ! Returns: + ! 2-way gaseous attenuation (dB/km) + ! + ! Reference: + ! Uses method of Liebe (1985) + ! + ! Created: + ! 12/09/05 John Haynes (haynes@atmos.colostate.edu) + ! Modified: + ! 01/31/06 Port from IDL to Fortran 90 + ! 12/19/14 Dustin Swales: Define type REALs as double precision (dustin.swales@noaa.gov) + ! ############################################################################################## + + ! INPUTS + real(wp), intent(in) :: & ! + PRES_mb, & ! Pressure (mb) (hPa) + T, & ! Temperature (K) + SH, & ! Specific humidity + f ! Frequency (GHz), < 300 GHz + + ! PARAMETERS + integer, parameter :: & ! + nbands_o2 = 48, & ! Number of O2 bands + nbands_h2o = 30 ! Number of h2o bands + ! LOCAL VARIABLES + real(wp) :: & + gases, th, e, p, sumo, gm0, a0, ap, term1, & + term2, term3, bf, be, term4, npp,e_th,one_th, & + pth3,eth35,aux1,aux2,aux3, aux4,gm,delt,x,y, & + gm2,fpp_o2,fpp_h2o,s_o2,s_h2o + integer :: i + + ! Table1 parameters v0, a1, a2, a3, a4, a5, a6 + real(wp),dimension(nbands_o2),parameter :: & + v0 = (/49.4523790,49.9622570,50.4742380,50.9877480,51.5033500, & + 52.0214090,52.5423930,53.0669060,53.5957480,54.1299999,54.6711570, & + 55.2213650,55.7838000,56.2647770,56.3378700,56.9681000,57.6124810, & + 58.3238740,58.4465890,59.1642040,59.5909820,60.3060570,60.4347750, & + 61.1505580,61.8001520,62.4112120,62.4862530,62.9979740,63.5685150, & + 64.1277640,64.6789000,65.2240670,65.7647690,66.3020880,66.8368270, & + 67.3695950,67.9008620,68.4310010,68.9603060,69.4890210,70.0173420, & + 118.7503410,368.4983500,424.7631200,487.2493700,715.3931500, & + 773.8387300, 834.1453300/), & + a1 = (/0.0000001,0.0000003,0.0000009,0.0000025,0.0000061,0.0000141, & + 0.0000310,0.0000641,0.0001247,0.0002280,0.0003918,0.0006316,0.0009535, & + 0.0005489,0.0013440,0.0017630,0.0000213,0.0000239,0.0000146,0.0000240, & + 0.0000211,0.0000212,0.0000246,0.0000250,0.0000230,0.0000193,0.0000152, & + 0.0000150,0.0000109,0.0007335,0.0004635,0.0002748,0.0001530,0.0000801, & + 0.0000395,0.0000183,0.0000080,0.0000033,0.0000013,0.0000005,0.0000002, & + 0.0000094,0.0000679,0.0006380,0.0002350,0.0000996,0.0006710,0.0001800/),& + a2 = (/11.8300000,10.7200000,9.6900000,8.8900000,7.7400000,6.8400000, & + 6.0000000,5.2200000,4.4800000,3.8100000,3.1900000,2.6200000,2.1150000, & + 0.0100000,1.6550000,1.2550000,0.9100000,0.6210000,0.0790000,0.3860000, & + 0.2070000,0.2070000,0.3860000,0.6210000,0.9100000,1.2550000,0.0780000, & + 1.6600000,2.1100000,2.6200000,3.1900000,3.8100000,4.4800000,5.2200000, & + 6.0000000,6.8400000,7.7400000,8.6900000,9.6900000,10.7200000,11.8300000,& + 0.0000000,0.0200000,0.0110000,0.0110000,0.0890000,0.0790000,0.0790000/),& + a3 = (/0.0083000,0.0085000,0.0086000,0.0087000,0.0089000,0.0092000, & + 0.0094000,0.0097000,0.0100000,0.0102000,0.0105000,0.0107900,0.0111000, & + 0.0164600,0.0114400,0.0118100,0.0122100,0.0126600,0.0144900,0.0131900, & + 0.0136000,0.0138200,0.0129700,0.0124800,0.0120700,0.0117100,0.0146800, & + 0.0113900,0.0110800,0.0107800,0.0105000,0.0102000,0.0100000,0.0097000, & + 0.0094000,0.0092000,0.0089000,0.0087000,0.0086000,0.0085000,0.0084000, & + 0.0159200,0.0192000,0.0191600,0.0192000,0.0181000,0.0181000,0.0181000/),& + a4 = (/0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000,0.0000000, & + 0.0000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000,0.6000000/),& + a5 = (/0.0056000,0.0056000,0.0056000,0.0055000,0.0056000,0.0055000, & + 0.0057000,0.0053000,0.0054000,0.0048000,0.0048000,0.0041700,0.0037500, & + 0.0077400,0.0029700,0.0021200,0.0009400,-0.0005500,0.0059700,-0.0024400,& + 0.0034400,-0.0041300,0.0013200,-0.0003600,-0.0015900,-0.0026600, & + -0.0047700,-0.0033400,-0.0041700,-0.0044800,-0.0051000,-0.0051000, & + -0.0057000,-0.0055000,-0.0059000,-0.0056000,-0.0058000,-0.0057000, & + -0.0056000,-0.0056000,-0.0056000,-0.0004400,0.0000000,0.0000000, & + 0.0000000,0.0000000,0.0000000,0.0000000/), & + a6 = (/1.7000000,1.7000000,1.7000000,1.7000000,1.8000000,1.8000000, & + 1.8000000,1.9000000,1.8000000,2.0000000,1.9000000,2.1000000,2.1000000, & + 0.9000000,2.3000000,2.5000000,3.7000000,-3.1000000,0.8000000,0.1000000, & + 0.5000000,0.7000000,-1.0000000,5.8000000,2.9000000,2.3000000,0.9000000, & + 2.2000000,2.0000000,2.0000000,1.8000000,1.9000000,1.8000000,1.8000000, & + 1.7000000,1.8000000,1.7000000,1.7000000,1.7000000,1.7000000,1.7000000, & + 0.9000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000,1.0000000/) + + ! Table2 parameters v1, b1, b2, b3 + real(wp),dimension(nbands_h2o),parameter :: & + v1 = (/22.2350800,67.8139600,119.9959400,183.3101170,321.2256440, & + 325.1529190,336.1870000,380.1973720,390.1345080,437.3466670,439.1508120, & + 443.0182950,448.0010750,470.8889740,474.6891270,488.4911330,503.5685320, & + 504.4826920,556.9360020,620.7008070,658.0065000,752.0332270,841.0735950, & + 859.8650000,899.4070000,902.5550000,906.2055240,916.1715820,970.3150220, & + 987.9267640/), & + b1 = (/0.1090000,0.0011000,0.0007000,2.3000000,0.0464000,1.5400000, & + 0.0010000,11.9000000,0.0044000,0.0637000,0.9210000,0.1940000,10.6000000, & + 0.3300000,1.2800000,0.2530000,0.0374000,0.0125000,510.0000000,5.0900000, & + 0.2740000,250.0000000,0.0130000,0.1330000,0.0550000,0.0380000,0.1830000, & + 8.5600000,9.1600000,138.0000000/), & + b2 = (/2.1430000,8.7300000,8.3470000,0.6530000,6.1560000,1.5150000, & + 9.8020000,1.0180000,7.3180000,5.0150000,3.5610000,5.0150000,1.3700000, & + 3.5610000,2.3420000,2.8140000,6.6930000,6.6930000,0.1140000,2.1500000, & + 7.7670000,0.3360000,8.1130000,7.9890000,7.8450000,8.3600000,5.0390000, & + 1.3690000,1.8420000,0.1780000/), & + b3 = (/0.0278400,0.0276000,0.0270000,0.0283500,0.0214000,0.0270000, & + 0.0265000,0.0276000,0.0190000,0.0137000,0.0164000,0.0144000,0.0238000, & + 0.0182000,0.0198000,0.0249000,0.0115000,0.0119000,0.0300000,0.0223000, & + 0.0300000,0.0286000,0.0141000,0.0286000,0.0286000,0.0264000,0.0234000, & + 0.0253000,0.0240000,0.0286000/) + + ! Conversions + th = 300._wp/T ! unitless + + ! DS2014 START: Using _wp for the exponential in the denominator results in slight errors + ! for dBze94. 0.01 % of values differ, relative range: 1.03e-05 to 1.78e-04 + !e = (RH*th*th*th*th*th)/(41.45_wp*10**(9.834_wp*th-10)) ! kPa + !e = (RH*th*th*th*th*th)/(41.45_wp*10**(9.834_wp*th-10)) ! kPa + e = SH*PRES_mb/(SH+0.622_wp)/1000._wp !kPa + ! DS2014 END + + p = PRES_mb/1000._wp-e ! kPa + e_th = e*th + one_th = 1 - th + pth3 = p*th*th*th + eth35 = e*th**(3.5) + + ! Term1 + sumo = 0._wp + aux1 = 1.1_wp*e_th + do i=1,nbands_o2 + aux2 = f/v0(i) + aux3 = v0(i)-f + aux4 = v0(i)+f + gm = a3(i)*(p*th**(0.8_wp-a4(i))+aux1) + gm2 = gm*gm + delt = a5(i)*p*th**a6(i) + x = aux3*aux3+gm2 + y = aux4*aux4+gm2 + fpp_o2 = (((1._wp/x)+(1._wp/y))*(gm*aux2) - (delt*aux2)*((aux3/(x))-(aux4/(x)))) + s_o2 = a1(i)*pth3*exp(a2(i)*one_th) + sumo = sumo + fpp_o2 * s_o2 + enddo + term1 = sumo + + ! Term2 + gm0 = 5.6E-3_wp*(p+1.1_wp*e)*th**(0.8_wp) + a0 = 3.07E-4_wp + ap = 1.4_wp*(1-1.2_wp*f**(1.5_wp)*1E-5)*1E-10 + term2 = (2*a0*(gm0*(1+(f/gm0)*(f/gm0))*(1+(f/60._wp)**2))**(-1) + ap*p*th**(2.5_wp))*f*p*th*th + + ! Term3 + sumo = 0._wp + aux1 = 4.8_wp*e_th + do i=1,nbands_h2o + aux2 = f/v1(i) + aux3 = v1(i)-f + aux4 = v1(i)+f + gm = b3(i)*(p*th**(0.8)+aux1) + gm2 = gm*gm + x = aux3*aux3+gm2 + y = aux4*aux4+gm2 + fpp_h2o = ((1._wp/x)+(1._wp/y))*(gm*aux2) ! - (delt*aux2)*((aux3/(x))-(aux4/(x))) + s_h2o = b1(i)*eth35*exp(b2(i)*one_th) + sumo = sumo + fpp_h2o * s_h2o + enddo + term3 = sumo + + ! Term4 + bf = 1.4E-6_wp + be = 5.41E-5_wp + term4 = (bf*p+be*e*th*th*th)*f*e*th**(2.5_wp) + + ! Summation and result + npp = term1 + term2 + term3 + term4 + gases = 0.182_wp*f*npp + + end function gases + subroutine hydro_class_init(lsingle,ldouble,sd) + ! ############################################################################################## + ! Purpose: + ! + ! Initialize variables used by the radar simulator. + ! Part of QuickBeam v3.0 by John Haynes and Roj Marchand + ! + ! Inputs: + ! NAME SIZE DESCRIPTION + ! [lsingle] (1) Logical flag to use single moment + ! [ldouble] (1) Logical flag to use two moment + ! Outputs: + ! [sd] Structure that define hydrometeor types + ! + ! Local variables: + ! [n_hydro] (1) Number of hydrometeor types + ! [hclass_type] (nhclass) Type of distribution (see quickbeam documentation) + ! [hclass_phase] (nhclass) 1==ice, 0=liquid + ! [hclass_dmin] (nhclass) Minimum diameter allowed is drop size distribution N(DDmax)=0 + ! [hclass_apm] (nhclass) Density of partical apm*D^bpm or constant = rho + ! [hclass_bpm] (nhclass) Density of partical apm*D^bpm or constant = rho + ! [hclass_rho] (nhclass) Density of partical apm*D^bpm or constant = rho + ! [hclass_p1] (nhclass) Default values of DSD parameters (see quickbeam documentation) + ! [hclass_p2] (nhclass) Default values of DSD parameters (see quickbeam documentation) + ! [hclass_p3] (nhclass) Default values of DSD parameters (see quickbeam documentation) + ! Modified: + ! 08/23/2006 placed into subroutine form (Roger Marchand) + ! June 2010 New interface to support "radar_simulator_params" structure + ! 12/22/2014 Moved radar simulator (CLOUDSAT) configuration initialization to cloudsat_init + ! ############################################################################################## + + ! #################################################################################### + ! NOTES on HCLASS variables + ! + ! TYPE - Set to + ! 1 for modified gamma distribution, + ! 2 for exponential distribution, + ! 3 for power law distribution, + ! 4 for monodisperse distribution, + ! 5 for lognormal distribution. + ! + ! PHASE - Set to 0 for liquid, 1 for ice. + ! DMIN - The minimum drop size for this class (micron), ignored for monodisperse. + ! DMAX - The maximum drop size for this class (micron), ignored for monodisperse. + ! Important note: The settings for DMIN and DMAX are + ! ignored in the current version for all distributions except for power + ! law. Except when the power law distribution is used, particle size + ! is fixed to vary from zero to infinity, a restriction that is expected + ! to be lifted in future versions. A placeholder must still be specified + ! for each. + ! Density of particles is given by apm*D^bpm or a fixed value rho. ONLY specify ONE of these two!! + ! APM - The alpha_m coefficient in equation (1) (kg m**-beta_m ) + ! BPM - The beta_m coefficient in equation (1), see section 4.1. + ! RHO - Hydrometeor density (kg m-3 ). + ! + ! P1, P2, P3 - are default distribution parameters that depend on the type + ! of distribution (see quickmbeam documentation for more information) + ! + ! Modified Gamma (must set P3 and one of P1 or P2) + ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 ), where + ! rho_a is the density of air in the radar volume. + ! P2 - Set to the particle mean diameter D (micron). + ! P3 - Set to the distribution width nu. + ! + ! Exponetial (set one of) + ! P1 - Set to a constant intercept parameter N0 (m-4). + ! P2 - Set to a constant lambda (micron-1). + ! + ! Power Law + ! P1 - Set this to the value of a constant power law parameter br + ! + ! Monodisperse + ! P1 - Set to a constant diameter D0 (micron) = Re. + ! + ! Log-normal (must set P3 and one of P1 or P2) + ! P1 - Set to the total particle number concentration Nt /rho_a (kg-1 ) + ! P2 - Set to the geometric mean particle radius rg (micron). + ! P3 - Set to the natural logarithm of the geometric standard deviation. + ! #################################################################################### + ! INPUTS + logical,intent(in) :: & + lsingle, & ! True -> use single moment + ldouble ! True -> use two moment + + ! OUTPUTS + type(size_distribution),intent(out) ::& + sd ! + + ! SINGLE MOMENT PARAMETERS + integer,parameter,dimension(N_HYDRO) :: & + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + HCLASS1_TYPE = (/5, 1, 2, 2, 5, 1, 2, 2, 2/), & ! + HCLASS1_PHASE = (/0, 1, 0, 1, 0, 1, 0, 1, 1/) ! + real(wp),parameter,dimension(N_HYDRO) ::& + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + HCLASS1_DMIN = (/ -1., -1., -1., -1., -1., -1., -1., -1., -1. /), & + HCLASS1_DMAX = (/ -1., -1., -1., -1., -1., -1., -1., -1., -1. /), & + HCLASS1_APM = (/524., 110.8, 524., -1., 524., 110.8, 524., -1., -1. /), & + HCLASS1_BPM = (/ 3., 2.91, 3., -1., 3., 2.91, 3., -1., -1. /), & + HCLASS1_RHO = (/ -1., -1., -1., 100., -1., -1., -1., 100., 400. /), & + HCLASS1_P1 = (/ -1., -1., 8.e6, 3.e6, -1., -1., 8.e6, 3.e6, 4.e6/), & + HCLASS1_P2 = (/ 6., 40., -1., -1., 6., 40., -1., -1., -1. /), & + HCLASS1_P3 = (/ 0.3, 2., -1., -1., 0.3, 2., -1., -1., -1. /) + + ! TWO MOMENT PARAMETERS + integer,parameter,dimension(N_HYDRO) :: & + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + HCLASS2_TYPE = (/ 1, 1, 1, 1, 1, 1, 1, 1, 1/), & + HCLASS2_PHASE = (/ 0, 1, 0, 1, 0, 1, 0, 1, 1/) + + real(wp),parameter,dimension(N_HYDRO) :: & + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + HCLASS2_DMIN = (/ -1, -1, -1, -1, -1, -1, -1, -1, -1/), & + HCLASS2_DMAX = (/ -1, -1, -1, -1, -1, -1, -1, -1, -1/), & + HCLASS2_APM = (/524, -1, 524, -1, 524, -1, 524, -1, -1/), & + HCLASS2_BPM = (/ 3, -1, 3, -1, 3, -1, 3, -1, -1/), & + HCLASS2_RHO = (/ -1, 500, -1, 100, -1, 500, -1, 100, 900/), & + HCLASS2_P1 = (/ -1, -1, -1, -1, -1, -1, -1, -1, -1/), & + HCLASS2_P2 = (/ -1, -1, -1, -1, -1, -1, -1, -1, -1/), & + HCLASS2_P3 = (/ -2, 1, 1, 1, -2, 1, 1, 1, 1/) + + if (lsingle) then + sd%dtype(1:N_HYDRO) = HCLASS1_TYPE(1:N_HYDRO) + sd%phase(1:N_HYDRO) = HCLASS1_PHASE(1:N_HYDRO) + sd%dmin(1:N_HYDRO) = HCLASS1_DMIN(1:N_HYDRO) + sd%dmax(1:N_HYDRO) = HCLASS1_DMAX(1:N_HYDRO) + sd%apm(1:N_HYDRO) = HCLASS1_APM(1:N_HYDRO) + sd%bpm(1:N_HYDRO) = HCLASS1_BPM(1:N_HYDRO) + sd%rho(1:N_HYDRO) = HCLASS1_RHO(1:N_HYDRO) + sd%p1(1:N_HYDRO) = HCLASS1_P1(1:N_HYDRO) + sd%p2(1:N_HYDRO) = HCLASS1_P2(1:N_HYDRO) + sd%p3(1:N_HYDRO) = HCLASS1_P3(1:N_HYDRO) + endif + if (ldouble) then + sd%dtype(1:N_HYDRO) = HCLASS2_TYPE(1:N_HYDRO) + sd%phase(1:N_HYDRO) = HCLASS2_PHASE(1:N_HYDRO) + sd%dmin(1:N_HYDRO) = HCLASS2_DMIN(1:N_HYDRO) + sd%dmax(1:N_HYDRO) = HCLASS2_DMAX(1:N_HYDRO) + sd%apm(1:N_HYDRO) = HCLASS2_APM(1:N_HYDRO) + sd%bpm(1:N_HYDRO) = HCLASS2_BPM(1:N_HYDRO) + sd%rho(1:N_HYDRO) = HCLASS2_RHO(1:N_HYDRO) + sd%p1(1:N_HYDRO) = HCLASS2_P1(1:N_HYDRO) + sd%p2(1:N_HYDRO) = HCLASS2_P2(1:N_HYDRO) + sd%p3(1:N_HYDRO) = HCLASS2_P3(1:N_HYDRO) + endif + end subroutine hydro_class_init +end module mod_quickbeam_optics Index: LMDZ6/trunk/libf/phylmd/cosp2/scops.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp2/scops.F90 (revision 3358) +++ LMDZ6/trunk/libf/phylmd/cosp2/scops.F90 (revision 3358) @@ -0,0 +1,240 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! Copyright (c) 2009, British Crown Copyright, the Met Office +! All rights reserved. +! +! Redistribution and use in source and binary forms, with or without modification, are +! permitted provided that the following conditions are met: +! +! 1. Redistributions of source code must retain the above copyright notice, this list of +! conditions and the following disclaimer. +! +! 2. Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other +! materials provided with the distribution. +! +! 3. Neither the name of the copyright holder nor the names of its contributors may be +! used to endorse or promote products derived from this software without specific prior +! written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY +! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF +! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL +! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT +! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS +! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT +! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! May 2015 - D. Swales - Modified for COSPv2.0 +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +module mod_scops + USE COSP_KINDS, ONLY: wp + USE MOD_RNG!, ONLY: rng_state,get_rng + use mod_cosp_error, ONLY: errorMessage + + implicit none + + integer,parameter :: default_overlap = 3 ! Used when invalid overlap assumption is provided. + +contains + subroutine scops(npoints,nlev,ncol,rngs,cc,conv,overlap,frac_out,ncolprint) + INTEGER :: npoints, & ! Number of model points in the horizontal + nlev, & ! Number of model levels in column + ncol, & ! Number of subcolumns + overlap ! Overlap type (1=max, 2=rand, 3=max/rand) + type(rng_state),dimension(npoints) :: rngs + INTEGER, parameter :: huge32 = 2147483647 + INTEGER, parameter :: i2_16 = 65536 + INTEGER :: i,j,ilev,ibox,ncolprint,ilev2 + + REAL(WP), dimension(npoints,nlev) :: & + cc, & ! Input cloud cover in each model level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by clouds + conv, & ! Input convective cloud cover in each model level (fraction) + ! NOTE: This is the HORIZONTAL area of each + ! grid box covered by convective clouds + tca ! Total cloud cover in each model level (fraction) + ! with extra layer of zeroes on top + ! in this version this just contains the values input + ! from cc but with an extra level + REAL(WP),intent(inout), dimension(npoints,ncol,nlev) :: & + frac_out ! Boxes gridbox divided up into equivalent of BOX in + ! original version, but indexed by column then row, rather than + ! by row then column + REAL(WP), dimension(npoints,ncol) :: & + threshold, & ! pointer to position in gridbox + maxocc, & ! Flag for max overlapped conv cld + maxosc, & ! Flag for max overlapped strat cld + boxpos, & ! ordered pointer to position in gridbox + threshold_min ! minimum value to define range in with new threshold is chosen. + REAL(WP), dimension(npoints) :: & + ran ! vector of random numbers + + ! Test for valid input overlap assumption + if (overlap .ne. 1 .and. overlap .ne. 2 .and. overlap .ne. 3) then + overlap=default_overlap + call errorMessage('ERROR(scops): Invalid overlap assumption provided. Using default overlap assumption (max/ran)') + endif + + boxpos = spread(([(i, i=1,ncol)]-0.5)/ncol,1,npoints) + + ! ####################################################################### + ! Initialize working variables + ! ####################################################################### + + ! Initialize frac_out to zero + frac_out(1:npoints,1:ncol,1:nlev)=0.0 + + ! Assign 2d tca array using 1d input array cc + tca(1:npoints,1:nlev) = cc(1:npoints,1:nlev) + + if (ncolprint.ne.0) then + write (6,'(a)') 'frac_out_pp_rev:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') ((frac_out(j,ibox,ilev),ibox=1,ncolprint),ilev=1,nlev) + enddo + write (6,'(a)') 'ncol:' + write (6,'(I3)') ncol + endif + if (ncolprint.ne.0) then + write (6,'(a)') 'last_frac_pp:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') (tca(j,1)) + enddo + endif + + ! ####################################################################### + ! ALLOCATE CLOUD INTO BOXES, FOR NCOLUMNS, NLEVELS + ! frac_out is the array that contains the information + ! where 0 is no cloud, 1 is a stratiform cloud and 2 is a + ! convective cloud + ! ####################################################################### + + ! Loop over vertical levels + DO ilev = 1,nlev + + ! Initialise threshold + IF (ilev.eq.1) then + ! If max overlap + IF (overlap.eq.1) then + ! Select pixels spread evenly across the gridbox + threshold(1:npoints,1:ncol)=boxpos(1:npoints,1:ncol) + ELSE + DO ibox=1,ncol + !include 'congvec.f90' + ran(1:npoints) = get_rng(RNGS) + ! select random pixels from the non-convective + ! part the gridbox ( some will be converted into + ! convective pixels below ) + threshold(1:npoints,ibox) = conv(1:npoints,ilev)+(1-conv(1:npoints,ilev))*ran(npoints) + enddo + ENDIF + IF (ncolprint.ne.0) then + write (6,'(a)') 'threshold_nsf2:' + do j=1,npoints,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + enddo + ENDIF + ENDIF + + IF (ncolprint.ne.0) then + write (6,'(a)') 'ilev:' + write (6,'(I2)') ilev + ENDIF + + DO ibox=1,ncol + ! All versions + !maxocc(1:npoints,ibox) = merge(1,0,boxpos(1:npoints,ibox) .le. conv(1:npoints,ilev)) + !maxocc(1:npoints,ibox) = merge(1,0, conv(1:npoints,ilev) .gt. boxpos(1:npoints,ibox)) + do j=1,npoints + if (boxpos(j,ibox).le.conv(j,ilev)) then + maxocc(j,ibox) = 1 + else + maxocc(j,ibox) = 0 + end if + enddo + + ! Max overlap + if (overlap.eq.1) then + threshold_min(1:npoints,ibox) = conv(1:npoints,ilev) + maxosc(1:npoints,ibox) = 1 + endif + + ! Random overlap + if (overlap.eq.2) then + threshold_min(1:npoints,ibox) = conv(1:npoints,ilev) + maxosc(1:npoints,ibox) = 0 + endif + ! Max/Random overlap + if (overlap.eq.3) then + ! DS2014 START: The bounds on tca are not valid when ilev=1. + !threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(tca(1:npoints,ilev-1),tca(1:npoints,ilev))) + !maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. & + ! min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)) .and. & + ! (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev))) + if (ilev .ne. 1) then + threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(tca(1:npoints,ilev-1),tca(1:npoints,ilev))) + maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. & + min(tca(1:npoints,ilev-1),tca(1:npoints,ilev)) .and. & + (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev))) + else + threshold_min(1:npoints,ibox) = max(conv(1:npoints,ilev),min(0._wp,tca(1:npoints,ilev))) + maxosc(1:npoints,ibox) = merge(1,0,threshold(1:npoints,ibox) .lt. & + min(0._wp,tca(1:npoints,ilev)) .and. & + (threshold(1:npoints,ibox).gt.conv(1:npoints,ilev))) + endif + endif + + ! Reset threshold + !include 'congvec.f90' + ran(1:npoints) = get_rng(RNGS) + + threshold(1:npoints,ibox)= maxocc(1:npoints,ibox)*(boxpos(1:npoints,ibox)) + & + (1-maxocc(1:npoints,ibox))*((maxosc(1:npoints,ibox))*(threshold(1:npoints,ibox)) + & + (1-maxosc(1:npoints,ibox))*(threshold_min(1:npoints,ibox)+ & + (1-threshold_min(1:npoints,ibox))*ran(1:npoints))) + + ! Fill frac_out with 1's where tca is greater than the threshold + frac_out(1:npoints,ibox,ilev) = merge(1,0,tca(1:npoints,ilev).gt.threshold(1:npoints,ibox)) + + ! Code to partition boxes into startiform and convective parts goes here + where(threshold(1:npoints,ibox).le.conv(1:npoints,ilev) .and. conv(1:npoints,ilev).gt.0.) frac_out(1:npoints,ibox,ilev)=2 + ENDDO ! ibox + + + ! Set last_frac to tca at this level, so as to be tca from last level next time round + if (ncolprint.ne.0) then + do j=1,npoints ,1000 + write(6,'(a10)') 'j=' + write(6,'(8I10)') j + write (6,'(a)') 'last_frac:' + write (6,'(8f5.2)') (tca(j,ilev)) + write (6,'(a)') 'conv:' + write (6,'(8f5.2)') (conv(j,ilev),ibox=1,ncolprint) + write (6,'(a)') 'max_overlap_cc:' + write (6,'(8f5.2)') (maxocc(j,ibox),ibox=1,ncolprint) + write (6,'(a)') 'max_overlap_sc:' + write (6,'(8f5.2)') (maxosc(j,ibox),ibox=1,ncolprint) + write (6,'(a)') 'threshold_min_nsf2:' + write (6,'(8f5.2)') (threshold_min(j,ibox),ibox=1,ncolprint) + write (6,'(a)') 'threshold_nsf2:' + write (6,'(8f5.2)') (threshold(j,ibox),ibox=1,ncolprint) + write (6,'(a)') 'frac_out_pp_rev:' + write (6,'(8f5.2)') ((frac_out(j,ibox,ilev2),ibox=1,ncolprint),ilev2=1,nlev) + enddo + endif + + enddo ! Loop over nlev + + ! END + end subroutine scops +end module mod_scops