Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/MISR_simulator.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/MISR_simulator.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/MISR_simulator.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/array_lib.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/array_lib.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/array_lib.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp.f90 (revision 5900) @@ -0,0 +1,3665 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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 +! Mar 2018- R. Guzman - Added OPAQ diagnostics and GLID simulator +! Apr 2018- R. Guzman - Added ATLID simulator +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + +MODULE MOD_COSP + USE COSP_KINDS, ONLY: wp + USE MOD_COSP_CONFIG, ONLY: R_UNDEF,PARASOL_NREFL,LIDAR_NCAT,LIDAR_NTYPE, SR_BINS,& + N_HYDRO,RTTOV_MAX_CHANNELS,numMISRHgtBins, & + cloudsat_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,nCloudsatPrecipClass,& + modis_histTauCenters,tau_binCenters, & +! cloudsat_preclvl,grLidar532_histBsct,atlid_histBsct !PREC_BUG + grLidar532_histBsct,atlid_histBsct + 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_ATLID_INTERFACE, ONLY: cosp_atlid_init, atlid_IN + USE MOD_COSP_GRLIDAR532_INTERFACE, ONLY: cosp_grLidar532_init, grLidar532_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) + surfelev ! Surface Elevation (m) + ! 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 simulators. + Nrefl ! Number of reflectances for PARASOL simulator + real(wp) :: & + emsfc_lw ! Surface emissivity @ 11micron + real(wp),allocatable,dimension(:,:,:) :: & + frac_out, & ! Cloud fraction + tau_067, & ! Optical depth @ 0.67micron + emiss_11, & ! Emissivity @ 11 micron + fracLiq, & ! Fraction of optical-depth due to liquid (MODIS) + asym, & ! Assymetry parameter @ 3.7micron (MODIS) + ss_alb, & ! Single-scattering albedo @ 3.7micron (MODIS) + betatot_calipso, & ! Lidar backscatter coefficient (calipso @ 532nm) + betatot_grLidar532, & ! Lidar backscatter coefficient (ground-lidar @ 532nm) + betatot_atlid, & ! Lidar backscatter coefficient (atlid @ 355nm) + betatot_ice_calipso, & ! Lidar backscatter coefficient ICE (calipso @ 532nm) + betatot_liq_calipso, & ! Lidar backscatter coefficient LIQUID (calipso @ 532nm) + tautot_calipso, & ! Lidar Optical thickness (calipso @ 532nm) + tautot_grLidar532, & ! Lidar Optical thickness (ground-lidar @ 532nm) + tautot_atlid, & ! Lidar Optical thickness (atlid @ 355nm) + tautot_ice_calipso, & ! Lidar Ice Optical thickness (calipso @ 532nm) + tautot_liq_calipso, & ! Lidar Liquid Optical thickness (calipso @ 532nm) + 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_calipso, & ! Lidar molecular backscatter coefficient (calipso @ 532nm) + beta_mol_grLidar532, & ! Lidar molecular backscatter coefficient (ground-lidar @ 532nm) + beta_mol_atlid, & ! Lidar molecular backscatter coefficient (atlid @ 355nm) + tau_mol_calipso, & ! Lidar molecular optical depth (calipso @ 532nm) + tau_mol_grLidar532, & ! Lidar molecular optical depth (ground-lidar @ 532nm) + tau_mol_atlid, & ! Lidar molecular optical depth (atlid @ 355nm) + tautot_S_liq, & ! Parasol Liquid water optical thickness, from TOA to SFC + tautot_S_ice, & ! Parasol Ice water optical thickness, from TOA to SFC + fracPrecipIce ! Fraction of precipitation which is frozen (1). + type(radar_cfg) :: & + rcfg_cloudsat ! Radar configuration 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_lidarcldtype => null(), & ! 3D "lidar" OPAQ type 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_cldtype => null(), & ! opaque and thin lidar cloud cover + z_opaque altitude + calipso_cldtypetemp => null(), & ! opaque and thin cloud temperature + calipso_cldtypemeanz => null(), & ! opaque and thin cloud altitude + calipso_cldtypemeanzse => null(),& ! same as just above with respect to SE + calipso_beta_mol => null(), & ! Molecular backscatter + calipso_temp_tot => null() + real(wp), dimension(:),pointer :: & + calipso_cldthinemis => null(), & ! thin cloud emissivity + calipso_srbval => null() ! SR bins in cfad_sr + + ! GROUND LIDAR outputs + real(wp),dimension(:,:,:),pointer :: & + grLidar532_beta_tot => null(), & ! Total GROUND LIDAR backscattered signal + grLidar532_cfad_sr => null() ! CFAD of GROUND LIDAR scattering ratio + real(wp), dimension(:,:),pointer :: & + grLidar532_lidarcld => null(), & ! 3D GROUND "lidar" cloud fraction + grLidar532_cldlayer => null(), & ! low, mid, high-level, total GROUND lidar cloud cover + grLidar532_beta_mol => null() ! GROUND LIDAR Molecular backscatter + real(wp), dimension(:),pointer :: & + grLidar532_srbval => null() ! SR bins in cfad_sr + + ! ATLID outputs + real(wp),dimension(:,:,:),pointer :: & + atlid_beta_tot => null(), & ! Total ATLID backscattered signal + atlid_cfad_sr => null() ! CFAD of ATLID scattering ratio + real(wp), dimension(:,:),pointer :: & + atlid_lidarcld => null(), & ! 3D ATLID cloud fraction + atlid_cldlayer => null(), & ! low, mid, high-level, total ATLID cloud cover + atlid_beta_mol => null() ! ATLID Molecular backscatter + real(wp), dimension(:),pointer :: & + atlid_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) + cloudsat_precip_cover => null() ! Radar total cloud amount by CloudSat precip flag (Npoints,dBZe_bins) + real(wp),dimension(:),pointer :: & + cloudsat_tcc => null(), & + cloudsat_tcc2 => null(), & + radar_lidar_tcc => null(), & ! Radar&lidar total cloud amount, grid-box scale (Npoints) + cloudsat_pia => null() ! Radar path integrated attenuation (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(grLidar532_IN) :: grLidar532IN ! Input to the GROUND LIDAR simulator + type(atlid_IN) :: atlidIN ! Input to the ATLID 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 + LgrLidar532_subcolumn,& ! On/Off switch for subcolumn GROUND LIDAR simulator + Latlid_subcolumn, & ! On/Off switch for subcolumn ATLID 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 + LgrLidar532_column, & ! On/Off switch for column GROUND LIDAR simulator + Latlid_column, & ! On/Off switch for column ATLID 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 + Lcloudsat_tcc, & ! + Lcloudsat_tcc2, & ! + Llidar_only_freq_cloud ! On/Off switch from joint Calipso/Cloudsat product + logical :: & + ok_lidar_cfad = .false., & + ok_lidar_cfad_grLidar532 = .false., & + ok_lidar_cfad_atlid = .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, cloudsat_tcc, cloudsat_tcc2 + 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, & + grLidar532_beta_mol,atlid_beta_mol + REAL(WP), dimension(:,:,:),allocatable :: & + modisJointHistogram,modisJointHistogramIce,modisJointHistogramLiq, & + calipso_beta_tot,calipso_betaperp_tot, cloudsatDBZe,parasolPix_refl, & + grLidar532_beta_tot,atlid_beta_tot,cloudsatZe_non + real(wp),dimension(:),allocatable,target :: & + out1D_1,out1D_2,out1D_3,out1D_4,out1D_5,out1D_6,out1D_7,out1D_8, & + out1D_9,out1D_10,out1D_11,out1D_12 + real(wp),dimension(:,:,:),allocatable :: & + betamol_in,betamoli,pnormi,ze_toti,ze_noni + + ! 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. + LgrLidar532_subcolumn = .false. + Latlid_subcolumn = .false. + Lparasol_subcolumn = .false. + Lcloudsat_subcolumn = .false. + Lmodis_subcolumn = .false. + Lrttov_subcolumn = .false. + Lisccp_column = .false. + Lmisr_column = .false. + Lcalipso_column = .false. + LgrLidar532_column = .false. + Latlid_column = .false. + Lparasol_column = .false. + Lcloudsat_column = .false. + Lmodis_column = .false. + Lrttov_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .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. + + ! GROUND LIDAR subcolumn + if (associated(cospOUT%grLidar532_beta_mol) .or. & + associated(cospOUT%grLidar532_beta_tot)) & + LgrLidar532_subcolumn = .true. + + ! ATLID subcolumn + if (associated(cospOUT%atlid_beta_mol) .or. & + associated(cospOUT%atlid_beta_tot)) & + Latlid_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_lidarcldtype) .or. & + associated(cospOUT%calipso_cldlayer) .or. & + associated(cospOUT%calipso_cldtype) .or. & + associated(cospOUT%calipso_cldtypetemp) .or. & + associated(cospOUT%calipso_cldtypemeanz) .or. & + associated(cospOUT%calipso_cldtypemeanzse) .or. & + associated(cospOUT%calipso_cldthinemis) .or. & + associated(cospOUT%calipso_cldlayerphase) .or. & + associated(cospOUT%calipso_lidarcldtmp)) then + Lcalipso_column = .true. + Lcalipso_subcolumn = .true. + endif + + ! GROUND LIDAR column + if (associated(cospOUT%grLidar532_cfad_sr) .or. & + associated(cospOUT%grLidar532_lidarcld) .or. & + associated(cospOUT%grLidar532_cldlayer)) then + LgrLidar532_column = .true. + LgrLidar532_subcolumn = .true. + endif + + ! ATLID column + if (associated(cospOUT%atlid_cfad_sr) .or. & + associated(cospOUT%atlid_lidarcld) .or. & + associated(cospOUT%atlid_cldlayer)) then + Latlid_column = .true. + Latlid_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) .or. & + associated(cospOUT%cloudsat_tcc) .or. associated(cospOUT%cloudsat_tcc2)) then + Lcalipso_column = .true. + Lcalipso_subcolumn = .true. + Lcloudsat_column = .true. + Lcloudsat_subcolumn = .true. + Lradar_lidar_tcc = .true. + Llidar_only_freq_cloud = .true. + Lcloudsat_tcc = .true. + Lcloudsat_tcc2 = .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, & + Latlid_subcolumn, Latlid_column, LgrLidar532_subcolumn, LgrLidar532_column, & + Lrttov_subcolumn, Lrttov_column, Lparasol_subcolumn, Lparasol_column, & + Lradar_lidar_tcc, Llidar_only_freq_cloud, Lcloudsat_tcc,Lcloudsat_tcc2, 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_calipso + calipsoIN%betatot => cospIN%betatot_calipso + calipsoIN%betatot_liq => cospIN%betatot_liq_calipso + calipsoIN%betatot_ice => cospIN%betatot_ice_calipso + calipsoIN%tau_mol => cospIN%tau_mol_calipso + calipsoIN%tautot => cospIN%tautot_calipso + calipsoIN%tautot_liq => cospIN%tautot_liq_calipso + calipsoIN%tautot_ice => cospIN%tautot_ice_calipso + endif + + if (LgrLidar532_subcolumn) then + grLidar532IN%Npoints => Npoints + grLidar532IN%Ncolumns => cospIN%Ncolumns + grLidar532IN%Nlevels => cospIN%Nlevels + grLidar532IN%beta_mol => cospIN%beta_mol_grLidar532 + grLidar532IN%betatot => cospIN%betatot_grLidar532 + grLidar532IN%tau_mol => cospIN%tau_mol_grLidar532 + grLidar532IN%tautot => cospIN%tautot_grLidar532 + endif + + if (Latlid_subcolumn) then + atlidIN%Npoints => Npoints + atlidIN%Ncolumns => cospIN%Ncolumns + atlidIN%Nlevels => cospIN%Nlevels + atlidIN%beta_mol_atlid => cospIN%beta_mol_atlid + atlidIN%betatot_atlid => cospIN%betatot_atlid + atlidIN%tau_mol_atlid => cospIN%tau_mol_atlid + atlidIN%tautot_atlid => cospIN%tautot_atlid + 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, .false., & + calipsoIN%beta_mol, calipsoIN%tau_mol, calipsoIN%betatot, calipsoIN%tautot, & + calipso_beta_mol(:,:), calipso_beta_tot(:,:,:), calipsoIN%betatot_ice, & + calipsoIN%tautot_ice, calipsoIN%betatot_liq, calipsoIN%tautot_liq, & + 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 + + ! GROUND LIDAR subcolumn simulator + if (LgrLidar532_subcolumn) then + ! Allocate space for local variables + allocate(grLidar532_beta_mol(grLidar532IN%Npoints,grLidar532IN%Nlevels), & + grLidar532_beta_tot(grLidar532IN%Npoints,grLidar532IN%Ncolumns,grLidar532IN%Nlevels)) + ! Call simulator + call lidar_subcolumn(grLidar532IN%npoints, grLidar532IN%ncolumns, grLidar532IN%nlevels,& + .true., grLidar532IN%beta_mol, grLidar532IN%tau_mol, grLidar532IN%betatot,& + grLidar532IN%tautot, grLidar532_beta_mol(:,:), grLidar532_beta_tot(:,:,:)) + ! Store output (if requested) + if (associated(cospOUT%grLidar532_beta_mol)) & + cospOUT%grLidar532_beta_mol(ij:ik,grLidar532IN%Nlevels:1:-1) = grLidar532_beta_mol + if (associated(cospOUT%grLidar532_beta_tot)) & + cospOUT%grLidar532_beta_tot(ij:ik,:,grLidar532IN%Nlevels:1:-1) = grLidar532_beta_tot + endif + + ! ATLID subcolumn simulator + if (Latlid_subcolumn) then + ! Allocate space for local variables + allocate(atlid_beta_mol(atlidIN%Npoints,atlidIN%Nlevels), & + atlid_beta_tot(atlidIN%Npoints,atlidIN%Ncolumns,atlidIN%Nlevels)) + ! Call simulator + call lidar_subcolumn(atlidIN%npoints, atlidIN%ncolumns, atlidIN%nlevels,& + .false., atlidIN%beta_mol_atlid, atlidIN%tau_mol_atlid, atlidIN%betatot_atlid,& + atlidIN%tautot_atlid, atlid_beta_mol(:,:), atlid_beta_tot(:,:,:)) + ! Store output (if requested) + if (associated(cospOUT%atlid_beta_mol)) & + cospOUT%atlid_beta_mol(ij:ik,atlidIN%Nlevels:1:-1) = atlid_beta_mol + if (associated(cospOUT%atlid_beta_tot)) & + cospOUT%atlid_beta_tot(ij:ik,:,atlidIN%Nlevels:1:-1) = atlid_beta_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), & + cloudsatZe_non(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,:),cloudsatZe_non(:,icol,:)) + enddo + ! Store output (if requested) + if (associated(cospOUT%cloudsat_Ze_tot)) then + cospOUT%cloudsat_Ze_tot(ij:ik,:,:) = cloudsatDBZe(:,:,1:cloudsatIN%Nlevels) + 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 + if (.not. associated(cospOUT%calipso_lidarcldtype)) then + allocate(out1D_7(Npoints*Nlvgrid*4)) + cospOUT%calipso_lidarcldtype(ij:ik,1:Nlvgrid,1:4) => out1D_7 + endif + if (.not. associated(cospOUT%calipso_cldtype)) then + allocate(out1D_8(Npoints*LIDAR_NTYPE)) + cospOUT%calipso_cldtype(ij:ik,1:LIDAR_NTYPE) => out1D_8 + endif + if (.not. associated(cospOUT%calipso_cldtypetemp)) then + allocate(out1D_9(Npoints*LIDAR_NTYPE)) + cospOUT%calipso_cldtypetemp(ij:ik,1:LIDAR_NTYPE) => out1D_9 + endif + if (.not. associated(cospOUT%calipso_cldtypemeanz)) then + allocate(out1D_10(Npoints*2)) + cospOUT%calipso_cldtypemeanz(ij:ik,1:2) => out1D_10 + endif + if (.not. associated(cospOUT%calipso_cldtypemeanzse)) then + allocate(out1D_12(Npoints*3)) + cospOUT%calipso_cldtypemeanzse(ij:ik,1:3) => out1D_12 + endif + if (.not. associated(cospOUT%calipso_cldthinemis)) then + allocate(out1D_11(Npoints)) + cospOUT%calipso_cldthinemis(ij:ik) => out1D_11 + endif + + ! Call simulator + ok_lidar_cfad=.true. + call lidar_column(calipsoIN%Npoints, calipsoIN%Ncolumns, calipsoIN%Nlevels, & + Nlvgrid, SR_BINS, LIDAR_NTYPE, 'calipso',calipso_beta_tot(:,:,:), calipso_beta_mol(:,:),& + cospgridIN%phalf(:,2:calipsoIN%Nlevels),cospgridIN%hgt_matrix, & + cospgridIN%hgt_matrix_half, vgrid_z(:), ok_lidar_cfad, LIDAR_NCAT, & + cospOUT%calipso_cfad_sr(ij:ik,:,:), cospOUT%calipso_lidarcld(ij:ik,:), & + cospOUT%calipso_cldlayer(ij:ik,:), & + cospgridIN%at(:,:), calipso_betaperp_tot(:,:,:), cospgridIN%surfelev, & + cospOUT%calipso_lidarcldphase(ij:ik,:,:), & + cospOUT%calipso_lidarcldtype(ij:ik,:,:), cospOUT%calipso_cldtype(ij:ik,:), & + cospOUT%calipso_cldtypetemp(ij:ik,:), cospOUT%calipso_cldtypemeanz(ij:ik,:), & + cospOUT%calipso_cldtypemeanzse(ij:ik,:), cospOUT%calipso_cldthinemis(ij:ik), & + 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 + if (allocated(out1D_7)) then + deallocate(out1D_7) + nullify(cospOUT%calipso_lidarcldtype) + endif + if (allocated(out1D_8)) then + deallocate(out1D_8) + nullify(cospOUT%calipso_cldtype) + endif + if (allocated(out1D_9)) then + deallocate(out1D_9) + nullify(cospOUT%calipso_cldtypetemp) + endif + if (allocated(out1D_10)) then + deallocate(out1D_10) + nullify(cospOUT%calipso_cldtypemeanz) + endif + if (allocated(out1D_12)) then + deallocate(out1D_12) + nullify(cospOUT%calipso_cldtypemeanzse) + endif + if (allocated(out1D_11)) then + deallocate(out1D_11) + nullify(cospOUT%calipso_cldthinemis) + endif + + endif + + ! GROUND LIDAR Simulator + if (LgrLidar532_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%grLidar532_cfad_sr)) then + allocate(out1D_1(Npoints*SR_BINS*Nlvgrid)) + cospOUT%grLidar532_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1 + endif + if (.not. associated(cospOUT%grLidar532_lidarcld)) then + allocate(out1D_2(Npoints*Nlvgrid)) + cospOUT%grLidar532_lidarcld(ij:ik,1:Nlvgrid) => out1D_2 + endif + if (.not. associated(cospOUT%grLidar532_cldlayer)) then + allocate(out1D_3(Npoints*LIDAR_NCAT)) + cospOUT%grLidar532_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_3 + endif + + ! Call simulator + ok_lidar_cfad_grLidar532=.true. + call lidar_column(grLidar532IN%Npoints, grLidar532IN%Ncolumns, grLidar532IN%Nlevels, & + Nlvgrid, SR_BINS, LIDAR_NTYPE, 'grlidar532',grLidar532_beta_tot(:,:,:), grLidar532_beta_mol(:,:),& + cospgridIN%phalf(:,2:grLidar532IN%Nlevels),cospgridIN%hgt_matrix, & + cospgridIN%hgt_matrix_half, vgrid_z(:), ok_lidar_cfad_grLidar532, LIDAR_NCAT, & + cospOUT%grLidar532_cfad_sr(ij:ik,:,:), cospOUT%grLidar532_lidarcld(ij:ik,:), & + cospOUT%grLidar532_cldlayer(ij:ik,:)) + + if (associated(cospOUT%grLidar532_srbval)) cospOUT%grLidar532_srbval = grLidar532_histBsct + + ! Free up memory (if necessary) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%grLidar532_cfad_sr) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%grLidar532_lidarcld) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%grLidar532_cldlayer) + endif + + endif + + ! ATLID Simulator + if (Latlid_column) then + ! Check to see which outputs are requested. If not requested, use a local dummy array + if (.not. associated(cospOUT%atlid_cfad_sr)) then + allocate(out1D_1(Npoints*SR_BINS*Nlvgrid)) + cospOUT%atlid_cfad_sr(ij:ik,1:SR_BINS,1:Nlvgrid) => out1D_1 + endif + if (.not. associated(cospOUT%atlid_lidarcld)) then + allocate(out1D_2(Npoints*Nlvgrid)) + cospOUT%atlid_lidarcld(ij:ik,1:Nlvgrid) => out1D_2 + endif + if (.not. associated(cospOUT%atlid_cldlayer)) then + allocate(out1D_3(Npoints*LIDAR_NCAT)) + cospOUT%atlid_cldlayer(ij:ik,1:LIDAR_NCAT) => out1D_3 + endif + + ! Call simulator + ok_lidar_cfad_atlid=.true. + call lidar_column(atlidIN%Npoints, atlidIN%Ncolumns, atlidIN%Nlevels, & + Nlvgrid, SR_BINS, LIDAR_NTYPE, 'atlid',atlid_beta_tot(:,:,:), & + atlid_beta_mol(:,:), cospgridIN%phalf(:,2:atlidIN%Nlevels), & + cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half, vgrid_z(:), & + ok_lidar_cfad_atlid, LIDAR_NCAT, cospOUT%atlid_cfad_sr(ij:ik,:,:), & + cospOUT%atlid_lidarcld(ij:ik,:), cospOUT%atlid_cldlayer(ij:ik,:)) + + if (associated(cospOUT%atlid_srbval)) cospOUT%atlid_srbval = atlid_histBsct + + ! Free up memory (if necessary) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%atlid_cfad_sr) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%atlid_lidarcld) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%atlid_cldlayer) + 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*cloudsat_DBZE_BINS*Nlvgrid)) + cospOUT%cloudsat_cfad_ze(ij:ik,1:cloudsat_DBZE_BINS,1:Nlvgrid) => out1D_1 + endif + + if (.not. associated(cospOUT%cloudsat_pia)) then + allocate(out1D_2(Npoints)) + cospOUT%cloudsat_pia(ij:ik) => out1D_2 + endif + if (.not. associated(cospOUT%cloudsat_precip_cover)) then + allocate(out1D_3(Npoints*nCloudsatPrecipClass)) + cospOUT%cloudsat_precip_cover(ij:ik,1:nCloudsatPrecipClass) => out1D_3 + endif + + ! Call simulator + call quickbeam_column(cloudsatIN%Npoints, cloudsatIN%Ncolumns, cloudsatIN%Nlevels,& + Nlvgrid, cloudsat_DBZE_BINS, 'cloudsat', cloudsatDBZe, cloudsatZe_non, & +! cospgridIN%land(:), cospgridIN%at(:,cospIN%Nlevels), cospIN%fracPrecipIce, & !PREC_BUG +! cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half, & !PREC_BUG + cospgridIN%land(:), cospgridIN%surfelev(:), cospgridIN%at(:,cospIN%Nlevels), & !PREC_BUG + cospIN%fracPrecipIce, cospgridIN%hgt_matrix, cospgridIN%hgt_matrix_half, & !PREC_BUG + cospOUT%cloudsat_cfad_ze(ij:ik,:,:), cospOUT%cloudsat_precip_cover, & + cospOUT%cloudsat_pia) + ! Free up memory (if necessary) + if (allocated(out1D_1)) then + deallocate(out1D_1) + nullify(cospOUT%cloudsat_cfad_ze) + endif + if (allocated(out1D_2)) then + deallocate(out1D_2) + nullify(cospOUT%cloudsat_pia) + endif + if (allocated(out1D_3)) then + deallocate(out1D_3) + nullify(cospOUT%cloudsat_precip_cover) + 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 .or. Lcloudsat_tcc .or. Lcloudsat_tcc2) then + + if (use_vgrid) then + allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,Nlvgrid), & + radar_lidar_tcc(cloudsatIN%Npoints), cloudsat_tcc(cloudsatIN%Npoints), & + cloudsat_tcc2(cloudsatIN%Npoints)) + allocate(betamol_in(cloudsatIN%Npoints,1,cloudsatIN%Nlevels), & + betamoli(cloudsatIN%Npoints,1,Nlvgrid), & + pnormI(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid), & + Ze_totI(cloudsatIN%Npoints,cloudsatIN%Ncolumns,Nlvgrid)) + + ! Regrid in the vertical (*NOTE* This routine requires SFC-2-TOA ordering, so flip + ! inputs and outputs to maintain TOA-2-SFC ordering convention in COSP2.) + 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), & + betamolI(:,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),pnormI(:,:,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_totI(:,:,Nlvgrid:1:-1),log_units=.true.) + + call cosp_lidar_only_cloud(cloudsatIN%Npoints, cloudsatIN%Ncolumns, Nlvgrid, & + pnormI, betamolI, Ze_totI, lidar_only_freq_cloud, radar_lidar_tcc, & + cloudsat_tcc, cloudsat_tcc2) + + deallocate(betamol_in,betamolI,pnormI,ze_totI) + else + allocate(lidar_only_freq_cloud(cloudsatIN%Npoints,cloudsatIN%Nlevels), & + radar_lidar_tcc(cloudsatIN%Npoints), cloudsat_tcc(cloudsatIN%Npoints), & + cloudsat_tcc2(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, cloudsat_tcc, cloudsat_tcc2) + 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 + if (associated(cospOUT%cloudsat_tcc)) then + cospOUT%cloudsat_tcc(ij:ik) = cloudsat_tcc + endif + if (associated(cospOUT%cloudsat_tcc2)) then + cospOUT%cloudsat_tcc2(ij:ik) = cloudsat_tcc2 + 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 (LgrLidar532_subcolumn) then + nullify(grLidar532IN%Npoints,grLidar532IN%Ncolumns,grLidar532IN%Nlevels,grLidar532IN%beta_mol, & + grLidar532IN%betatot,grLidar532IN%tau_mol,grLidar532IN%tautot) + endif + + if (Latlid_subcolumn) then + nullify(atlidIN%Npoints,atlidIN%Ncolumns,atlidIN%Nlevels,atlidIN%beta_mol_atlid, & + atlidIN%betatot_atlid,atlidIN%tau_mol_atlid,atlidIN%tautot_atlid) + 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(grLidar532_beta_tot)) deallocate(grLidar532_beta_tot) + if (allocated(atlid_beta_tot)) deallocate(atlid_beta_tot) + if (allocated(calipso_beta_mol)) deallocate(calipso_beta_mol) + if (allocated(grLidar532_beta_mol)) deallocate(grLidar532_beta_mol) + if (allocated(atlid_beta_mol)) deallocate(atlid_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) + if (allocated(cloudsat_tcc)) deallocate(cloudsat_tcc) + if (allocated(cloudsat_tcc2)) deallocate(cloudsat_tcc2) + + end function COSP_SIMULATOR + ! ###################################################################################### + ! SUBROUTINE cosp_init + ! ###################################################################################### + SUBROUTINE COSP_INIT(Lisccp, Lmodis, Lmisr, Lcloudsat, Lcalipso, LgrLidar532, Latlid, Lparasol, Lrttov, & + cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs, cloudsat_do_ray, & + isccp_top_height, isccp_top_height_direction, surface_radar, rcfg, lusevgrid, & + luseCSATvgrid, Nvgrid, Nlevels, cloudsat_micro_scheme) + + ! INPUTS + logical,intent(in) :: Lisccp,Lmodis,Lmisr,Lcloudsat,Lcalipso,LgrLidar532,Latlid,Lparasol,Lrttov + integer,intent(in) :: & + cloudsat_use_gas_abs, & ! + cloudsat_do_ray, & ! + isccp_top_height, & ! + isccp_top_height_direction, & ! + Nlevels, & ! + Nvgrid, & ! Number of levels for new L3 grid + surface_radar ! + 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 + + ! 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 + 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() + 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 (LgrLidar532) call cosp_grLidar532_init() + if (Latlid) call cosp_atlid_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, Latlid_subcolumn, & + Latlid_column, LgrLidar532_subcolumn, LgrLidar532_column, Lrttov_subcolumn, & + Lrttov_column, Lparasol_subcolumn, Lparasol_column, Lradar_lidar_tcc, & + Llidar_only_freq_cloud, Lcloudsat_tcc, Lcloudsat_tcc2, 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 + Latlid_subcolumn, & ! EarthCare subcolumn simulator on/off switch + Latlid_column, & ! EarthCare column simulator on/off switch + LgrLidar532_subcolumn, & ! Ground Lidar subcolumn simulator on/off switch + LgrLidar532_column, & ! Ground Lidar 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 + Lcloudsat_tcc, & ! + Lcloudsat_tcc2, & ! + 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 + logical :: alloc_status + + nError = 0 + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! PART 0: Ensure that the inputs needed by the requested simulators are allocated. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! ISCCP simulator + if (Lisccp_subcolumn .or. Lisccp_column) then + alloc_status = .true. + if (.not. allocated(cospgridIN%skt)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%skt has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%qv)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%qv has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%frac_out)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%frac_out has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_067)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%tau_067 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%emiss_11)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospIN%emiss_11 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%sunlit)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%sunlit has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%pfull)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (ISSCP simulator): cospgridIN%pfull has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + 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 + endif + + ! MISR simulator + if (Lmisr_subcolumn .or. Lmisr_column) then + alloc_status = .true. + if (.not. allocated(cospIN%tau_067)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospIN%tau_067 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%sunlit)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%sunlit has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MISR simulator): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lmisr_subcolumn = .false. + Lmisr_column = .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 + endif + endif + + ! EarthCare Lidar simulator. + if (Latlid_subcolumn .or. Latlid_column) then + alloc_status = .true. + if (.not. allocated(cospIN%beta_mol_atlid)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%beta_mol_atlid has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot_atlid)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%betatot_atlid has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_mol_atlid)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%tau_mol_atlid has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_atlid)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospIN%tautot_atlid has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Latlid_subcolumn = .false. + Latlid_column = .false. + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_mol)) cospOUT%atlid_beta_mol(:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_tot)) cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF + endif + + ! EarthCare column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%hgt_matrix_half has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (EarthCare Lidar simulator): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Latlid_column = .false. + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + endif + endif + + ! Ground Lidar simulator. + if (LgrLidar532_subcolumn .or. LgrLidar532_column) then + alloc_status = .true. + if (.not. allocated(cospIN%beta_mol_grLidar532)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%beta_mol_grLidar532 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot_grLidar532)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%betatot_grLidar532 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_mol_grLidar532)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%tau_mol_grLidar532 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_grLidar532)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospIN%tautot_grLidar532 has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_mol)) cospOUT%grLidar532_beta_mol(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_tot)) cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF + endif + + ! Ground Lidar column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%hgt_matrix_half has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Ground Lidar simulator): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + LgrLidar532_column = .false. + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + endif + endif + + ! Calipso Lidar simulator + if (Lcalipso_subcolumn .or. Lcalipso_column) then + alloc_status = .true. + if (.not. allocated(cospIN%beta_mol_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%beta_mol_calipso has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%betatot_calipso has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot_liq_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospIN%betatot_liq_calipso has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%betatot_ice_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospIN%betatot_ice_calipso has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_mol_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%tau_mol_calipso has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospIN%tautot_calipso has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_liq_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospIN%tautot_liq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_ice_calipso)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospIN%tautot_ice has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + 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_beta_mol)) cospOUT%calipso_beta_mol(:,:) = R_UNDEF + if (associated(cospOUT%calipso_beta_tot)) cospOUT%calipso_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_betaperp_tot)) cospOUT%calipso_betaperp_tot(:,:,:) = R_UNDEF + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Lcloudsat_tcc) then + Lcloudsat_tcc = .false. + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + endif + if (Lcloudsat_tcc2) then + Lcloudsat_tcc2 = .false. + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + + ! Calipso column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator):'//& + ' cospgridIN%hgt_matrix_half has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Calipso Lidar simulator): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + 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 (Lcloudsat_tcc) then + Lcloudsat_tcc = .false. + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + endif + if (Lcloudsat_tcc2) then + Lcloudsat_tcc2 = .false. + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + endif + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + endif + + ! PARASOL simulator + if (Lparasol_subcolumn .or. Lparasol_column) then + alloc_status = .true. + if (.not. allocated(cospIN%tautot_S_liq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_liq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tautot_S_ice)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospIN%tautot_S_ice has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + 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 + + ! PARASOL column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%land)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (PARASOL simulator): cospgridIN%land has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lparasol_column = .false. + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + endif + + ! Cloudsat radar simulator + if (Lcloudsat_subcolumn .or. Lcloudsat_column) then + alloc_status = .true. + if (.not. allocated(cospIN%z_vol_cloudsat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospIN%z_vol_cloudsat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%kr_vol_cloudsat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospIN%kr_vol_cloudsat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%g_vol_cloudsat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospIN%g_vol_cloudsat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospgridIN%hgt_matrix has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lcloudsat_subcolumn = .false. + Lcloudsat_column = .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 (Lcloudsat_tcc) then + Lcloudsat_tcc = .false. + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + endif + if (Lcloudsat_tcc2) then + Lcloudsat_tcc2 = .false. + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + endif + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + + ! Cloudsat column simulator requires additional inputs not required by the subcolumn simulator. + alloc_status = .true. + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (Cloudsat radar simulator):'//& + ' cospgridIN%hgt_matrix_half has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lcloudsat_column = .false. + if (associated(cospOUT%cloudsat_cfad_ze)) cospOUT%cloudsat_cfad_ze(:,:,:) = R_UNDEF + if (Lcloudsat_tcc) then + Lcloudsat_tcc = .false. + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + endif + if (Lcloudsat_tcc2) then + Lcloudsat_tcc2 = .false. + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + endif + ! Also, turn-off joint-products + if (Lradar_lidar_tcc) then + Lradar_lidar_tcc = .false. + if (associated(cospOUT%radar_lidar_tcc)) cospOUT%radar_lidar_tcc(:) = R_UNDEF + endif + if (Llidar_only_freq_cloud) then + Llidar_only_freq_cloud = .false. + if (associated(cospOUT%lidar_only_freq_cloud)) cospOUT%lidar_only_freq_cloud(:,:) = R_UNDEF + endif + endif + endif + + ! MODIS simulator + if (Lmodis_subcolumn .or. Lmodis_column) then + alloc_status = .true. + if (.not. allocated(cospIN%fracLiq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%fracLiq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%tau_067)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%tau_067 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%asym)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%asym has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospIN%ss_alb)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospIN%ss_alb has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%sunlit)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (MODIS simulator): cospgridIN%sunlit has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + 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 + endif + + ! RTTOV + if (Lrttov_column) then + alloc_status = .true. + if (.not. allocated(cospgridIN%emis_sfc)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%hgt_matrix_half)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%emis_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%u_sfc)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%u_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%v_sfc)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%v_sfc has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%skt)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%skt has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%qv)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%land)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%land has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%lat)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lat has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%lon)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%lon has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%seaice)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%seaice has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%pfull)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%pfull has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%phalf)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%phalf has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%at)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%at has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%qv)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%qv has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%o3)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%o3 has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%tca)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%tca has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%cloudIce)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudIce has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%cloudLiq)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%cloudLiq has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%fl_rain)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_rain has not been allocated' + alloc_status = .false. + endif + if (.not. allocated(cospgridIN%fl_snow)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable (RTTOV): cospgridIN%fl_snow has not been allocated' + alloc_status = .false. + endif + if (.not. alloc_status) then + Lrttov_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 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([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lmodis_subcolumn, Lmodis_column])) then + 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 + endif + + if (any([Lisccp_subcolumn, Lisccp_column, Lmisr_subcolumn, Lmisr_column, Lrttov_column,& + Lcalipso_column, Lcloudsat_column, Lradar_lidar_tcc,Llidar_only_freq_cloud, & + Lcloudsat_tcc, Lcloudsat_tcc2])) then + 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_column = .false. + Lcalipso_column = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .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%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = 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 + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn, Lisccp_column, Lrttov_column])) then + 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_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 + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lmodis_subcolumn,Lmodis_column,Lcalipso_column,Lrttov_column,& + LgrLidar532_column,Latlid_column])) then + 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. + Lmodis_subcolumn = .false. + Lmodis_column = .false. + Lcalipso_column = .false. + Lrttov_column = .false. + Latlid_column = .false. + LgrLidar532_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 + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then + 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_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 + endif + endif + if (any([Lmisr_subcolumn,Lmisr_column,Lcloudsat_subcolumn,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,& + Llidar_only_freq_cloud,LgrLidar532_column,Latlid_column,Lcloudsat_tcc, Lcloudsat_tcc2])) then + 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. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .false. + Latlid_column = .false. + LgrLidar532_column = .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 + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + endif + if (any([Lrttov_column,Lcloudsat_column,Lcalipso_column,Lradar_lidar_tcc,Llidar_only_freq_cloud, & + LgrLidar532_column, Latlid_column, Lcloudsat_tcc, Lcloudsat_tcc2])) then + 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_column = .false. + Lcloudsat_column = .false. + Lcalipso_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .false. + Latlid_column = .false. + LgrLidar532_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%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 + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + endif + if (any([Lrttov_column,Lcalipso_column,Lparasol_column])) then + if (any(cospgridIN%land .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospgridIN%land contains values out of range' + Lrttov_column = .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%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + if (associated(cospOUT%parasolGrid_refl)) cospOUT%parasolGrid_refl(:,:) = R_UNDEF + endif + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lrttov_column])) then + 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_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 + endif + endif + + ! RTTOV Inputs + if (Lrttov_column) then + 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_column = .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_column = .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_column = .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_column = .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_column = .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_column = .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_column = .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_column = .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_column = .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_column = .false. + if (associated(cospOUT%rttov_tbs)) cospOUT%rttov_tbs(:,:) = R_UNDEF + endif + endif + + ! COSP_INPUTS + if (any([Lisccp_subcolumn,Lisccp_column])) then + 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 + endif + if (any([Lisccp_subcolumn,Lisccp_column,Lmisr_subcolumn,Lmisr_column,Lmodis_subcolumn,Lmodis_column])) then + 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 + endif + if (any([Lisccp_subcolumn,Lisccp_column])) then + 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 + endif + if (any([Lmodis_subcolumn,Lmodis_column])) then + 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 + endif + if (any([Latlid_subcolumn,Latlid_column])) then + if (any(cospIN%betatot_atlid .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_atlid contains values out of range' + Latlid_subcolumn = .false. + Latlid_column = .false. + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_tot)) cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_mol)) cospOUT%atlid_beta_mol(:,:) = R_UNDEF + endif + if (any(cospIN%beta_mol_atlid .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_atlid contains values out of range' + Latlid_subcolumn = .false. + Latlid_column = .false. + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_tot)) cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_mol)) cospOUT%atlid_beta_mol(:,:) = R_UNDEF + endif + if (any(cospIN%tautot_atlid .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_atlid contains values out of range' + Latlid_subcolumn = .false. + Latlid_column = .false. + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_tot)) cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_mol)) cospOUT%atlid_beta_mol(:,:) = R_UNDEF + endif + if (any(cospIN%tau_mol_atlid .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_atlid contains values out of range' + Latlid_subcolumn = .false. + Latlid_column = .false. + if (associated(cospOUT%atlid_cfad_sr)) cospOUT%atlid_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_lidarcld)) cospOUT%atlid_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%atlid_cldlayer)) cospOUT%atlid_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_tot)) cospOUT%atlid_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%atlid_beta_mol)) cospOUT%atlid_beta_mol(:,:) = R_UNDEF + endif + endif + + if (any([LgrLidar532_subcolumn,LgrLidar532_column])) then + if (any(cospIN%betatot_grLidar532 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_grLidar532 contains values out of range' + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_tot)) cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_mol)) cospOUT%grLidar532_beta_mol(:,:) = R_UNDEF + endif + if (any(cospIN%beta_mol_grLidar532 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_grLidar532 contains values out of range' + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_tot)) cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_mol)) cospOUT%grLidar532_beta_mol(:,:) = R_UNDEF + endif + if (any(cospIN%tautot_grLidar532 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_grLidar532 contains values out of range' + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_tot)) cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_mol)) cospOUT%grLidar532_beta_mol(:,:) = R_UNDEF + endif + if (any(cospIN%tau_mol_grLidar532 .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_grLidar532 contains values out of range' + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + if (associated(cospOUT%grLidar532_cfad_sr)) cospOUT%grLidar532_cfad_sr(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_lidarcld)) cospOUT%grLidar532_lidarcld(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_cldlayer)) cospOUT%grLidar532_cldlayer(:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_tot)) cospOUT%grLidar532_beta_tot(:,:,:) = R_UNDEF + if (associated(cospOUT%grLidar532_beta_mol)) cospOUT%grLidar532_beta_mol(:,:) = R_UNDEF + endif + endif + + if (any([Lcalipso_subcolumn,Lcalipso_column])) then + if (any(cospIN%betatot_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_calipso 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 + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + if (any(cospIN%betatot_liq_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = ('ERROR: COSP input variable: cospIN%betatot_liq_calipso 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 + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + if (any(cospIN%betatot_ice_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%betatot_ice_calipso 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 + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + if (any(cospIN%tautot_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_calipso 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 + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + if (any(cospIN%tautot_liq_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = ('ERROR: COSP input variable: cospIN%tautot_liq_calipso 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 + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + if (any(cospIN%tautot_ice_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tautot_ice_calipso 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 + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + if (any(cospIN%tau_mol_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%tau_mol_calipso 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 + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + endif + if (any([Lcalipso_subcolumn,Lcalipso_column,Lcloudsat_column,Lradar_lidar_tcc, & + Llidar_only_freq_cloud, Lcloudsat_tcc, Lcloudsat_tcc2])) then + if (any(cospIN%beta_mol_calipso .lt. 0)) then + nError=nError+1 + errorMessage(nError) = 'ERROR: COSP input variable: cospIN%beta_mol_calipso contains values out of range' + Lcalipso_subcolumn = .false. + Lcalipso_column = .false. + Lcloudsat_column = .false. + Lradar_lidar_tcc = .false. + Llidar_only_freq_cloud = .false. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .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 + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + if (associated(cospOUT%calipso_lidarcldtype)) cospOUT%calipso_lidarcldtype(:,:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtype)) cospOUT%calipso_cldtype(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypetemp)) cospOUT%calipso_cldtypetemp(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanz)) cospOUT%calipso_cldtypemeanz(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldtypemeanzse)) cospOUT%calipso_cldtypemeanzse(:,:) = R_UNDEF + if (associated(cospOUT%calipso_cldthinemis)) cospOUT%calipso_cldthinemis(:) = R_UNDEF + endif + endif + if (any([Lparasol_subcolumn,Lparasol_column])) then + 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 + endif + if (any([Lcloudsat_subcolumn,Lcloudsat_column,Lradar_lidar_tcc,Llidar_only_freq_cloud, & + Lcloudsat_tcc, Lcloudsat_tcc2])) then + 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. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .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 + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = 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. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .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 + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = 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. + Lcloudsat_tcc = .false. + Lcloudsat_tcc2 = .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 + if (associated(cospOUT%cloudsat_tcc)) cospOUT%cloudsat_tcc(:) = R_UNDEF + if (associated(cospOUT%cloudsat_tcc2)) cospOUT%cloudsat_tcc2(:) = R_UNDEF + endif + endif + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Part 2: Check input fields array size for consistency. This needs to be done for each + ! simulator + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! ISCCP + if (Lisccp_subcolumn .or. Lisccp_column) then + 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 + endif + + ! MISR + if (Lmisr_subcolumn .or. Lmisr_column) then + 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 + endif + + ! MODIS + if (Lmodis_subcolumn .or. Lmodis_column) then + 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 + endif + + ! CLOUDSAT + if (Lcloudsat_subcolumn .or. Lcloudsat_column) then + 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 + endif + + ! GROUND LIDAR @ 532nm + if (LgrLidar532_subcolumn .or. LgrLidar532_column) then + if (size(cospIN%beta_mol_grLidar532,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_grLidar532,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_mol_grLidar532,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_grLidar532,1) .ne. cospIN%Npoints) then + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%betatot_grLidar532,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_grLidar532,2) .ne. cospIN%Ncolumns) then + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%beta_mol_grLidar532,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_grLidar532,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_mol_grLidar532,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_grLidar532,3) .ne. cospIN%Nlevels) then + LgrLidar532_subcolumn = .false. + LgrLidar532_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(grLidar532_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! ATLID + if (Latlid_subcolumn .or. Latlid_column) then + if (size(cospIN%beta_mol_atlid,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_atlid,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_mol_atlid,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_atlid,1) .ne. cospIN%Npoints) then + Latlid_subcolumn = .false. + Latlid_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(atlid_simulator): The number of points in the input fields are inconsistent' + endif + if (size(cospIN%betatot_atlid,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_atlid,2) .ne. cospIN%Ncolumns) then + Latlid_subcolumn = .false. + Latlid_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(atlid_simulator): The number of sub-columns in the input fields are inconsistent' + endif + if (size(cospIN%beta_mol_atlid,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_atlid,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_mol_atlid,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_atlid,3) .ne. cospIN%Nlevels) then + Latlid_subcolumn = .false. + Latlid_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(atlid_simulator): The number of levels in the input fields are inconsistent' + endif + endif + + ! CALIPSO + if (Lcalipso_subcolumn .or. Lcalipso_column) then + if (size(cospIN%beta_mol_calipso,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_calipso,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_liq_calipso,1) .ne. cospIN%Npoints .OR. & + size(cospIN%betatot_ice_calipso,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tau_mol_calipso,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_calipso,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_liq_calipso,1) .ne. cospIN%Npoints .OR. & + size(cospIN%tautot_ice_calipso,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_calipso,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%betatot_liq_calipso,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%betatot_ice_calipso,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_calipso,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_liq_calipso,2) .ne. cospIN%Ncolumns .OR. & + size(cospIN%tautot_ice_calipso,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_calipso,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_calipso,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_liq_calipso,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%betatot_ice_calipso,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tau_mol_calipso,2) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_calipso,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_liq_calipso,3) .ne. cospIN%Nlevels .OR. & + size(cospIN%tautot_ice_calipso,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 + endif + + ! PARASOL + if (Lparasol_subcolumn .or. Lparasol_column) then + 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 + endif + + ! RTTOV + if (Lrttov_column) then + 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_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_column = .false. + nError=nError+1 + errorMessage(nError) = 'ERROR(rttov_simulator): The number of levels in the input fields are inconsistent' + endif + endif + end subroutine cosp_errorCheck + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_atlid_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_atlid_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_atlid_interface.f90 (revision 5900) @@ -0,0 +1,66 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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 +! Apr 2018 - R. Guzman - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_ATLID_INTERFACE + USE COSP_KINDS, ONLY: wp + IMPLICIT NONE + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE atlid_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type atlid_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + + real(wp),dimension(:,:),pointer :: & + beta_mol_atlid, & ! Molecular backscatter coefficient + tau_mol_atlid ! Molecular optical depth + real(wp),dimension(:,:,:),pointer :: & + betatot_atlid, & ! + tautot_atlid ! Optical thickess integrated from top + real(wp),dimension(:,:,:,:),pointer :: & + taupart_atlid + end type atlid_IN + +CONTAINS + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_atlid_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_atlid_init() + + end subroutine cosp_atlid_init + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_ATLID_INTERFACE Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_calipso_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_calipso_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_calipso_interface.f90 (revision 5900) @@ -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 +! Jul 2017 - R. Guzman - Added Ground LIDar variables (GLID) +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_cloudsat_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_cloudsat_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_cloudsat_interface.f90 (revision 5900) @@ -0,0 +1,142 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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 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 + + ! 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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_config.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_config.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_config.f90 (revision 5900) @@ -0,0 +1,429 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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. +! Mar 2018 - R. Guzman - Added LIDAR_NTYPE for the OPAQ diagnostics +! Apr 2018 - R. Guzman - Added parameters for GROUND LIDAR and ATLID simulators +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +MODULE MOD_COSP_CONFIG + USE COSP_KINDS, ONLY: wp,dp + 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. + + ! Mode debug ou prod (AI 0302018) + logical :: ok_debug_cosp = .true. + ! #################################################################################### + ! 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 = '/homedata/rguzman/CALIPSO/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),save,allocatable,dimension(:) :: & + modis_histTau ! Joint-histogram boundaries (optical depth) + !$OMP THREADPRIVATE(modis_histTau) + real(wp),save,allocatable,dimension(:,:) :: & + modis_histTauEdges ! Joint-histogram bin edges (optical depth) + !$OMP THREADPRIVATE(modis_histTauEdges) + real(wp),save,allocatable,dimension(:) :: & + modis_histTauCenters ! Joint-histogram bin centers (optical depth) + !$OMP THREADPRIVATE(modis_histTauCenters) + + ! #################################################################################### + ! 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 :: & + CLOUDSAT_DBZE_BINS = 15, & ! Number of dBZe bins in histogram (cfad) + CLOUDSAT_DBZE_MIN = -100, & ! Minimum value for radar reflectivity + CLOUDSAT_DBZE_MAX = 80, & ! Maximum value for radar reflectivity + CLOUDSAT_CFAD_ZE_MIN = -50, & ! Lower value of the first CFAD Ze bin + CLOUDSAT_CFAD_ZE_WIDTH = 5 ! Bin width (dBZe) + + real(wp),parameter,dimension(CLOUDSAT_DBZE_BINS+1) :: & + cloudsat_histRef = (/CLOUDSAT_DBZE_MIN,(/(i, i=int(CLOUDSAT_CFAD_ZE_MIN+CLOUDSAT_CFAD_ZE_WIDTH),& + int(CLOUDSAT_CFAD_ZE_MIN+(CLOUDSAT_DBZE_BINS-1)*CLOUDSAT_CFAD_ZE_WIDTH), & + int(CLOUDSAT_CFAD_ZE_WIDTH))/),CLOUDSAT_DBZE_MAX/) + real(wp),parameter,dimension(2,CLOUDSAT_DBZE_BINS) :: & + cloudsat_binEdges = reshape(source=(/cloudsat_histRef(1),((cloudsat_histRef(k), & + l=1,2),k=2,CLOUDSAT_DBZE_BINS),cloudsat_histRef(CLOUDSAT_DBZE_BINS+1)/),& + shape = (/2,CLOUDSAT_DBZE_BINS/)) + real(wp),parameter,dimension(CLOUDSAT_DBZE_BINS) :: & + cloudsat_binCenters = (cloudsat_binEdges(1,:)+cloudsat_binEdges(2,:))/2._wp + + ! Parameters for Cloudsat near-surface precipitation diagnostics. + ! Precipitation classes. + integer, parameter :: & + nCloudsatPrecipClass = 10 + integer, parameter :: & + pClass_noPrecip = 0, & ! No precipitation + pClass_Rain1 = 1, & ! Rain possible + pClass_Rain2 = 2, & ! Rain probable + pClass_Rain3 = 3, & ! Rain certain + pClass_Snow1 = 4, & ! Snow possible + pClass_Snow2 = 5, & ! Snow certain + pClass_Mixed1 = 6, & ! Mixed-precipitation possible + pClass_Mixed2 = 7, & ! Mixed-precipitation certain + pClass_Rain4 = 8, & ! Heavy rain + pClass_default = 9 ! Default + ! Reflectivity bin boundaries, used by decision tree to classify precipitation type. + real(wp), dimension(4),parameter :: & + Zenonbinval =(/0._wp, -5._wp, -7.5_wp, -15._wp/) + real(wp), dimension(6),parameter :: & + Zbinvallnd = (/10._wp, 5._wp, 2.5_wp, -2.5_wp, -5._wp, -15._wp/) + ! Vertical level index(Nlvgrid) for Cloudsat precipitation occurence/frequency diagnostics. + ! Level 39 of Nlvgrid(40) is 480-960m. +! integer, parameter :: & !PREC_BUG +! cloudsat_preclvl = 39 !PREC_BUG + + ! #################################################################################### + ! 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) + LIDAR_NTYPE = 3 ! Number of categories for OPAQ (opaque/thin cloud + z_opaque) + 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/)) + + ! #################################################################################### + ! Parameters used by the GROUND LIDAR simulator + ! #################################################################################### + ! GROUND LIDAR 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) :: & + grLidar532_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) :: & + grLidar532_binEdges = reshape(source=(/grLidar532_histBsct(1),((grLidar532_histBsct(k), & + l=1,2),k=2,SR_BINS),grLidar532_histBsct(SR_BINS+1)/), & + shape = (/2,SR_BINS/)) + real(wp),parameter,dimension(SR_BINS) :: & + grLidar532_binCenters = (grLidar532_binEdges(1,:)+grLidar532_binEdges(2,:))/2._wp + +! integer,parameter :: & +! LIDAR_NCAT = 4 ! Number of categories for cloudtop heights (high/mid/low/tot) + + ! #################################################################################### + ! Parameters used by the ATLID LIDAR simulator + ! #################################################################################### + ! ATLID LIDAR backscatter histogram bins + real(wp),parameter :: & + S_cld_atlid = 1.74, & ! Threshold for cloud detection + S_att_atlid = 0.01, & ! + S_cld_att_atlid = 6.67 ! Threshold for undefined cloud phase detection + real(wp),parameter,dimension(SR_BINS+1) :: & + atlid_histBsct = (/-1.,0.01,1.03,1.38,1.74,2.07,2.62,3.65,4.63,5.63,6.67,8.8,11.25, & + 13.2,17.2,999./) ! Backscatter histogram bins + real(wp),parameter,dimension(2,SR_BINS) :: & + atlid_binEdges = reshape(source=(/atlid_histBsct(1),((atlid_histBsct(k), & + l=1,2),k=2,SR_BINS),atlid_histBsct(SR_BINS+1)/), & + shape = (/2,SR_BINS/)) + real(wp),parameter,dimension(SR_BINS) :: & + atlid_binCenters = (atlid_binEdges(1,:)+atlid_binEdges(2,:))/2._wp + +! integer,parameter :: & +! LIDAR_NCAT = 4 ! Number of categories for cloudtop heights (high/mid/low/tot) + + ! #################################################################################### + ! New vertical grid used by CALIPSO and CLOUDSAT L3 (set up during initialization) + ! #################################################################################### + integer :: & + Nlvgrid ! Number of levels in New grid + real(wp),dimension(:), save, allocatable :: & + vgrid_zl, & ! New grid bottoms + vgrid_zu, & ! New grid tops + vgrid_z ! New grid center + !$OMP THREADPRIVATE(vgrid_zl,vgrid_zu,vgrid_z) + + ! #################################################################################### + ! Vertical grid used by CALIPSO and CLOUDSAT L3 (LMDZ parameter) + ! #################################################################################### + + integer, parameter :: & + niv_sorties = 40 + real(wp),parameter,dimension(niv_sorties) :: & + vgrid_z_in = (/240.0, 720.0, 1200.0, 1680.0, 2160.0, 2640.0, 3120.0, 3600.0, & + 4080.0, 4560.0, 5040.0, 5520.0, 6000.0, 6480.0, 6960.0, 7440.0, & + 7920.0, 8400.0, 8880.0, 9360.0, 9840.0, 10320.0, 10800.0, & + 11280.0, 11760.0, 12240.0, 12720.0, 13200.0, 13680.0, 14160.0, & + 14640.0, 15120.0, 15600.0, 16080.0, 16560.0, 17040.0, 17520.0, & + 18000.0, 18480.0, 18960.0/) + +END MODULE MOD_COSP_CONFIG Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_errorHandling.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_errorHandling.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_errorHandling.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_grLidar532_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_grLidar532_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_grLidar532_interface.f90 (revision 5900) @@ -0,0 +1,62 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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 +! Apr 2018 - R. Guzman - Original version +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +MODULE MOD_COSP_GRLIDAR532_INTERFACE + USE COSP_KINDS, ONLY: wp + IMPLICIT NONE + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE grLidar532_in + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + type grLidar532_IN + integer,pointer :: & + Npoints, & ! Number of gridpoints. + Ncolumns, & ! Number of columns. + Nlevels ! Number of levels. + real(wp),dimension(:,:),pointer :: & + beta_mol, & + tau_mol + real(wp),dimension(:,:,:),pointer :: & + betatot, & + tautot + end type grLidar532_IN +contains + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE cosp_grLidar532_init + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine cosp_grLidar532_init() + + end subroutine cosp_grLidar532_init + + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! END MODULE + ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +END MODULE MOD_COSP_GRLIDAR532_INTERFACE Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_isccp_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_isccp_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_isccp_interface.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_kinds.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_kinds.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_kinds.f90 (revision 5900) @@ -0,0 +1,39 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_math_constants.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_math_constants.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_math_constants.f90 (revision 5900) @@ -0,0 +1,6 @@ +MODULE cosp_math_constants + USE cosp_kinds, only: wp + IMPLICIT NONE + REAL(wp), PARAMETER :: pi = acos(-1.0_wp) + +END MODULE cosp_math_constants Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_misr_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_misr_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_misr_interface.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_modis_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_modis_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_modis_interface.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_optics.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_optics.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_optics.f90 (revision 5900) @@ -0,0 +1,492 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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 +! 04/04/18 Rodrigo Guzman- Added CALIOP-like Ground LIDar routines (GLID) +! 10/04/18 Rodrigo Guzman- Added ATLID-like (EarthCare) lidar routines (ATLID) +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +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) + w0(j,i,1:nLevels) = (tauLIQ(j,i,1:nLevels)*water_w0(1:nLevels) + tauICE(j,i,1:nLevels) *ice_w0(1:nLevels)) / & + (tau(1:nLevels)) + g(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)) / (w0(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, lidar_freq, lground, & + 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) + lidar_freq ! Lidar frequency (nm). Use to change between lidar platforms + logical,intent(in) :: & + lground ! True for ground-based lidar + 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,nlev) :: & + beta_mol, & ! Molecular backscatter coefficient + tau_mol ! Molecular optical depth + ! OUTPUTS (optional) + REAL(WP),optional,intent(out),dimension(npoints,ncolumns) :: & + tautot_S_liq, & ! TOA optical depth for liquid + tautot_S_ice ! TOA optical depth for ice + REAL(WP),optional,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 + + ! 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,alpha_part,tau_part + real(wp) :: Cmol,rdiffm + logical :: lparasol,lphaseoptics + INTEGER :: i,k,icol,zi,zf,zinc,zoffset + + ! Local data + REAL(WP),PARAMETER :: rhoice = 0.5e+03 ! Density of ice (kg/m3) + REAL(WP),PARAMETER :: Cmol_532nm = 6.2446e-32 ! Wavelength dependent + REAL(WP),PARAMETER :: Cmol_355nm = 3.2662e-31! Wavelength dependent + REAL(WP),PARAMETER :: rdiffm_532nm = 0.7_wp ! Multiple scattering correction parameter + REAL(WP),PARAMETER :: rdiffm_355nm = 0.6_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/) + ! ############################################################################## + + ! Which LIDAR frequency are we using? + if (lidar_freq .eq. 355) then + Cmol = Cmol_355nm + rdiffm = rdiffm_355nm + endif + if (lidar_freq .eq. 532) then + Cmol = Cmol_532nm + rdiffm = rdiffm_532nm + endif + + ! Do we need to generate optical inputs for Parasol simulator? + lparasol = .false. + if (present(tautot_S_liq) .and. present(tautot_S_ice)) lparasol = .true. + + ! Are optical-depths and backscatter coefficients for ice and liquid requested? + lphaseoptics=.false. + if (present(betatot_ice) .and. present(betatot_liq) .and. present(tautot_liq) .and. & + present(tautot_ice)) lphaseoptics=.true. + + ! Is this lidar spaceborne (default) or ground-based (lground=.true.)? + zi = 2 + zf = nlev + zinc = 1 + zoffset = -1 + if (lground) then + zi = nlev-1 + zf = 1 + zinc = -1 + zoffset = 1 + endif + + ! 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 = zi,zf,zinc + tau_mol(1:npoints,k) = tau_mol(1:npoints,k) + tau_mol(1:npoints,k+zoffset) + 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) + if (lphaseoptics) then + 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) + endif + + ! ############################################################################## + ! *) 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 + + ! Initialize (if necessary) + if (lparasol) then + tautot_S_liq(1:npoints,1:ncolumns) = 0._wp + tautot_S_ice(1:npoints,1:ncolumns) = 0._wp + endif + + ! 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,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,1:nlev,i) = 0._wp + endwhere + enddo + + ! Optical thicknes + tau_part(1:npoints,1:nlev,1:npart) = rdiffm * alpha_part(1:npoints,1:nlev,1:npart) + do i = 1, npart + ! Optical thickness of each layer (particles) + tau_part(1:npoints,1:nlev,i) = tau_part(1:npoints,1:nlev,i) & + & * (zheight(1:npoints,1:nlev)-zheight(1:npoints,2:nlev+1) ) + ! Optical thickness from TOA to layer k (particles) + do k=zi,zf,zinc + tau_part(1:npoints,k,i) = tau_part(1:npoints,k,i) + tau_part(1:npoints,k+zoffset,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,1:nlev,i) + tautot(1:npoints,icol,1:nlev) = tautot(1:npoints,icol,1:nlev) + & + tau_part(1:npoints,1:nlev,i) + ENDDO + + ! ############################################################################## + ! Beta and optical thickness (liquid/ice) + ! ############################################################################## + if (lphaseoptics) then + ! 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,1:nlev,INDX_LSICE)+ & + kp_part(1:npoints,1:nlev,INDX_CVICE)*alpha_part(1:npoints,1:nlev,INDX_CVICE) + tautot_ice(1:npoints,icol,1:nlev) = tautot_ice(1:npoints,icol,1:nlev) + & + tau_part(1:npoints,1:nlev,INDX_LSICE) + & + tau_part(1:npoints,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,1:nlev,INDX_LSLIQ)+ & + kp_part(1:npoints,1:nlev,INDX_CVLIQ)*alpha_part(1:npoints,1:nlev,INDX_CVLIQ) + tautot_liq(1:npoints,icol,1:nlev) = tautot_liq(1:npoints,icol,1:nlev) + & + tau_part(1:npoints,1:nlev,INDX_LSLIQ) + & + tau_part(1:npoints,1:nlev,INDX_CVLIQ) + endif + + ! ############################################################################## + ! Optical depths used by the PARASOL simulator + ! ############################################################################## + if (lparasol) then + tautot_S_liq(:,icol) = tau_part(:,nlev,1)+tau_part(:,nlev,3) + tautot_S_ice(:,icol) = tau_part(:,nlev,2)+tau_part(:,nlev,4) + endif + enddo + + end subroutine lidar_optics + +end module cosp_optics Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_parasol_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_parasol_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_parasol_interface.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_phys_constants.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_phys_constants.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_phys_constants.f90 (revision 5900) @@ -0,0 +1,65 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_stats.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_stats.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_stats.f90 (revision 5900) @@ -0,0 +1,307 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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, radar_tcc, radar_tcc2) + ! 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, & ! + radar_tcc, & ! + radar_tcc2 ! + + ! 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,flag_radarcld,flag_radarcld_no1km,j_1km + + lidar_only_freq_cloud = 0._wp + tcc = 0._wp + radar_tcc = 0._wp + radar_tcc2 = 0._wp + do pr=1,Npoints + do i=1,Ncolumns + flag_sat = 0 + flag_cld = 0 + flag_radarcld = 0 !+JEK + flag_radarcld_no1km=0 !+JEK + ! look for j_1km from bottom to top + j = 1 + do while (Ze_tot(pr,i,j) .eq. R_GROUND) + j = j+1 + enddo + j_1km = j+1 !this is the vertical index of 1km above surface + + 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 + flag_radarcld=1 + if (j .gt. j_1km) flag_radarcld_no1km=1 + endif + enddo !levels + if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1._wp + if (flag_radarcld .eq. 1) radar_tcc(pr)=radar_tcc(pr)+1. + if (flag_radarcld_no1km .eq. 1) radar_tcc2(pr)=radar_tcc2(pr)+1. + enddo !columns + enddo !points + lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns + tcc=tcc/Ncolumns + radar_tcc=radar_tcc/Ncolumns + radar_tcc2=radar_tcc2/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 + where(radar_tcc /= R_UNDEF) radar_tcc = radar_tcc*100._wp + where(radar_tcc2 /= R_UNDEF) radar_tcc2 = radar_tcc2*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/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_utils.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_utils.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/cosp_utils.f90 (revision 5900) @@ -0,0 +1,105 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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 + + real(wp) :: seuil + + if (ok_debug_cosp) then + seuil=1.e-15 + else + seuil=0.0 + endif + + + + 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 + if ((reff(i,j,k) <= 0._wp).and.(flux(i,k) > seuil)) 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 + +!Test Artem MxRatio +!print '(a8, i5, i8, i8, f10.2, f10.2, f10.2, f10.2, f10.2)',& +!'MxRatio ', k, j, i, rho, p(i,k), T(i,k), flux(i,k), mxratio(i,j,k) + + enddo + enddo + enddo + endif +END SUBROUTINE COSP_PRECIP_MXRATIO + + +END MODULE MOD_COSP_UTILS Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/icarus.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/icarus.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/icarus.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/lidar_simulator.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lidar_simulator.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lidar_simulator.f90 (revision 5900) @@ -0,0 +1,1561 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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 +! +! Mar 2018 - R. Guzman - Added OPAQ subroutines +! References OPAQ: +! +! Guzman et al. (2017): Direct atmosphere opacity observations from CALIPSO provide +! new constraints on cloud-radiation interactions. JGR-Atmospheres, DOI: 10.1002/2016JD025946 +! Vaillant de Guelis et al. (2017a): The link between outgoing longwave radiation and +! the altitude at which a spaceborne lidar beam is fully attenuated. AMT, 10, 4659-4685, +! https://doi.org/10.5194/amt-10-4659-2017 +! +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +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,vgrid_z,atlid_histBsct, & + grLidar532_histBsct,S_CLD_ATLID,S_ATT_ATLID,S_CLD_ATT_ATLID + 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, lground, beta_mol, tau_mol, & + betatot, tautot, pmol, pnorm, betatot_ice, tautot_ice, betatot_liq, tautot_liq, & + pnorm_perp_tot) + + ! INPUTS + INTEGER,intent(in) :: & + npoints, & ! Number of gridpoints + ncolumns, & ! Number of subcolumns + nlev ! Number of levels + logical,intent(in) :: & + lground ! True for ground-based lidar simulator + 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 + ! Optional Inputs + REAL(WP),intent(in),dimension(npoints,ncolumns,nlev),optional :: & + 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) + ! Optional outputs + REAL(WP),intent(out),dimension(npoints,ncolumns,nlev),optional :: & + pnorm_perp_tot ! Perpendicular lidar backscattered signal power + + ! LOCAL VARIABLES + INTEGER :: k,icol,zi,zf,zinc + logical :: lphaseoptics + 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 + + ! Phase optics? + lphaseoptics=.false. + if (present(betatot_ice) .and. present(betatot_liq) .and. present(tautot_liq) .and. & + present(tautot_ice)) lphaseoptics=.true. + + ! Is this lidar spaceborne (default) or ground-based? + if (lground) then + zi = nlev + zf = 1 + zinc = -1 + else + zi = 1 + zf = nlev + zinc = 1 + endif + + ! #################################################################################### + ! *) Molecular signal + ! #################################################################################### + call cmp_backsignal(nlev,npoints,beta_mol(1:npoints,zi:zf:zinc),& + tau_mol(1:npoints,zi:zf:zinc),pmol(1:npoints,zi:zf:zinc)) + + ! #################################################################################### + ! PLANE PARRALLEL FIELDS + ! #################################################################################### + do icol=1,ncolumns + ! ################################################################################# + ! *) Total Backscatter signal + ! ################################################################################# + call cmp_backsignal(nlev,npoints,betatot(1:npoints,icol,zi:zf:zinc),& + tautot(1:npoints,icol,zi:zf:zinc),pnorm(1:npoints,icol,zi:zf:zinc)) + + ! ################################################################################# + ! *) Ice/Liq Backscatter signal + ! ################################################################################# + if (lphaseoptics) then + ! Computation of the ice and liquid lidar backscattered signal (ATBice and ATBliq) + ! Ice only + call cmp_backsignal(nlev,npoints,betatot_ice(1:npoints,icol,zi:zf:zinc),& + tautot_ice(1:npoints,icol,zi:zf:zinc), pnorm_ice(1:npoints,icol,zi:zf:zinc)) + ! Liquid only + call cmp_backsignal(nlev,npoints,betatot_liq(1:npoints,icol,zi:zf:zinc),& + tautot_liq(1:npoints,icol,zi:zf:zinc), pnorm_liq(1:npoints,icol,zi:zf:zinc)) + endif + enddo + + ! #################################################################################### + ! PERDENDICULAR FIELDS (Only needed if distinguishing by phase (ice/liquid)) + ! #################################################################################### + if (lphaseoptics) then + 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,zi:zf:zinc),& + tautot_ice(1:npoints,icol,zi:zf:zinc),beta_perp_ice(1:npoints,icol,zi:zf:zinc)) + + ! Liquid only + call cmp_beta(nlev,npoints,pnorm_perp_liq(1:npoints,icol,zi:zf:zinc),& + tautot_liq(1:npoints,icol,zi:zf:zinc),beta_perp_liq(1:npoints,icol,zi:zf:zinc)) + + ! ################################################################################# + ! *) 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 if + end subroutine lidar_subcolumn + + ! ###################################################################################### + ! SUBROUTINE lidar_column + ! ###################################################################################### + subroutine lidar_column(npoints, ncol, nlevels, llm, max_bin, ntype, platform, pnorm, pmol, & + pplay, zlev, zlev_half, vgrid_z, ok_lidar_cfad, ncat, cfad2, lidarcld, cldlayer, & + ! Optional stuff below + tmp, pnorm_perp, surfelev, lidarcldphase, lidarcldtype, cldtype, cldtypetemp, & + cldtypemeanz, cldtypemeanzse, cldthinemis, 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) + ntype ! Number of OPAQ products (opaque/thin cloud + z_opaque) + character(len=*),intent(in) :: & + platform ! Name of platform (e.g. calipso,atlid,grLidar532) + real(wp),intent(in),dimension(npoints,ncol,Nlevels) :: & + pnorm ! Lidar ATB + real(wp),intent(in),dimension(npoints,Nlevels) :: & + pmol, & ! Molecular ATB + pplay ! Pressure on model levels (Pa) + 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 + real(wp),intent(in),dimension(llm) :: & + vgrid_z ! mid-level altitude of the output vertical grid + ! Optional Inputs + real(wp),intent(in),dimension(npoints,ncol,Nlevels),optional :: & + pnorm_perp ! Lidar perpendicular ATB + real(wp),intent(in),dimension(npoints),optional :: & + surfelev ! Surface Elevation (m) + real(wp),intent(in),dimension(npoints,Nlevels),optional :: & + tmp ! Temperature at each 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,max_bin,llm) :: & + cfad2 ! CFADs of SR + ! Optional Outputs + real(wp),intent(out),dimension(npoints,ntype),optional :: & + cldtype, & ! "lidar" OPAQ type covers (opaque/thin cloud + z_opaque) + cldtypetemp ! Opaque and thin clouds + z_opaque temperature + real(wp),intent(out),dimension(npoints,2),optional :: & + cldtypemeanz ! Opaque and thin clouds altitude + real(wp),intent(out),dimension(npoints,3),optional :: & + cldtypemeanzse ! Opaque, thin clouds and z_opaque altitude with respect to SE + real(wp),intent(out),dimension(npoints),optional :: & + cldthinemis ! Thin clouds emissivity computed from SR + real(wp),intent(out),dimension(npoints,llm,nphase),optional :: & + lidarcldphase ! 3D "lidar" phase cloud fraction + real(wp),intent(out),dimension(npoints,llm,ntype+1),optional :: & + lidarcldtype ! 3D "lidar" OPAQ type fraction + real(wp),intent(out),dimension(npoints,40,5),optional :: & + lidarcldtmp ! 3D "lidar" phase cloud fraction as a function of temp + real(wp),intent(out),dimension(npoints,ncat,nphase),optional :: & + cldlayerphase ! "lidar" phase low mid high cloud fraction + + ! Local Variables + integer :: ic,i,j + logical :: lcalipso,latlid,lgrlidar532 + 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 + real(wp),dimension(SR_BINS+1) :: histBsct + + ! Which lidar platform? + lcalipso = .false. + latlid = .false. + lgrlidar532 = .false. + if (platform .eq. 'calipso') lcalipso=.true. + if (platform .eq. 'atlid') latlid=.true. + if (platform .eq. 'grlidar532') lgrlidar532=.true. + + ! Vertically regrid input data + if (use_vgrid) then + 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)) + if (lcalipso) 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)) + 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 + endif + + ! Initialization (The histogram bins, are set up during initialization and the + ! maximum value is used as the upper bounds.) + if (lcalipso) then + xmax = maxval(calipso_histBsct) + histBsct = calipso_histBsct + endif + if (latlid) then + xmax = maxval(atlid_histBsct) + histBsct = atlid_histBsct + endif + if (lgrlidar532) then + xmax = maxval(grLidar532_histBsct) + histBsct = grLidar532_histBsct + endif + + ! 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 + if (lcalipso) then + ! 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) + + ! Calipso opaque cloud diagnostics + CALL COSP_OPAQ(npoints,ncol,llm,ntype,tmpFlip,x3d,S_att,S_cld,R_UNDEF,lidarcldtype, & + cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,surfelev) + endif + if (latlid) then + CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,llm,ncat,x3d,pnormFlip,pplayFlip, & + S_att_atlid,S_cld_atlid,S_cld_att_atlid,R_UNDEF,lidarcld,cldlayer) + endif + if (lgrLidar532) then + CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,llm,ncat,x3d,pnormFlip,pplayFlip, & + S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer) + endif + 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 + if (lcalipso) then + ! 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) + ! Calipso opaque cloud diagnostics + CALL COSP_OPAQ(npoints,ncol,nlevels,ntype,tmp,x3d,S_att,S_cld,R_UNDEF,lidarcldtype, & + cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z,surfelev) + endif + if (latlid) then + CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,nlevels,ncat,x3d,pnorm,pplay, & + S_att_atlid,S_cld_atlid,S_cld_att_atlid, R_UNDEF,lidarcld,cldlayer) + endif + if (lgrlidar532) then + CALL COSP_CLDFRAC_NOPHASE(npoints,ncol,nlevels,ncat,x3d,pnorm,pplay, & + S_att,S_cld,S_cld_att,R_UNDEF,lidarcld,cldlayer) + endif + 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,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 + if (lcalipso) then + where(cldtype(:,1) /= R_UNDEF) cldtype(:,1) = cldtype(:,1)*100._wp + where(cldtype(:,2) /= R_UNDEF) cldtype(:,2) = cldtype(:,2)*100._wp + where(cldlayerphase /= R_UNDEF) cldlayerphase = cldlayerphase*100._wp + where(lidarcldphase /= R_UNDEF) lidarcldphase = lidarcldphase*100._wp + where(lidarcldtype /= R_UNDEF) lidarcldtype = lidarcldtype*100._wp + where(lidarcldtmp /= R_UNDEF) lidarcldtmp = lidarcldtmp*100._wp + endif + 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 (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 + + 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 + real(wp) :: epsrealwp + + epsrealwp = epsilon(1._wp) + 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. epsrealwp ) + 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)/epsrealwp + 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 + + ! #################################################################################### + ! SUBROUTINE cosp_cldfrac_nophase + ! Conventions: Ncat must be equal to 4 + ! #################################################################################### + SUBROUTINE COSP_CLDFRAC_NOPHASE(Npoints,Ncolumns,Nlevels,Ncat,x,ATB,pplay, & + S_att,S_cld,S_cld_att,undef,lidarcld,cldlayer) + + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels, & ! Number of vertical levels + Ncat ! Number of cloud layer types + 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 + real(wp),intent(in),dimension(Npoints,Nlevels) :: & + pplay ! Pressure + + ! Outputs + 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 + + ! Local variables + integer :: & + ip, k, iz, ic, ncol, nlev, i + real(wp) :: & + p1 + real(wp),dimension(Npoints,Nlevels) :: & + nsub + real(wp),dimension(Npoints,Ncolumns,Ncat) :: & + cldlay,nsublay + real(wp),dimension(Npoints,Ncat) :: & + nsublayer + real(wp),dimension(Npoints,Ncolumns,Nlevels) :: & + cldy, & ! + srok ! + + ! #################################################################################### + ! 1) Initialize + ! #################################################################################### + lidarcld = 0._wp + nsub = 0._wp + cldlay = 0._wp + nsublay = 0._wp + + ! #################################################################################### + ! 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) + ! #################################################################################### + do k=1,Nlevels + do ic = 1, Ncolumns + do ip = 1, Npoints + + 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 + + RETURN + END SUBROUTINE COSP_CLDFRAC_NOPHASE + + ! #################################################################################### + ! SUBROUTINE cosp_opaq + ! Conventions: Ntype must be equal to 3 + ! #################################################################################### + SUBROUTINE COSP_OPAQ(Npoints,Ncolumns,Nlevels,Ntype,tmp,x,S_att,S_cld,undef,lidarcldtype, & + cldtype,cldtypetemp,cldtypemeanz,cldtypemeanzse,cldthinemis,vgrid_z, & + surfelev) + + ! Local parameter + real(wp),parameter :: & + S_att_opaq = 0.06_wp, & ! Fully Attenuated threshold (Guzman et al. 2017, JGR-Atmospheres) + eta = 0.6_wp ! Multiple-scattering factor (Vaillant de Guelis et al. 2017a, AMT) + + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of subcolumns + Nlevels, & ! Number of vertical levels + Ntype ! Number of OPAQ cloud types (opaque, thin clouds and z_opaque) + real(wp),intent(in) :: & + S_att, & ! Fully Attenuated legacy threshold + S_cld, & ! Cloud detection threshold + undef ! Undefined value + real(wp),intent(in),dimension(Nlevels) :: & + vgrid_z ! mid-level vertical profile altitude (subcolumns) + real(wp),intent(in),dimension(Npoints,Ncolumns,Nlevels) :: & + x ! SR profiles (subcolumns) + real(wp),intent(in),dimension(Npoints,Nlevels) :: & + tmp ! Temperature profiles + real(wp),intent(in),dimension(Npoints) :: & + surfelev ! Surface Elevation (SE) + + ! Outputs + real(wp),intent(out),dimension(Npoints,Nlevels,Ntype+1) :: & + lidarcldtype ! 3D OPAQ product fraction (opaque clouds, thin clouds, z_opaque, opacity) + real(wp),intent(out),dimension(Npoints,Ntype) :: & + cldtype, & ! Opaque/thin cloud covers + z_opaque altitude + cldtypetemp ! Opaque and thin clouds + z_opaque temperature + real(wp),intent(out),dimension(Npoints,2) :: & + cldtypemeanz ! Opaque and thin clouds altitude + real(wp),intent(out),dimension(Npoints,3) :: & + cldtypemeanzse ! Opaque, thin clouds and z_opaque altitude with respect to SE + real(wp),intent(out),dimension(Npoints) :: & + cldthinemis ! Thin clouds emissivity + + ! Local variables + integer :: & + ip, k, zopac, ic, iz, z_top, z_base, topcloud + real(wp) :: & + srmean, srcount, trans2, tau_app, tau_vis, tau_ir, cloudemis + real(wp),dimension(Npoints) :: & + count_emis + real(wp),dimension(Npoints,Nlevels) :: & + nsub, nsubopaq + real(wp),dimension(Npoints,Ncolumns,Ntype+1) :: & ! Opaque, thin, z_opaque and all cloud cover + cldlay, nsublay + real(wp),dimension(Npoints,Ntype) :: & + nsublayer + real(wp),dimension(Npoints,Ncolumns,Nlevels) :: & + cldy, & ! + cldyopaq, & ! + srok, & ! + srokopaq ! + + ! #################################################################################### + ! 1) Initialize + ! #################################################################################### + cldtype(:,:) = 0._wp + cldtypetemp(:,:) = 0._wp + cldtypemeanz(:,:) = 0._wp + cldtypemeanzse(:,:) = 0._wp + cldthinemis(:) = 0._wp + count_emis(:) = 0._wp + lidarcldtype(:,:,:) = 0._wp + nsub = 0._wp + nsubopaq = 0._wp + cldlay = 0._wp + nsublay = 0._wp + nsublayer = 0._wp + + ! #################################################################################### + ! 2) Cloud detection and Fully attenuated layer 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 + ! Fully attenuated layer detection at subgrid-scale: + where ( (x(:,:,k) .lt. S_att_opaq) .and. (x(:,:,k) .ge. 0.) .and. (x(:,:,k) .ne. undef) ) !DEBUG + cldyopaq(:,:,k)=1._wp + elsewhere + cldyopaq(:,:,k)=0._wp + endwhere + + + ! Number of usefull sub-column layers: + where ( (x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) ) + srok(:,:,k)=1._wp + elsewhere + srok(:,:,k)=0._wp + endwhere + ! Number of usefull sub-columns layers for z_opaque 3D fraction: + where ( (x(:,:,k) .ge. 0.) .and. (x(:,:,k) .ne. undef) ) !DEBUG + srokopaq(:,:,k)=1._wp + elsewhere + srokopaq(:,:,k)=0._wp + endwhere + enddo + + ! #################################################################################### + ! 3) Grid-box 3D OPAQ product fraction and cloud type cover (opaque/thin) + mean z_opaque + ! #################################################################################### + + do k=1,Nlevels + do ic = 1, Ncolumns + do ip = 1, Npoints + + cldlay(ip,ic,1) = MAX(cldlay(ip,ic,1),cldyopaq(ip,ic,k)) ! Opaque cloud + cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k)) ! All cloud + + nsublay(ip,ic,1) = MAX(nsublay(ip,ic,1),srok(ip,ic,k)) + nsublay(ip,ic,2) = MAX(nsublay(ip,ic,2),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) + nsubopaq(ip,k) = nsubopaq(ip,k) + srokopaq(ip,ic,k) + + enddo + enddo + enddo + +! OPAQ variables + do ic = 1, Ncolumns + do ip = 1, Npoints + + ! Declaring non-opaque cloudy profiles as thin cloud profiles + if ( cldlay(ip,ic,4).gt. 0. .and. cldlay(ip,ic,1) .eq. 0. ) then + cldlay(ip,ic,2) = 1._wp + endif + + ! Filling in 3D and 2D variables + + ! Opaque cloud profiles + if ( cldlay(ip,ic,1) .eq. 1. ) then + zopac = 0._wp + z_top = 0._wp + do k=1,Nlevels-1 + ! Declaring z_opaque altitude and opaque cloud fraction for 3D and 2D variables + ! From SFC-2-TOA ( actually from vgrid_z(SFC+1) = vgrid_z(Nlevels-1) ) + if ( cldy(ip,ic,Nlevels-k) .eq. 1. .and. zopac .eq. 0. ) then + lidarcldtype(ip,Nlevels-k + 1,3) = lidarcldtype(ip,Nlevels-k + 1,3) + 1._wp + cldlay(ip,ic,3) = vgrid_z(Nlevels-k+1) ! z_opaque altitude + nsublay(ip,ic,3) = 1._wp + zopac = Nlevels-k+1 ! z_opaque vertical index on vgrid_z + endif + if ( cldy(ip,ic,Nlevels-k) .eq. 1. ) then + lidarcldtype(ip,Nlevels-k ,1) = lidarcldtype(ip,Nlevels-k ,1) + 1._wp + z_top = Nlevels-k ! top cloud layer vertical index on vgrid_z + endif + enddo + ! Summing opaque cloud mean temperatures and altitudes + ! as defined in Vaillant de Guelis et al. 2017a, AMT + if (zopac .ne. 0) then + cldtypetemp(ip,1) = cldtypetemp(ip,1) + ( tmp(ip,zopac) + tmp(ip,z_top) )/2. + cldtypetemp(ip,3) = cldtypetemp(ip,3) + tmp(ip,zopac) ! z_opaque + cldtypemeanz(ip,1) = cldtypemeanz(ip,1) + ( vgrid_z(zopac) + vgrid_z(z_top) )/2. + cldtypemeanzse(ip,1) = cldtypemeanzse(ip,1) + (( vgrid_z(zopac) + vgrid_z(z_top) )/2.) - surfelev(ip) + cldtypemeanzse(ip,3) = cldtypemeanzse(ip,3) + ( vgrid_z(zopac) - surfelev(ip) ) + else + cldlay(ip,ic,1) = 0 + endif + endif + + ! Thin cloud profiles + if ( cldlay(ip,ic,2) .eq. 1. ) then + topcloud = 0._wp + z_top = 0._wp + z_base = 0._wp + do k=1,Nlevels + ! Declaring thin cloud fraction for 3D variable + ! From TOA-2-SFC + if ( cldy(ip,ic,k) .eq. 1. .and. topcloud .eq. 1. ) then + lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1._wp + z_base = k ! bottom cloud layer + endif + if ( cldy(ip,ic,k) .eq. 1. .and. topcloud .eq. 0. ) then + lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1._wp + z_top = k ! top cloud layer + z_base = k ! bottom cloud layer + topcloud = 1._wp + endif + enddo + ! Computing mean emissivity using layers below the bottom cloud layer to the surface + srmean = 0._wp + srcount = 0._wp + cloudemis = 0._wp + do k=z_base+1,Nlevels + if ( (x(ip,ic,k) .gt. S_att_opaq) .and. (x(ip,ic,k) .lt. 1.0) .and. (x(ip,ic,k) .ne. undef) ) then + srmean = srmean + x(ip,ic,k) + srcount = srcount + 1. + endif + enddo + ! If clear sky layers exist below bottom cloud layer + if ( srcount .gt. 0. ) then + trans2 = srmean/srcount ! thin cloud transmittance**2 + tau_app = -(log(trans2))/2. ! apparent cloud optical depth + tau_vis = tau_app/eta ! cloud visible optical depth (multiple scat.) + tau_ir = tau_vis/2. ! approx. relation between visible and IR ODs + cloudemis = 1. - exp(-tau_ir) ! no diffusion in IR considered : emis = 1-T + count_emis(ip) = count_emis(ip) + 1. + endif + ! Summing thin cloud mean temperatures and altitudes + ! as defined in Vaillant de Guelis et al. 2017a, AMT + cldtypetemp(ip,2) = cldtypetemp(ip,2) + ( tmp(ip,z_base) + tmp(ip,z_top) )/2. + cldtypemeanz(ip,2) = cldtypemeanz(ip,2) + ( vgrid_z(z_base) + vgrid_z(z_top) )/2. + cldtypemeanzse(ip,2) = cldtypemeanzse(ip,2) + (( vgrid_z(z_base) + vgrid_z(z_top) )/2.) - surfelev(ip) + cldthinemis(ip) = cldthinemis(ip) + cloudemis + endif + + enddo + enddo + + ! 3D cloud types fraction (opaque=1 and thin=2 clouds) + where ( nsub(:,:) .gt. 0. ) + lidarcldtype(:,:,1) = lidarcldtype(:,:,1)/nsub(:,:) + lidarcldtype(:,:,2) = lidarcldtype(:,:,2)/nsub(:,:) + elsewhere + lidarcldtype(:,:,1) = undef + lidarcldtype(:,:,2) = undef + endwhere + ! 3D z_opaque fraction (=3) + where ( nsubopaq(:,:) .gt. 0. ) + lidarcldtype(:,:,3) = lidarcldtype(:,:,3)/nsubopaq(:,:) + elsewhere + lidarcldtype(:,:,3) = undef + lidarcldtype(:,:,4) = undef !declaring undef for opacity as well + endwhere + ! 3D opacity fraction (=4) !Summing z_opaque fraction from TOA(k=1) to SFC(k=Nlevels) + lidarcldtype(:,1,4) = lidarcldtype(:,1,3) !top layer equal to 3D z_opaque fraction + do ip = 1, Npoints + do k = 2, Nlevels + if ( (lidarcldtype(ip,k,3) .ne. undef) .and. (lidarcldtype(ip,k-1,4) .ne. undef) ) then + lidarcldtype(ip,k,4) = lidarcldtype(ip,k,3) + lidarcldtype(ip,k-1,4) + else + lidarcldtype(ip,k,4) = undef + endif + enddo + enddo + + ! Layered cloud types (opaque, thin and z_opaque 2D variables) + + do iz = 1, Ntype + do ic = 1, Ncolumns + cldtype(:,iz) = cldtype(:,iz) + cldlay(:,ic,iz) + nsublayer(:,iz) = nsublayer(:,iz) + nsublay(:,ic,iz) + enddo + enddo + + ! Mean temperature and altitude + where (cldtype(:,1) .gt. 0.) + cldtypetemp(:,1) = cldtypetemp(:,1)/cldtype(:,1) ! opaque cloud temp + cldtypetemp(:,3) = cldtypetemp(:,3)/cldtype(:,1) ! z_opaque + cldtypemeanz(:,1) = cldtypemeanz(:,1)/cldtype(:,1) ! opaque cloud alt + cldtypemeanzse(:,1) = cldtypemeanzse(:,1)/cldtype(:,1) ! opaque cloud alt - SE + cldtypemeanzse(:,3) = cldtypemeanzse(:,3)/cldtype(:,1) ! z_opaque - SE + elsewhere + cldtypetemp(:,1) = undef + cldtypetemp(:,3) = undef + cldtypemeanz(:,1) = undef + cldtypemeanzse(:,1) = undef + cldtypemeanzse(:,3) = undef + endwhere + + where (cldtype(:,2) .gt. 0.) ! thin cloud + cldtypetemp(:,2) = cldtypetemp(:,2)/cldtype(:,2) + cldtypemeanz(:,2) = cldtypemeanz(:,2)/cldtype(:,2) + cldtypemeanzse(:,2) = cldtypemeanzse(:,2)/cldtype(:,2) + elsewhere + cldtypetemp(:,2) = undef + cldtypemeanz(:,2) = undef + cldtypemeanzse(:,2) = undef + endwhere + + ! Mean thin cloud emissivity + where (count_emis(:) .gt. 0.) ! thin cloud + cldthinemis(:) = cldthinemis(:)/count_emis(:) + elsewhere + cldthinemis(:) = undef + endwhere + + where (nsublayer(:,:) .gt. 0.) + cldtype(:,:) = cldtype(:,:)/nsublayer(:,:) + elsewhere + cldtype(:,:) = undef + endwhere + + END SUBROUTINE COSP_OPAQ + +end module mod_lidar_simulator Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_construct_destroy_mod.f90 (revision 5900) @@ -0,0 +1,675 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! Module pour construir et detruire les variables "cospIN", "cospstateIN" et "cospOUT" +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +MODULE LMDZ_COSP_CONSTRUCT_DESTROY_MOD + +use cosp_kinds, only: wp +use mod_cosp, only: cosp_optical_inputs,cosp_column_inputs,cosp_outputs +use lmdz_cosp_read_outputkeys, only: cosp_config + + USE mod_cosp_config, only : R_UNDEF, CLOUDSAT_DBZE_BINS, SR_BINS, PARASOL_NREFL, & + LIDAR_NTEMP, LIDAR_NCAT, LIDAR_NTYPE, & + numMODISReffIceBins,reffICE_binCenters, & + numMODISReffLiqBins, reffLIQ_binCenters, & + numISCCPTauBins,numISCCPPresBins, & + numMISRTauBins,numMISRHgtBins, & + numModisTauBins,numMODISPresBins + + implicit none + +contains + + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE construct_cospIN + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine construct_cospIN(cfg,npoints,ncolumns,nlevels,y) + ! Inputs + integer,intent(in) :: & + npoints, & ! Number of horizontal gridpoints + ncolumns, & ! Number of subcolumns + nlevels ! Number of vertical levels + + type(cosp_config),intent(in) :: & + cfg ! COSP output config (logical keys) + + ! 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%frac_out(npoints, ncolumns,nlevels)) + + if (cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lisccp) then + allocate(y%tau_067(npoints, ncolumns,nlevels),& + y%emiss_11(npoints, ncolumns,nlevels)) + endif + if (cfg%Lcalipso) then + allocate(y%betatot_calipso(npoints, ncolumns,nlevels),& + y%betatot_ice_calipso(npoints, ncolumns,nlevels),& + y%betatot_liq_calipso(npoints, ncolumns,nlevels),& + y%tautot_calipso(npoints, ncolumns,nlevels),& + y%tautot_ice_calipso(npoints, ncolumns,nlevels),& + y%tautot_liq_calipso(npoints, ncolumns,nlevels),& + y%beta_mol_calipso(npoints, nlevels),& + y%tau_mol_calipso(npoints, nlevels),& + y%tautot_S_ice(npoints, ncolumns ),& + y%tautot_S_liq(npoints, ncolumns )) + endif + + if (cfg%LgrLidar532) then + allocate(y%beta_mol_grLidar532(npoints, nlevels),& + y%betatot_grLidar532(npoints, ncolumns,nlevels),& + y%tau_mol_grLidar532(npoints, nlevels),& + y%tautot_grLidar532(npoints, ncolumns,nlevels)) + endif + + if (cfg%Latlid) then + allocate(y%beta_mol_atlid(npoints, nlevels),& + y%betatot_atlid(npoints, ncolumns,nlevels),& + y%tau_mol_atlid(npoints, nlevels),& + y%tautot_atlid(npoints, ncolumns,nlevels)) + endif + + if (cfg%Lcloudsat) then + allocate(y%z_vol_cloudsat(npoints, ncolumns,nlevels),& + y%kr_vol_cloudsat(npoints, ncolumns,nlevels),& + y%g_vol_cloudsat(npoints, ncolumns,nlevels),& + y%fracPrecipIce(npoints, ncolumns)) + endif + if (cfg%Lmodis) then + allocate(y%fracLiq(npoints, ncolumns,nlevels),& + y%asym(npoints, ncolumns,nlevels),& + y%ss_alb(npoints, ncolumns,nlevels)) + endif + + + 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%surfelev(npoints),& + 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(cfg,Npoints,Ncolumns,Nlevels,Nlvgrid,Nchan,x) + ! Inputs + 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 + type(cosp_config),intent(in) :: & + cfg ! COSP output config (logical keys) + + ! Outputs + type(cosp_outputs),intent(out) :: & + x ! COSP output structure + + ! ISCCP simulator outputs + if (cfg%Lboxtauisccp) allocate(x%isccp_boxtau(Npoints,Ncolumns)) + if (cfg%Lboxptopisccp) allocate(x%isccp_boxptop(Npoints,Ncolumns)) + if (cfg%Lclisccp) allocate(x%isccp_fq(Npoints,numISCCPTauBins,numISCCPPresBins)) + if (cfg%Lcltisccp) allocate(x%isccp_totalcldarea(Npoints)) + if (cfg%Lpctisccp) allocate(x%isccp_meanptop(Npoints)) + if (cfg%Ltauisccp) allocate(x%isccp_meantaucld(Npoints)) + if (cfg%Lmeantbisccp) allocate(x%isccp_meantb(Npoints)) + if (cfg%Lmeantbclrisccp) allocate(x%isccp_meantbclr(Npoints)) + if (cfg%Lalbisccp) allocate(x%isccp_meanalbedocld(Npoints)) + + ! MISR simulator + if (cfg%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 (cfg%Lcltmodis) allocate(x%modis_Cloud_Fraction_Total_Mean(Npoints)) + if (cfg%Lclwmodis) allocate(x%modis_Cloud_Fraction_Water_Mean(Npoints)) + if (cfg%Lclimodis) allocate(x%modis_Cloud_Fraction_Ice_Mean(Npoints)) + if (cfg%Lclhmodis) allocate(x%modis_Cloud_Fraction_High_Mean(Npoints)) + if (cfg%Lclmmodis) allocate(x%modis_Cloud_Fraction_Mid_Mean(Npoints)) + if (cfg%Lcllmodis) allocate(x%modis_Cloud_Fraction_Low_Mean(Npoints)) + if (cfg%Ltautmodis) allocate(x%modis_Optical_Thickness_Total_Mean(Npoints)) + if (cfg%Ltauwmodis) allocate(x%modis_Optical_Thickness_Water_Mean(Npoints)) + if (cfg%Ltauimodis) allocate(x%modis_Optical_Thickness_Ice_Mean(Npoints)) + if (cfg%Ltautlogmodis) allocate(x%modis_Optical_Thickness_Total_LogMean(Npoints)) + if (cfg%Ltauwlogmodis) allocate(x%modis_Optical_Thickness_Water_LogMean(Npoints)) + if (cfg%Ltauilogmodis) allocate(x%modis_Optical_Thickness_Ice_LogMean(Npoints)) + if (cfg%Lreffclwmodis) allocate(x%modis_Cloud_Particle_Size_Water_Mean(Npoints)) + if (cfg%Lreffclimodis) allocate(x%modis_Cloud_Particle_Size_Ice_Mean(Npoints)) + if (cfg%Lpctmodis) allocate(x%modis_Cloud_Top_Pressure_Total_Mean(Npoints)) + if (cfg%Llwpmodis) allocate(x%modis_Liquid_Water_Path_Mean(Npoints)) + if (cfg%Liwpmodis) allocate(x%modis_Ice_Water_Path_Mean(Npoints)) + if (cfg%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 (cfg%LlidarBetaMol532) allocate(x%calipso_beta_mol(Npoints,Nlevels)) + if (cfg%Latb532) allocate(x%calipso_beta_tot(Npoints,Ncolumns,Nlevels)) + if (cfg%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 (cfg%Lclcalipso) allocate(x%calipso_lidarcld(Npoints,Nlvgrid)) + if (cfg%Lclhcalipso .or. cfg%Lclmcalipso .or. cfg%Lcllcalipso .or. cfg%Lcltcalipso) then + allocate(x%calipso_cldlayer(Npoints,LIDAR_NCAT)) + endif + if (cfg%Lclcalipsoice .or. cfg%Lclcalipsoliq .or. cfg%Lclcalipsoun) then + allocate(x%calipso_lidarcldphase(Npoints,Nlvgrid,6)) + endif + if (cfg%Lclcalipsotmp .or. cfg%Lclcalipsotmpliq .or. cfg%Lclcalipsoice .or. & + cfg%Lclcalipsotmpun .or. cfg%Lclcalipsotmpice) then + allocate(x%calipso_lidarcldtmp(Npoints,LIDAR_NTEMP,5)) + 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 + allocate(x%calipso_cldlayerphase(Npoints,LIDAR_NCAT,6)) + endif + if (cfg%Lclopaquecalipso .or. cfg%Lclthincalipso .or. cfg%Lclzopaquecalipso) then + allocate(x%calipso_cldtype(Npoints,LIDAR_NTYPE)) + endif + if (cfg%Lclopaquetemp .or. cfg%Lclthintemp .or. cfg%Lclzopaquetemp) then + allocate(x%calipso_cldtypetemp(Npoints,LIDAR_NTYPE)) + endif + if (cfg%Lclopaquemeanz .or. cfg%Lclthinmeanz) then + allocate(x%calipso_cldtypemeanz(Npoints,2)) + endif + if (cfg%Lclopaquemeanzse .or. cfg%Lclthinmeanzse .or. cfg%Lclzopaquecalipsose) then + allocate(x%calipso_cldtypemeanzse(Npoints,3)) + endif + if (cfg%Lclthinemis) then + allocate(x%calipso_cldthinemis(Npoints)) + endif + if (cfg%Lclcalipsoopaque .or. cfg%Lclcalipsothin .or. cfg%Lclcalipsozopaque .or. & + cfg%Lclcalipsoopacity) then + allocate(x%calipso_lidarcldtype(Npoints,Nlvgrid,LIDAR_NTYPE+1)) + 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 (cfg%LlidarBetaMol532 .or. cfg%Latb532 .or. cfg%LcfadLidarsr532 .or. cfg%Lclcalipso .or. & + cfg%Lclcalipsoice .or. cfg%Lclcalipsoliq .or. cfg%Lclcalipsoun .or. cfg%Lclcalipso2 .or. & + cfg%Lclhcalipso .or. cfg%Lclmcalipso .or. cfg%Lcllcalipso .or. cfg%Lcltcalipso .or. & + cfg%Lclcalipsotmp .or. cfg%Lclcalipsoice .or. cfg%Lclcalipsotmpun .or. & + cfg%Lclcalipsotmpliq .or. 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 + allocate(x%calipso_tau_tot(Npoints,Ncolumns,Nlevels)) + allocate(x%calipso_temp_tot(Npoints,Nlevels)) + endif + + ! GROUND LIDAR @ 532NM simulator + if (cfg%LlidarBetaMol532gr) allocate(x%grLidar532_beta_mol(Npoints,Nlevels)) + if (cfg%Latb532gr) allocate(x%grLidar532_beta_tot(Npoints,Ncolumns,Nlevels)) + if (cfg%LcfadLidarsr532gr) then + allocate(x%grLidar532_srbval(SR_BINS+1)) + allocate(x%grLidar532_cfad_sr(Npoints,SR_BINS,Nlvgrid)) + endif + if (cfg%LclgrLidar532) allocate(x%grLidar532_lidarcld(Npoints,Nlvgrid)) + if (cfg%LclhgrLidar532 .or. cfg%LclmgrLidar532 .or. cfg%LcllgrLidar532 .or. cfg%LcltgrLidar532) then + allocate(x%grLidar532_cldlayer(Npoints,LIDAR_NCAT)) + endif + + ! ATLID simulator + if (cfg%LlidarBetaMol355) allocate(x%atlid_beta_mol(Npoints,Nlevels)) + if (cfg%Latb355) allocate(x%atlid_beta_tot(Npoints,Ncolumns,Nlevels)) + if (cfg%LcfadLidarsr355) then + allocate(x%atlid_srbval(SR_BINS+1)) + allocate(x%atlid_cfad_sr(Npoints,SR_BINS,Nlvgrid)) + endif + if (cfg%Lclatlid) allocate(x%atlid_lidarcld(Npoints,Nlvgrid)) + if (cfg%Lclhatlid .or. cfg%Lclmatlid .or. cfg%Lcllatlid .or. cfg%Lcltatlid) then + allocate(x%atlid_cldlayer(Npoints,LIDAR_NCAT)) + endif + + ! PARASOL + if (cfg%Lparasolrefl) then + allocate(x%parasolPix_refl(Npoints,Ncolumns,PARASOL_NREFL)) + allocate(x%parasolGrid_refl(Npoints,PARASOL_NREFL)) + endif + + ! Cloudsat simulator + if (cfg%Ldbze94) allocate(x%cloudsat_Ze_tot(Npoints,Ncolumns,Nlevels)) + if (cfg%LcfadDbze94) allocate(x%cloudsat_cfad_ze(Npoints,cloudsat_DBZE_BINS,Nlvgrid)) + if (cfg%Lptradarflag0 .or. cfg%Lptradarflag1 .or. cfg%Lptradarflag2 .or. cfg%Lptradarflag3 .or. & + cfg%Lptradarflag4 .or. cfg%Lptradarflag5 .or. cfg%Lptradarflag6 .or. cfg%Lptradarflag7 .or. & + cfg%Lptradarflag8 .or. cfg%Lptradarflag9) then + allocate(x%cloudsat_precip_cover(Npoints,cloudsat_DBZE_BINS)) + endif + if (cfg%Lradarpia) allocate(x%cloudsat_pia(Npoints)) + + ! Combined CALIPSO/CLOUDSAT fields + if (cfg%Lclcalipso2) allocate(x%lidar_only_freq_cloud(Npoints,Nlvgrid)) + if (cfg%Lcltlidarradar) allocate(x%radar_lidar_tcc(Npoints)) + if (cfg%Lcloudsat_tcc) allocate(x%cloudsat_tcc(Npoints)) + if (cfg%Lcloudsat_tcc2) allocate(x%cloudsat_tcc2(Npoints)) + + ! RTTOV + if (cfg%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_calipso)) deallocate(y%beta_mol_calipso) + if (allocated(y%tau_mol_calipso)) deallocate(y%tau_mol_calipso) + if (allocated(y%betatot_calipso)) deallocate(y%betatot_calipso) + if (allocated(y%betatot_ice_calipso)) deallocate(y%betatot_ice_calipso) + if (allocated(y%betatot_liq_calipso)) deallocate(y%betatot_liq_calipso) + if (allocated(y%tautot_calipso)) deallocate(y%tautot_calipso) + if (allocated(y%tautot_ice_calipso)) deallocate(y%tautot_ice_calipso) + if (allocated(y%tautot_liq_calipso)) deallocate(y%tautot_liq_calipso) + 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) + if (allocated(y%beta_mol_grLidar532)) deallocate(y%beta_mol_grLidar532) + if (allocated(y%betatot_grLidar532)) deallocate(y%betatot_grLidar532) + if (allocated(y%tau_mol_grLidar532)) deallocate(y%tau_mol_grLidar532) + if (allocated(y%tautot_grLidar532)) deallocate(y%tautot_grLidar532) + if (allocated(y%beta_mol_atlid)) deallocate(y%beta_mol_atlid) + if (allocated(y%betatot_atlid)) deallocate(y%betatot_atlid) + if (allocated(y%tau_mol_atlid)) deallocate(y%tau_mol_atlid) + if (allocated(y%tautot_atlid)) deallocate(y%tautot_atlid) + if (allocated(y%fracPrecipIce)) deallocate(y%fracPrecipIce) + + 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) + if (allocated(y%surfelev)) deallocate(y%surfelev) + + 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_lidarcldtype)) then + deallocate(y%calipso_lidarcldtype) + nullify(y%calipso_lidarcldtype) + 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_cldtype)) then + deallocate(y%calipso_cldtype) + nullify(y%calipso_cldtype) + endif + if (associated(y%calipso_cldtypetemp)) then + deallocate(y%calipso_cldtypetemp) + nullify(y%calipso_cldtypetemp) + endif + if (associated(y%calipso_cldtypemeanz)) then + deallocate(y%calipso_cldtypemeanz) + nullify(y%calipso_cldtypemeanz) + endif + if (associated(y%calipso_cldtypemeanzse)) then + deallocate(y%calipso_cldtypemeanzse) + nullify(y%calipso_cldtypemeanzse) + endif + if (associated(y%calipso_cldthinemis)) then + deallocate(y%calipso_cldthinemis) + nullify(y%calipso_cldthinemis) + 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%grLidar532_beta_mol)) then + deallocate(y%grLidar532_beta_mol) + nullify(y%grLidar532_beta_mol) + endif + if (associated(y%grLidar532_beta_tot)) then + deallocate(y%grLidar532_beta_tot) + nullify(y%grLidar532_beta_tot) + endif + if (associated(y%grLidar532_cldlayer)) then + deallocate(y%grLidar532_cldlayer) + nullify(y%grLidar532_cldlayer) + endif + if (associated(y%grLidar532_lidarcld)) then + deallocate(y%grLidar532_lidarcld) + nullify(y%grLidar532_lidarcld) + endif + if (associated(y%grLidar532_cfad_sr)) then + deallocate(y%grLidar532_cfad_sr) + nullify(y%grLidar532_cfad_sr) + endif + if (associated(y%grLidar532_srbval)) then + deallocate(y%grLidar532_srbval) + nullify(y%grLidar532_srbval) + endif + if (associated(y%atlid_beta_mol)) then + deallocate(y%atlid_beta_mol) + nullify(y%atlid_beta_mol) + endif + if (associated(y%atlid_beta_tot)) then + deallocate(y%atlid_beta_tot) + nullify(y%atlid_beta_tot) + endif + if (associated(y%atlid_cldlayer)) then + deallocate(y%atlid_cldlayer) + nullify(y%atlid_cldlayer) + endif + if (associated(y%atlid_lidarcld)) then + deallocate(y%atlid_lidarcld) + nullify(y%atlid_lidarcld) + endif + if (associated(y%atlid_cfad_sr)) then + deallocate(y%atlid_cfad_sr) + nullify(y%atlid_cfad_sr) + endif + if (associated(y%atlid_srbval)) then + deallocate(y%atlid_srbval) + nullify(y%atlid_srbval) + 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%cloudsat_precip_cover)) then + deallocate(y%cloudsat_precip_cover) + nullify(y%cloudsat_precip_cover) + endif + if (associated(y%cloudsat_pia)) then + deallocate(y%cloudsat_pia) + nullify(y%cloudsat_pia) + endif + if (associated(y%cloudsat_tcc)) then + deallocate(y%cloudsat_tcc) + nullify(y%cloudsat_tcc) + endif + if (associated(y%cloudsat_tcc2)) then + deallocate(y%cloudsat_tcc2) + nullify(y%cloudsat_tcc2) + endif + if (associated(y%radar_lidar_tcc)) then + deallocate(y%radar_lidar_tcc) + nullify(y%radar_lidar_tcc) + endif + if (associated(y%cloudsat_tcc)) then + deallocate(y%cloudsat_tcc) + nullify(y%cloudsat_tcc) + endif + if (associated(y%cloudsat_tcc2)) then + deallocate(y%cloudsat_tcc2) + nullify(y%cloudsat_tcc2) + 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 LMDZ_COSP_CONSTRUCT_DESTROY_MOD + Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_interface.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_interface.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_interface.f90 (revision 5900) @@ -0,0 +1,571 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! Nouveau code d'interface entre LMDZ et COSPv2 (version 2) +! L'ancienne interface s'appelait "phys_cosp2" et avait ete concue pour COSPv1.4. +! Dans cette nouvelle version de COSP, le code a ete restructure pour optimiser les calculs +! des differents simulateurs et pour proposer de nouvelles fonctionnalites (par exemple, +! intervenir sur les profils sous-maille, ou subcolumns, donnes en entre a COSP afin que +! leur definition soit coherente avec les parametrisations du modele hote). +! Cette version de COSP propose aussi de nombreux nouveaux diagnostics, notamment pour +! le simulateur lidar (diagnostics CALIPSO-OPAQ, lidar sol 532nm et lidar ATLID 355nm). +! +! Interface reecrite par R.Guzman (01/2019), a partir de l'interface initiale concue +! et ecrite par A.Idelkadi +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! subroutine phys_cosp2( itap,dtime,freq_cosp, & + subroutine lmdz_cosp_interface(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 +! overlaplmdz, !Type Overlap venant de LMDZ +! 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 micron) +! 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 relative +! 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 -------------- +! La liste complete des diagnostics de sortie (observables simulees) que l'on peut +! avoir avec COSPv2 se trouve au debut du fichier : cosp_read_otputkeys.F90 + + +!!! Modules specifiques a l'interface LMDZ-COSP + use mod_phys_lmdz_para + use mod_grid_phy_lmdz + use ioipsl + use iophy + use lmdz_xios, ONLY : using_xios + use lmdz_cosp_output_mod + use lmdz_cosp_output_write_mod + use lmdz_cosp_read_outputkeys + use lmdz_cosp_subsample_and_optics_mod, only : subsample_and_optics + use lmdz_cosp_construct_destroy_mod + +!!! Modules faisant partie du code source de COSPv2 + use cosp_kinds, only: wp + use MOD_COSP_CONFIG, only: N_HYDRO,RTTOV_MAX_CHANNELS, & + niv_sorties, vgrid_z_in + use mod_quickbeam_optics, only: size_distribution,hydro_class_init, & + quickbeam_optics_init + use quickbeam, only: radar_cfg + use mod_cosp, only: cosp_init,cosp_optical_inputs, & + cosp_column_inputs,cosp_outputs, & + cosp_simulator + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! Declaration des variables +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + IMPLICIT NONE + + ! Local variables + character(len=64),PARAMETER :: cosp_input_nl = 'cospv2_input_nl.txt' + character(len=64),PARAMETER :: cosp_output_nl = 'cospv2_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 model vertical levels + integer :: Nptslmdz, Nlevlmdz ! Nb de points issus de physiq.F + integer, save :: Npoints_it ! Max number of gridpoints to be + ! processed in one iteration + type(cosp_config), save :: cfg ! Variable qui contient les cles + ! logiques des simulateurs et des + ! diagnostics, definie dans: + ! lmdz_cosp_construct_destroy_mod +!$OMP THREADPRIVATE(cfg) + + integer :: t0, t1, count_rate, count_max + real(wp), save :: cloudsat_radar_freq, cloudsat_k2, rttov_ZenAng, co2, & + ch4, n2o, co, emsfc_lw +!$OMP THREADPRIVATE(emsfc_lw) + + integer, dimension(RTTOV_MAX_CHANNELS), save :: rttov_Channels + real(wp), dimension(RTTOV_MAX_CHANNELS), save :: rttov_Surfem + integer, save :: surface_radar, use_mie_tables, & + cloudsat_use_gas_abs, cloudsat_do_ray, & + melt_lay + integer, save :: lidar_ice_type + integer, save :: rttov_platform, rttov_satellite, & + rttov_Instrument, rttov_Nchannels + logical, save :: use_vgrid_in, csat_vgrid_in, & + use_precipitation_fluxes + +! Declaration necessaires pour les sorties IOIPSL + 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) + + integer, save :: cosp_init_flag = 0 +!$OMP THREADPRIVATE(cosp_init_flag) + + +!----------------------------- Input variables from LMDZ-GCM ------------------------------- + integer :: overlaplmdz ! overlap type: 1=max, + ! 2=rand, 3=max/rand + real, dimension(Nptslmdz,Nlevlmdz) :: 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, dtau_c, dem_c, 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(Nptslmdz) :: land ! variables intermediaire pour masque TerLic + 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 + + + ! ###################################################################################### + ! Declarations specific to COSP2 + ! ###################################################################################### + + ! Local variables + 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(size_distribution), save :: sd ! Hydrometeor description +!$OMP THREADPRIVATE(sd) + type(radar_cfg), save :: rcfg_cloudsat ! Radar configuration +!$OMP THREADPRIVATE(rcfg_cloudsat) + real, dimension(Nptslmdz,Nlevlmdz,N_HYDRO) :: Reff ! Liquid and Ice particles + ! effective radius + type(cosp_outputs) :: cospOUT ! COSP simulator outputs + 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 + character(len=64), save :: cloudsat_micro_scheme + + ! 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 + +! Parametres qui sont lus a partir du fichier "cosp_input_nl.txt" + namelist/COSP_INPUT/overlap, isccp_topheight, isccp_topheight_direction, & + npoints_it, ncolumns, use_vgrid_in, csat_vgrid_in, & + cloudsat_radar_freq, surface_radar, use_mie_tables, & + cloudsat_use_gas_abs, cloudsat_do_ray, melt_lay, cloudsat_k2, & + cloudsat_micro_scheme, lidar_ice_type, use_precipitation_fluxes, & + rttov_platform, rttov_satellite, rttov_Instrument, rttov_Nchannels, & + rttov_Channels, rttov_Surfem, rttov_ZenAng, co2, ch4, n2o, co + +!------------------------ Fin declaration des variables ------------------------ + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 1) Lecture du fichier "cosp_input_nl.txt", parametres d'entree pour COSP +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +print*,'Entree lmdz_cosp_interface' !phys_cosp2' +if (debut_cosp) then + NPoints=Nptslmdz + Nlevels=Nlevlmdz +! Surface emissivity + emsfc_lw = 1. + +! 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_in) + CALL bcast(csat_vgrid_in) + CALL bcast(cloudsat_radar_freq) + CALL bcast(surface_radar) + CALL bcast(cloudsat_use_gas_abs) + CALL bcast(cloudsat_do_ray) + CALL bcast(cloudsat_k2) + CALL bcast(lidar_ice_type) + CALL bcast(use_precipitation_fluxes) + CALL bcast(rttov_platform) + CALL bcast(rttov_satellite) + CALL bcast(rttov_Instrument) + CALL bcast(rttov_Nchannels) + CALL bcast(rttov_Channels) + CALL bcast(rttov_Surfem) + CALL bcast(rttov_ZenAng) + CALL bcast(co2) + CALL bcast(ch4) + CALL bcast(n2o) + CALL bcast(co) + CALL bcast(cloudsat_micro_scheme) + + print*,'ok read cosp_input_nl' + +! Clefs Outputs initialisation + IF (using_xios) THEN + call cosp_outputkeys_init(cfg) + ELSE + call read_cosp_output_nl(itap,cosp_output_nl,cfg) + ENDIF + + print*,' Cles des differents simulateurs cosp a itap :',itap + print*,'cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, & + cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov', & + cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, & + cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov + + if (overlaplmdz.ne.overlap) then + print*,'Attention overlaplmdz different de overlap lu dans namelist ' + endif + + IF (using_xios) THEN + print*,'On passe par using_xios' + ELSE + if (cosp_init_flag .eq. 0) then + + ! Initialize the distributional parameters for hydrometeors in radar simulator. + ! In COSPv1.4, this was declared in cosp_defs.f. + if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment') then + ldouble = .true. + lsingle = .false. + endif + call hydro_class_init(lsingle,ldouble,sd) + call quickbeam_optics_init() + + print*,' just before call COSP_INIT, cosp_init_flag =', cosp_init_flag + call COSP_INIT(cfg%Lisccp, cfg%Lmodis, cfg%Lmisr, cfg%Lcloudsat, cfg%Lcalipso, & + cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, cfg%Lrttov, & + cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs, & + cloudsat_do_ray, isccp_topheight, isccp_topheight_direction, & + surface_radar, rcfg_cloudsat, use_vgrid_in, csat_vgrid_in, & + niv_sorties, Nlevels, cloudsat_micro_scheme) + cosp_init_flag = 1 + print*,' just after call COSP_INIT, cosp_init_flag =', cosp_init_flag + endif + 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.ge.1).and.(first_write))then + IF (using_xios) call read_xiosfieldactive(cfg) + first_write=.false. + +if (cosp_init_flag .eq. 0) then + + ! Initialize the distributional parameters for hydrometeors in radar simulator. + ! In COSPv1.4, this was declared in cosp_defs.f. + if (cloudsat_micro_scheme == 'MMF_v3.5_two_moment') then + ldouble = .true. + lsingle = .false. + endif + call hydro_class_init(lsingle,ldouble,sd) + call quickbeam_optics_init() + + print*,' just before call COSP_INIT, cosp_init_flag =', cosp_init_flag + call COSP_INIT(cfg%Lisccp, cfg%Lmodis, cfg%Lmisr, cfg%Lcloudsat, cfg%Lcalipso, & + cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, cfg%Lrttov, & + cloudsat_radar_freq, cloudsat_k2, cloudsat_use_gas_abs, & + cloudsat_do_ray, isccp_topheight, isccp_topheight_direction, & + surface_radar, rcfg_cloudsat, use_vgrid_in, csat_vgrid_in, & + niv_sorties, Nlevels, cloudsat_micro_scheme) + cosp_init_flag = 1 + print*,' just after call COSP_INIT, cosp_init_flag =', cosp_init_flag +endif ! cosp_init_flag + + +print*,' Cles des differents simulateurs cosp a itap :',itap +print*,'cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, & + cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov', & + cfg%Lcloudsat, cfg%Lcalipso, cfg%LgrLidar532, cfg%Latlid, cfg%Lparasol, & + cfg%Lisccp, cfg%Lmisr, cfg%Lmodis, cfg%Lrttov + + endif !(itap.gt.1).and.(first_write) + + time_bnds(1) = dtime-dtime/2. + time_bnds(2) = dtime+dtime/2. + + d_time_bnds=time_bnds + d_dtime=dtime + +!------------------------- Fin initialisation de COSP -------------------------- + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 3) Calculs des champs d'entree COSP a partir des variables LMDZ +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! 0) Create ptop/ztop for gbx%pf and gbx%zlev are for the the interface, + ! also reverse CAM height/pressure values for input into CSOP + ! CAM state%pint from top to surface, COSP wants surface to top. + +! 0) Altitudes du modele calculees a partir de la variable geopotentiel phi et phis + 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 + +! 1) Quantite de nuages (couverture?), convectif (=0) et total + cca = 0._wp ! convective_cloud_amount (1) + tca = tca ! total_cloud_amount (1) + +! 2) Humidite relative est donnee tel quel (variable rh) + +! 3) Masque terre/mer a partir de la variable fracTerLic + do ip = 1, Npoints + if (fracTerLic(ip).ge.0.5) then + land(ip) = 1. + else + land(ip) = 0. + endif + enddo + + +! 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 + + ! ISCCP simulator + dtau_c = 0. + dem_c = 0. + +! note: reff_cosp dimensions should be same as cosp (reff_cosp has 9 hydrometeor dimension) + Reff(1:Npoints,1:Nlevels,1:N_HYDRO) = 0. + Reff(:,:,I_LSCLIQ) = ref_liq*1e-6 + Reff(:,:,I_LSCICE) = ref_ice*1e-6 + Reff(:,:,I_CVCLIQ) = ref_liq*1e-6 + Reff(:,:,I_CVCICE) = ref_ice*1e-6 + + +if (cosp_init_flag .eq. 1) then ! cosp_init_flag = 1 + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 4a) On construit la variable cospOUT qui contient tous les diagnostics de sortie. +! Elle sera remplie lors de l'appel du simulateur COSP +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + call construct_cosp_outputs(cfg,Npoints,Ncolumns,Nlevels,niv_sorties,0,cospOUT) + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 4b) On construit la variable cospstateIN que l'on va remplir avec les champs LMDZ +! Les champ verticaux doivent etre donnes a l'envers, c-a-d : (Nlevels:1) = (TOA:SFC) +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + call construct_cospstateIN(Npoints,Nlevels,0,cospstateIN) + + cospstateIN%lat = lat(1:Npoints) + cospstateIN%lon = lon(1:Npoints) + cospstateIN%at = t(1:Npoints,Nlevels:1:-1) + cospstateIN%qv = sh(1:Npoints,Nlevels:1:-1) + cospstateIN%o3 = mr_ozone(1:Npoints,Nlevels:1:-1) + cospstateIN%sunlit = sunlit(1:Npoints) + cospstateIN%skt = skt(1:Npoints) + cospstateIN%land = land(1:Npoints) + cospstateIN%surfelev = zlev_half(1:Npoints,1) + cospstateIN%pfull = p(1:Npoints,Nlevels:1:-1) + cospstateIN%phalf(1:Npoints,1) = 0._wp + cospstateIN%phalf(1:Npoints,2:Nlevels+1) = ph(1:Npoints,Nlevels:1:-1) + cospstateIN%hgt_matrix = zlev(1:Npoints,Nlevels:1:-1) + cospstateIN%hgt_matrix_half(1:Npoints,Nlevels+1) = 0._wp + cospstateIN%hgt_matrix_half(1:Npoints,1:Nlevels) = zlev_half(1:Npoints,Nlevels:1:-1) + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 4c) On construit la variable cospIN qui contient les proprietes optiques subcolumn +! pour COSP. Elle sera essentiellement remplie dans la subroutine subsample_and_optics +! ou sont appeles SCOPS, PREC_SCOPS et les subroutines qui calculent les signaux +! simules pour chaque simulateur actif. +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + call construct_cospIN(cfg,Npoints,Ncolumns,Nlevels,cospIN) + cospIN%emsfc_lw = emsfc_lw + if (cfg%Lcloudsat) cospIN%rcfg_cloudsat = rcfg_cloudsat + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 5) Appel de subsample_and_optics : Les champs verticaux doivent etre donnes a +! l'envers comme pour le remplissage de cospstateIN, c-a-d : (Nlevels:1) = (TOA:SFC) +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + call subsample_and_optics(cfg, Npoints, Nlevels, Ncolumns, N_HYDRO,overlap, & + use_precipitation_fluxes, lidar_ice_type, sd, & + tca(1:Npoints,Nlevels:1:-1), cca(1:Npoints,Nlevels:1:-1), & + fl_lsrain(1:Npoints,Nlevels:1:-1), & + fl_lssnow(1:Npoints,Nlevels:1:-1), & + fl_lsgrpl(1:Npoints,Nlevels:1:-1), & + fl_ccrain(1:Npoints,Nlevels:1:-1), & + fl_ccsnow(1:Npoints,Nlevels:1:-1), & + mr_lsliq(1:Npoints,Nlevels:1:-1), & + mr_lsice(1:Npoints,Nlevels:1:-1), & + mr_ccliq(1:Npoints,Nlevels:1:-1), & + mr_ccice(1:Npoints,Nlevels:1:-1), & + Reff(1:Npoints,Nlevels:1:-1,:), & + dtau_c(1:Npoints,Nlevels:1:-1), & + dtau_s(1:Npoints,Nlevels:1:-1), & + dem_c(1:Npoints,Nlevels:1:-1), & + dem_s(1:Npoints,Nlevels:1:-1), cospstateIN, cospIN) + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 6) On appelle le simulateur COSPv2 +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + print*,'call simulateur' + +cosp_status = COSP_SIMULATOR(cospIN, cospstateIN, cospOUT, 1, Npoints, debug=.false.) + +endif ! cosp_init_flag = 1 + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 7a) Ecriture des sorties 1: on cree d'abord les fichiers NCDF pour ecrire les sorties +! en appelant lmdz_cosp_output_open (lors du premier appel de cette interface pour les +! 2 options d'ecriture), ou sont definis les axes et les caracteristiques +! des fichiers de sortie avec les diagnostics. +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + if (debut_cosp) then + !$OMP MASTER + + print *, ' Open outpts files and define axis' + call lmdz_cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp, & + ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, & + ecrit_mth, ecrit_day, ecrit_hf, use_vgrid_in, & + niv_sorties, vgrid_z_in, zlev(1,:)) + + !$OMP END MASTER + !$OMP BARRIER + debut_cosp=.false. + endif ! debut_cosp + +if (cosp_init_flag .eq. 1) then + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 7b) Ecriture des sorties 2: le remplissage des fichiers de sortie se fait a chaque +! appel de cette interface avec une difference entre les 2 options d'ecriture: +! +! AVEC xios, on commence a remplir les fichiers de sortie a partir du DEUXIEME +! appel de cette interface (lorsque cosp_init_flag = 1). +! +! SANS xios, on commence a remplir les fichiers de sortie a partir du PREMIER +! appel de cette interface (lorsque cosp_init_flag = 1). +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + print *, 'Calling write output' + call lmdz_cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, & + missing_val, cfg, niv_sorties, cospOUT) + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! 8) On libere la memoire allouee lors de cet appel a l'interface +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + call destroy_cospIN(cospIN) + call destroy_cospstateIN(cospstateIN) + call destroy_cosp_outputs(cospOUT) + +endif ! cosp_init_flag = 1 + +end subroutine lmdz_cosp_interface Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_output_mod.F90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_output_mod.F90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_output_mod.F90 (revision 5900) @@ -0,0 +1,516 @@ +! 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 +! +! R.Guzman jan 2019 (mise a jour pour COSPv2) +! On change le nom du module a "lmdz_cosp_output_mod" et celui de la routine a "lmdz_cosp_output_open" +! pour qu'on sache qu'il s'agit d'un module specifique a l'implementation de COSP dans LMDZ +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + MODULE lmdz_cosp_output_mod + + 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 (43) + TYPE(ctrl_outcosp), SAVE :: o_cllcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllcalipso", "CALIPSO Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmcalipso", "CALIPSO Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhcalipso", "CALIPSO High-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltcalipso", "CALIPSO Total Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipso", "CALIPSO Cloud Fraction (532 nm)", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cfadLidarsr532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cfadLidarsr532", "CALIPSO Scattering Ratio CFAD (532 nm)", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_atb532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "atb532", "CALIPSO Attenuated Total Backscatter (532 nm)","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_lidarBetaMol532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "lidarBetaMol532", "CALIPSO 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", "CALIPSO Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsoliq", "CALIPSO Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsoun", "CALIPSO Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmpice", "CALIPSO Ice-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpliq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmpliq", "CALIPSO Liq-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmpun = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmpun", "CALIPSO Undef-Phase Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsotmp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsotmp", "CALIPSO Cloud Fraction", "%", (/ ('', i=1, 3) /)) + + TYPE(ctrl_outcosp), SAVE :: o_clopaquecalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clopaquecalipso", "CALIPSO Opaque Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clthincalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clthincalipso", "CALIPSO Thin Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clzopaquecalipso = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clzopaquecalipso", "CALIPSO mean opacity altitude", "m", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoopaque = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsoopaque", "CALIPSO Opaque profile Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsothin = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsothin", "CALIPSO Thin profile Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsozopaque = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsozopaque", "CALIPSO z_opaque Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clcalipsoopacity = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clcalipsoopacity", "CALIPSO opacity Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clopaquetemp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clopaquetemp", "CALIPSO Opaque Cloud Temperature", "K", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clthintemp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clthintemp", "CALIPSO Thin Cloud Temperature", "K", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clzopaquetemp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clzopaquetemp", "CALIPSO z_opaque Temperature", "K", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clopaquemeanz = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clopaquemeanz", "CALIPSO Opaque Cloud Altitude", "m", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clthinmeanz = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clthinmeanz", "CALIPSO Thin Cloud Altitude", "m", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clthinemis = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clthinemis", "CALIPSO Thin Cloud Emissivity", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clopaquemeanzse = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clopaquemeanzse", "CALIPSO Opaque Cloud Altitude with respect to Surface Elevation", "m", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clthinmeanzse = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clthinmeanzse", "CALIPSO Thin Cloud Altitude with respect to Surface Elevation", "m", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clzopaquecalipsose = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clzopaquecalipsose", "CALIPSO mean opacity Altitude with respect to Surface Elevation", "m", (/ ('', i=1, 3) /)) + +! GROUND LIDAR 532 nm vars (8) + TYPE(ctrl_outcosp), SAVE :: o_cllgrLidar532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllgrLidar532", "GROUND LIDAR 532 nm Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmgrLidar532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmgrLidar532", "GROUND LIDAR 532 nm Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhgrLidar532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhgrLidar532", "GROUND LIDAR 532 nm High-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltgrLidar532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltgrLidar532", "GROUND LIDAR 532 nm Total Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clgrLidar532 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clgrLidar532", "GROUND LIDAR 532 nm Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cfadLidarsr532gr = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cfadLidarsr532gr", "GROUND LIDAR 532 nm Scattering Ratio CFAD", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_atb532gr = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "atb532gr", "GROUND LIDAR 532 nm Attenuated Total Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_lidarBetaMol532gr = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "lidarBetaMol532gr", "GROUND LIDAR 532 nm Molecular Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /)) + +! ATLID vars (8) + TYPE(ctrl_outcosp), SAVE :: o_cllatlid = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cllatlid", "ATLID Low-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clmatlid = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clmatlid", "ATLID Mid-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clhatlid = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clhatlid", "ATLID High-level Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltatlid = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltatlid", "ATLID Total Cloud Fraction", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_clatlid = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clatlid", "ATLID Cloud Fraction (532 nm)", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cfadLidarsr355 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cfadLidarsr355", "ATLID Scattering Ratio CFAD (532 nm)", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_atb355 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "atb355", "ATLID Attenuated Total Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_lidarBetaMol355 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "lidarBetaMol355", "ATLID Molecular Backscatter (532 nm)","m-1 sr-1", (/ ('', i=1, 3) /)) + +! PARASOL vars (2) + TYPE(ctrl_outcosp), SAVE :: o_parasolGrid_refl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "parasolGrid_refl", "PARASOL Reflectance","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_parasolPix_refl = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "parasolPix_refl", "PARASOL Subcolumn Reflectance","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) /)) + + +! Radar CloudSat vars (13) + 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) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag0 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag0", "CloudSat Radar Precipitation frequency flag 0", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag1 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag1", "CloudSat Radar Precipitation frequency flag 1", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag2 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag2", "CloudSat Radar Precipitation frequency flag 2", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag3 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag3", "CloudSat Radar Precipitation frequency flag 3", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag4 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag4", "CloudSat Radar Precipitation frequency flag 4", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag5 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag5", "CloudSat Radar Precipitation frequency flag 5", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag6 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag6", "CloudSat Radar Precipitation frequency flag 6", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag7 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag7", "CloudSat Radar Precipitation frequency flag 7", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag8 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag8", "CloudSat Radar Precipitation frequency flag 8", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_ptradarflag9 = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "ptradarflag9", "CloudSat Radar Precipitation frequency flag 9", "1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_radarpia = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "radarpia", "CloudSat Radar PIA", "1", (/ ('', i=1, 3) /)) + +! CALIPSO + CloudSat vars (4) + 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", "CALIPSO and CloudSat Radar Total Cloud Fraction", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cloudsat_tcc = ctrl_outcosp((/ .TRUE., .TRUE.,.TRUE. /), & + "cloudsat_tcc", "CALIPSO and CloudSat Radar Total Cloud Fraction?", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cloudsat_tcc2 = ctrl_outcosp((/ .TRUE., .TRUE.,.TRUE. /), & + "cloudsat_tcc2", "CALIPSO and CloudSat Radar Total Cloud Fraction?", "%", (/ ('', i=1, 3) /)) + +! ISCCP vars (9) + sunlit (1) +! 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_clisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "clisccp", "Cloud Fraction as Calculated by the ISCCP Simulator","%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_boxtauisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "boxtauisccp", "Optical Depth in Each Column as Calculated by the ISCCP Simulator","1", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_boxptopisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "boxptopisccp", "Cloud Top Pressure in Each Column as Calculated by the ISCCP Simulator","Pa", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_cltisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "cltisccp", "Total Cloud Fraction as Calculated by the ISCCP Simulator", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_pctisccp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "pctisccp", "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((/ .TRUE., .TRUE., .TRUE. /), & + "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((/ .TRUE., .TRUE., .TRUE. /), & + "meantbclrisccp", "Mean clear-sky 10.5 micron brightness temperature as calculated & + by the ISCCP Simulator","K", (/ ('', i=1, 3) /)) + +! MISR simulator var (3) + TYPE(ctrl_outcosp), SAVE :: o_misr_fq = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "misr_fq", "MISR joint-PDF of cloud top pressure and optical depth","%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_misr_meanztop = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "misr_meanztop", "MISR Mean Cloud Top Height","%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_misr_cldarea = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "misr_cldarea", "MISR cloud cover","%", (/ ('', i=1, 3) /)) + +! MODIS simulator vars (20) + 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_modis_ot_vs_ctp = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "modis_ot_vs_ctp", "MODIS joint-PDF of cloud top pressure and optical depth", "%", (/ ('', i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_modis_ot_vs_reffice = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "modis_ot_vs_reffice", "MODIS Joint-PDF of optical-depth and ice particle size", "%", (/ ('',i=1, 3) /)) + TYPE(ctrl_outcosp), SAVE :: o_modis_ot_vs_reffliq = ctrl_outcosp((/ .TRUE., .TRUE.,.TRUE. /), & + "modis_ot_vs_reffliq", "MODIS Joint-PDF of optical-depth and liquid particle size", "%", (/ ('',i=1, 3) /)) + +! Rttovs simulator var (1) + TYPE(ctrl_outcosp), SAVE :: o_tbrttov = ctrl_outcosp((/ .TRUE., .TRUE., .TRUE. /), & + "tbrttov", "Rttovs Cloud Area Fraction", "%", (/ ('', i=1, 3) /)) + +! Scops and others var (1) + 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 lmdz_cosp_output_open(Nlevlmdz, Ncolumns, presnivs, dtime, freq_cosp, & + ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml, & + ecrit_mth, ecrit_day, ecrit_hf, use_vgrid, Nlvgrid, vgrid_z_loc, & + vgrid_mz) + + use mod_cosp_config, only : CLOUDSAT_DBZE_BINS, SR_BINS, CLOUDSAT_CFAD_ZE_MIN, PARASOL_NREFL, & + CLOUDSAT_CFAD_ZE_WIDTH,PARASOL_SZA, & + isccp_histPresCenters,tau_binCenters, LIDAR_NTEMP, & + LIDAR_PHASE_TEMP,misr_histHgtCenters,numMISRHgtBins, & + numMODISReffIceBins,reffICE_binCenters, & + numMODISReffLiqBins, reffLIQ_binCenters, pres_binCenters, & + cloudsat_binCenters, calipso_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 + ! ug Pour les sorties XIOS + use wxios_mod + + IMPLICIT NONE + +!!! Variables d'entree + integer :: Nlevlmdz, Ncolumns, Nlvgrid ! Number of levels + real,dimension(Nlevlmdz) :: presnivs, vgrid_mz + real,dimension(Nlvgrid) :: vgrid_z_loc + real :: dtime, freq_cosp, ecrit_day, ecrit_hf, ecrit_mth + logical :: use_vgrid + logical :: ok_mensuelCOSP, ok_journeCOSP, ok_hfCOSP, ok_all_xml + +!!! Variables locales + integer :: idayref, iff, ii + real :: zjulian,zjulian_start + real(wp),dimension(Ncolumns) :: column_ax + CHARACTER(LEN=20), DIMENSION(3) :: chfreq = (/ '1day', '1d ', '3h ' /) + +!!! Variables d'entree + + ! 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 + + WRITE(lunout,*) 'Debut lmdz_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 + + + 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) + + IF (using_xios) THEN + + + ! 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", Nlvgrid, vgrid_z_loc) + print*,'wxios_add_vaxis Nlvgrid, vgrid_z_loc',Nlvgrid,vgrid_z_loc + + 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 CLOUDSAT_DBZE_BINS, cloudsat_binCenters ', & + CLOUDSAT_DBZE_BINS, cloudsat_binCenters + CALL wxios_add_vaxis("dbze", CLOUDSAT_DBZE_BINS, cloudsat_binCenters) + + WRITE(lunout,*) 'wxios_add_vaxis scatratio SR_BINS, calipso_binCenters', & + SR_BINS, calipso_binCenters + CALL wxios_add_vaxis("scatratio", SR_BINS, calipso_binCenters) + + 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) + + IF (using_xios) THEN + 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",Nlvgrid,vgrid_z_loc,nvert(iff)) + else +! Axe vertical modele LMDZ presnivs + CALL histvert(cosp_nidfiles(iff),"presnivs","Vertical levels","Pa",Nlevlmdz,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,pres_binCenters,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",numMISRHgtBins,misr_histHgtCenters,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",CLOUDSAT_DBZE_BINS,cloudsat_binCenters,nvertbze(iff)) + + CALL histvert(cosp_nidfiles(iff),"scatratio","backscattering_ratio","1",SR_BINS,calipso_binCenters,nvertsratio(iff)) + + CALL histvert(cosp_nidfiles(iff),"tau","cloud optical depth","1",7,tau_binCenters,nverttau(iff)) + +!!! Valeur indefinie en cas IOIPSL + Cosp_fill_value=0. + +#endif + + ENDIF + ENDDO + + end SUBROUTINE lmdz_cosp_output_open + + END MODULE lmdz_cosp_output_mod Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_output_write_mod.f90 (revision 5900) @@ -0,0 +1,1041 @@ +!!!! Abderrahmane Idelkadi aout 2013 !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +! Module pour definir (au 1er appel) et ecrire les variables dans les fichiers de sortie cosp +! +! R.Guzman jan 2019 (mise a jour pour COSPv2) +! On change le nom du module a "lmdz_cosp_output_write_mod" et celui de la routine a "lmdz_cosp_output_write" +! pour qu on sache qu il s agit d un module specifique a l implementation de COSP dans LMDZ +! +!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + MODULE lmdz_cosp_output_write_mod + + USE lmdz_cosp_output_mod + USE mod_cosp_config, only : R_UNDEF, CLOUDSAT_DBZE_BINS, SR_BINS, PARASOL_NREFL, & + 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 lmdz_cosp_output_write(Nlevlmdz, Npoints, Ncolumns, itap, dtime, freq_COSP, missing_cosp, & + cfg, Nlvgrid, cospOUT) + + + USE ioipsl + USE time_phylmdz_mod, ONLY: itau_phy, start_time, day_step_phy + USE print_control_mod, ONLY: lunout,prt_level + USE lmdz_cosp_read_outputkeys, only: cosp_config +!COSPv2 + use cosp_kinds, only: wp + use mod_cosp, only: cosp_outputs + + use wxios_mod, only: wxios_closedef + USE lmdz_xios, only: xios_update_calendar, xios_field_is_active + IMPLICIT NONE +!!! Variables d'entree + integer :: itap, Nlevlmdz, Ncolumns, Npoints, Nlvgrid + real :: freq_COSP, dtime, missing_val, missing_cosp + type(cosp_config) :: cfg ! Control outputs + type(cosp_outputs) :: & + cospOUT ! COSP simulator outputs + + +!!! 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,Nlvgrid,SR_BINS) :: tmp_fi4da_cfadL, tmp_fi4da_cfadLgr, tmp_fi4da_cfadLatlid + real, dimension(Npoints,Nlvgrid,CLOUDSAT_DBZE_BINS) :: tmp_fi4da_cfadR + real, dimension(Npoints,numMISRHgtBins,7) :: tmp_fi4da_misr + + missing_val=missing_cosp + + Nlevout = 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. + +!!!! Sorties Calipso + if (cfg%Lcalipso) then + +! print*,'Appel histwrite2d_cosp' + if (cfg%Lcllcalipso) then + where(cospOUT%calipso_cldlayer(:,1) == R_UNDEF) cospOUT%calipso_cldlayer(:,1) = missing_val + CALL histwrite2d_cosp(o_cllcalipso,cospOUT%calipso_cldlayer(:,1)) + endif + if (cfg%Lclhcalipso) then + where(cospOUT%calipso_cldlayer(:,3) == R_UNDEF) cospOUT%calipso_cldlayer(:,3) = missing_val + CALL histwrite2d_cosp(o_clhcalipso,cospOUT%calipso_cldlayer(:,3)) + endif + if (cfg%Lclmcalipso) then + where(cospOUT%calipso_cldlayer(:,2) == R_UNDEF) cospOUT%calipso_cldlayer(:,2) = missing_val + CALL histwrite2d_cosp(o_clmcalipso,cospOUT%calipso_cldlayer(:,2)) + endif + if (cfg%Lcltcalipso) then + where(cospOUT%calipso_cldlayer(:,4) == R_UNDEF) cospOUT%calipso_cldlayer(:,4) = missing_val + CALL histwrite2d_cosp(o_cltcalipso,cospOUT%calipso_cldlayer(:,4)) + endif + if (cfg%Lclcalipso) then + where(cospOUT%calipso_lidarcld == R_UNDEF) cospOUT%calipso_lidarcld = missing_val + CALL histwrite3d_cosp(o_clcalipso,cospOUT%calipso_lidarcld,nvert) + endif + if (cfg%Lclcalipsotmp) then + where(cospOUT%calipso_lidarcldtmp(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,1) = missing_val + CALL histwrite3d_cosp(o_clcalipsotmp,cospOUT%calipso_lidarcldtmp(:,:,1),nverttemp) + endif + + if (cfg%Lcllcalipsoice) then + where(cospOUT%calipso_cldlayerphase(:,1,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,1) = missing_val + CALL histwrite2d_cosp(o_cllcalipsoice,cospOUT%calipso_cldlayerphase(:,1,1)) + endif + if (cfg%Lclhcalipsoice) then + where(cospOUT%calipso_cldlayerphase(:,3,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,1) = missing_val + CALL histwrite2d_cosp(o_clhcalipsoice,cospOUT%calipso_cldlayerphase(:,3,1)) + endif + if (cfg%Lclmcalipsoice) then + where(cospOUT%calipso_cldlayerphase(:,2,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,1) = missing_val + CALL histwrite2d_cosp(o_clmcalipsoice,cospOUT%calipso_cldlayerphase(:,2,1)) + endif + if (cfg%Lcltcalipsoice) then + where(cospOUT%calipso_cldlayerphase(:,4,1) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,1) = missing_val + CALL histwrite2d_cosp(o_cltcalipsoice,cospOUT%calipso_cldlayerphase(:,4,1)) + endif + if (cfg%Lclcalipsoice) then + where(cospOUT%calipso_lidarcldphase(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,1) = missing_val + CALL histwrite3d_cosp(o_clcalipsoice,cospOUT%calipso_lidarcldphase(:,:,1),nvert) + endif + if (cfg%Lclcalipsotmpice) then + where(cospOUT%calipso_lidarcldtmp(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,2) = missing_val + CALL histwrite3d_cosp(o_clcalipsotmpice,cospOUT%calipso_lidarcldtmp(:,:,2),nverttemp) + endif + + if (cfg%Lcllcalipsoliq) then + where(cospOUT%calipso_cldlayerphase(:,1,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,2) = missing_val + CALL histwrite2d_cosp(o_cllcalipsoliq,cospOUT%calipso_cldlayerphase(:,1,2)) + endif + if (cfg%Lclhcalipsoliq) then + where(cospOUT%calipso_cldlayerphase(:,3,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,2) = missing_val + CALL histwrite2d_cosp(o_clhcalipsoliq,cospOUT%calipso_cldlayerphase(:,3,2)) + endif + if (cfg%Lclmcalipsoliq) then + where(cospOUT%calipso_cldlayerphase(:,2,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,2) = missing_val + CALL histwrite2d_cosp(o_clmcalipsoliq,cospOUT%calipso_cldlayerphase(:,2,2)) + endif + if (cfg%Lcltcalipsoliq) then + where(cospOUT%calipso_cldlayerphase(:,4,2) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,2) = missing_val + CALL histwrite2d_cosp(o_cltcalipsoliq,cospOUT%calipso_cldlayerphase(:,4,2)) + endif + if (cfg%Lclcalipsoliq) then + where(cospOUT%calipso_lidarcldphase(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,2) = missing_val + CALL histwrite3d_cosp(o_clcalipsoliq,cospOUT%calipso_lidarcldphase(:,:,2),nvert) + endif + if (cfg%Lclcalipsotmpliq) then + where(cospOUT%calipso_lidarcldtmp(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,3) = missing_val + CALL histwrite3d_cosp(o_clcalipsotmpliq,cospOUT%calipso_lidarcldtmp(:,:,3),nverttemp) + endif + if (cfg%Lcllcalipsoun) then + where(cospOUT%calipso_cldlayerphase(:,1,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,1,3) = missing_val + CALL histwrite2d_cosp(o_cllcalipsoun,cospOUT%calipso_cldlayerphase(:,1,3)) + endif + if (cfg%Lclhcalipsoun) then + where(cospOUT%calipso_cldlayerphase(:,3,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,3,3) = missing_val + CALL histwrite2d_cosp(o_clhcalipsoun,cospOUT%calipso_cldlayerphase(:,3,3)) + endif + if (cfg%Lclmcalipsoun) then + where(cospOUT%calipso_cldlayerphase(:,2,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,2,3) = missing_val + CALL histwrite2d_cosp(o_clmcalipsoun,cospOUT%calipso_cldlayerphase(:,2,3)) + endif + if (cfg%Lcltcalipsoun) then + where(cospOUT%calipso_cldlayerphase(:,4,3) == R_UNDEF) cospOUT%calipso_cldlayerphase(:,4,3) = missing_val + CALL histwrite2d_cosp(o_cltcalipsoun,cospOUT%calipso_cldlayerphase(:,4,3)) + endif + if (cfg%Lclcalipsoun) then + where(cospOUT%calipso_lidarcldphase(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldphase(:,:,3) = missing_val + CALL histwrite3d_cosp(o_clcalipsoun,cospOUT%calipso_lidarcldphase(:,:,3),nvert) + endif + if (cfg%Lclcalipsotmpun) then + where(cospOUT%calipso_lidarcldtmp(:,:,4) == R_UNDEF) cospOUT%calipso_lidarcldtmp(:,:,4) = missing_val + CALL histwrite3d_cosp(o_clcalipsotmpun,cospOUT%calipso_lidarcldtmp(:,:,4),nverttemp) + endif + + if (cfg%Lclopaquecalipso) then + where(cospOUT%calipso_cldtype(:,1) == R_UNDEF) cospOUT%calipso_cldtype(:,1) = missing_val + CALL histwrite2d_cosp(o_clopaquecalipso,cospOUT%calipso_cldtype(:,1)) + endif + if (cfg%Lclthincalipso) then + where(cospOUT%calipso_cldtype(:,2) == R_UNDEF) cospOUT%calipso_cldtype(:,2) = missing_val + CALL histwrite2d_cosp(o_clthincalipso,cospOUT%calipso_cldtype(:,2)) + endif + if (cfg%Lclzopaquecalipso) then + where(cospOUT%calipso_cldtype(:,3) == R_UNDEF) cospOUT%calipso_cldtype(:,3) = missing_val + CALL histwrite2d_cosp(o_clzopaquecalipso,cospOUT%calipso_cldtype(:,3)) + endif + if (cfg%Lclcalipsoopaque) then + where(cospOUT%calipso_lidarcldtype(:,:,1) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,1) = missing_val + CALL histwrite3d_cosp(o_clcalipsoopaque,cospOUT%calipso_lidarcldtype(:,:,1),nvert) + endif + if (cfg%Lclcalipsothin) then + where(cospOUT%calipso_lidarcldtype(:,:,2) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,2) = missing_val + CALL histwrite3d_cosp(o_clcalipsothin,cospOUT%calipso_lidarcldtype(:,:,2),nvert) + endif + if (cfg%Lclcalipsozopaque) then + where(cospOUT%calipso_lidarcldtype(:,:,3) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,3) = missing_val + CALL histwrite3d_cosp(o_clcalipsozopaque,cospOUT%calipso_lidarcldtype(:,:,3),nvert) + endif + if (cfg%Lclcalipsoopacity) then + where(cospOUT%calipso_lidarcldtype(:,:,4) == R_UNDEF) cospOUT%calipso_lidarcldtype(:,:,4) = missing_val + CALL histwrite3d_cosp(o_clcalipsoopacity,cospOUT%calipso_lidarcldtype(:,:,4),nvert) + endif + + if (cfg%Lclopaquetemp) then + where(cospOUT%calipso_cldtypetemp(:,1) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,1) = missing_val + CALL histwrite2d_cosp(o_clopaquetemp,cospOUT%calipso_cldtypetemp(:,1)) + endif + if (cfg%Lclthintemp) then + where(cospOUT%calipso_cldtypetemp(:,2) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,2) = missing_val + CALL histwrite2d_cosp(o_clthintemp,cospOUT%calipso_cldtypetemp(:,2)) + endif + if (cfg%Lclzopaquetemp) then + where(cospOUT%calipso_cldtypetemp(:,3) == R_UNDEF) cospOUT%calipso_cldtypetemp(:,3) = missing_val + CALL histwrite2d_cosp(o_clzopaquetemp,cospOUT%calipso_cldtypetemp(:,3)) + endif + if (cfg%Lclopaquemeanz) then + where(cospOUT%calipso_cldtypemeanz(:,1) == R_UNDEF) cospOUT%calipso_cldtypemeanz(:,1) = missing_val + CALL histwrite2d_cosp(o_clopaquemeanz,cospOUT%calipso_cldtypemeanz(:,1)) + endif + if (cfg%Lclthinmeanz) then + where(cospOUT%calipso_cldtypemeanz(:,2) == R_UNDEF) cospOUT%calipso_cldtypemeanz(:,2) = missing_val + CALL histwrite2d_cosp(o_clthinmeanz,cospOUT%calipso_cldtypemeanz(:,2)) + endif + if (cfg%Lclthinemis) then + where(cospOUT%calipso_cldthinemis == R_UNDEF) cospOUT%calipso_cldthinemis = missing_val + CALL histwrite2d_cosp(o_clthinemis,cospOUT%calipso_cldthinemis) + endif + if (cfg%Lclopaquemeanzse) then + where(cospOUT%calipso_cldtypemeanzse(:,1) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,1) = missing_val + CALL histwrite2d_cosp(o_clopaquemeanzse,cospOUT%calipso_cldtypemeanzse(:,1)) + endif + if (cfg%Lclthinmeanzse) then + where(cospOUT%calipso_cldtypemeanzse(:,2) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,2) = missing_val + CALL histwrite2d_cosp(o_clthinmeanzse,cospOUT%calipso_cldtypemeanzse(:,2)) + endif + if (cfg%Lclzopaquecalipsose) then + where(cospOUT%calipso_cldtypemeanzse(:,3) == R_UNDEF) cospOUT%calipso_cldtypemeanzse(:,3) = missing_val + CALL histwrite2d_cosp(o_clzopaquecalipsose,cospOUT%calipso_cldtypemeanzse(:,3)) + endif + + + if (cfg%LcfadLidarsr532) then + where(cospOUT%calipso_cfad_sr == R_UNDEF) cospOUT%calipso_cfad_sr = missing_val + + do icl=1,SR_BINS + do k=1,Nlvgrid + do ip=1,Npoints + tmp_fi4da_cfadL(ip,k,icl)=cospOUT%calipso_cfad_sr(ip,icl,k) + enddo + enddo + enddo +! if (cfg%LcfadLidarsr532) CALL histwrite4d_cosp(o_cfad_lidarsr532,stlidar%cfad_sr) + CALL histwrite4d_cosp(o_cfadLidarsr532,tmp_fi4da_cfadL) !!! "_" enleve + endif + + if (cfg%Latb532) then + where(cospOUT%calipso_beta_tot == R_UNDEF) cospOUT%calipso_beta_tot = missing_val + CALL histwrite4d_cosp(o_atb532,cospOUT%calipso_beta_tot) + endif + if (cfg%LlidarBetaMol532) then + where(cospOUT%calipso_beta_mol == R_UNDEF) cospOUT%calipso_beta_mol = missing_val + CALL histwrite3d_cosp(o_lidarBetaMol532,cospOUT%calipso_beta_mol,nvertmcosp) + endif + + endif !Calipso + + +!!!! Sorties Ground Lidar + if (cfg%LgrLidar532) then +! AI juin 2020 Voir a quoi correspond ce champs +! where(cospOUT%grLidar532_srbval == R_UNDEF) cospOUT%grLidar532_srbval = missing_val + + if (cfg%LcllgrLidar532) then + where(cospOUT%grLidar532_cldlayer(:,1) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,1) = missing_val + CALL histwrite2d_cosp(o_cllgrLidar532,cospOUT%grLidar532_cldlayer(:,1)) + endif + if (cfg%LclmgrLidar532) then + where(cospOUT%grLidar532_cldlayer(:,2) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,2) = missing_val + CALL histwrite2d_cosp(o_clmgrLidar532,cospOUT%grLidar532_cldlayer(:,2)) + endif + if (cfg%LclhgrLidar532) then + where(cospOUT%grLidar532_cldlayer(:,3) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,3) = missing_val + CALL histwrite2d_cosp(o_clhgrLidar532,cospOUT%grLidar532_cldlayer(:,3)) + endif + if (cfg%LcltgrLidar532) then + where(cospOUT%grLidar532_cldlayer(:,4) == R_UNDEF) cospOUT%grLidar532_cldlayer(:,4) = missing_val + CALL histwrite2d_cosp(o_cltgrLidar532,cospOUT%grLidar532_cldlayer(:,4)) + endif + + if (cfg%LclgrLidar532) then + where(cospOUT%grLidar532_lidarcld == R_UNDEF) cospOUT%grLidar532_lidarcld = missing_val + CALL histwrite3d_cosp(o_clgrLidar532,cospOUT%grLidar532_lidarcld,nvert) + endif + if (cfg%LlidarBetaMol532gr) then + where(cospOUT%grLidar532_beta_mol == R_UNDEF) cospOUT%grLidar532_beta_mol = missing_val + CALL histwrite3d_cosp(o_lidarBetaMol532gr,cospOUT%grLidar532_beta_mol,nvertmcosp) + endif + if (cfg%LcfadLidarsr532gr) then + where(cospOUT%grLidar532_cfad_sr == R_UNDEF) cospOUT%grLidar532_cfad_sr = missing_val + do icl=1,SR_BINS + do k=1,Nlvgrid + do ip=1,Npoints + tmp_fi4da_cfadLgr(ip,k,icl)=cospOUT%grLidar532_cfad_sr(ip,icl,k) + enddo + enddo + enddo + CALL histwrite4d_cosp(o_cfadLidarsr532gr,tmp_fi4da_cfadLgr) + endif + + if (cfg%Latb532gr) then + where(cospOUT%grLidar532_beta_tot == R_UNDEF) cospOUT%grLidar532_beta_tot = missing_val + CALL histwrite4d_cosp(o_atb532gr,cospOUT%grLidar532_beta_tot) + endif +endif ! Ground Lidar 532 nm + + +!!!! Sorties Atlid + if (cfg%Latlid) then +! AI juin 2020 Voir a quoi correspond ce champs +! where(cospOUT%atlid_srbval == R_UNDEF) cospOUT%atlid_srbval = missing_val + + if (cfg%Lcllatlid) then + where(cospOUT%atlid_cldlayer(:,1) == R_UNDEF) cospOUT%atlid_cldlayer(:,1) = missing_val + CALL histwrite2d_cosp(o_cllatlid,cospOUT%atlid_cldlayer(:,1)) + endif + if (cfg%Lclmatlid) then + where(cospOUT%atlid_cldlayer(:,2) == R_UNDEF) cospOUT%atlid_cldlayer(:,2) = missing_val + CALL histwrite2d_cosp(o_clmatlid,cospOUT%atlid_cldlayer(:,2)) + endif + if (cfg%Lclhatlid) then + where(cospOUT%atlid_cldlayer(:,3) == R_UNDEF) cospOUT%atlid_cldlayer(:,3) = missing_val + CALL histwrite2d_cosp(o_clhatlid,cospOUT%atlid_cldlayer(:,3)) + endif + if (cfg%Lcltatlid) then + where(cospOUT%atlid_cldlayer(:,4) == R_UNDEF) cospOUT%atlid_cldlayer(:,4) = missing_val + CALL histwrite2d_cosp(o_cltatlid,cospOUT%atlid_cldlayer(:,4)) + endif + if (cfg%Lclatlid) then + where(cospOUT%atlid_lidarcld == R_UNDEF) cospOUT%atlid_lidarcld = missing_val + CALL histwrite3d_cosp(o_clatlid,cospOUT%atlid_lidarcld,nvert) + endif + if (cfg%LlidarBetaMol355) then + where(cospOUT%atlid_beta_mol == R_UNDEF) cospOUT%atlid_beta_mol = missing_val + CALL histwrite3d_cosp(o_lidarBetaMol355,cospOUT%atlid_beta_mol,nvertmcosp) + endif + if (cfg%LcfadLidarsr355) then + where(cospOUT%atlid_cfad_sr == R_UNDEF) cospOUT%atlid_cfad_sr = missing_val + do icl=1,SR_BINS + do k=1,Nlvgrid + do ip=1,Npoints + tmp_fi4da_cfadLatlid(ip,k,icl)=cospOUT%atlid_cfad_sr(ip,icl,k) + enddo + enddo + enddo + CALL histwrite4d_cosp(o_cfadlidarsr355,tmp_fi4da_cfadLatlid) + endif + + if (cfg%Latb355) then + where(cospOUT%atlid_beta_tot == R_UNDEF) cospOUT%atlid_beta_tot = missing_val + CALL histwrite4d_cosp(o_atb355,cospOUT%atlid_beta_tot) + endif +endif ! Atlid + + + if (cfg%Lparasol) then + if (cfg%LparasolRefl) then + where(cospOUT%parasolGrid_refl == R_UNDEF) cospOUT%parasolGrid_refl = missing_val + where(cospOUT%parasolPix_refl == R_UNDEF) cospOUT%parasolPix_refl = missing_val + CALL histwrite3d_cosp(o_parasolGrid_refl,cospOUT%parasolGrid_refl,nvertp) + CALL histwrite4d_cosp(o_parasolPix_refl,cospOUT%parasolPix_refl) + endif ! LparasolRefl + endif ! Parasol + +! if (cfg%LparasolRefl) then +! do k=1,PARASOL_NREFL +! do ip=1, Npoints +! if (stlidar%cldlayer(ip,4).gt.1.and.stlidar%parasolrefl(ip,k).ne.missing_val) then +! parasolcrefl(ip,k)=(stlidar%parasolrefl(ip,k)-0.03*(1.-stlidar%cldlayer(ip,4)/100.))/ & +! (stlidar%cldlayer(ip,4)/100.) +! 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 + + +!!! Sorties CloudSat + if (cfg%Lcloudsat) then +! AI juin 2020 voir a quoi correspond ce champs +! where(cospOUT%cloudsat_pia == R_UNDEF) cospOUT%cloudsat_pia = missing_val + + if (cfg%Lptradarflag0) then + where(cospOUT%cloudsat_precip_cover(:,1) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,1) = missing_val + CALL histwrite2d_cosp(o_ptradarflag0,cospOUT%cloudsat_precip_cover(:,1)) + endif + if (cfg%Lptradarflag1) then + where(cospOUT%cloudsat_precip_cover(:,2) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,2) = missing_val + CALL histwrite2d_cosp(o_ptradarflag1,cospOUT%cloudsat_precip_cover(:,2)) + endif + if (cfg%Lptradarflag2) then + where(cospOUT%cloudsat_precip_cover(:,3) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,3) = missing_val + CALL histwrite2d_cosp(o_ptradarflag2,cospOUT%cloudsat_precip_cover(:,3)) + endif + if (cfg%Lptradarflag3) then + where(cospOUT%cloudsat_precip_cover(:,4) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,4) = missing_val + CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,4)) + endif + if (cfg%Lptradarflag4) then + where(cospOUT%cloudsat_precip_cover(:,5) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,5) = missing_val + CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,5)) + endif + if (cfg%Lptradarflag5) then + where(cospOUT%cloudsat_precip_cover(:,6) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,6) = missing_val + CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,6)) + endif + if (cfg%Lptradarflag6) then + where(cospOUT%cloudsat_precip_cover(:,7) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,7) = missing_val + CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,7)) + endif + if (cfg%Lptradarflag7) then + where(cospOUT%cloudsat_precip_cover(:,8) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,8) = missing_val + CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,8)) + endif + if (cfg%Lptradarflag8) then + where(cospOUT%cloudsat_precip_cover(:,9) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,9) = missing_val + CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,9)) + endif + if (cfg%Lptradarflag9) then + where(cospOUT%cloudsat_precip_cover(:,10) == R_UNDEF) cospOUT%cloudsat_precip_cover(:,10) = missing_val + CALL histwrite2d_cosp(o_ptradarflag3,cospOUT%cloudsat_precip_cover(:,10)) + endif + + if (cfg%Ldbze94) then + where(cospOUT%cloudsat_Ze_tot == R_UNDEF) cospOUT%cloudsat_Ze_tot = missing_val + CALL histwrite4d_cosp(o_dbze94,cospOUT%cloudsat_Ze_tot) + endif + if (cfg%LcfadDbze94) then + where(cospOUT%cloudsat_cfad_ze == R_UNDEF) cospOUT%cloudsat_cfad_ze = missing_val + do icl=1,CLOUDSAT_DBZE_BINS + do k=1,Nlvgrid + do ip=1,Npoints + tmp_fi4da_cfadR(ip,k,icl)=cospOUT%cloudsat_cfad_ze(ip,icl,k) + enddo + enddo + enddo + CALL histwrite4d_cosp(o_cfadDbze94,tmp_fi4da_cfadR) + endif + endif +! endif pour CloudSat + + +!!! Sorties combinees Cloudsat et Calipso + if (cfg%Lcalipso .and. cfg%Lcloudsat) then + + if (cfg%Lclcalipso2) then + where(cospOUT%lidar_only_freq_cloud == R_UNDEF) & + cospOUT%lidar_only_freq_cloud = missing_val + CALL histwrite3d_cosp(o_clcalipso2,cospOUT%lidar_only_freq_cloud,nvert) + endif + if (cfg%Lcloudsat_tcc) then + where(cospOUT%cloudsat_tcc == R_UNDEF) & + cospOUT%cloudsat_tcc = missing_val + CALL histwrite2d_cosp(o_cloudsat_tcc,cospOUT%cloudsat_tcc) + endif + if (cfg%Lcloudsat_tcc2) then + where(cospOUT%cloudsat_tcc2 == R_UNDEF) & + cospOUT%cloudsat_tcc2 = missing_val + CALL histwrite2d_cosp(o_cloudsat_tcc2,cospOUT%cloudsat_tcc2) + endif + if (cfg%Lcltlidarradar) then + where(cospOUT%radar_lidar_tcc == R_UNDEF) & + cospOUT%radar_lidar_tcc = missing_val + CALL histwrite2d_cosp(o_cltlidarradar,cospOUT%radar_lidar_tcc) + endif + endif + + +!!! Sorties Isccp + if (cfg%Lisccp) then + where(cospOUT%isccp_totalcldarea == R_UNDEF) cospOUT%isccp_totalcldarea = missing_val + where(cospOUT%isccp_meanptop == R_UNDEF) cospOUT%isccp_meanptop = missing_val + where(cospOUT%isccp_meantaucld == R_UNDEF) cospOUT%isccp_meantaucld = missing_val + where(cospOUT%isccp_meanalbedocld == R_UNDEF) cospOUT%isccp_meanalbedocld = missing_val + where(cospOUT%isccp_meantb == R_UNDEF) cospOUT%isccp_meantb = missing_val + where(cospOUT%isccp_meantbclr == R_UNDEF) cospOUT%isccp_meantbclr = missing_val + where(cospOUT%isccp_fq == R_UNDEF) cospOUT%isccp_fq = missing_val + where(cospOUT%isccp_boxtau == R_UNDEF) cospOUT%isccp_boxtau = missing_val + where(cospOUT%isccp_boxptop == R_UNDEF) cospOUT%isccp_boxptop = missing_val + +! CALL histwrite2d_cosp(o_sunlit,gbx%sunlit) + if (cfg%Lclisccp) CALL histwrite4d_cosp(o_clisccp,cospOUT%isccp_fq) + + if (cfg%Lboxtauisccp) CALL histwrite3d_cosp(o_boxtauisccp,cospOUT%isccp_boxtau,nvertcol) + if (cfg%Lboxptopisccp) CALL histwrite3d_cosp(o_boxptopisccp,cospOUT%isccp_boxptop,nvertcol) + if (cfg%Lcltisccp) CALL histwrite2d_cosp(o_cltisccp,cospOUT%isccp_totalcldarea) + if (cfg%Lpctisccp) CALL histwrite2d_cosp(o_pctisccp,cospOUT%isccp_meanptop) + if (cfg%Ltauisccp) CALL histwrite2d_cosp(o_tauisccp,cospOUT%isccp_meantaucld) + if (cfg%Lalbisccp) CALL histwrite2d_cosp(o_albisccp,cospOUT%isccp_meanalbedocld) + if (cfg%Lmeantbisccp) CALL histwrite2d_cosp(o_meantbisccp,cospOUT%isccp_meantb) + if (cfg%Lmeantbclrisccp) CALL histwrite2d_cosp(o_meantbclrisccp,cospOUT%isccp_meantbclr) + endif ! Isccp + + +!!! MISR simulator + if (cfg%Lmisr) then + + if (cfg%LclMISR) then +! Ces 3 diagnostics sont controles par la clef logique "LclMISR" + where(cospOUT%misr_fq == R_UNDEF) cospOUT%misr_fq = missing_val +! where(cospOUT%misr_dist_model_layertops == R_UNDEF) cospOUT%misr_dist_model_layertops = missing_val + where(cospOUT%misr_meanztop == R_UNDEF) cospOUT%misr_meanztop = missing_val + where(cospOUT%misr_cldarea == R_UNDEF) cospOUT%misr_cldarea = missing_val + + do icl=1,numMISRHgtBins + do k=1,Nlvgrid + do ip=1,Npoints + tmp_fi4da_misr(ip,icl,k)=cospOUT%misr_fq(ip,k,icl) + enddo + enddo + enddo +! if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,misr%fq_MISR) +! if (cfg%LclMISR) CALL histwrite4d_cosp(o_clMISR,tmp_fi4da_misr) + CALL histwrite4d_cosp(o_misr_fq,tmp_fi4da_misr) + + CALL histwrite2d_cosp(o_misr_meanztop,cospOUT%misr_meanztop) + CALL histwrite2d_cosp(o_misr_cldarea,cospOUT%misr_cldarea) + endif ! LclMISR + + endif ! Misr + + +!!! Modis simulator + if (cfg%Lmodis) then + where(cospOUT%modis_Cloud_Fraction_Low_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Fraction_Low_Mean = missing_val + where(cospOUT%modis_Cloud_Fraction_High_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Fraction_High_Mean = missing_val + where(cospOUT%modis_Cloud_Fraction_Mid_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Fraction_Mid_Mean = missing_val + where(cospOUT%modis_Cloud_Fraction_Total_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Fraction_Total_Mean = missing_val + where(cospOUT%modis_Cloud_Fraction_Water_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Fraction_Water_Mean = missing_val + where(cospOUT%modis_Cloud_Fraction_Ice_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Fraction_Ice_Mean = missing_val + where(cospOUT%modis_Optical_Thickness_Total_Mean == R_UNDEF) & + cospOUT%modis_Optical_Thickness_Total_Mean = missing_val + where(cospOUT%modis_Optical_Thickness_Water_Mean == R_UNDEF) & + cospOUT%modis_Optical_Thickness_Water_Mean = missing_val + where(cospOUT%modis_Optical_Thickness_Ice_Mean == R_UNDEF) & + cospOUT%modis_Optical_Thickness_Ice_Mean = missing_val + where(cospOUT%modis_Cloud_Particle_Size_Water_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Particle_Size_Water_Mean = missing_val + where(cospOUT%modis_Cloud_Particle_Size_Ice_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Particle_Size_Ice_Mean = missing_val + where(cospOUT%modis_Cloud_Top_Pressure_Total_Mean == R_UNDEF) & + cospOUT%modis_Cloud_Top_Pressure_Total_Mean = missing_val + where(cospOUT%modis_Liquid_Water_Path_Mean == R_UNDEF) & + cospOUT%modis_Liquid_Water_Path_Mean = missing_val + where(cospOUT%modis_Ice_Water_Path_Mean == R_UNDEF) & + cospOUT%modis_Ice_Water_Path_Mean = missing_val + where(cospOUT%modis_Optical_Thickness_Total_LogMean == R_UNDEF) & + cospOUT%modis_Optical_Thickness_Total_LogMean = missing_val + where(cospOUT%modis_Optical_Thickness_Water_LogMean == R_UNDEF) & + cospOUT%modis_Optical_Thickness_Water_LogMean = missing_val + where(cospOUT%modis_Optical_Thickness_Ice_LogMean == R_UNDEF) & + cospOUT%modis_Optical_Thickness_Ice_LogMean = missing_val + + if (cfg%Lcllmodis) CALL histwrite2d_cosp(o_cllmodis,cospOUT%modis_Cloud_Fraction_Low_Mean) + if (cfg%Lclhmodis) CALL histwrite2d_cosp(o_clhmodis,cospOUT%modis_Cloud_Fraction_High_Mean) + if (cfg%Lclmmodis) CALL histwrite2d_cosp(o_clmmodis,cospOUT%modis_Cloud_Fraction_Mid_Mean) + if (cfg%Lcltmodis) CALL histwrite2d_cosp(o_cltmodis,cospOUT%modis_Cloud_Fraction_Total_Mean) + if (cfg%Lclwmodis) CALL histwrite2d_cosp(o_clwmodis,cospOUT%modis_Cloud_Fraction_Water_Mean) + if (cfg%Lclimodis) CALL histwrite2d_cosp(o_climodis,cospOUT%modis_Cloud_Fraction_Ice_Mean) + if (cfg%Ltautmodis) CALL histwrite2d_cosp(o_tautmodis,cospOUT%modis_Optical_Thickness_Total_Mean) + if (cfg%Ltauwmodis) CALL histwrite2d_cosp(o_tauwmodis,cospOUT%modis_Optical_Thickness_Water_Mean) + if (cfg%Ltauimodis) CALL histwrite2d_cosp(o_tauimodis,cospOUT%modis_Optical_Thickness_Ice_Mean) + if (cfg%Ltautlogmodis) CALL histwrite2d_cosp(o_tautlogmodis,cospOUT%modis_Optical_Thickness_Total_LogMean) + if (cfg%Ltauwlogmodis) CALL histwrite2d_cosp(o_tauwlogmodis,cospOUT%modis_Optical_Thickness_Water_LogMean) + if (cfg%Ltauilogmodis) CALL histwrite2d_cosp(o_tauilogmodis,cospOUT%modis_Optical_Thickness_Ice_LogMean) + if (cfg%Lreffclwmodis) CALL histwrite2d_cosp(o_reffclwmodis,cospOUT%modis_Cloud_Particle_Size_Water_Mean) + if (cfg%Lreffclimodis) CALL histwrite2d_cosp(o_reffclimodis,cospOUT%modis_Cloud_Particle_Size_Ice_Mean) + if (cfg%Lpctmodis) CALL histwrite2d_cosp(o_pctmodis,cospOUT%modis_Cloud_Top_Pressure_Total_Mean) + if (cfg%Llwpmodis) CALL histwrite2d_cosp(o_lwpmodis,cospOUT%modis_Liquid_Water_Path_Mean) + if (cfg%Liwpmodis) CALL histwrite2d_cosp(o_iwpmodis,cospOUT%modis_Ice_Water_Path_Mean) + + if (cfg%Lclmodis) then +! Ces 3 diagnostics sont controles par la clef logique "Lclmodis" + where(cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure == R_UNDEF) & + cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure = missing_val + where(cospOUT%modis_Optical_Thickness_vs_ReffICE == R_UNDEF) & + cospOUT%modis_Optical_Thickness_vs_ReffICE = missing_val + where(cospOUT%modis_Optical_thickness_vs_ReffLIQ == R_UNDEF) & + cospOUT%modis_Optical_thickness_vs_ReffLIQ = missing_val + + CALL histwrite4d_cosp(o_modis_ot_vs_ctp,cospOUT%modis_Optical_Thickness_vs_Cloud_Top_Pressure) + CALL histwrite4d_cosp(o_modis_ot_vs_reffice,cospOUT%modis_Optical_Thickness_vs_ReffICE) + CALL histwrite4d_cosp(o_modis_ot_vs_reffliq,cospOUT%modis_Optical_thickness_vs_ReffLIQ) + + endif ! Lclmodis + + endif !modis + + + IF(.NOT.cosp_varsdefined) THEN +!$OMP MASTER +! Fermeture dans phys_output_write +!#ifdef 1 + !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 + ENDIF !cosp_varsdefined + + END SUBROUTINE lmdz_cosp_output_write + + +! ug Routine pour definir itau_iocosp depuis cosp_output_write_mod: + SUBROUTINE set_itau_iocosp(ito) + USE clesphys_mod_h + 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 + use wxios_mod + USE clesphys_mod_h, ONLY: ok_all_xml + + IMPLICIT NONE + + + 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 + + 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 + + + END SUBROUTINE histdef2d_cosp + + + SUBROUTINE histdef3d_cosp (iff,var,nvertsave,ncols) + USE clesphys_mod_h + 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 + + use wxios_mod + + + IMPLICIT NONE + + + 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 + + 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 + + + END SUBROUTINE histdef3d_cosp + + + SUBROUTINE histwrite2d_cosp(var,field) + USE clesphys_mod_h + 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 + + USE lmdz_xios, only: xios_send_field + + IMPLICIT NONE + + 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 + print*,'var, cosp_varsdefined dans cosp_varsdefined ',var%name, cosp_varsdefined + !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)) + deallocate(index2d) + 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 + ENDDO + + 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 + +!$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 clesphys_mod_h + 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 + + USE lmdz_xios, only: xios_send_field + + + IMPLICIT NONE + + 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)) + + 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 + deallocate(index3d) + ENDIF + ENDDO + 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 + +!$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 clesphys_mod_h + 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 + + USE lmdz_xios, only: xios_send_field + + + IMPLICIT NONE + + 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) + +! 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 + +!$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 lmdz_cosp_output_write_mod Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_read_outputkeys.f90 (revision 5900) @@ -0,0 +1,1717 @@ +!!!============================================================================= +!!! 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 +!! +!!! RG janvier 2019 +!! Mise a jour pour avoir toutes les sorties de COSPv2 +!! Changement de nom a "lmdz_cosp_read_outputkeys" +!!!============================================================================= + +module lmdz_cosp_read_outputkeys + + USE mod_phys_lmdz_para + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! TYPE COSP_CONFIG + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + TYPE COSP_CONFIG + logical :: & + Lwrite_output, & ! Control for output file + Lfracout, & ! Control SCOPS cloud fraction out ? +! simulators + Lcloudsat, & ! CLOUDSAT simulator on/off switch + Lcalipso, & ! CALIPSO simulator on/off switch + LgrLidar532, & ! GROUND LIDAR simulator on/off switch + Latlid, & ! ATLID simulator on/off switch + Lisccp, & ! ISCCP simulator on/off switch + Lmodis, & ! MODIS simulatoe on/off switch + Lmisr, & ! MISR simulator on/off switch + Lrttov, & ! RTTOV simulator on/off switch + Lparasol, & ! PARASOL simulator on/off switch + +! diagnostics + 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) + Latb532gr, & ! GROUND LIDAR @ 532NM attenuated total backscatter (532nm) + Latb355, & ! ATLID attenuated total backscatter (355nm) + LlidarBetaMol532, & ! CALIPSO molecular backscatter (532nm) + LlidarBetaMol532gr,&! GROUND LIDAR @ 532NM molecular backscatter (532nm) + LlidarBetaMol355, & ! ATLID molecular backscatter (355nm) + LcfadLidarsr532, & ! CALIPSO scattering ratio CFAD + LcfadLidarsr532gr,& ! GROUND LIDAR @ 532NM scattering ratio CFAD + LcfadLidarsr355, & ! ATLID scattering ratio CFAD + Lclcalipso2, & ! CALIPSO cloud fraction undetected by cloudsat + Lclcalipso, & ! CALIPSO cloud area fraction + LclgrLidar532, & ! GROUND LIDAR @ 532NM cloud area fraction + Lclatlid, & ! ATLID 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 + LclhgrLidar532, & ! GROUND LIDAR @ 532NM high-level cloud fraction + LcllgrLidar532, & ! GROUND LIDAR @ 532NM low-level cloud fraction + LclmgrLidar532, & ! GROUND LIDAR @ 532NM mid-level cloud fraction + LcltgrLidar532, & ! GROUND LIDAR @ 532NM total cloud fraction + Lclhatlid, & ! ATLID high-level cloud fraction + Lcllatlid, & ! ATLID low-level cloud fraction + Lclmatlid, & ! ATLID mid-level cloud fraction + Lcltatlid, & ! ATLID total cloud fraction + Lcltlidarradar, & ! CALIPSO-CLOUDSAT total cloud fraction + Lcloudsat_tcc, & ! + Lcloudsat_tcc2, & ! + 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 + Lclopaquecalipso, & ! CALIPSO opaque cloud cover (2D Map) + Lclthincalipso, & ! CALIPSO thin cloud cover (2D Map) + Lclzopaquecalipso,& ! CALIPSO z_opaque altitude (opaque clouds only, 2D Map) + Lclcalipsoopaque, & ! CALIPSO opaque cloud profiles 3D fraction + Lclcalipsothin, & ! CALIPSO thin cloud profiles 3D fraction + Lclcalipsozopaque,& ! CALIPSO z_opaque 3D fraction + Lclcalipsoopacity,& ! CALIPSO opacity 3D fraction + Lclopaquetemp, & ! CALIPSO opaque cloud temperature + Lclthintemp, & ! CALIPSO thin cloud temperature + Lclzopaquetemp, & ! CALIPSO z_opaque temperature + Lclopaquemeanz, & ! CALIPSO opaque cloud altitude + Lclthinmeanz, & ! CALIPSO thin cloud altitude + Lclthinemis, & ! CALIPSO thin cloud emissivity + Lclopaquemeanzse, & ! CALIPSO opaque cloud altitude with respect to SE + Lclthinmeanzse, & ! CALIPSO thin cloud altitude with respect to SE + Lclzopaquecalipsose,& ! CALIPSO z_opaque altitude with respect to SE + LcfadDbze94, & ! CLOUDSAT radar reflectivity CFAD + Ldbze94, & ! CLOUDSAT radar reflectivity + LparasolRefl, & ! PARASOL reflectance + Ltbrttov, & ! RTTOV mean clear-sky brightness temperature + Lptradarflag0, & ! CLOUDSAT no precipitation flag + Lptradarflag1, & ! CLOUDSAT rain possible flag + Lptradarflag2, & ! CLOUDSAT rain probable flag + Lptradarflag3, & ! CLOUDSAT rain certain flag + Lptradarflag4, & ! CLOUDSAT snow possible flag + Lptradarflag5, & ! CLOUDSAT snow certain flag + Lptradarflag6, & ! CLOUDSAT mixed-precipitation possible flag + Lptradarflag7, & ! CLOUDSAT mixed-precipitation certain flag + Lptradarflag8, & ! CLOUDSAT heavy rain flag + Lptradarflag9, & ! CLOUDSAT default flag + Lradarpia ! CLOUDSAT PIA + + +! character(len=32),dimension(:),allocatable :: out_list + character(len=32) :: out_list(107) + END TYPE COSP_CONFIG + + +CONTAINS +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------- SUBROUTINE READ_COSP_OUTPUT_NL ------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE cosp_outputkeys_init(cfg) + implicit none + type(cosp_config),intent(inout) :: cfg + character(len=32) :: out_list(107) + integer :: i + + do i=1,107 + cfg%out_list(i)='' + enddo + + + cfg%Lcloudsat=.false. + cfg%Lcalipso=.false. + cfg%LgrLidar532=.false. + cfg%Latlid=.false. + cfg%Lisccp=.false. + cfg%Lmodis=.false. + cfg%Lmisr=.false. + cfg%Lrttov=.false. + cfg%Lparasol=.false. + cfg%Lwrite_output=.false. + cfg%Lfracout=.false. + + + cfg%Lpctisccp=.false. + cfg%Lclisccp=.false. + cfg%Lboxptopisccp=.false. + cfg%Lboxtauisccp=.false. + cfg%Ltauisccp=.false. + cfg%Lcltisccp=.false. + cfg%Lmeantbisccp=.false. + cfg%Lmeantbclrisccp=.false. + cfg%Lalbisccp=.false. + cfg%LclMISR=.false. + cfg%Lcltmodis=.false. + cfg%Lclwmodis=.false. + cfg%Lclimodis=.false. + cfg%Lclhmodis=.false. + cfg%Lclmmodis=.false. + cfg%Lcllmodis=.false. + cfg%Ltautmodis=.false. + cfg%Ltauwmodis=.false. + cfg%Ltauimodis=.false. + cfg%Ltautlogmodis=.false. + cfg%Ltauwlogmodis=.false. + cfg%Ltauilogmodis=.false. + cfg%Lreffclwmodis=.false. + cfg%Lreffclimodis=.false. + cfg%Lpctmodis=.false. + cfg%Llwpmodis=.false. + cfg%Liwpmodis=.false. + cfg%Lclmodis=.false. + cfg%Latb532=.false. + cfg%Latb532gr=.false. + cfg%Latb355=.false. + cfg%LlidarBetaMol532=.false. + cfg%LlidarBetaMol532gr=.false. + cfg%LlidarBetaMol355=.false. + cfg%LcfadLidarsr532=.false. + cfg%LcfadLidarsr532gr=.false. + cfg%LcfadLidarsr355 =.false. + cfg%Lclcalipso2=.false. + cfg%Lclcalipso=.false. + cfg%LclgrLidar532=.false. + cfg%Lclatlid=.false. + cfg%Lclhcalipso=.false. + cfg%Lcllcalipso=.false. + cfg%Lclmcalipso=.false. + cfg%Lcltcalipso=.false. + cfg%LclhgrLidar532=.false. + cfg%LcllgrLidar532=.false. + cfg%LclmgrLidar532 =.false. + cfg%LcltgrLidar532=.false. + cfg%Lclhatlid=.false. + cfg%Lcllatlid=.false. + cfg%Lclmatlid=.false. + cfg%Lcltatlid=.false. + cfg%Lcltlidarradar=.false. + cfg%Lcloudsat_tcc=.false. + cfg%Lcloudsat_tcc2=.false. + cfg%Lclcalipsoliq=.false. + cfg%Lclcalipsoice=.false. + cfg%Lclcalipsoun=.false. + cfg%Lclcalipsotmp=.false. + cfg%Lclcalipsotmpliq=.false. + cfg%Lclcalipsotmpice=.false. + cfg%Lclcalipsotmpun=.false. + cfg%Lcltcalipsoliq=.false. + cfg%Lcltcalipsoice=.false. + cfg%Lcltcalipsoun=.false. + cfg%Lclhcalipsoliq=.false. + cfg%Lclhcalipsoice=.false. + cfg%Lclhcalipsoun=.false. + cfg%Lclmcalipsoliq=.false. + cfg%Lclmcalipsoice=.false. + cfg%Lclmcalipsoun=.false. + cfg%Lcllcalipsoliq=.false. + cfg%Lcllcalipsoice=.false. + cfg%Lcllcalipsoun =.false. + cfg%Lclopaquecalipso=.false. + cfg%Lclthincalipso=.false. + cfg%Lclzopaquecalipso=.false. + cfg%Lclcalipsoopaque=.false. + cfg%Lclcalipsothin=.false. + cfg%Lclcalipsozopaque=.false. + cfg%Lclcalipsoopacity=.false. + cfg%Lclopaquetemp=.false. + cfg%Lclthintemp=.false. + cfg%Lclzopaquetemp=.false. + cfg%Lclopaquemeanz=.false. + cfg%Lclthinmeanz=.false. + cfg%Lclthinemis=.false. + cfg%Lclopaquemeanzse=.false. + cfg%Lclthinmeanzse=.false. + cfg%Lclzopaquecalipsose=.false. + cfg%LcfadDbze94=.false. + cfg%Ldbze94=.false. + cfg%Lparasolrefl=.false. + cfg%Ltbrttov=.false. + cfg%Lptradarflag0=.false. + cfg%Lptradarflag1=.false. + cfg%Lptradarflag2=.false. + cfg%Lptradarflag3=.false. + cfg%Lptradarflag4=.false. + cfg%Lptradarflag5=.false. + cfg%Lptradarflag6=.false. + cfg%Lptradarflag7=.false. + cfg%Lptradarflag8=.false. + cfg%Lptradarflag9=.false. + cfg%Lradarpia=.false. + + end subroutine cosp_outputkeys_init + + + SUBROUTINE cosp_outputkeys_test(cfg) + implicit none + type(cosp_config),intent(out) :: cfg + character(len=32) :: out_list(107) + integer :: i + + do i=1,107 + cfg%out_list(i)='' + enddo + + cfg%Lcloudsat=.false. + cfg%Lcalipso=.true. + cfg%LgrLidar532=.false. + cfg%Latlid=.false. + cfg%Lisccp=.false. + cfg%Lmodis=.false. + cfg%Lmisr=.false. + cfg%Lrttov=.false. + cfg%Lparasol=.false. + cfg%Lwrite_output=.false. +! cfg%Lfracout=.false. + + cfg%Lpctisccp=.false. + cfg%Lclisccp=.false. + cfg%Lboxptopisccp=.false. + cfg%Lboxtauisccp=.false. + cfg%Ltauisccp=.false. + cfg%Lcltisccp=.false. + cfg%Lmeantbisccp=.false. + cfg%Lmeantbclrisccp=.false. + cfg%Lalbisccp=.false. + cfg%LclMISR=.false. + cfg%Lcltmodis=.false. + cfg%Lclwmodis=.false. + cfg%Lclimodis=.false. + cfg%Lclhmodis=.false. + cfg%Lclmmodis=.false. + cfg%Lcllmodis=.false. + cfg%Ltautmodis=.false. + cfg%Ltauwmodis=.false. + cfg%Ltauimodis=.false. + cfg%Ltautlogmodis=.false. + cfg%Ltauwlogmodis=.false. + cfg%Ltauilogmodis=.false. + cfg%Lreffclwmodis=.false. + cfg%Lreffclimodis=.false. + cfg%Lpctmodis=.false. + cfg%Llwpmodis=.false. + cfg%Liwpmodis=.false. + cfg%Lclmodis=.false. + cfg%Latb532=.false. + cfg%Latb532gr=.false. + cfg%Latb355=.false. + cfg%LlidarBetaMol532=.false. + cfg%LlidarBetaMol532gr=.false. + cfg%LlidarBetaMol355=.false. + cfg%LcfadLidarsr532=.false. + cfg%LcfadLidarsr532gr=.false. + cfg%LcfadLidarsr355 =.false. + cfg%Lclcalipso2=.false. + cfg%Lclcalipso=.false. + cfg%LclgrLidar532=.false. + cfg%Lclatlid=.false. + cfg%Lclhcalipso=.true. + cfg%Lcllcalipso=.true. + cfg%Lclmcalipso=.true. + cfg%Lcltcalipso=.true. + cfg%LclhgrLidar532=.false. + cfg%LcllgrLidar532=.false. + cfg%LclmgrLidar532 =.false. + cfg%LcltgrLidar532=.false. + cfg%Lclhatlid=.false. + cfg%Lcllatlid=.false. + cfg%Lclmatlid=.false. + cfg%Lcltatlid=.false. + cfg%Lcltlidarradar=.false. + cfg%Lcloudsat_tcc=.false. + cfg%Lcloudsat_tcc2=.false. + cfg%Lclcalipsoliq=.false. + cfg%Lclcalipsoice=.false. + cfg%Lclcalipsoun=.false. + cfg%Lclcalipsotmp=.false. + cfg%Lclcalipsotmpliq=.false. + cfg%Lclcalipsotmpice=.false. + cfg%Lclcalipsotmpun=.false. + cfg%Lcltcalipsoliq=.false. + cfg%Lcltcalipsoice=.false. + cfg%Lcltcalipsoun=.false. + cfg%Lclhcalipsoliq=.false. + cfg%Lclhcalipsoice=.false. + cfg%Lclhcalipsoun=.false. + cfg%Lclmcalipsoliq=.false. + cfg%Lclmcalipsoice=.false. + cfg%Lclmcalipsoun=.false. + cfg%Lcllcalipsoliq=.false. + cfg%Lcllcalipsoice=.false. + cfg%Lcllcalipsoun =.false. + cfg%Lclopaquecalipso=.false. + cfg%Lclthincalipso=.false. + cfg%Lclzopaquecalipso=.false. + cfg%Lclcalipsoopaque=.false. + cfg%Lclcalipsothin=.false. + cfg%Lclcalipsozopaque=.false. + cfg%Lclcalipsoopacity=.false. + cfg%Lclopaquetemp=.false. + cfg%Lclthintemp=.false. + cfg%Lclzopaquetemp=.false. + cfg%Lclopaquemeanz=.false. + cfg%Lclthinmeanz=.false. + cfg%Lclthinemis=.false. + cfg%Lclopaquemeanzse=.false. + cfg%Lclthinmeanzse=.false. + cfg%Lclzopaquecalipsose=.false. + cfg%LcfadDbze94=.false. + cfg%Ldbze94=.false. + cfg%Lparasolrefl=.false. + cfg%Ltbrttov=.false. + cfg%Lptradarflag0=.false. + cfg%Lptradarflag1=.false. + cfg%Lptradarflag2=.false. + cfg%Lptradarflag3=.false. + cfg%Lptradarflag4=.false. + cfg%Lptradarflag5=.false. + cfg%Lptradarflag6=.false. + cfg%Lptradarflag7=.false. + cfg%Lptradarflag8=.false. + cfg%Lptradarflag9=.false. + cfg%Lradarpia=.false. + + end subroutine cosp_outputkeys_test + + + SUBROUTINE READ_COSP_OUTPUT_NL(itap,cosp_nl,cfg) + USE lmdz_xios, ONLY: xios_field_is_active, using_xios + implicit none + character(len=*),intent(in) :: cosp_nl + type(cosp_config),intent(inout) :: cfg + ! Local variables + integer :: i, itap + +!COSPv2 + logical, save :: & + Lisccp = .false. ,& ! Local on/off switch for simulators + Lmodis = .false., & ! + Lmisr = .false., & ! + Lcalipso = .false., & ! + LgrLidar532 = .false., & ! + Latlid = .false., & ! + Lcloudsat = .false., & ! + Lrttov = .false., & ! + Lparasol = .false. ! + + + logical, save :: Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,Lclhcalipso, & + Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,Lclcalipsoliq, & + Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice, & + Lclcalipsotmpun,Lclhcalipsoliq,Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,& + Lclhcalipsoice,Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun, & + Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,Lclthincalipso, & + Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque, & + Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,Lclzopaquetemp,Lclopaquemeanz, & + Lclthinmeanz,Lclthinemis,Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,& + LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,LclhgrLidar532,& + LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,LlidarBetaMol355, & + LcfadLidarsr355,Latb355,Lclatlid,Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid, & + Lalbisccp,Lboxptopisccp,Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,& + Lmeantbisccp,Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar, & + Lcloudsat_tcc, Lcloudsat_tcc2,Lfracout, & + LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis, & + Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis,Ltauwlogmodis, & + Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis, & + Lclmodis,Ltbrttov,Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3, & + Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,Lptradarflag8, & + Lptradarflag9,Lradarpia + + namelist/COSP_OUTPUT/Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso, & + Lclhcalipso,Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl, & + Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp, & + Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun,Lclhcalipsoliq, & + Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,Lclhcalipsoice, & + Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun, & + Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso, & + Lclthincalipso,Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin, & + Lclcalipsozopaque,Lclcalipsoopacity,Lclopaquetemp,Lclthintemp, & + Lclzopaquetemp,Lclopaquemeanz,Lclthinmeanz,Lclthinemis, & + Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose, & + LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532, & + LclhgrLidar532,LcllgrLidar532,LclmgrLidar532,LcltgrLidar532, & + LlidarBetaMol355,LcfadLidarsr355,Latb355,Lclatlid, & + Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid,Lalbisccp,Lboxptopisccp, & + Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,Lmeantbisccp, & + Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar, & + Lcloudsat_tcc, Lcloudsat_tcc2, Lfracout, & + LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis, & + Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis, & + Ltautlogmodis,Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis, & + Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis,Lclmodis,Ltbrttov, & + Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3, & + Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7, & + Lptradarflag8,Lptradarflag9,Lradarpia + + do i=1,107 + 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 + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Which simulators need to be run? Look at which outputs are requested. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (Lpctisccp .or. Lclisccp .or. Lboxptopisccp .or. Lboxtauisccp .or. Ltauisccp .or. & + Lcltisccp .or. Lmeantbisccp .or. Lmeantbclrisccp .or. Lalbisccp) Lisccp = .true. + if (LclMISR) Lmisr = .true. + if (Lcltmodis .or. Lclwmodis .or. Lclimodis .or. Lclhmodis .or. Lclmmodis .or. & + Lcllmodis .or. Ltautmodis .or. Ltauwmodis .or. Ltauimodis .or. Ltautlogmodis .or. & + Ltauwlogmodis .or. Ltauilogmodis .or. Lreffclwmodis .or. Lreffclimodis .or. & + Lpctmodis .or. Llwpmodis .or. Liwpmodis .or. Lclmodis) Lmodis = .true. + if (Lclcalipso2 .or. Lclcalipso .or. Lclhcalipso .or. Lcllcalipso .or. Lclmcalipso & + .or. Lcltcalipso .or. Lcltlidarradar .or. Lclcalipsoliq .or. Lclcalipsoice .or. & + Lclcalipsoun .or. Lclcalipsotmp .or. Lclcalipsotmpliq .or. Lclcalipsotmpice .or. & + Lclcalipsotmpun .or. Lcltcalipsoliq .or. Lcltcalipsoice .or. Lcltcalipsoun .or. & + Lclhcalipsoliq .or. Lclhcalipsoice .or. Lclhcalipsoun .or. Lclmcalipsoliq .or. & + Lclmcalipsoice .or. Lclmcalipsoun .or. Lcllcalipsoliq .or. Lcllcalipsoice .or. & + Lcllcalipsoun .or. LlidarBetaMol532 .or. LcfadLidarsr532 .or. Lcltlidarradar .or. & + Lcltlidarradar .or. Lclopaquecalipso .or. Lclthincalipso .or. Lclzopaquecalipso & + .or. Lclcalipsoopaque .or. Lclcalipsothin .or. Lclcalipsozopaque .or. & + Lclcalipsoopacity .or. Lclopaquetemp .or. Lclthintemp .or. Lclzopaquetemp .or. & + Lclopaquemeanz .or. Lclthinmeanz .or. Lclthinemis .or. Lclopaquemeanzse .or. & + Lclthinmeanzse .or. Lclzopaquecalipsose) Lcalipso = .true. + + if (LlidarBetaMol532gr .or. LcfadLidarsr532gr .or. Latb532gr .or. LclgrLidar532 .or. & + LclhgrLidar532 .or. LcllgrLidar532 .or. LclmgrLidar532 .or. LcltgrLidar532) & + LgrLidar532 = .true. + + if (LlidarBetaMol355 .or. LcfadLidarsr355 .or. Latb355 .or. Lclatlid .or. & + Lclhatlid .or. Lcllatlid .or. Lclmatlid .or. Lcltatlid) & + Latlid = .true. + + if (LcfadDbze94 .or. Ldbze94 .or. Lcltlidarradar .or. Lptradarflag0 .or. Lptradarflag1 & + .or. Lptradarflag2 .or. Lptradarflag3 .or. Lptradarflag4 .or. Lptradarflag5 .or. & + Lptradarflag6 .or. Lptradarflag7 .or. Lptradarflag8 .or. Lptradarflag9 .or. & + Lradarpia) Lcloudsat = .true. + if (Lparasolrefl) Lparasol = .true. + if (Ltbrttov) Lrttov = .true. + + CALL bcast(Lcloudsat) + CALL bcast(Lcalipso) + CALL bcast(LgrLidar532) + CALL bcast(Latlid) + CALL bcast(Lparasol) + CALL bcast(Lisccp) + CALL bcast(Lmodis) + CALL bcast(Lmisr) + CALL bcast(Lrttov) + + CALL bcast(Lcfaddbze94) + CALL bcast(Ldbze94) + CALL bcast(Latb532) + CALL bcast(LcfadLidarsr532) + CALL bcast(Lclcalipso) + CALL bcast(Lclhcalipso) + CALL bcast(Lcllcalipso) + CALL bcast(Lclmcalipso) + CALL bcast(Lcltcalipso) + CALL bcast(LparasolRefl) + CALL bcast(Lclcalipsoliq) + CALL bcast(Lclcalipsoice) + CALL bcast(Lclcalipsoun) + CALL bcast(Lclcalipsotmp) + CALL bcast(Lclcalipsotmpliq) + CALL bcast(Lclcalipsotmpice) + CALL bcast(Lclcalipsotmpun) + CALL bcast(Lclhcalipsoliq) + CALL bcast(Lcllcalipsoliq) + CALL bcast(Lclmcalipsoliq) + CALL bcast(Lcltcalipsoliq) + CALL bcast(Lclhcalipsoice) + CALL bcast(Lcllcalipsoice) + CALL bcast(Lclmcalipsoice) + CALL bcast(Lcltcalipsoice) + CALL bcast(Lclhcalipsoun) + CALL bcast(Lcllcalipsoun) + CALL bcast(Lclmcalipsoun) + CALL bcast(Lcltcalipsoun) + CALL bcast(Lclopaquecalipso) + CALL bcast(Lclthincalipso) + CALL bcast(Lclzopaquecalipso) + CALL bcast(Lclcalipsoopaque) + CALL bcast(Lclcalipsothin) + CALL bcast(Lclcalipsozopaque) + CALL bcast(Lclcalipsoopacity) + CALL bcast(Lclopaquetemp) + CALL bcast(Lclthintemp) + CALL bcast(Lclzopaquetemp) + CALL bcast(Lclopaquemeanz) + CALL bcast(Lclthinmeanz) + CALL bcast(Lclthinemis) + CALL bcast(Lclopaquemeanzse) + CALL bcast(Lclthinmeanzse) + CALL bcast(Lclzopaquecalipsose) + CALL bcast(LlidarBetaMol532gr) + CALL bcast(LcfadLidarsr532gr) + CALL bcast(Latb532gr) + CALL bcast(LclgrLidar532) + CALL bcast(LclhgrLidar532) + CALL bcast(LcllgrLidar532) + CALL bcast(LclmgrLidar532) + CALL bcast(LcltgrLidar532) + CALL bcast(LlidarBetaMol355) + CALL bcast(LcfadLidarsr355) + CALL bcast(Latb355) + CALL bcast(Lclatlid) + CALL bcast(Lclhatlid) + CALL bcast(Lcllatlid) + CALL bcast(Lclmatlid) + CALL bcast(Lcltatlid) + CALL bcast(Lalbisccp) + CALL bcast(Lboxptopisccp) + CALL bcast(Lboxtauisccp) + CALL bcast(Lpctisccp) + CALL bcast(Lclisccp) + CALL bcast(Ltauisccp) + CALL bcast(Lcltisccp) + CALL bcast(Lmeantbisccp) + CALL bcast(Lmeantbclrisccp) + CALL bcast(LclMISR) + CALL bcast(Lclcalipso2) + CALL bcast(Lcltlidarradar) + CALL bcast(Lcloudsat_tcc) + CALL bcast(Lcloudsat_tcc2) + 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(Lptradarflag0) + CALL bcast(Lptradarflag1) + CALL bcast(Lptradarflag2) + CALL bcast(Lptradarflag3) + CALL bcast(Lptradarflag4) + CALL bcast(Lptradarflag5) + CALL bcast(Lptradarflag6) + CALL bcast(Lptradarflag7) + CALL bcast(Lptradarflag8) + CALL bcast(Lptradarflag9) + CALL bcast(Lradarpia) + +!$OMP BARRIER + + ! Copy instrument flags to cfg structure + cfg%Lcloudsat = Lcloudsat + cfg%Lcalipso = Lcalipso + cfg%LgrLidar532 = LgrLidar532 + cfg%Latlid = Latlid + cfg%Lisccp = Lisccp + cfg%Lmodis = Lmodis + cfg%Lmisr = Lmisr + cfg%Lrttov = Lrttov + cfg%Lparasol = Lparasol + + print*,' cfg%Lcloudsat = ',cfg%Lcloudsat + + ! Flag to control output to file + cfg%Lwrite_output = .false. + if (cfg%Lcloudsat .or. cfg%Lcalipso .or. cfg%LgrLidar532 .or. cfg%Latlid .or. cfg%Lisccp .or. cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lrttov .or. cfg%Lparasol .or. Lfracout) then + cfg%Lwrite_output = .true. + endif + + ! Output diagnostics + i = 1 + + if (Lcfaddbze94) cfg%out_list(i) = 'cfaddbze94' + i = i+1 + if (Ldbze94) cfg%out_list(i) = 'dbze94' + i = i+1 + if (Latb532) cfg%out_list(i) = 'atb532' + i = i+1 + if (LcfadLidarsr532) cfg%out_list(i) = 'cfadLidarsr532' + i = i+1 + if (Lclcalipso) cfg%out_list(i) = 'clcalipso' + i = i+1 + if (Lclhcalipso) cfg%out_list(i) = 'clhcalipso' + 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 (LparasolRefl) cfg%out_list(i) = 'parasolRefl' + i = i+1 + if (Lclcalipsoliq) cfg%out_list(i) = 'clcalipsoliq' + i = i+1 + if (Lclcalipsoice) cfg%out_list(i) = 'clcalipsoice' + i = i+1 + if (Lclcalipsoun) cfg%out_list(i) = 'clcalipsoun' + i = i+1 + if (Lclcalipsotmp) cfg%out_list(i) = 'clcalipsotmp' + i = i+1 + if (Lclcalipsotmpliq) cfg%out_list(i) = 'clcalipsotmpliq' + i = i+1 + if (Lclcalipsotmpice) cfg%out_list(i) = 'clcalipsotmpice' + i = i+1 + if (Lclcalipsotmpun) cfg%out_list(i) = 'clcalipsotmpun' + i = i+1 + if (Lclhcalipsoliq) cfg%out_list(i) = 'clhcalipsoliq' + i = i+1 + if (Lcllcalipsoliq) cfg%out_list(i) = 'cllcalipsoliq' + i = i+1 + if (Lclmcalipsoliq) cfg%out_list(i) = 'clmcalipsoliq' + i = i+1 + if (Lcltcalipsoliq) cfg%out_list(i) = 'cltcalipsoliq' + i = i+1 + if (Lclhcalipsoice) cfg%out_list(i) = 'clhcalipsoice' + i = i+1 + if (Lcllcalipsoice) cfg%out_list(i) = 'cllcalipsoice' + i = i+1 + if (Lclmcalipsoice) cfg%out_list(i) = 'clmcalipsoice' + i = i+1 + if (Lcltcalipsoice) cfg%out_list(i) = 'cltcalipsoice' + i = i+1 + if (Lclhcalipsoun) cfg%out_list(i) = 'clhcalipsoun' + i = i+1 + if (Lcllcalipsoun) cfg%out_list(i) = 'cllcalipsoun' + i = i+1 + if (Lclmcalipsoun) cfg%out_list(i) = 'clmcalipsoun' + i = i+1 + if (Lcltcalipsoun) cfg%out_list(i) = 'cltcalipsoun' + i = i+1 + if (Lclopaquecalipso) cfg%out_list(i) = 'clopaquecalipso' + i = i+1 + if (Lclthincalipso) cfg%out_list(i) = 'clthincalipso' + i = i+1 + if (Lclzopaquecalipso) cfg%out_list(i) = 'clzopaquecalipso' + i = i+1 + if (Lclcalipsoopaque) cfg%out_list(i) = 'clcalipsoopaque' + i = i+1 + if (Lclcalipsothin) cfg%out_list(i) = 'clcalipsothin' + i = i+1 + if (Lclcalipsozopaque) cfg%out_list(i) = 'clcalipsozopaque' + i = i+1 + if (Lclcalipsoopacity) cfg%out_list(i) = 'clcalipsoopacity' + i = i+1 + if (Lclopaquetemp) cfg%out_list(i) = 'clopaquetemp' + i = i+1 + if (Lclthintemp) cfg%out_list(i) = 'clthintemp' + i = i+1 + if (Lclzopaquetemp) cfg%out_list(i) = 'clzopaquetemp' + i = i+1 + if (Lclopaquemeanz) cfg%out_list(i) = 'clopaquemeanz' + i = i+1 + if (Lclthinmeanz) cfg%out_list(i) = 'clthinmeanz' + i = i+1 + if (Lclthinemis) cfg%out_list(i) = 'clthinemis' + i = i+1 + if (Lclopaquemeanzse) cfg%out_list(i) = 'clopaquemeanzse' + i = i+1 + if (Lclthinmeanzse) cfg%out_list(i) = 'clthinmeanzse' + i = i+1 + if (Lclzopaquecalipsose) cfg%out_list(i) = 'clzopaquecalipsose' + i = i+1 + if (LlidarBetaMol532gr) cfg%out_list(i) = 'lidarBetaMol532gr' + i = i+1 + if (LcfadLidarsr532gr) cfg%out_list(i) = 'cfadLidarsr532gr' + i = i+1 + if (Latb532gr) cfg%out_list(i) = 'atb532gr' + i = i+1 + if (LclgrLidar532) cfg%out_list(i) = 'clgrLidar532' + i = i+1 + if (LclhgrLidar532) cfg%out_list(i) = 'clhgrLidar532' + i = i+1 + if (LcllgrLidar532) cfg%out_list(i) = 'cllgrLidar532' + i = i+1 + if (LclmgrLidar532) cfg%out_list(i) = 'clmgrLidar532' + i = i+1 + if (LcltgrLidar532) cfg%out_list(i) = 'cltgrLidar532' + i = i+1 + if (LlidarBetaMol355) cfg%out_list(i) = 'lidarBetaMol355' + i = i+1 + if (LcfadLidarsr355) cfg%out_list(i) = 'cfadLidarsr355' + i = i+1 + if (Latb355) cfg%out_list(i) = 'atb355' + i = i+1 + if (Lclatlid) cfg%out_list(i) = 'clatlid' + i = i+1 + if (Lclhatlid) cfg%out_list(i) = 'clhatlid' + i = i+1 + if (Lcllatlid) cfg%out_list(i) = 'cllatlid' + i = i+1 + if (Lclmatlid) cfg%out_list(i) = 'clmatlid' + i = i+1 + if (Lcltatlid) cfg%out_list(i) = 'cltatlid' + i = i+1 + if (Lalbisccp) cfg%out_list(i) = 'albisccp' + i = i+1 + if (Lboxptopisccp) cfg%out_list(i) = 'boxptopisccp' + i = i+1 + if (Lboxtauisccp) cfg%out_list(i) = 'boxtauisccp' + i = i+1 + if (Lpctisccp) cfg%out_list(i) = 'pctisccp' + i = i+1 + if (Lclisccp) cfg%out_list(i) = 'clisccp' + i = i+1 + if (Ltauisccp) cfg%out_list(i) = 'tauisccp' + i = i+1 + if (Lcltisccp) cfg%out_list(i) = 'cltisccp' + i = i+1 + if (Lmeantbisccp) cfg%out_list(i) = 'meantbisccp' + i = i+1 + if (Lmeantbclrisccp) cfg%out_list(i) = 'meantbclrisccp' + i = i+1 + if (LclMISR) cfg%out_list(i) = 'clMISR' + i = i+1 + if (Lclcalipso2) cfg%out_list(i) = 'clcalipso2' + i = i+1 + if (Lcltlidarradar) cfg%out_list(i) = 'cltlidarradar' + i = i+1 + if (Lcloudsat_tcc) cfg%out_list(i) = 'cloudsat_tcc' + i = i+1 + if (Lcloudsat_tcc2) cfg%out_list(i) = 'cloudsat_tcc2' + i = i+1 + if (Lfracout) cfg%out_list(i) = 'fracout' + i = i+1 + if (LlidarBetaMol532) cfg%out_list(i) = 'lidarBetaMol532' + 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 (Ltbrttov) cfg%out_list(i) = 'tbrttov' + i = i+1 + if (Lptradarflag0) cfg%out_list(i) = 'ptradarflag0' + i = i+1 + if (Lptradarflag1) cfg%out_list(i) = 'ptradarflag1' + i = i+1 + if (Lptradarflag2) cfg%out_list(i) = 'ptradarflag2' + i = i+1 + if (Lptradarflag3) cfg%out_list(i) = 'ptradarflag3' + i = i+1 + if (Lptradarflag4) cfg%out_list(i) = 'ptradarflag4' + i = i+1 + if (Lptradarflag5) cfg%out_list(i) = 'ptradarflag5' + i = i+1 + if (Lptradarflag6) cfg%out_list(i) = 'ptradarflag6' + i = i+1 + if (Lptradarflag7) cfg%out_list(i) = 'ptradarflag7' + i = i+1 + if (Lptradarflag8) cfg%out_list(i) = 'ptradarflag8' + i = i+1 + if (Lptradarflag9) cfg%out_list(i) = 'ptradarflag9' + i = i+1 + if (Lradarpia) cfg%out_list(i) = 'radarpia' +! i = i+1 !si on laisse, 108 au lieu de 107 + + if (i.gt.107) then + print *, 'COSP_IO: wrong number of output diagnostics' + print *, i,107 + stop + endif + + + ! Copy diagnostic flags to cfg structure + + cfg%Lpctisccp = Lpctisccp + cfg%Lclisccp = Lclisccp + cfg%Lboxptopisccp = Lboxptopisccp + cfg%Lboxtauisccp = Lboxtauisccp + cfg%Ltauisccp = Ltauisccp + cfg%Lcltisccp = Lcltisccp + cfg%Lmeantbisccp = Lmeantbisccp + cfg%Lmeantbclrisccp = Lmeantbclrisccp + cfg%Lalbisccp = Lalbisccp + cfg%LclMISR = LclMISR + 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%Latb532 = Latb532 + cfg%Latb532gr = Latb532gr + cfg%Latb355 = Latb355 + cfg%LlidarBetaMol532 = LlidarBetaMol532 + cfg%LlidarBetaMol532gr = LlidarBetaMol532gr + cfg%LlidarBetaMol355 = LlidarBetaMol355 + cfg%LcfadLidarsr532 = LcfadLidarsr532 + cfg%LcfadLidarsr532gr = LcfadLidarsr532gr + cfg%LcfadLidarsr355 = LcfadLidarsr355 + cfg%Lclcalipso2 = Lclcalipso2 + cfg%Lclcalipso = Lclcalipso + cfg%LclgrLidar532 = LclgrLidar532 + cfg%Lclatlid = Lclatlid + cfg%Lclhcalipso = Lclhcalipso + cfg%Lcllcalipso = Lcllcalipso + cfg%Lclmcalipso = Lclmcalipso + cfg%Lcltcalipso = Lcltcalipso + cfg%LclhgrLidar532 = LclhgrLidar532 + cfg%LcllgrLidar532 = LcllgrLidar532 + cfg%LclmgrLidar532 = LclmgrLidar532 + cfg%LcltgrLidar532 = LcltgrLidar532 + cfg%Lclhatlid = Lclhatlid + cfg%Lcllatlid = Lcllatlid + cfg%Lclmatlid = Lclmatlid + cfg%Lcltatlid = Lcltatlid + cfg%Lcltlidarradar = Lcltlidarradar + cfg%Lcloudsat_tcc = Lcloudsat_tcc + cfg%Lcloudsat_tcc2 = Lcloudsat_tcc2 + cfg%Lclcalipsoliq = Lclcalipsoliq + cfg%Lclcalipsoice = Lclcalipsoice + cfg%Lclcalipsoun = Lclcalipsoun + cfg%Lclcalipsotmp = Lclcalipsotmp + cfg%Lclcalipsotmpliq = Lclcalipsotmpliq + cfg%Lclcalipsotmpice = Lclcalipsotmpice + cfg%Lclcalipsotmpun = Lclcalipsotmpun + cfg%Lcltcalipsoliq = Lcltcalipsoliq + cfg%Lcltcalipsoice = Lcltcalipsoice + cfg%Lcltcalipsoun = Lcltcalipsoun + cfg%Lclhcalipsoliq = Lclhcalipsoliq + cfg%Lclhcalipsoice = Lclhcalipsoice + cfg%Lclhcalipsoun = Lclhcalipsoun + cfg%Lclmcalipsoliq = Lclmcalipsoliq + cfg%Lclmcalipsoice = Lclmcalipsoice + cfg%Lclmcalipsoun = Lclmcalipsoun + cfg%Lcllcalipsoliq = Lcllcalipsoliq + cfg%Lcllcalipsoice = Lcllcalipsoice + cfg%Lcllcalipsoun = Lcllcalipsoun + cfg%Lclopaquecalipso = Lclopaquecalipso + cfg%Lclthincalipso = Lclthincalipso + cfg%Lclzopaquecalipso = Lclzopaquecalipso + cfg%Lclcalipsoopaque = Lclcalipsoopaque + cfg%Lclcalipsothin = Lclcalipsothin + cfg%Lclcalipsozopaque = Lclcalipsozopaque + cfg%Lclcalipsoopacity = Lclcalipsoopacity + cfg%Lclopaquetemp = Lclopaquetemp + cfg%Lclthintemp = Lclthintemp + cfg%Lclzopaquetemp = Lclzopaquetemp + cfg%Lclopaquemeanz = Lclopaquemeanz + cfg%Lclthinmeanz = Lclthinmeanz + cfg%Lclthinemis = Lclthinemis + cfg%Lclopaquemeanzse = Lclopaquemeanzse + cfg%Lclthinmeanzse = Lclthinmeanzse + cfg%Lclzopaquecalipsose = Lclzopaquecalipsose + cfg%LcfadDbze94 = LcfadDbze94 + cfg%Ldbze94 = Ldbze94 + cfg%Lparasolrefl = Lparasolrefl + cfg%Ltbrttov = Ltbrttov + cfg%Lptradarflag0 = Lptradarflag0 + cfg%Lptradarflag1 = Lptradarflag1 + cfg%Lptradarflag2 = Lptradarflag2 + cfg%Lptradarflag3 = Lptradarflag3 + cfg%Lptradarflag4 = Lptradarflag4 + cfg%Lptradarflag5 = Lptradarflag5 + cfg%Lptradarflag6 = Lptradarflag6 + cfg%Lptradarflag7 = Lptradarflag7 + cfg%Lptradarflag8 = Lptradarflag8 + cfg%Lptradarflag9 = Lptradarflag9 + cfg%Lradarpia = Lradarpia + cfg%Lfracout = Lfracout + + END SUBROUTINE READ_COSP_OUTPUT_NL + + + SUBROUTINE read_xiosfieldactive(cfg) + USE lmdz_xios, ONLY: xios_field_is_active, using_xios + implicit none + type(cosp_config),intent(inout) :: cfg + integer :: i + +!COSPv2 local variables + logical :: & + Lisccp = .false., & ! Local on/off switch for simulators + Lmodis = .false., & ! + Lmisr = .false., & ! + Lcalipso = .false., & ! + LgrLidar532 = .false., & ! + Latlid = .false., & ! + Lcloudsat = .false., & ! + Lrttov = .false., & ! + Lparasol = .false., & ! + Lwrite_output=.false. ! ecrire un fichier de sortie COSP ! RG voir si on garde + + logical :: Lcfaddbze94,Ldbze94,Latb532,LcfadLidarsr532,Lclcalipso,Lclhcalipso, & + Lcllcalipso,Lclmcalipso,Lcltcalipso,LparasolRefl,Lclcalipsoliq, & + Lclcalipsoice,Lclcalipsoun,Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice, & + Lclcalipsotmpun,Lclhcalipsoliq,Lcllcalipsoliq,Lclmcalipsoliq,Lcltcalipsoliq,& + Lclhcalipsoice,Lcllcalipsoice,Lclmcalipsoice,Lcltcalipsoice,Lclhcalipsoun, & + Lcllcalipsoun,Lclmcalipsoun,Lcltcalipsoun,Lclopaquecalipso,Lclthincalipso, & + Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque, & + Lclcalipsoopacity,Lclopaquetemp,Lclthintemp,Lclzopaquetemp,Lclopaquemeanz, & + Lclthinmeanz,Lclthinemis,Lclopaquemeanzse,Lclthinmeanzse,Lclzopaquecalipsose,& + LlidarBetaMol532gr,LcfadLidarsr532gr,Latb532gr,LclgrLidar532,LclhgrLidar532,& + LcllgrLidar532,LclmgrLidar532,LcltgrLidar532,LlidarBetaMol355, & + LcfadLidarsr355,Latb355,Lclatlid,Lclhatlid,Lcllatlid,Lclmatlid,Lcltatlid, & + Lalbisccp,Lboxptopisccp,Lboxtauisccp,Lpctisccp,Lclisccp,Ltauisccp,Lcltisccp,& + Lmeantbisccp,Lmeantbclrisccp,LclMISR,Lclcalipso2,Lcltlidarradar, & + Lcloudsat_tcc, Lcloudsat_tcc2,Lfracout, & + LlidarBetaMol532,Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis, & + Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis,Ltauwlogmodis, & + Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis,Liwpmodis, & + Lclmodis,Ltbrttov,Lptradarflag0,Lptradarflag1,Lptradarflag2,Lptradarflag3, & + Lptradarflag4,Lptradarflag5,Lptradarflag6,Lptradarflag7,Lptradarflag8, & + Lptradarflag9,Lradarpia + + + character(len=32) :: out_list(107) + + IF (using_xios) THEN + + do i=1,107 + cfg%out_list(i)='' + enddo + +! diagnostics + Lpctisccp=.false. + Lclisccp=.false. + Lboxptopisccp=.false. + Lboxtauisccp=.false. + Ltauisccp=.false. + Lcltisccp=.false. + Lmeantbisccp=.false. + Lmeantbclrisccp=.false. + Lalbisccp=.false. + LclMISR=.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. + Latb532=.false. + Latb532gr=.false. + Latb355=.false. + LlidarBetaMol532=.false. + LlidarBetaMol532gr=.false. + LlidarBetaMol355=.false. + LcfadLidarsr532=.false. + LcfadLidarsr532gr=.false. + LcfadLidarsr355 =.false. + Lclcalipso2=.false. + Lclcalipso=.false. + LclgrLidar532=.false. + Lclatlid=.false. + Lclhcalipso=.false. + Lcllcalipso=.false. + Lclmcalipso=.false. + Lcltcalipso=.false. + LclhgrLidar532=.false. + LcllgrLidar532=.false. + LclmgrLidar532 =.false. + LcltgrLidar532=.false. + Lclhatlid=.false. + Lcllatlid=.false. + Lclmatlid=.false. + Lcltatlid=.false. + Lcltlidarradar=.false. + Lcloudsat_tcc=.false. + Lcloudsat_tcc2=.false. + Lclcalipsoliq=.false. + Lclcalipsoice=.false. + Lclcalipsoun=.false. + Lclcalipsotmp=.false. + Lclcalipsotmpliq=.false. + Lclcalipsotmpice=.false. + Lclcalipsotmpun=.false. + Lcltcalipsoliq=.false. + Lcltcalipsoice=.false. + Lcltcalipsoun=.false. + Lclhcalipsoliq=.false. + Lclhcalipsoice=.false. + Lclhcalipsoun=.false. + Lclmcalipsoliq=.false. + Lclmcalipsoice=.false. + Lclmcalipsoun=.false. + Lcllcalipsoliq=.false. + Lcllcalipsoice=.false. + Lcllcalipsoun =.false. + Lclopaquecalipso=.false. + Lclthincalipso=.false. + Lclzopaquecalipso=.false. + Lclcalipsoopaque=.false. + Lclcalipsothin=.false. + Lclcalipsozopaque=.false. + Lclcalipsoopacity=.false. + Lclopaquetemp=.false. + Lclthintemp=.false. + Lclzopaquetemp=.false. + Lclopaquemeanz=.false. + Lclthinmeanz=.false. + Lclthinemis=.false. + Lclopaquemeanzse=.false. + Lclthinmeanzse=.false. + Lclzopaquecalipsose=.false. + LcfadDbze94=.false. + Ldbze94=.false. + Lparasolrefl=.false. + Ltbrttov=.false. + Lptradarflag0=.false. + Lptradarflag1=.false. + Lptradarflag2=.false. + Lptradarflag3=.false. + Lptradarflag4=.false. + Lptradarflag5=.false. + Lptradarflag6=.false. + Lptradarflag7=.false. + Lptradarflag8=.false. + Lptradarflag9=.false. + Lradarpia=.false. + Lfracout=.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_crefl")) cfg%LparasolRefl=.TRUE. +! IF (xios_field_is_active("Ncrefl")) cfg%LparasolRefl=.TRUE. + IF (xios_field_is_active("cfadLidarsr532")) LcfadLidarsr532=.TRUE. + IF (xios_field_is_active("atb532")) Latb532=.TRUE. + IF (xios_field_is_active("lidarBetaMol532")) 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("clopaquetemp")) Lclopaquetemp=.TRUE. + IF (xios_field_is_active("clthintemp")) Lclthintemp=.TRUE. + IF (xios_field_is_active("clzopaquetemp")) Lclzopaquetemp=.TRUE. + IF (xios_field_is_active("clopaquemeanz")) Lclopaquemeanz=.TRUE. + IF (xios_field_is_active("clthinmeanz")) Lclthinmeanz=.TRUE. + IF (xios_field_is_active("clthinemis")) Lclthinemis=.TRUE. + IF (xios_field_is_active("clopaquemeanzse")) Lclopaquemeanzse=.TRUE. + IF (xios_field_is_active("clthinmeanzse")) Lclthinmeanzse=.TRUE. + IF (xios_field_is_active("clzopaquecalipsose")) Lclzopaquecalipsose=.TRUE. +!!!! 43 champs CALIPSO + + IF (xios_field_is_active("parasolGrid_refl")) LparasolRefl=.TRUE. + IF (xios_field_is_active("parasolPix_refl")) LparasolRefl=.TRUE. +!!!! 2 champs PARASOL controles par une seule clef logique + + IF (xios_field_is_active("lidarBetaMol532gr")) LlidarBetaMol532gr=.TRUE. + IF (xios_field_is_active("cfadLidarsr532gr")) LcfadLidarsr532gr=.TRUE. + IF (xios_field_is_active("atb532gr")) Latb532gr=.TRUE. + IF (xios_field_is_active("clgrLidar532")) LclgrLidar532=.TRUE. + IF (xios_field_is_active("clhgrLidar532")) LclhgrLidar532=.TRUE. + IF (xios_field_is_active("cllgrLidar532")) LcllgrLidar532=.TRUE. + IF (xios_field_is_active("clmgrLidar532")) LclmgrLidar532=.TRUE. + IF (xios_field_is_active("cltgrLidar532")) LcltgrLidar532=.TRUE. +!!!! 8 champs GROUND LIDAR 532 nm + + IF (xios_field_is_active("lidarBetaMol355")) LlidarBetaMol355=.TRUE. + IF (xios_field_is_active("cfadLidarsr355")) LcfadLidarsr355=.TRUE. + IF (xios_field_is_active("atb355")) Latb355=.TRUE. + IF (xios_field_is_active("clatlid")) Lclatlid=.TRUE. + IF (xios_field_is_active("clhatlid")) Lclhatlid=.TRUE. + IF (xios_field_is_active("cllatlid")) Lcllatlid=.TRUE. + IF (xios_field_is_active("clmatlid")) Lclmatlid=.TRUE. + IF (xios_field_is_active("cltatlid")) Lcltatlid=.TRUE. +!!!! 8 champs ATLID + + IF (xios_field_is_active("cfadDbze94")) LcfadDbze94=.TRUE. + IF (xios_field_is_active("dbze94")) Ldbze94=.TRUE. + IF (xios_field_is_active("ptradarflag0")) Lptradarflag0=.TRUE. + IF (xios_field_is_active("ptradarflag1")) Lptradarflag1=.TRUE. + IF (xios_field_is_active("ptradarflag2")) Lptradarflag2=.TRUE. + IF (xios_field_is_active("ptradarflag3")) Lptradarflag3=.TRUE. + IF (xios_field_is_active("ptradarflag4")) Lptradarflag4=.TRUE. + IF (xios_field_is_active("ptradarflag5")) Lptradarflag5=.TRUE. + IF (xios_field_is_active("ptradarflag6")) Lptradarflag6=.TRUE. + IF (xios_field_is_active("ptradarflag7")) Lptradarflag7=.TRUE. + IF (xios_field_is_active("ptradarflag8")) Lptradarflag8=.TRUE. + IF (xios_field_is_active("ptradarflag9")) Lptradarflag9=.TRUE. + IF (xios_field_is_active("radarpia")) Lradarpia=.TRUE. +!!! 13 champs CLOUDSAT + + IF (xios_field_is_active("cltlidarradar")) Lcltlidarradar=.TRUE. + IF (xios_field_is_active("clcalipso2")) Lclcalipso2=.TRUE. + IF (xios_field_is_active("cloudsat_tcc")) Lcloudsat_tcc=.TRUE. !COSPv2 + IF (xios_field_is_active("cloudsat_tcc2")) Lcloudsat_tcc2=.TRUE. !COSPv2 +!!! 4 champs CLOUDSAT et CALIPSO + + IF (xios_field_is_active("clisccp")) Lclisccp=.TRUE. + IF (xios_field_is_active("boxtauisccp")) Lboxtauisccp=.TRUE. + IF (xios_field_is_active("boxptopisccp")) Lboxptopisccp=.TRUE. + IF (xios_field_is_active("cltisccp")) Lcltisccp=.TRUE. + IF (xios_field_is_active("pctisccp")) 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("misr_fq")) LclMISR=.TRUE. + IF (xios_field_is_active("misr_meanztop")) LclMISR=.TRUE. + IF (xios_field_is_active("misr_cldarea")) LclMISR=.TRUE. +!!! 3 champs MISR controles par une seule clef logique + + 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("modis_ot_vs_ctp")) Lclmodis=.TRUE. + IF (xios_field_is_active("modis_ot_vs_reffice")) Lclmodis=.TRUE. + IF (xios_field_is_active("modis_ot_vs_reffliq")) Lclmodis=.TRUE. +! IF (xios_field_is_active("crimodis")) Lcrimodis=.TRUE. !COSPv2 +! IF (xios_field_is_active("crlmodis")) Lcrlmodis=.TRUE. !COSPv2 +!!! 20 champs MODIS dont 3 champs controles par la clef logique "clmodis" + +! IF (xios_field_is_active("tbrttov")) cfg%Ltbrttov=.TRUE. +! IF (xios_field_is_active("fracout")) Lfracout=.TRUE. + +!!! 106 diagnostics en tout dans COSPv2 + fracout (107) + + +! 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("cfadLidarsr532").OR. & + xios_field_is_active("atb532").OR. & + xios_field_is_active("lidarBetaMol532").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("clopaquetemp").OR. & + xios_field_is_active("clthintemp").OR. & + xios_field_is_active("clzopaquetemp").OR. & + xios_field_is_active("clopaquemeanz").OR. & + xios_field_is_active("clthinmeanz").OR. & + xios_field_is_active("clthinemis").OR. & + xios_field_is_active("clopaquemeanzse").OR. & + xios_field_is_active("clthinmeanzse").OR. & + xios_field_is_active("clzopaquecalipsose")) Lcalipso=.TRUE. + + IF (xios_field_is_active("parasolGrid_refl").OR. & + xios_field_is_active("parasolPix_refl")) Lparasol=.TRUE. + + IF (xios_field_is_active("lidarBetaMol532gr").OR. & + xios_field_is_active("cfadLidarsr532gr").OR. & + xios_field_is_active("atb532gr").OR. & + xios_field_is_active("clgrLidar532").OR. & + xios_field_is_active("clhgrLidar532").OR. & + xios_field_is_active("cllgrLidar532").OR. & + xios_field_is_active("clmgrLidar532").OR. & + xios_field_is_active("cltgrLidar532")) LgrLidar532=.TRUE. + + IF (xios_field_is_active("lidarBetaMol355").OR. & + xios_field_is_active("cfadLidarsr355").OR. & + xios_field_is_active("atb355").OR. & + xios_field_is_active("clatlid").OR. & + xios_field_is_active("clhatlid").OR. & + xios_field_is_active("cllatlid").OR. & + xios_field_is_active("clmatlid").OR. & + xios_field_is_active("cltatlid")) Latlid=.TRUE. + + IF (xios_field_is_active("cfadDbze94").OR. & + xios_field_is_active("dbze94").OR. & + xios_field_is_active("ptradarflag0").OR. & + xios_field_is_active("ptradarflag1").OR. & + xios_field_is_active("ptradarflag2").OR. & + xios_field_is_active("ptradarflag3").OR. & + xios_field_is_active("ptradarflag4").OR. & + xios_field_is_active("ptradarflag5").OR. & + xios_field_is_active("ptradarflag6").OR. & + xios_field_is_active("ptradarflag7").OR. & + xios_field_is_active("ptradarflag8").OR. & + xios_field_is_active("ptradarflag9").OR. & + xios_field_is_active("radarpia")) Lcloudsat=.TRUE. + + IF (xios_field_is_active("cltlidarradar").OR. & + xios_field_is_active("clcalipso2").OR. & + xios_field_is_active("cloudsat_tcc").OR. & + xios_field_is_active("cloudsat_tcc2")) THEN + Lcloudsat=.TRUE. + Lcalipso=.TRUE. + ENDIF + + IF (xios_field_is_active("clisccp").OR. & !COSPv2 nouveau nom + xios_field_is_active("boxtauisccp").OR. & + xios_field_is_active("boxptopisccp").OR. & + xios_field_is_active("cltisccp").OR. & !COSPv2 nouveau nom + xios_field_is_active("pctisccp").OR. & !COSPv2 nouveau nom + xios_field_is_active("tauisccp").OR. & + xios_field_is_active("albisccp").OR. & + xios_field_is_active("meantbisccp").OR. & + xios_field_is_active("meantbclrisccp")) Lisccp=.TRUE. + + IF (xios_field_is_active("misr_fq").OR. & + xios_field_is_active("misr_meanztop").OR. & + xios_field_is_active("misr_cldarea")) Lmisr=.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("modis_ot_vs_ctp").OR. & + xios_field_is_active("modis_ot_vs_reffice").OR. & + xios_field_is_active("modis_ot_vs_reffliq")) Lmodis=.TRUE. +! xios_field_is_active("crimodis").OR. & !COSPv2 n'existe plus +! xios_field_is_active("crlmodis")) Lmodis_sim=.TRUE. !COSPv2 n'existe plus + + ENDIF ! (is_master) + +!$OMP BARRIER + + CALL bcast(Lcloudsat) + CALL bcast(Lcalipso) + CALL bcast(LgrLidar532) + CALL bcast(Latlid) + CALL bcast(Lisccp) + CALL bcast(Lmodis) + CALL bcast(Lmisr) + CALL bcast(Lparasol) + CALL bcast(Lrttov) + + CALL bcast(Lcfaddbze94) + CALL bcast(Ldbze94) + CALL bcast(Latb532) + CALL bcast(LcfadLidarsr532) + CALL bcast(Lclcalipso) + CALL bcast(Lclhcalipso) + CALL bcast(Lcllcalipso) + CALL bcast(Lclmcalipso) + CALL bcast(Lcltcalipso) + CALL bcast(LparasolRefl) + CALL bcast(Lclcalipsoliq) + CALL bcast(Lclcalipsoice) + CALL bcast(Lclcalipsoun) + CALL bcast(Lclcalipsotmp) + CALL bcast(Lclcalipsotmpliq) + CALL bcast(Lclcalipsotmpice) + CALL bcast(Lclcalipsotmpun) + CALL bcast(Lclhcalipsoliq) + CALL bcast(Lcllcalipsoliq) + CALL bcast(Lclmcalipsoliq) + CALL bcast(Lcltcalipsoliq) + CALL bcast(Lclhcalipsoice) + CALL bcast(Lcllcalipsoice) + CALL bcast(Lclmcalipsoice) + CALL bcast(Lcltcalipsoice) + CALL bcast(Lclhcalipsoun) + CALL bcast(Lcllcalipsoun) + CALL bcast(Lclmcalipsoun) + CALL bcast(Lcltcalipsoun) + CALL bcast(Lclopaquecalipso) + CALL bcast(Lclthincalipso) + CALL bcast(Lclzopaquecalipso) + CALL bcast(Lclcalipsoopaque) + CALL bcast(Lclcalipsothin) + CALL bcast(Lclcalipsozopaque) + CALL bcast(Lclcalipsoopacity) + CALL bcast(Lclopaquetemp) + CALL bcast(Lclthintemp) + CALL bcast(Lclzopaquetemp) + CALL bcast(Lclopaquemeanz) + CALL bcast(Lclthinmeanz) + CALL bcast(Lclthinemis) + CALL bcast(Lclopaquemeanzse) + CALL bcast(Lclthinmeanzse) + CALL bcast(Lclzopaquecalipsose) + CALL bcast(LlidarBetaMol532gr) + CALL bcast(LcfadLidarsr532gr) + CALL bcast(Latb532gr) + CALL bcast(LclgrLidar532) + CALL bcast(LclhgrLidar532) + CALL bcast(LcllgrLidar532) + CALL bcast(LclmgrLidar532) + CALL bcast(LcltgrLidar532) + CALL bcast(LlidarBetaMol355) + CALL bcast(LcfadLidarsr355) + CALL bcast(Latb355) + CALL bcast(Lclatlid) + CALL bcast(Lclhatlid) + CALL bcast(Lcllatlid) + CALL bcast(Lclmatlid) + CALL bcast(Lcltatlid) + CALL bcast(Lalbisccp) + CALL bcast(Lboxptopisccp) + CALL bcast(Lboxtauisccp) + CALL bcast(Lpctisccp) + CALL bcast(Lclisccp) + CALL bcast(Ltauisccp) + CALL bcast(Lcltisccp) + CALL bcast(Lmeantbisccp) + CALL bcast(Lmeantbclrisccp) + CALL bcast(LclMISR) + CALL bcast(Lclcalipso2) + CALL bcast(Lcltlidarradar) + CALL bcast(Lcloudsat_tcc) + CALL bcast(Lcloudsat_tcc2) + 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(Lptradarflag0) + CALL bcast(Lptradarflag1) + CALL bcast(Lptradarflag2) + CALL bcast(Lptradarflag3) + CALL bcast(Lptradarflag4) + CALL bcast(Lptradarflag5) + CALL bcast(Lptradarflag6) + CALL bcast(Lptradarflag7) + CALL bcast(Lptradarflag8) + CALL bcast(Lptradarflag9) + CALL bcast(Lradarpia) + +! IF (xios_field_is_active("tbrttov")) cfg%Lrttov_sim=.TRUE. + + + ! Copy diagnostic flags to cfg structure +! ISCCP simulator (9 diagnostics) + cfg%Lpctisccp = Lpctisccp + cfg%Lclisccp = Lclisccp + cfg%Lboxptopisccp = Lboxptopisccp + cfg%Lboxtauisccp = Lboxtauisccp + cfg%Ltauisccp = Ltauisccp + cfg%Lcltisccp = Lcltisccp + cfg%Lmeantbisccp = Lmeantbisccp + cfg%Lmeantbclrisccp = Lmeantbclrisccp + cfg%Lalbisccp = Lalbisccp + +! CloudSat simulator (13 diagnostics) + cfg%Ldbze94 = Ldbze94 + cfg%LcfadDbze94 = LcfadDbze94 + cfg%Lptradarflag0 = Lptradarflag0 + cfg%Lptradarflag1 = Lptradarflag1 + cfg%Lptradarflag2 = Lptradarflag2 + cfg%Lptradarflag3 = Lptradarflag3 + cfg%Lptradarflag4 = Lptradarflag4 + cfg%Lptradarflag5 = Lptradarflag5 + cfg%Lptradarflag6 = Lptradarflag6 + cfg%Lptradarflag7 = Lptradarflag7 + cfg%Lptradarflag8 = Lptradarflag8 + cfg%Lptradarflag9 = Lptradarflag9 + cfg%Lradarpia = Lradarpia + +! Cloudsat et Calipso (4 diagnostics) + cfg%Lclcalipso2 = Lclcalipso2 + cfg%Lcltlidarradar = Lcltlidarradar + cfg%Lcloudsat_tcc = Lcloudsat_tcc + cfg%Lcloudsat_tcc2 = Lcloudsat_tcc2 + +! CALIPSO simulator (43 diagnostics) + cfg%Latb532 = Latb532 + cfg%LlidarBetaMol532 = LlidarBetaMol532 + cfg%LcfadLidarsr532 = LcfadLidarsr532 + cfg%Lclcalipso = Lclcalipso + cfg%Lclhcalipso = Lclhcalipso + cfg%Lcllcalipso = Lcllcalipso + cfg%Lclmcalipso = Lclmcalipso + cfg%Lcltcalipso = Lcltcalipso + cfg%Lclcalipsoliq = Lclcalipsoliq + cfg%Lclcalipsoice = Lclcalipsoice + cfg%Lclcalipsoun = Lclcalipsoun + cfg%Lclcalipsotmp = Lclcalipsotmp + cfg%Lclcalipsotmpliq = Lclcalipsotmpliq + cfg%Lclcalipsotmpice = Lclcalipsotmpice + cfg%Lclcalipsotmpun = Lclcalipsotmpun + cfg%Lcltcalipsoliq = Lcltcalipsoliq + cfg%Lcltcalipsoice = Lcltcalipsoice + cfg%Lcltcalipsoun = Lcltcalipsoun + cfg%Lclhcalipsoliq = Lclhcalipsoliq + cfg%Lclhcalipsoice = Lclhcalipsoice + cfg%Lclhcalipsoun = Lclhcalipsoun + cfg%Lclmcalipsoliq = Lclmcalipsoliq + cfg%Lclmcalipsoice = Lclmcalipsoice + cfg%Lclmcalipsoun = Lclmcalipsoun + cfg%Lcllcalipsoliq = Lcllcalipsoliq + cfg%Lcllcalipsoice = Lcllcalipsoice + cfg%Lcllcalipsoun = Lcllcalipsoun + cfg%Lclopaquecalipso = Lclopaquecalipso + cfg%Lclthincalipso = Lclthincalipso + cfg%Lclzopaquecalipso = Lclzopaquecalipso + cfg%Lclcalipsoopaque = Lclcalipsoopaque + cfg%Lclcalipsothin = Lclcalipsothin + cfg%Lclcalipsozopaque = Lclcalipsozopaque + cfg%Lclcalipsoopacity = Lclcalipsoopacity + cfg%Lclopaquetemp = Lclopaquetemp + cfg%Lclthintemp = Lclthintemp + cfg%Lclzopaquetemp = Lclzopaquetemp + cfg%Lclopaquemeanz = Lclopaquemeanz + cfg%Lclthinmeanz = Lclthinmeanz + cfg%Lclthinemis = Lclthinemis + cfg%Lclopaquemeanzse = Lclopaquemeanzse + cfg%Lclthinmeanzse = Lclthinmeanzse + cfg%Lclzopaquecalipsose = Lclzopaquecalipsose + +! PARASOL simulator (2 diagnostics, 1 clef) + cfg%Lparasolrefl = Lparasolrefl + +! GROUND LIDAR 532 nm simulator (8 diagnostics) + cfg%Latb532gr = Latb532gr + cfg%LlidarBetaMol532gr = LlidarBetaMol532gr + cfg%LcfadLidarsr532gr = LcfadLidarsr532gr + cfg%LclgrLidar532 = LclgrLidar532 + cfg%LclhgrLidar532 = LclhgrLidar532 + cfg%LcllgrLidar532 = LcllgrLidar532 + cfg%LclmgrLidar532 = LclmgrLidar532 + cfg%LcltgrLidar532 = LcltgrLidar532 + +! ATLID simulator (8 diagnostics) + cfg%Latb355 = Latb355 + cfg%LlidarBetaMol355 = LlidarBetaMol355 + cfg%LcfadLidarsr355 = LcfadLidarsr355 + cfg%Lclatlid = Lclatlid + cfg%Lclhatlid = Lclhatlid + cfg%Lcllatlid = Lcllatlid + cfg%Lclmatlid = Lclmatlid + cfg%Lcltatlid = Lcltatlid + +! MISR simulator (3 diagnostics, 1 clef) + cfg%LclMISR = LclMISR + +! RTTOV (1 diagnostic) + cfg%Ltbrttov = Ltbrttov + +! MODIS simulator (20 diagnostics, 18 clefs) + 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 + +! Others + cfg%Lfracout=Lfracout + +! Copy instrument flags to cfg structure + cfg%Lcloudsat = Lcloudsat + cfg%Lcalipso = Lcalipso + cfg%LgrLidar532 = LgrLidar532 + cfg%Latlid = Latlid + cfg%Lparasol = Lparasol + cfg%Lisccp = Lisccp + cfg%Lmodis = Lmodis + cfg%Lmisr = Lmisr + cfg%Lrttov = Lrttov + if (cfg%Lcloudsat .or. cfg%Lcalipso .or. cfg%LgrLidar532 .or. cfg%Latlid .or. cfg%Lisccp .or. cfg%Lmodis .or. cfg%Lmisr .or. cfg%Lrttov .or. cfg%Lparasol .or. cfg%Lfracout) then + cfg%Lwrite_output=.TRUE. + endif + + ENDIF !using_xios + + END SUBROUTINE read_xiosfieldactive + +END MODULE lmdz_cosp_read_outputkeys Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/lmdz_cosp_subsample_and_optics_mod.f90 (revision 5900) @@ -0,0 +1,456 @@ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! +! Module pour remplir la variable "cospIN", calculs des proprietes optiques subcolumn +! pour les differents simulateurs +! +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + +MODULE LMDZ_COSP_SUBSAMPLE_AND_OPTICS_MOD + +use cosp_kinds, only: wp +USE MOD_COSP_CONFIG +USE mod_quickbeam_optics, only: size_distribution,quickbeam_optics,gases +use quickbeam, only: radar_cfg +use MOD_COSP, only: cosp_optical_inputs,cosp_column_inputs +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 +use cosp_optics, ONLY: cosp_simulator_optics,lidar_optics,modis_optics, & + modis_optics_partition +use mod_cosp_stats, ONLY: COSP_CHANGE_VERTICAL_GRID +use lmdz_cosp_read_outputkeys, ONLY: cosp_config + + + implicit none + + ! 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/) + + +contains + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! SUBROUTINE subsample_and_optics + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + subroutine subsample_and_optics(cfg, nPoints, nLevels, nColumns, nHydro, overlap, & + use_precipitation_fluxes, lidar_ice_type, sd, tca, cca, fl_lsrainIN, fl_lssnowIN, & + fl_lsgrplIN, fl_ccrainIN, fl_ccsnowIN, mr_lsliq, mr_lsice, mr_ccliq, mr_ccice, & + reffIN, dtau_c, dtau_s, dem_c, dem_s, cospstateIN, cospIN) + ! Inputs + integer,intent(in) :: nPoints, nLevels, nColumns, nHydro, overlap, lidar_ice_type + real(wp),intent(in),dimension(nPoints,nLevels) :: tca,cca,mr_lsliq,mr_lsice,mr_ccliq, & + mr_ccice,dtau_c,dtau_s,dem_c,dem_s,fl_lsrainIN,fl_lssnowIN,fl_lsgrplIN,fl_ccrainIN,& + fl_ccsnowIN + real(wp),intent(in),dimension(nPoints,nLevels,nHydro) :: reffIN + logical,intent(in) :: use_precipitation_fluxes + type(size_distribution),intent(inout) :: sd + type(cosp_config),intent(in) :: cfg ! Configuration options + + ! Outputs + type(cosp_optical_inputs),intent(inout) :: cospIN + type(cosp_column_inputs),intent(inout) :: cospstateIN + + type(rng_state),allocatable,dimension(:) :: rngs ! Seeds for random number generator + integer,dimension(:),allocatable :: seed + integer,dimension(:),allocatable :: cloudsat_preclvl_index !PREC_BUG + integer :: i,j,k + real(wp),dimension(:,:), allocatable :: & + ls_p_rate, cv_p_rate, frac_ls, frac_cv, prec_ls, prec_cv,g_vol + real(wp),dimension(:,:,:), allocatable :: & + frac_prec, MODIS_cloudWater, MODIS_cloudIce, fracPrecipIce, fracPrecipIce_statGrid,& + MODIS_watersize,MODIS_iceSize, MODIS_opticalThicknessLiq,MODIS_opticalThicknessIce + real(wp),dimension(:,:,:,:),allocatable :: & + mr_hydro, Reff, Np + real(wp),dimension(nPoints,nLevels) :: & + column_frac_out, column_prec_out, fl_lsrain, fl_lssnow, fl_lsgrpl, fl_ccrain, fl_ccsnow +! real(wp),dimension(nPoints,nColumns,Nlvgrid_local) :: tempOut + logical :: cmpGases=.true. + + if (Ncolumns .gt. 1) then + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Generate subcolumns for clouds (SCOPS) and precipitation type (PREC_SCOPS) + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! RNG used for subcolumn generation + allocate(rngs(nPoints),seed(nPoints)) + seed(:)=0 + seed = int(cospstateIN%phalf(:,Nlevels+1)) ! In case of NPoints=1 + ! *NOTE* Chunking will change the seed + if (NPoints .gt. 1) seed=int((cospstateIN%phalf(:,Nlevels+1)-minval(cospstateIN%phalf(:,Nlevels+1)))/ & + (maxval(cospstateIN%phalf(:,Nlevels+1))-minval(cospstateIN%phalf(:,Nlevels+1)))*100000) + 1 + call init_rng(rngs, seed) + + ! Call scops + call scops(NPoints,Nlevels,Ncolumns,rngs,tca,cca,overlap,cospIN%frac_out,0) + deallocate(seed,rngs) + + ! Sum up precipitation rates + allocate(ls_p_rate(nPoints,nLevels),cv_p_rate(nPoints,Nlevels)) + if(use_precipitation_fluxes) then + ls_p_rate(:,1:nLevels) = fl_lsrainIN + fl_lssnowIN + fl_lsgrplIN + cv_p_rate(:,1:nLevels) = fl_ccrainIN + fl_ccsnowIN + else + ls_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow) + mixing_ratio (groupel) + cv_p_rate(:,1:nLevels) = 0 ! mixing_ratio(rain) + mixing_ratio(snow) + endif + + ! Call PREC_SCOPS + allocate(frac_prec(nPoints,nColumns,nLevels)) + call prec_scops(nPoints,nLevels,nColumns,ls_p_rate,cv_p_rate,cospIN%frac_out,frac_prec) + deallocate(ls_p_rate,cv_p_rate) + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Compute fraction in each gridbox for precipitation and cloud type. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Allocate + allocate(frac_ls(nPoints,nLevels),prec_ls(nPoints,nLevels), & + frac_cv(nPoints,nLevels),prec_cv(nPoints,nLevels)) + + ! Initialize + frac_ls(1:nPoints,1:nLevels) = 0._wp + prec_ls(1:nPoints,1:nLevels) = 0._wp + frac_cv(1:nPoints,1:nLevels) = 0._wp + prec_cv(1:nPoints,1:nLevels) = 0._wp + do j=1,nPoints + do k=1,nLevels + do i=1,nColumns + if (cospIN%frac_out(j,i,k) .eq. 1) frac_ls(j,k) = frac_ls(j,k)+1._wp + if (cospIN%frac_out(j,i,k) .eq. 2) frac_cv(j,k) = frac_cv(j,k)+1._wp + if (frac_prec(j,i,k) .eq. 1) prec_ls(j,k) = prec_ls(j,k)+1._wp + if (frac_prec(j,i,k) .eq. 2) prec_cv(j,k) = prec_cv(j,k)+1._wp + if (frac_prec(j,i,k) .eq. 3) prec_cv(j,k) = prec_cv(j,k)+1._wp + if (frac_prec(j,i,k) .eq. 3) prec_ls(j,k) = prec_ls(j,k)+1._wp + enddo + frac_ls(j,k)=frac_ls(j,k)/nColumns + frac_cv(j,k)=frac_cv(j,k)/nColumns + prec_ls(j,k)=prec_ls(j,k)/nColumns + prec_cv(j,k)=prec_cv(j,k)/nColumns + enddo + enddo + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Assign gridmean mixing-ratios (mr_XXXXX), effective radius (ReffIN) and number + ! concentration (not defined) to appropriate sub-column. Here we are using scops. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + allocate(mr_hydro(nPoints,nColumns,nLevels,nHydro), & + Reff(nPoints,nColumns,nLevels,nHydro), & + Np(nPoints,nColumns,nLevels,nHydro)) + + ! Initialize + mr_hydro(:,:,:,:) = 0._wp + Reff(:,:,:,:) = 0._wp + Np(:,:,:,:) = 0._wp + do k=1,nColumns + ! Subcolumn cloud fraction + column_frac_out = cospIN%frac_out(:,k,:) + + ! LS clouds + where (column_frac_out == I_LSC) + mr_hydro(:,k,:,I_LSCLIQ) = mr_lsliq + mr_hydro(:,k,:,I_LSCICE) = mr_lsice + Reff(:,k,:,I_LSCLIQ) = ReffIN(:,:,I_LSCLIQ) + Reff(:,k,:,I_LSCICE) = ReffIN(:,:,I_LSCICE) + ! CONV clouds + elsewhere (column_frac_out == I_CVC) + mr_hydro(:,k,:,I_CVCLIQ) = mr_ccliq + mr_hydro(:,k,:,I_CVCICE) = mr_ccice + Reff(:,k,:,I_CVCLIQ) = ReffIN(:,:,I_CVCLIQ) + Reff(:,k,:,I_CVCICE) = ReffIN(:,:,I_CVCICE) + end where + + ! Subcolumn precipitation + column_prec_out = frac_prec(:,k,:) + + ! LS Precipitation + where ((column_prec_out == 1) .or. (column_prec_out == 3) ) + Reff(:,k,:,I_LSRAIN) = ReffIN(:,:,I_LSRAIN) + Reff(:,k,:,I_LSSNOW) = ReffIN(:,:,I_LSSNOW) + Reff(:,k,:,I_LSGRPL) = ReffIN(:,:,I_LSGRPL) + ! CONV precipitation + elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3)) + Reff(:,k,:,I_CVRAIN) = ReffIN(:,:,I_CVRAIN) + Reff(:,k,:,I_CVSNOW) = ReffIN(:,:,I_CVSNOW) + end where + enddo + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Convert the subcolumn mixing ratio and precipitation fluxes from gridbox mean + ! values to fraction-based values. + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! Initialize + fl_lsrain(:,:) = 0._wp + fl_lssnow(:,:) = 0._wp + fl_lsgrpl(:,:) = 0._wp + fl_ccrain(:,:) = 0._wp + fl_ccsnow(:,:) = 0._wp + do k=1,nLevels + do j=1,nPoints + ! In-cloud mixing ratios. + 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 (use_precipitation_fluxes) then + if (prec_ls(j,k) .ne. 0.) then + fl_lsrain(j,k) = fl_lsrainIN(j,k)/prec_ls(j,k) + fl_lssnow(j,k) = fl_lssnowIN(j,k)/prec_ls(j,k) + fl_lsgrpl(j,k) = fl_lsgrplIN(j,k)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + fl_ccrain(j,k) = fl_ccrainIN(j,k)/prec_cv(j,k) + fl_ccsnow(j,k) = fl_ccsnowIN(j,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 (use_precipitation_fluxes) then + ! LS rain + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 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), fl_lsrain, & + mr_hydro(:,:,:,I_LSRAIN), Reff(:,:,:,I_LSRAIN)) + ! LS snow + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 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), fl_lssnow, & + mr_hydro(:,:,:,I_LSSNOW), Reff(:,:,:,I_LSSNOW)) + ! CV rain + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 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), fl_ccrain, & + mr_hydro(:,:,:,I_CVRAIN), Reff(:,:,:,I_CVRAIN)) + ! CV snow + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 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), fl_ccsnow, & + mr_hydro(:,:,:,I_CVSNOW), Reff(:,:,:,I_CVSNOW)) + ! LS groupel. + call cosp_precip_mxratio(nPoints, nLevels, nColumns, cospstateIN%pfull, & + cospstateIN%at, frac_prec, 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), fl_lsgrpl, & + mr_hydro(:,:,:,I_LSGRPL), Reff(:,:,:,I_LSGRPL)) + deallocate(frac_prec) + endif + + else + cospIN%frac_out(:,:,:) = 1 + allocate(mr_hydro(nPoints,1,nLevels,nHydro),Reff(nPoints,1,nLevels,nHydro), & + Np(nPoints,1,nLevels,nHydro)) + mr_hydro(:,1,:,I_LSCLIQ) = mr_lsliq + mr_hydro(:,1,:,I_LSCICE) = mr_lsice + mr_hydro(:,1,:,I_CVCLIQ) = mr_ccliq + mr_hydro(:,1,:,I_CVCICE) = mr_ccice + Reff(:,1,:,:) = ReffIN + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 11 micron emissivity + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Lisccp) then + call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,dem_c,dem_s, & + cospIN%emiss_11) + endif + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! 0.67 micron optical depth + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Lisccp .or. cfg%Lmisr .or. cfg%Lmodis) then + call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out,dtau_c,dtau_s, & + cospIN%tau_067) + endif + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! LIDAR Polarized optics + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Lcalipso) then + call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 532, .false., & + mr_hydro(:,:,:,I_LSCLIQ), mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), & + mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE), & + ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull, & + cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_calipso, & + cospIN%betatot_calipso, cospIN%tau_mol_calipso, cospIN%tautot_calipso, & + cospIN%tautot_S_liq, cospIN%tautot_S_ice, cospIN%betatot_ice_calipso, & + cospIN%betatot_liq_calipso, cospIN%tautot_ice_calipso, cospIN%tautot_liq_calipso) + endif + + if (cfg%LgrLidar532) then + call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 532, .true., & + mr_hydro(:,:,:,I_LSCLIQ), mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), & + mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE), & + ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull, & + cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_grLidar532, & + cospIN%betatot_grLidar532, cospIN%tau_mol_grLidar532, cospIN%tautot_grLidar532) + endif + + if (cfg%Latlid) then + call lidar_optics(nPoints, nColumns, nLevels, 4, lidar_ice_type, 355, .false., & + mr_hydro(:,:,:,I_LSCLIQ), mr_hydro(:,:,:,I_LSCICE), mr_hydro(:,:,:,I_CVCLIQ), & + mr_hydro(:,:,:,I_CVCICE), ReffIN(:,:,I_LSCLIQ), ReffIN(:,:,I_LSCICE), & + ReffIN(:,:,I_CVCLIQ), ReffIN(:,:,I_CVCICE), cospstateIN%pfull, & + cospstateIN%phalf, cospstateIN%at, cospIN%beta_mol_atlid, cospIN%betatot_atlid,& + cospIN%tau_mol_atlid, cospIN%tautot_atlid) + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! CLOUDSAT RADAR OPTICS + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Lcloudsat) then + + ! Compute gaseous absorption (assume identical for each subcolun) + allocate(g_vol(nPoints,nLevels)) + g_vol(:,:)=0._wp + do i=1,nPoints + do j=1,nLevels + if (cospIN%rcfg_cloudsat%use_gas_abs == 1 .or. (cospIN%rcfg_cloudsat%use_gas_abs == 2 .and. j .eq. 1)) then + g_vol(i,j) = gases(cospstateIN%pfull(i,j), cospstateIN%at(i,j),cospstateIN%qv(i,j),cospIN%rcfg_cloudsat%freq) + endif + cospIN%g_vol_cloudsat(i,:,j)=g_vol(i,j) + end do + end do + + ! Loop over all subcolumns + allocate(fracPrecipIce(nPoints,nColumns,nLevels)) + fracPrecipIce(:,:,:) = 0._wp + do k=1,nColumns + call quickbeam_optics(sd, cospIN%rcfg_cloudsat, nPoints, nLevels, R_UNDEF, & + mr_hydro(:,k,:,1:nHydro)*1000._wp, Reff(:,k,:,1:nHydro)*1.e6_wp,& + Np(:,k,:,1:nHydro), cospstateIN%pfull, cospstateIN%at, & + cospstateIN%qv, cospIN%z_vol_cloudsat(1:nPoints,k,:), & + cospIN%kr_vol_cloudsat(1:nPoints,k,:)) + + ! At each model level, what fraction of the precipitation is frozen? + where(mr_hydro(:,k,:,I_LSRAIN) .gt. 0 .or. mr_hydro(:,k,:,I_LSSNOW) .gt. 0 .or. & + mr_hydro(:,k,:,I_CVRAIN) .gt. 0 .or. mr_hydro(:,k,:,I_CVSNOW) .gt. 0 .or. & + mr_hydro(:,k,:,I_LSGRPL) .gt. 0) + fracPrecipIce(:,k,:) = (mr_hydro(:,k,:,I_LSSNOW) + mr_hydro(:,k,:,I_CVSNOW) + & + mr_hydro(:,k,:,I_LSGRPL)) / & + (mr_hydro(:,k,:,I_LSSNOW) + mr_hydro(:,k,:,I_CVSNOW) + mr_hydro(:,k,:,I_LSGRPL) + & + mr_hydro(:,k,:,I_LSRAIN) + mr_hydro(:,k,:,I_CVRAIN)) + elsewhere + fracPrecipIce(:,k,:) = 0._wp + endwhere + enddo + + ! Regrid frozen fraction to Cloudsat/Calipso statistical grid + allocate(fracPrecipIce_statGrid(nPoints,nColumns,Nlvgrid)) + fracPrecipIce_statGrid(:,:,:) = 0._wp + call cosp_change_vertical_grid(Npoints, Ncolumns, Nlevels, cospstateIN%hgt_matrix(:,Nlevels:1:-1), & + cospstateIN%hgt_matrix_half(:,Nlevels:1:-1), fracPrecipIce(:,:,Nlevels:1:-1), Nlvgrid, & +! vgrid_zl(Nlvgrid:1:-1), vgrid_zu(Nlvgrid:1:-1), fracPrecipIce_statGrid) !!! ORIGINAL + vgrid_zl(Nlvgrid:1:-1), vgrid_zu(Nlvgrid:1:-1), fracPrecipIce_statGrid(:,:,Nlvgrid:1:-1)) !DEBUG fracPrecipIce_statGrid + + ! Find proper layer to compute precip flags in Cloudsat/Calipso statistical grid !PREC_BUG + allocate(cloudsat_preclvl_index(nPoints)) !PREC_BUG + cloudsat_preclvl_index(:) = 0._wp !PREC_BUG + ! Computing altitude index for precip flags calculation (2nd layer above surfelev) !PREC_BUG + cloudsat_preclvl_index(:) = 39 - floor( cospstateIN%surfelev(:)/480. ) !PREC_BUG + + ! For near-surface diagnostics, we only need the frozen fraction at one layer. + do i=1,nPoints !PREC_BUG + cospIN%fracPrecipIce(i,:) = fracPrecipIce_statGrid(i,:,cloudsat_preclvl_index(i)) !PREC_BUG + enddo !PREC_BUG +! cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,cloudsat_preclvl) !!! ORIGINAL +! cospIN%fracPrecipIce(:,:) = fracPrecipIce_statGrid(:,:,2) !!! TEST ARTEM + + endif + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + ! MODIS optics + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + if (cfg%Lmodis) then + allocate(MODIS_cloudWater(nPoints,nColumns,nLevels), & + MODIS_cloudIce(nPoints,nColumns,nLevels), & + MODIS_waterSize(nPoints,nColumns,nLevels), & + MODIS_iceSize(nPoints,nColumns,nLevels), & + MODIS_opticalThicknessLiq(nPoints,nColumns,nLevels), & + MODIS_opticalThicknessIce(nPoints,nColumns,nLevels)) + ! Cloud water + call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out, & + mr_hydro(:,:,:,I_CVCLIQ),mr_hydro(:,:,:,I_LSCLIQ),MODIS_cloudWater) + ! Cloud ice + call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out, & + mr_hydro(:,:,:,I_CVCICE),mr_hydro(:,:,:,I_LSCICE),MODIS_cloudIce) + ! Water droplet size + call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out, & + Reff(:,:,:,I_CVCLIQ),Reff(:,:,:,I_LSCLIQ),MODIS_waterSize) + ! Ice crystal size + call cosp_simulator_optics(nPoints,nColumns,nLevels,cospIN%frac_out, & + Reff(:,:,:,I_CVCICE),Reff(:,:,:,I_LSCICE),MODIS_iceSize) + + ! Partition optical thickness into liquid and ice parts + call modis_optics_partition(nPoints, nLevels, 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, nLevels, 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, & + Np,Reff) + endif + end subroutine subsample_and_optics + +END MODULE LMDZ_COSP_SUBSAMPLE_AND_OPTICS_MOD Index: /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/math_lib.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/math_lib.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/math_lib.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/mo_rng.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/mo_rng.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/mo_rng.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/modis_simulator.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/modis_simulator.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/modis_simulator.f90 (revision 5900) @@ -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 = R_UNDEF + Optical_Thickness_Total_MeanLog10 = R_UNDEF + 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 = R_UNDEF + Optical_Thickness_Water_MeanLog10 = R_UNDEF + Cloud_Particle_Size_Water_Mean = R_UNDEF + Liquid_Water_Path_Mean = R_UNDEF + 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 = R_UNDEF + Optical_Thickness_Ice_MeanLog10 = R_UNDEF + Cloud_Particle_Size_Ice_Mean = R_UNDEF + Ice_Water_Path_Mean = R_UNDEF + 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/branches/LMDZ-COSP/libf/phylmd/cospv2/mrgrnk.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/mrgrnk.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/mrgrnk.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/optics_lib.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/optics_lib.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/optics_lib.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/parasol.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/parasol.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/parasol.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/prec_scops.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/prec_scops.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/prec_scops.f90 (revision 5900) @@ -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/branches/LMDZ-COSP/libf/phylmd/cospv2/quickbeam.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/quickbeam.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/quickbeam.f90 (revision 5900) @@ -0,0 +1,643 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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: R_UNDEF,cloudsat_histRef,use_vgrid,vgrid_zl,vgrid_zu,& + pClass_noPrecip, pClass_Rain1, pClass_Rain2, pClass_Rain3,& + pClass_Snow1, pClass_Snow2, pClass_Mixed1, pClass_Mixed2, & + pClass_Rain4, pClass_default, Zenonbinval, Zbinvallnd, & + N_HYDRO,nCloudsatPrecipClass !,cloudsat_preclvl !PREC_BUG + 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,dBZe,Ze_non) + + ! 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) + dBZe ! Effective radar reflectivity factor (dBZ) + + ! LOCAL VARIABLES + integer :: k,pr,start_gate,end_gate,d_gate + real(wp),dimension(nprof,ngate) :: & + 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 + 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, DBZE_BINS, platform, & + Ze_tot, Ze_tot_non, land, surfelev, t2m, fracPrecipIce, zlev, zlev_half, cfad_ze, & !PREC_BUG + cloudsat_precip_cover, cloudsat_pia) + ! 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 + DBZE_BINS ! Number of bins for cfad. + character(len=*),intent(in) :: & + platform ! Name of platform (e.g. cloudsat) + real(wp),dimension(Npoints),intent(in) :: & + land, & ! Land/Sea mask. (1/0) + surfelev, & ! Surface Elevation (m) !PREC_BUG + t2m ! Near-surface temperature + real(wp),dimension(Npoints,Ncolumns),intent(in) :: & + fracPrecipIce ! Fraction of precipitation which is frozen. (1) + real(wp),intent(in),dimension(npoints,ncolumns,Nlevels) :: & + Ze_tot, & ! Effective reflectivity factor (dBZ) + Ze_tot_non ! Effective reflectivity factor w/o attenuation (dBZ) + 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 ! + real(wp),dimension(Npoints,nCloudsatPrecipClass),intent(out) :: & + cloudsat_precip_cover ! Model precip rate in by CloudSat precip flag + real(wp),dimension(Npoints),intent(out) :: & + cloudsat_pia ! Cloudsat path integrated attenuation + + ! Local variables + integer :: i,j + real(wp),dimension(npoints,ncolumns,llm) :: ze_toti,ze_noni + logical :: lcloudsat = .false. + + ! Which platforms to create diagnostics for? + if (platform .eq. 'cloudsat') lcloudsat=.true. + + ! Create Cloudsat diagnostics. + if (lcloudsat) then + if (use_vgrid) then + ! Regrid in the vertical (*NOTE* This routine requires SFC-2-TOA ordering, so flip + ! inputs and outputs to maintain TOA-2-SFC ordering convention in COSP2.) + 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_toti(:,:,llm:1:-1),log_units=.true.) + + ! Effective reflectivity histogram + do i=1,Npoints + do j=1,llm + cfad_ze(i,:,j) = hist1D(Ncolumns,Ze_toti(i,:,j),DBZE_BINS,cloudsat_histRef) + enddo + enddo + where(cfad_ze .ne. R_UNDEF) cfad_ze = cfad_ze/Ncolumns + + ! Compute cloudsat near-surface precipitation diagnostics + ! First, regrid in the vertical Ze_tot_non. + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,zlev(:,nlevels:1:-1),& + zlev_half(:,nlevels:1:-1),Ze_tot_non(:,:,nlevels:1:-1),llm,vgrid_zl(llm:1:-1),& + vgrid_zu(llm:1:-1),Ze_noni(:,:,llm:1:-1),log_units=.true.) + ! Not call routine to generate diagnostics. + call cloudsat_precipOccurence(Npoints, Ncolumns, llm, N_HYDRO, Ze_toti, Ze_noni, & + land, surfelev, t2m, fracPrecipIce, cloudsat_precip_cover, cloudsat_pia) !PREC_BUG + 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 + endif + + end subroutine quickbeam_column + ! ############################################################################################## + ! ############################################################################################## + ! ###################################################################################### + ! SUBROUTINE cloudsat_precipOccurence + ! + ! Notes from July 2016: Add precip flag also looped over subcolumns + ! Modified by Tristan L'Ecuyer (TSL) to add precipitation flagging + ! based on CloudSat's 2C-PRECIP-COLUMN algorithm (Haynes et al, JGR, 2009). + ! To mimic the satellite algorithm, this code applies thresholds to non-attenuated + ! reflectivities, Ze_non, consistent with those outlined in Haynes et al, JGR (2009). + ! + ! Procedures/Notes: + ! + ! (1) If the 2-way attenuation exceeds 40 dB, the pixel will be flagged as 'heavy rain' + ! consistent with the multiple-scattering analysis of Battaglia et al, JGR (2008). + ! (2) Rain, snow, and mixed precipitation scenes are separated according to the fraction + ! of the total precipitation hydrometeor mixing ratio that exists as ice. + ! (3) The entire analysis is applied to the range gate from 480-960 m to be consistent with + ! CloudSat's 720 m ground-clutter. + ! (4) Only a single flag is assigned to each model grid since there is no variation in + ! hydrometeor contents across a single model level. Unlike CFADs, whose variation enters + ! due to differening attenuation corrections from hydrometeors aloft, the non-attenuated + ! reflectivities used in the computation of this flag cannot vary across sub-columns. + ! + ! radar_prec_flag = 1-Rain possible 2-Rain probable 3-Rain certain + ! 4-Snow possible 5-Snow certain + ! 6-Mixed possible 7-Mixed certain + ! 8-Heavy Rain + ! 9- default value + ! + ! Modified by Dustin Swales (University of Colorado) for use with COSP2. + ! *NOTE* All inputs (Ze_out, Ze_non_out, fracPrecipIce) are at a single level from the + ! statistical output grid used by Cloudsat. This level is controlled by the + ! parameter cloudsat_preclvl, defined in src/cosp_config.F90 + ! ###################################################################################### + subroutine cloudsat_precipOccurence(Npoints, Ncolumns, llm, Nhydro, Ze_out, Ze_non_out, & + land, surfelev, t2m, fracPrecipIce, cloudsat_precip_cover, cloudsat_pia) !PREC_BUG + + ! Inputs + integer,intent(in) :: & + Npoints, & ! Number of columns + Ncolumns, & ! Numner of subcolumns + Nhydro, & ! Number of hydrometeor types + llm ! Number of levels + real(wp),dimension(Npoints),intent(in) :: & + land, & ! Land/Sea mask. (1/0) + surfelev, & ! Surface Elevation (m) !PREC_BUG + t2m ! Near-surface temperature + real(wp),dimension(Npoints,Ncolumns,llm),intent(in) :: & + Ze_out, & ! Effective reflectivity factor (dBZ) + Ze_non_out ! Effective reflectivity factor, w/o attenuation (dBZ) + real(wp),dimension(Npoints,Ncolumns),intent(in) :: & + fracPrecipIce ! Fraction of precipitation which is frozen. (1) + + ! Outputs + real(wp),dimension(Npoints,nCloudsatPrecipClass),intent(out) :: & + cloudsat_precip_cover ! Model precip rate in by CloudSat precip flag + real(wp),dimension(Npoints),intent(out) :: & + cloudsat_pia ! Cloudsat path integrated attenuation + + ! Local variables + integer,dimension(Npoints,Ncolumns) :: & + cloudsat_pflag, & ! Subcolumn precipitation flag + cloudsat_precip_pia ! Subcolumn path integrated attenutation. + integer,dimension(Npoints) :: & !PREC_BUG + cloudsat_preclvl_index ! Altitude index for precip flags calculation !PREC_BUG + ! in 40-level grid (2nd layer above surfelev) !PREC_BUG + integer :: pr,i,k,m,j,cloudsat_preclvl !PREC_BUG + real(wp) :: Zmax + + ! Initialize + cloudsat_pflag(:,:) = pClass_default + cloudsat_precip_pia(:,:) = 0._wp + cloudsat_precip_cover(:,:) = 0._wp + cloudsat_pia(:) = 0._wp + cloudsat_preclvl_index(:) = 0._wp !PREC_BUG + + +!!! Computing altitude index for precip flags calculation !PREC_BUG +cloudsat_preclvl_index(:) = 39 - floor( surfelev(:)/480. ) !PREC_BUG + + ! ###################################################################################### + ! SUBCOLUMN processing + ! ###################################################################################### + do i=1, Npoints + + cloudsat_preclvl = cloudsat_preclvl_index(i) !PREC_BUG +! print*, 'i, surfelev(i), cloudsat_preclvl : ', i, surfelev(i), cloudsat_preclvl !PREC_BUG + + do pr=1,Ncolumns + ! 1) Compute the PIA in all profiles containing hydrometeors + if ( (Ze_non_out(i,pr,cloudsat_preclvl).gt.-100) .and. (Ze_out(i,pr,cloudsat_preclvl).gt.-100) ) then + if ( (Ze_non_out(i,pr,cloudsat_preclvl).lt.100) .and. (Ze_out(i,pr,cloudsat_preclvl).lt.100) ) then + cloudsat_precip_pia(i,pr) = Ze_non_out(i,pr,cloudsat_preclvl) - Ze_out(i,pr,cloudsat_preclvl) + endif + endif + + ! 2) Compute precipitation flag + ! ################################################################################ + ! 2a) Oceanic points. + ! ################################################################################ + if (land(i) .eq. 0) then +! print*, 'aaa i, pr, fracPrecipIce(i,pr) : ', i, pr, fracPrecipIce(i,pr) !Artem + ! Snow + if(fracPrecipIce(i,pr).gt.0.9) then + if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(2)) then + cloudsat_pflag(i,pr) = pClass_Snow2 ! TSL: Snow certain + endif + if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. & + Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(2)) then + cloudsat_pflag(i,pr) = pClass_Snow1 ! TSL: Snow possible + endif + endif + + ! Mixed + if(fracPrecipIce(i,pr).gt.0.1.and.fracPrecipIce(i,pr).le.0.9) then + if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(2)) then + cloudsat_pflag(i,pr) = pClass_Mixed2 ! TSL: Mixed certain + endif + if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. & + Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(2)) then + cloudsat_pflag(i,pr) = pClass_Mixed1 ! TSL: Mixed possible + endif + endif + + ! Rain + if(fracPrecipIce(i,pr).le.0.1) then + if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(1)) then + cloudsat_pflag(i,pr) = pClass_Rain3 ! TSL: Rain certain + endif + if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(3).and. & + Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(1)) then + cloudsat_pflag(i,pr) = pClass_Rain2 ! TSL: Rain probable + endif + if(Ze_non_out(i,pr,cloudsat_preclvl).gt.Zenonbinval(4).and. & + Ze_non_out(i,pr,cloudsat_preclvl).le.Zenonbinval(3)) then + cloudsat_pflag(i,pr) = pClass_Rain1 ! TSL: Rain possible + endif + if(cloudsat_precip_pia(i,pr).gt.40) then + cloudsat_pflag(i,pr) = pClass_Rain4 ! TSL: Heavy Rain + endif + endif + + ! No precipitation + if(Ze_non_out(i,pr,cloudsat_preclvl).le.-15) then + cloudsat_pflag(i,pr) = pClass_noPrecip ! TSL: Not Raining + endif + endif ! Ocean points + + ! ################################################################################ + ! 2b) Land points. + ! ################################################################################ + if (land(i) .eq. 1) then + ! Find Zmax, the maximum reflectivity value in the attenuated profile (Ze_out); + Zmax=maxval(Ze_out(i,pr,:)) + + ! Snow (T<273) + if(t2m(i) .lt. 273._wp) then + if(Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(5)) then + cloudsat_pflag(i,pr) = pClass_Snow2 ! JEK: Snow certain + endif + if(Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6) .and. & + Ze_out(i,pr,cloudsat_preclvl).le.Zbinvallnd(5)) then + cloudsat_pflag(i,pr) = pClass_Snow1 ! JEK: Snow possible + endif + endif + + ! Mized phase (273275) + if(t2m(i) .gt. 275) then + if ((Zmax .gt. Zbinvallnd(1) .and. cloudsat_precip_pia(i,pr).gt.30) .or. & + (Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(2))) then + cloudsat_pflag(i,pr) = pClass_Rain3 ! JEK: Rain certain + endif + if((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)) .and. & + (Zmax .gt. Zbinvallnd(3))) then + cloudsat_pflag(i,pr) = pClass_Rain2 ! JEK: Rain probable + endif + if((Ze_out(i,pr,cloudsat_preclvl) .gt. Zbinvallnd(6)) .and. & + (Zmax.lt.Zbinvallnd(3))) then + cloudsat_pflag(i,pr) = pClass_Rain1 ! JEK: Rain possible + endif + if(cloudsat_precip_pia(i,pr).gt.40) then + cloudsat_pflag(i,pr) = pClass_Rain4 ! JEK: Heavy Rain + endif + endif + + ! No precipitation + if(Ze_out(i,pr,cloudsat_preclvl).le.-15) then + cloudsat_pflag(i,pr) = pClass_noPrecip ! JEK: Not Precipitating + endif + endif ! Land points + enddo ! Sub-columns + enddo ! Gridpoints + + ! ###################################################################################### + ! COLUMN processing + ! ###################################################################################### + + ! Aggregate subcolumns + do i=1,Npoints + ! Gridmean precipitation fraction for each precipitation type + do k=1,nCloudsatPrecipClass + if (any(cloudsat_pflag(i,:) .eq. k-1)) then + cloudsat_precip_cover(i,k) = count(cloudsat_pflag(i,:) .eq. k-1) + endif + enddo + + ! Gridmean path integrated attenuation (pia) + cloudsat_pia(i)=sum(cloudsat_precip_pia(i,:)) + enddo + + ! Normalize by number of subcolumns + where ((cloudsat_precip_cover /= R_UNDEF).and.(cloudsat_precip_cover /= 0.0)) & + cloudsat_precip_cover = cloudsat_precip_cover / Ncolumns + where ((cloudsat_pia/= R_UNDEF).and.(cloudsat_pia/= 0.0)) & + cloudsat_pia = cloudsat_pia / Ncolumns + + end subroutine cloudsat_precipOccurence + + ! ############################################################################################## + ! ############################################################################################## + 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/branches/LMDZ-COSP/libf/phylmd/cospv2/quickbeam_optics.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/quickbeam_optics.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/quickbeam_optics.f90 (revision 5900) @@ -0,0 +1,1380 @@ +! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +! 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,z_vol,kr_vol) + + ! 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) + + ! OUTPUTS + real(wp),intent(out), dimension(nprof, ngate) :: & + z_vol, & ! Effective reflectivity factor (mm^6/m^3) + kr_vol ! Attenuation coefficient hydro (dB/km) + + ! INTERNAL VARIABLES + integer :: & + phase, ns,tp,j,k,pr,itt,iRe_type,n + logical :: & + hydro + 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 ! + + ! Initialization + 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 + ! 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 + + 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/branches/LMDZ-COSP/libf/phylmd/cospv2/scops.f90 =================================================================== --- /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/scops.f90 (revision 5900) +++ /LMDZ6/branches/LMDZ-COSP/libf/phylmd/cospv2/scops.f90 (revision 5900) @@ -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