Index: LMDZ6/trunk/libf/phylmd/cosp/cosp.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp.F90 (revision 3231) +++ (revision ) @@ -1,605 +1,0 @@ -! (c) British Crown Copyright 2008, 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: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -#include "cosp_defs.h" -MODULE MOD_COSP - USE MOD_COSP_TYPES - USE MOD_COSP_SIMULATOR - USE MOD_COSP_MODIS_SIMULATOR - IMPLICIT NONE - -CONTAINS - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!--------------------- SUBROUTINE COSP --------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!#ifdef RTTOV -!SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) -!#else -SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) -!#endif - ! Arguments - integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand - integer,intent(in) :: Ncolumns - type(cosp_config),intent(in) :: cfg ! Configuration options - type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats - type(cosp_gridbox),intent(inout) :: gbx - type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info - type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator - type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator - type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator - type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator - type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator -!#ifdef RTTOV -! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV -!#endif - type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator - type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator - - ! Local variables - integer :: Npoints ! Number of gridpoints - integer :: Nlevels ! Number of levels - integer :: Nhydro ! Number of hydrometeors - integer :: Niter ! Number of calls to cosp_simulator - integer :: i_first,i_last ! First and last gridbox to be processed in each iteration - integer :: i,Ni - integer,dimension(2) :: ix,iy - logical :: reff_zero - real :: maxp,minp - integer,dimension(:),allocatable :: & ! Dimensions nPoints - seed ! It is recommended that the seed is set to a different value for each model - ! gridbox it is called on, as it is possible that the choice of the same - ! seed value every time may introduce some statistical bias in the results, - ! particularly for low values of NCOL. - ! Types used in one iteration - type(cosp_gridbox) :: gbx_it - type(cosp_subgrid) :: sgx_it - type(cosp_vgrid) :: vgrid_it - type(cosp_sgradar) :: sgradar_it - type(cosp_sglidar) :: sglidar_it - type(cosp_isccp) :: isccp_it - type(cosp_modis) :: modis_it - type(cosp_misr) :: misr_it -!#ifdef RTTOV -! type(cosp_rttov) :: rttov_it -!#endif - type(cosp_radarstats) :: stradar_it - type(cosp_lidarstats) :: stlidar_it - -!++++++++++ Dimensions ++++++++++++ - Npoints = gbx%Npoints - Nlevels = gbx%Nlevels - Nhydro = gbx%Nhydro - -!++++++++++ Depth of model layers ++++++++++++ - do i=1,Nlevels-1 - gbx%dlev(:,i) = gbx%zlev_half(:,i+1) - gbx%zlev_half(:,i) - enddo - gbx%dlev(:,Nlevels) = 2.0*(gbx%zlev(:,Nlevels) - gbx%zlev_half(:,Nlevels)) - -!++++++++++ Apply sanity checks to inputs ++++++++++ -! call cosp_check_input('longitude',gbx%longitude,min_val=0.0,max_val=360.0) - call cosp_check_input('longitude',gbx%longitude,min_val=-180.0,max_val=180.0) - call cosp_check_input('latitude',gbx%latitude,min_val=-90.0,max_val=90.0) - call cosp_check_input('dlev',gbx%dlev,min_val=0.0) - call cosp_check_input('p',gbx%p,min_val=0.0) - call cosp_check_input('ph',gbx%ph,min_val=0.0) - call cosp_check_input('T',gbx%T,min_val=0.0) - call cosp_check_input('q',gbx%q,min_val=0.0) - call cosp_check_input('sh',gbx%sh,min_val=0.0) - call cosp_check_input('dtau_s',gbx%dtau_s,min_val=0.0) - call cosp_check_input('dtau_c',gbx%dtau_c,min_val=0.0) - call cosp_check_input('dem_s',gbx%dem_s,min_val=0.0,max_val=1.0) - call cosp_check_input('dem_c',gbx%dem_c,min_val=0.0,max_val=1.0) - ! Point information (Npoints) - call cosp_check_input('land',gbx%land,min_val=0.0,max_val=1.0) - call cosp_check_input('psfc',gbx%psfc,min_val=0.0) - call cosp_check_input('sunlit',gbx%sunlit,min_val=0.0,max_val=1.0) - call cosp_check_input('skt',gbx%skt,min_val=0.0) - ! TOTAL and CONV cloud fraction for SCOPS - call cosp_check_input('tca',gbx%tca,min_val=0.0,max_val=1.0) - call cosp_check_input('cca',gbx%cca,min_val=0.0,max_val=1.0) - ! Precipitation fluxes on model levels - call cosp_check_input('rain_ls',gbx%rain_ls,min_val=0.0) - call cosp_check_input('rain_cv',gbx%rain_cv,min_val=0.0) - call cosp_check_input('snow_ls',gbx%snow_ls,min_val=0.0) - call cosp_check_input('snow_cv',gbx%snow_cv,min_val=0.0) - call cosp_check_input('grpl_ls',gbx%grpl_ls,min_val=0.0) - ! Hydrometeors concentration and distribution parameters - call cosp_check_input('mr_hydro',gbx%mr_hydro,min_val=0.0) - ! Effective radius [m]. (Npoints,Nlevels,Nhydro) - call cosp_check_input('Reff',gbx%Reff,min_val=0.0) - reff_zero=.true. - if (any(gbx%Reff > 1.e-8)) then - reff_zero=.false. - ! reff_zero == .false. - ! and gbx%use_reff == .true. Reff use in radar and lidar - ! and reff_zero == .false. Reff use in lidar and set to 0 for radar - endif - if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar - gbx%Reff = DEFAULT_LIDAR_REFF - print *, '---------- COSP WARNING ------------' - print *, '' - print *, 'Using default Reff in lidar simulations' - print *, '' - print *, '----------------------------------' - endif - - ! Aerosols concentration and distribution parameters - call cosp_check_input('conc_aero',gbx%conc_aero,min_val=0.0) - ! Checks for CRM mode - if (Ncolumns == 1) then - if (gbx%use_precipitation_fluxes) then - print *, '---------- COSP ERROR ------------' - print *, '' - print *, 'Use of precipitation fluxes not supported in CRM mode (Ncolumns=1)' - print *, '' - print *, '----------------------------------' - stop - endif - if ((maxval(gbx%dtau_c) > 0.0).or.(maxval(gbx%dem_c) > 0.0)) then - print *, '---------- COSP ERROR ------------' - print *, '' - print *, ' dtau_c > 0.0 or dem_c > 0.0. In CRM mode (Ncolumns=1), ' - print *, ' the optical depth (emmisivity) of all clouds must be ' - print *, ' passed through dtau_s (dem_s)' - print *, '' - print *, '----------------------------------' - stop - endif - endif - - ! We base the seed in the decimal part of the surface pressure. - allocate(seed(Npoints)) - seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1 - ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to - ! randomize for each call to COSP even when Npoints ==1 - minp = minval(gbx%psfc) - maxp = maxval(gbx%psfc) - if (Npoints .gt. 1) seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1 - ! Below it's how it was done in the original implementation of the ISCCP simulator. - ! The one above is better for offline data, when you may have packed data - ! that subsamples the decimal fraction of the surface pressure. -! if (Npoints .gt. 1) seed=(gbx%psfc-int(gbx%psfc))*1000000 - - - if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints -!#ifdef RTTOV -! call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) -!#else - call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) -!#endif - else ! Several iterations to save memory - Niter = gbx%Npoints/gbx%Npoints_it ! Integer division - if (Niter*gbx%Npoints_it < gbx%Npoints) Niter = Niter + 1 - do i=1,Niter - i_first = (i-1)*gbx%Npoints_it + 1 - i_last = i_first + gbx%Npoints_it - 1 - i_last = min(i_last,gbx%Npoints) - Ni = i_last - i_first + 1 - if (i == 1) then - ! Allocate types for all but last iteration - call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, & - gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, & - Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & - gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & - gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & - gbx%use_precipitation_fluxes,gbx%use_reff, & - gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & - gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & - gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & - gbx_it) - call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) - call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) - call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) - call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) - call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) - call construct_cosp_modis(cfg, Ni, modis_it) - call construct_cosp_misr(cfg,Ni,misr_it) -!#ifdef RTTOV -! call construct_cosp_rttov(Ni,gbx%nchan,rttov_it) -!#endif - call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) - call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) - elseif (i == Niter) then ! last iteration - call free_cosp_gridbox(gbx_it,.true.) - call free_cosp_subgrid(sgx_it) - call free_cosp_vgrid(vgrid_it) - call free_cosp_sgradar(sgradar_it) - call free_cosp_sglidar(sglidar_it) - call free_cosp_isccp(isccp_it) - call free_cosp_modis(modis_it) - call free_cosp_misr(misr_it) -!#ifdef RTTOV -! call free_cosp_rttov(rttov_it) -!#endif - call free_cosp_radarstats(stradar_it) - call free_cosp_lidarstats(stlidar_it) - ! Allocate types for iterations - call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, & - gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, & - Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & - gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & - gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & - gbx%use_precipitation_fluxes,gbx%use_reff, & - gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & - gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & - gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & - gbx_it) - ! --- Copy arrays without Npoints as dimension --- - gbx_it%dist_prmts_hydro = gbx%dist_prmts_hydro - gbx_it%dist_type_aero = gbx_it%dist_type_aero - call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) - call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) - call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) - call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) - call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) - call construct_cosp_modis(cfg,Ni, modis_it) - call construct_cosp_misr(cfg,Ni,misr_it) -!#ifdef RTTOV -! call construct_cosp_rttov(Ni,gbx%nchan,rttov_it) -!#endif - call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) - call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) - endif - ! --- Copy sections of arrays with Npoints as dimension --- - ix=(/i_first,i_last/) - iy=(/1,Ni/) - call cosp_gridbox_cpsection(ix,iy,gbx,gbx_it) - ! These serve as initialisation of *_it types - call cosp_subgrid_cpsection(ix,iy,sgx,sgx_it) - if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar,sgradar_it) - if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it) - if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it) - if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis,modis_it) - if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr,misr_it) -!#ifdef RTTOV -! if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov,rttov_it) -!#endif - if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it) - if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it) -!#ifdef RTTOV -! call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, & -! sglidar_it,isccp_it,misr_it,modis_it,rttov_it,stradar_it,stlidar_it) -!#else - call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, & - sglidar_it,isccp_it,misr_it,modis_it,stradar_it,stlidar_it) -!#endif - ! --- Copy results to output structures --- - ix=(/1,Ni/) - iy=(/i_first,i_last/) - call cosp_subgrid_cpsection(ix,iy,sgx_it,sgx) - if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar_it,sgradar) - if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar) - if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp) - if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis_it,modis) - if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr_it,misr) -!#ifdef RTTOV -! if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov_it,rttov) -!#endif - if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar) - if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar) - enddo - ! Deallocate types - call free_cosp_gridbox(gbx_it,.true.) - call free_cosp_subgrid(sgx_it) - call free_cosp_vgrid(vgrid_it) - call free_cosp_sgradar(sgradar_it) - call free_cosp_sglidar(sglidar_it) - call free_cosp_isccp(isccp_it) - call free_cosp_modis(modis_it) - call free_cosp_misr(misr_it) -!#ifdef RTTOV -! call free_cosp_rttov(rttov_it) -!#endif - call free_cosp_radarstats(stradar_it) - call free_cosp_lidarstats(stlidar_it) - endif - deallocate(seed) - - -END SUBROUTINE COSP - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!--------------------- SUBROUTINE COSP_ITER ---------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!#ifdef RTTOV -!SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) -!#else -SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) -!#endif - ! Arguments - integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand - integer,dimension(:),intent(in) :: seed - type(cosp_config),intent(in) :: cfg ! Configuration options - type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats - type(cosp_gridbox),intent(inout) :: gbx - type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info - type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator - type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator - type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator - type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator - type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator -!#ifdef RTTOV -! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV -!#endif - type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator - type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator - - ! Local variables - integer :: Npoints ! Number of gridpoints - integer :: Ncolumns ! Number of subcolumns - integer :: Nlevels ! Number of levels - integer :: Nhydro ! Number of hydrometeors - integer :: i,j,k - integer :: I_HYDRO - real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out - real,dimension(:,:),pointer :: column_prec_out ! Array with one column of prec_frac - integer :: scops_debug=0 ! set to non-zero value to print out inputs for debugging in SCOPS - real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, & - tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud. - ! Levels are from TOA to SURFACE. (nPoints, nLev) - real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level - ! Levels are from SURFACE to TOA - real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric density - type(cosp_sghydro) :: sghydro ! Subgrid info for hydrometeors en each iteration - - - !++++++++++ Dimensions ++++++++++++ - Npoints = gbx%Npoints - Ncolumns = gbx%Ncolumns - Nlevels = gbx%Nlevels - Nhydro = gbx%Nhydro - - !++++++++++ Climate/NWP mode ++++++++++ - if (Ncolumns > 1) then - !++++++++++ Subgrid sampling ++++++++++ - ! Allocate arrays before calling SCOPS - allocate(frac_ls(Npoints,Nlevels),frac_cv(Npoints,Nlevels),prec_ls(Npoints,Nlevels),prec_cv(Npoints,Nlevels)) - allocate(tca_scops(Npoints,Nlevels),cca_scops(Npoints,Nlevels), & - ls_p_rate(Npoints,Nlevels),cv_p_rate(Npoints,Nlevels)) - ! Initialize to zero - frac_ls=0.0 - prec_ls=0.0 - frac_cv=0.0 - prec_cv=0.0 - ! Cloud fractions for SCOPS from TOA to SFC - tca_scops = gbx%tca(:,Nlevels:1:-1) - cca_scops = gbx%cca(:,Nlevels:1:-1) - - ! Call to SCOPS - ! strat and conv arrays are passed with levels from TOA to SURFACE. - call scops(Npoints,Nlevels,Ncolumns,seed,tca_scops,cca_scops,overlap,sgx%frac_out,scops_debug) - - ! temporarily use prec_ls/cv to transfer information about precipitation flux into prec_scops - if(gbx%use_precipitation_fluxes) then - ls_p_rate(:,Nlevels:1:-1)=gbx%rain_ls(:,1:Nlevels)+gbx%snow_ls(:,1:Nlevels)+gbx%grpl_ls(:,1:Nlevels) - cv_p_rate(:,Nlevels:1:-1)=gbx%rain_cv(:,1:Nlevels)+gbx%snow_cv(:,1:Nlevels) - else - ls_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_LSRAIN)+ & - gbx%mr_hydro(:,1:Nlevels,I_LSSNOW)+ & - gbx%mr_hydro(:,1:Nlevels,I_LSGRPL) - cv_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_CVRAIN)+ & - gbx%mr_hydro(:,1:Nlevels,I_CVSNOW) - endif - - call prec_scops(Npoints,Nlevels,Ncolumns,ls_p_rate,cv_p_rate,sgx%frac_out,sgx%prec_frac) - - ! Precipitation fraction - do j=1,Npoints,1 - do k=1,Nlevels,1 - do i=1,Ncolumns,1 - if (sgx%frac_out (j,i,Nlevels+1-k) == I_LSC) frac_ls(j,k)=frac_ls(j,k)+1. - if (sgx%frac_out (j,i,Nlevels+1-k) == I_CVC) frac_cv(j,k)=frac_cv(j,k)+1. - if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 1) prec_ls(j,k)=prec_ls(j,k)+1. - if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 2) prec_cv(j,k)=prec_cv(j,k)+1. - if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 3) then - prec_cv(j,k)=prec_cv(j,k)+1. - prec_ls(j,k)=prec_ls(j,k)+1. - endif - enddo !i - 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 !k - enddo !j - - ! Levels from SURFACE to TOA. - if (Npoints*Ncolumns*Nlevels < 10000) then - sgx%frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) - sgx%prec_frac(1:Npoints,:,1:Nlevels) = sgx%prec_frac(1:Npoints,:,Nlevels:1:-1) - else - ! This is done within a loop (unvectorized) over nPoints to save memory - do j=1,Npoints - sgx%frac_out(j,:,1:Nlevels) = sgx%frac_out(j,:,Nlevels:1:-1) - sgx%prec_frac(j,:,1:Nlevels) = sgx%prec_frac(j,:,Nlevels:1:-1) - enddo - endif - - ! Deallocate arrays that will no longer be used - deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate) - - ! Populate the subgrid arrays - call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro) - do k=1,Ncolumns - !--------- Mixing ratios for clouds and Reff for Clouds and precip ------- - column_frac_out => sgx%frac_out(:,k,:) - where (column_frac_out == I_LSC) !+++++++++++ LS clouds ++++++++ - sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ) - sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE) - - sghydro%Reff(:,k,:,I_LSCLIQ) = gbx%Reff(:,:,I_LSCLIQ) - sghydro%Reff(:,k,:,I_LSCICE) = gbx%Reff(:,:,I_LSCICE) - - sghydro%Np(:,k,:,I_LSCLIQ) = gbx%Np(:,:,I_LSCLIQ) - sghydro%Np(:,k,:,I_LSCICE) = gbx%Np(:,:,I_LSCICE) - - elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV clouds ++++++++ - sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ) - sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE) - - sghydro%Reff(:,k,:,I_CVCLIQ) = gbx%Reff(:,:,I_CVCLIQ) - sghydro%Reff(:,k,:,I_CVCICE) = gbx%Reff(:,:,I_CVCICE) - - sghydro%Np(:,k,:,I_CVCLIQ) = gbx%Np(:,:,I_CVCLIQ) - sghydro%Np(:,k,:,I_CVCICE) = gbx%Np(:,:,I_CVCICE) - - end where - column_prec_out => sgx%prec_frac(:,k,:) - where ((column_prec_out == 1) .or. (column_prec_out == 3) ) !++++ LS precip ++++ - sghydro%Reff(:,k,:,I_LSRAIN) = gbx%Reff(:,:,I_LSRAIN) - sghydro%Reff(:,k,:,I_LSSNOW) = gbx%Reff(:,:,I_LSSNOW) - sghydro%Reff(:,k,:,I_LSGRPL) = gbx%Reff(:,:,I_LSGRPL) - - sghydro%Np(:,k,:,I_LSRAIN) = gbx%Np(:,:,I_LSRAIN) - sghydro%Np(:,k,:,I_LSSNOW) = gbx%Np(:,:,I_LSSNOW) - sghydro%Np(:,k,:,I_LSGRPL) = gbx%Np(:,:,I_LSGRPL) - elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3)) !++++ CONV precip ++++ - sghydro%Reff(:,k,:,I_CVRAIN) = gbx%Reff(:,:,I_CVRAIN) - sghydro%Reff(:,k,:,I_CVSNOW) = gbx%Reff(:,:,I_CVSNOW) - - sghydro%Np(:,k,:,I_CVRAIN) = gbx%Np(:,:,I_CVRAIN) - sghydro%Np(:,k,:,I_CVSNOW) = gbx%Np(:,:,I_CVSNOW) - end where - !--------- Precip ------- - if (.not. gbx%use_precipitation_fluxes) then - where (column_frac_out == I_LSC) !+++++++++++ LS Precipitation ++++++++ - sghydro%mr_hydro(:,k,:,I_LSRAIN) = gbx%mr_hydro(:,:,I_LSRAIN) - sghydro%mr_hydro(:,k,:,I_LSSNOW) = gbx%mr_hydro(:,:,I_LSSNOW) - sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL) - elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV Precipitation ++++++++ - sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN) - sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW) - end where - endif - enddo - ! convert the mixing ratio and precipitation flux from gridbox mean to the fraction-based values - do k=1,Nlevels - do j=1,Npoints - !--------- Clouds ------- - if (frac_ls(j,k) .ne. 0.) then - sghydro%mr_hydro(j,:,k,I_LSCLIQ) = sghydro%mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k) - sghydro%mr_hydro(j,:,k,I_LSCICE) = sghydro%mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k) - endif - if (frac_cv(j,k) .ne. 0.) then - sghydro%mr_hydro(j,:,k,I_CVCLIQ) = sghydro%mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k) - sghydro%mr_hydro(j,:,k,I_CVCICE) = sghydro%mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k) - endif - !--------- Precip ------- - if (gbx%use_precipitation_fluxes) then - if (prec_ls(j,k) .ne. 0.) then - gbx%rain_ls(j,k) = gbx%rain_ls(j,k)/prec_ls(j,k) - gbx%snow_ls(j,k) = gbx%snow_ls(j,k)/prec_ls(j,k) - gbx%grpl_ls(j,k) = gbx%grpl_ls(j,k)/prec_ls(j,k) - endif - if (prec_cv(j,k) .ne. 0.) then - gbx%rain_cv(j,k) = gbx%rain_cv(j,k)/prec_cv(j,k) - gbx%snow_cv(j,k) = gbx%snow_cv(j,k)/prec_cv(j,k) - endif - else - if (prec_ls(j,k) .ne. 0.) then - sghydro%mr_hydro(j,:,k,I_LSRAIN) = sghydro%mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k) - sghydro%mr_hydro(j,:,k,I_LSSNOW) = sghydro%mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k) - sghydro%mr_hydro(j,:,k,I_LSGRPL) = sghydro%mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k) - endif - if (prec_cv(j,k) .ne. 0.) then - sghydro%mr_hydro(j,:,k,I_CVRAIN) = sghydro%mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k) - sghydro%mr_hydro(j,:,k,I_CVSNOW) = sghydro%mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k) - endif - endif - enddo !k - enddo !j - deallocate(frac_ls,prec_ls,frac_cv,prec_cv) - - if (gbx%use_precipitation_fluxes) then - -#ifdef MMF_V3p5_TWO_MOMENT - - write(*,*) 'Precipitation Flux to Mixing Ratio conversion not (yet?) supported ', & - 'for MMF3.5 Two Moment Microphysics' - stop -#else - ! Density - allocate(rho(Npoints,Nlevels)) - I_HYDRO = I_LSRAIN - call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., & - n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & - g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & - gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & - gbx%rain_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) - I_HYDRO = I_LSSNOW - call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., & - n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & - g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & - gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & - gbx%snow_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) - I_HYDRO = I_CVRAIN - call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., & - n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & - g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & - gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & - gbx%rain_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) - I_HYDRO = I_CVSNOW - call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., & - n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & - g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & - gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & - gbx%snow_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) - I_HYDRO = I_LSGRPL - call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., & - n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & - g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & - gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & - gbx%grpl_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) - if(allocated(rho)) deallocate(rho) -#endif - - endif - !++++++++++ CRM mode ++++++++++ - else - call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro) - sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro - sghydro%Reff(:,1,:,:) = gbx%Reff - sghydro%Np(:,1,:,:) = gbx%Np ! added by Roj with Quickbeam V3.0 - - !--------- Clouds ------- - where ((gbx%dtau_s > 0.0)) - sgx%frac_out(:,1,:) = 1 ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) - endwhere - endif ! Ncolumns > 1 - - !++++++++++ Simulator ++++++++++ -!#ifdef RTTOV -! call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) -!#else - call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) -!#endif - - ! Deallocate subgrid arrays - call free_cosp_sghydro(sghydro) -END SUBROUTINE COSP_ITER - -END MODULE MOD_COSP Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_constants.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_constants.F90 (revision 3231) +++ (revision ) @@ -1,304 +1,0 @@ -! (c) British Crown Copyright 2008, 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: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! 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 -! -! -! - -#include "cosp_defs.h" -MODULE MOD_COSP_CONSTANTS - IMPLICIT NONE - - character(len=32) :: COSP_VERSION='COSP v1.4' - - ! Indices to address arrays of LS and CONV hydrometeors - integer,parameter :: I_LSCLIQ = 1 - integer,parameter :: I_LSCICE = 2 - integer,parameter :: I_LSRAIN = 3 - integer,parameter :: I_LSSNOW = 4 - integer,parameter :: I_CVCLIQ = 5 - integer,parameter :: I_CVCICE = 6 - integer,parameter :: I_CVRAIN = 7 - integer,parameter :: I_CVSNOW = 8 - integer,parameter :: I_LSGRPL = 9 - - ! Missing value - real,parameter :: R_UNDEF = -1.0E30 - - ! Number of possible output variables - integer,parameter :: N_OUT_LIST = 74 !OPAQ 65+7 !TIBO 72+2 - integer,parameter :: N3D = 11 !TIBO 10+1 - integer,parameter :: N2D = 19 !OPAQ 14+4 !TIBO 18+1 - integer,parameter :: N1D = 43 !OPAQ 40+3 - - ! Value for forward model result from a level that is under the ground - real,parameter :: R_GROUND = -1.0E20 - - ! Stratiform and convective clouds in frac_out - integer, parameter :: I_LSC = 1, & ! Large-scale clouds - I_CVC = 2 ! Convective clouds - - ! Timing of different simulators, including statistics module - integer, parameter :: N_SIMULATORS = 7 - integer,parameter :: I_RADAR = 1 - integer,parameter :: I_LIDAR = 2 - integer,parameter :: I_ISCCP = 3 - integer,parameter :: I_MISR = 4 - integer,parameter :: I_MODIS = 5 - integer,parameter :: I_RTTOV = 6 - integer,parameter :: I_STATS = 7 - character*32, dimension(N_SIMULATORS) :: SIM_NAME = (/'Radar','Lidar','ISCCP','MISR ','MODIS','RTTOV','Stats'/) - integer,dimension(N_SIMULATORS) :: tsim - data tsim/N_SIMULATORS*0.0/ - - !--- Radar constants - ! CFAD constants - integer,parameter :: DBZE_BINS = 15 ! Number of dBZe bins in histogram (cfad) - real,parameter :: DBZE_MIN = -100.0 ! Minimum value for radar reflectivity - real,parameter :: DBZE_MAX = 80.0 ! Maximum value for radar reflectivity - real,parameter :: CFAD_ZE_MIN = -50.0 ! Lower value of the first CFAD Ze bin - real,parameter :: CFAD_ZE_WIDTH = 5.0 ! Bin width (dBZe) - - - !--- Lidar constants - ! CFAD constants - integer,parameter :: SR_BINS = 15 - integer,parameter :: DPOL_BINS = 6 - real,parameter :: LIDAR_UNDEF = 999.999 - - ! Other constants - integer,parameter :: LIDAR_NCAT = 4 - integer,parameter :: LIDAR_NTYPE = 3 !OPAQ - integer,parameter :: PARASOL_NREFL = 5 ! parasol - real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/) - real,parameter :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius - - integer,parameter :: LIDAR_NTEMP = 40 - real,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,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/)) - - !--- MISR constants - integer,parameter :: MISR_N_CTH = 16 - - !--- RTTOV constants - integer,parameter :: RTTOV_MAX_CHANNELS = 20 - - ! ISCCP tau-Pc axes - real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/) - real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, & - 9.4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/)) - - real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./) - real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = 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,7/)) - - real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = 1000.0*(/ 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,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = 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,MISR_N_CTH/)) - - - ! - ! The following code was modifed by Roj with implementation of quickbeam V3 - ! (1) use ifdef to support more than one microphyscis scheme - ! (2) added constants microphysic_scheme_name, LOAD_scale_LUTs, and SAVE_scale_LUTs - ! - - ! directory where LUTs will be stored - character*120 :: RADAR_SIM_LUT_DIRECTORY = './' - -#ifdef MMF_V3_SINGLE_MOMENT - - ! - ! Table hclass for quickbeam to support one-moment (bulk) microphysics scheme used by MMF V3.0 & V3.5 - ! - - ! - ! NOTE: if ANY value in this section of code is changed, the existing LUT - ! (i.e., the associated *.dat file) MUST be deleted so that a NEW - ! LUT will be created !!! - ! - character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3_single_moment' - - logical :: RADAR_SIM_LOAD_scale_LUTs_flag = .false. - logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false. - integer,parameter :: N_HYDRO = 9 - - integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO) - - real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), & - HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), & - HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO) - - ! HCLASS_CP is not used in the version of Quickbeam included in COSP - ! LSL LSI LSR LSS CVL CVI CVR CVS LSG - data HCLASS_TYPE/ 5, 1, 2, 2, 5, 1, 2, 2, 2/ - data HCLASS_PHASE/ 0, 1, 0, 1, 0, 1, 0, 1, 1/ - data HCLASS_DMIN/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ - data HCLASS_DMAX/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ - data HCLASS_APM/ 524, 110.8, 524, -1, 524, 110.8, 524, -1, -1/ - data HCLASS_BPM/ 3, 2.91, 3, -1, 3, 2.91, 3, -1, -1/ - data HCLASS_RHO/ -1, -1, -1, 100, -1, -1, -1, 100, 400/ - data HCLASS_P1/ -1, -1, 8.e6, 3.e6, -1, -1, 8.e6, 3.e6, 4.e6/ - data HCLASS_P2/ 6, 40, -1, -1, 6, 40, -1, -1, -1/ - data HCLASS_P3/ 0.3, 2, -1, -1, 0.3, 2, -1, -1, -1/ - - ! 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. - ! - - - real,dimension(N_HYDRO) :: N_ax,N_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma_1,gamma_2,gamma_3,gamma_4 - - ! Microphysical settings for the precipitation flux to mixing ratio conversion - ! LSL LSI LSR LSS CVL CVI CVR CVS LSG - data N_ax/ -1., -1., 8.e6, 3.e6, -1., -1., 8.e6, 3.e6, 4.e6/ - data N_bx/ -1., -1., 0.0, 0.0, -1., -1., 0.0, 0.0, 0.0/ - data alpha_x/ -1., -1., 0.0, 0.0, -1., -1., 0.0, 0.0, 0.0/ - data c_x/ -1., -1., 842.0, 4.84, -1., -1., 842.0, 4.84, 94.5/ - data d_x/ -1., -1., 0.8, 0.25, -1., -1., 0.8, 0.25, 0.5/ - data g_x/ -1., -1., 0.5, 0.5, -1., -1., 0.5, 0.5, 0.5/ - data a_x/ -1., -1., 524.0, 52.36, -1., -1., 524.0, 52.36, 209.44/ - data b_x/ -1., -1., 3.0, 3.0, -1., -1., 3.0, 3.0, 3.0/ - data gamma_1/ -1., -1., 17.83725, 8.284701, -1., -1., 17.83725, 8.284701, 11.63230/ - data gamma_2/ -1., -1., 6.0, 6.0, -1., -1., 6.0, 6.0, 6.0/ - data gamma_3/ -1., -1., 2.0, 2.0, -1., -1., 2.0, 2.0, 2.0/ - data gamma_4/ -1., -1., 6.0, 6.0, -1., -1., 6.0, 6.0, 6.0/ - - - -#endif - - -#ifdef MMF_V3p5_TWO_MOMENT - - ! - ! Table hclass for quickbeam to support two-moment "morrison" microphysics scheme used by V3.5 (SAM 6.8) - ! - ! This Number concentriation Np in [1/kg] MUST be input to COSP/radar simulator - ! - ! NOTE: Be sure to check that the ice-density (rho) set it this tables matches what you used - ! - - ! - ! NOTE: if ANY value in this section of code is changed, the existing LUT - ! (i.e., the associated *.dat file) MUST be deleted so that a NEW - ! LUT will be created !!! - ! - character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3.5_two_moment' - - logical :: RADAR_SIM_LOAD_scale_LUTs_flag = .false. - logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false. - - integer,parameter :: N_HYDRO = 9 - - integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO) - - real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), & - HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), & - HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO) - - ! HCLASS_CP is not used in the version of Quickbeam included in COSP - ! LSL LSI LSR LSS CVL CVI CVR CVS LSG - data HCLASS_TYPE/ 1, 1, 1, 1, 1, 1, 1, 1, 1/ - data HCLASS_PHASE/ 0, 1, 0, 1, 0, 1, 0, 1, 1/ - data HCLASS_DMIN/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ - data HCLASS_DMAX/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ - data HCLASS_APM/ 524, -1, 524, -1, 524, -1, 524, -1, -1/ - data HCLASS_BPM/ 3, -1, 3, -1, 3, -1, 3, -1, -1/ - data HCLASS_RHO/ -1, 500, -1, 100, -1, 500, -1, 100, 900/ - data HCLASS_P1/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ - data HCLASS_P2/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ - data HCLASS_P3/ -2, 1, 1, 1, -2, 1, 1, 1, 1/ - ! Note: value of "-2" for HCLASS_P3 uses martin 1994 parameteriztion of gamma function width with Number concentration -#endif - -END MODULE MOD_COSP_CONSTANTS Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_isccp_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_isccp_simulator.F90 (revision 3231) +++ (revision ) @@ -1,96 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_isccp_simulator.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -MODULE MOD_COSP_ISCCP_SIMULATOR - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - IMPLICIT NONE - -CONTAINS - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_ISCCP_SIMULATOR(gbx,sgx,y) - - ! Arguments - type(cosp_gridbox),intent(in) :: gbx ! Gridbox info - type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info - type(cosp_isccp),intent(inout) :: y ! ISCCP simulator output - - ! Local variables - integer :: Nlevels,Npoints - real :: pfull(gbx%Npoints, gbx%Nlevels) - real :: phalf(gbx%Npoints, gbx%Nlevels + 1) - real :: qv(gbx%Npoints, gbx%Nlevels) - real :: cc(gbx%Npoints, gbx%Nlevels) - real :: conv(gbx%Npoints, gbx%Nlevels) - real :: dtau_s(gbx%Npoints, gbx%Nlevels) - real :: dtau_c(gbx%Npoints, gbx%Nlevels) - real :: at(gbx%Npoints, gbx%Nlevels) - real :: dem_s(gbx%Npoints, gbx%Nlevels) - real :: dem_c(gbx%Npoints, gbx%Nlevels) - real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) - integer :: sunlit(gbx%Npoints) - - Nlevels = gbx%Nlevels - Npoints = gbx%Npoints - ! Flip inputs. Levels from TOA to surface - pfull = gbx%p(:,Nlevels:1:-1) - phalf(:,1) = 0.0 ! Top level - phalf(:,2:Nlevels+1) = gbx%ph(:,Nlevels:1:-1) - qv = gbx%sh(:,Nlevels:1:-1) - cc = 0.999999*gbx%tca(:,Nlevels:1:-1) - conv = 0.999999*gbx%cca(:,Nlevels:1:-1) - dtau_s = gbx%dtau_s(:,Nlevels:1:-1) - dtau_c = gbx%dtau_c(:,Nlevels:1:-1) - at = gbx%T(:,Nlevels:1:-1) - dem_s = gbx%dem_s(:,Nlevels:1:-1) - dem_c = gbx%dem_c(:,Nlevels:1:-1) - frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) - sunlit = int(gbx%sunlit) - call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, & - pfull,phalf,qv,cc,conv,dtau_s,dtau_c, & - gbx%isccp_top_height,gbx%isccp_top_height_direction, & - gbx%isccp_overlap,frac_out, & - gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, & - y%meanptop,y%meantaucld,y%meanalbedocld, & - y%meantb,y%meantbclr,y%boxtau,y%boxptop) - - ! Flip outputs. Levels from surface to TOA - ! --- (npoints,tau=7,pressure=7) - y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1) - - - ! Check if there is any value slightly greater than 1 - where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5)) - y%totalcldarea = 1.0 - endwhere - -END SUBROUTINE COSP_ISCCP_SIMULATOR - -END MODULE MOD_COSP_ISCCP_SIMULATOR Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_lidar.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_lidar.F90 (revision 3231) +++ (revision ) @@ -1,87 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_lidar.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! History: -! Jul 2007 - A. Bodas-Salcedo - Initial version -! Oct 2008 - S. Bony - Instructions "Call for large-scale cloud" removed -> sgx%frac_out is used instead. -! Call lidar_simulator changed (lsca, gbx%cca and depol removed; -! frac_out changed in sgx%frac_out) -! Jun 2011 - G. Cesana - Added betaperp_tot argument -! -! -MODULE MOD_COSP_LIDAR - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - IMPLICIT NONE - -CONTAINS - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------- SUBROUTINE COSP_LIDAR ------------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y) - - ! Arguments - type(cosp_gridbox),intent(in) :: gbx ! Gridbox info - type(cosp_subgrid),intent(in) :: sgx ! Subgrid info - type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors - type(cosp_sglidar),intent(inout) :: y ! Subgrid output - - ! Local variables - integer :: i - real :: presf(sgx%Npoints, sgx%Nlevels + 1) - real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci - real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot - real,dimension(sgx%Npoints, sgx%Nlevels) :: betaperp_tot - real,dimension(sgx%Npoints, PARASOL_NREFL) :: refle - - presf(:,1:sgx%Nlevels) = gbx%ph - presf(:,sgx%Nlevels + 1) = 0.0 - lsca = gbx%tca-gbx%cca - do i=1,sgx%Ncolumns - ! Temporary arrays for simulator call - mr_ll(:,:) = sghydro%mr_hydro(:,i,:,I_LSCLIQ) - mr_li(:,:) = sghydro%mr_hydro(:,i,:,I_LSCICE) - mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ) - mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE) - call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4, PARASOL_NREFL, LIDAR_UNDEF & - , gbx%p, presf, gbx%T, mr_ll, mr_li, mr_cl, mr_ci & - , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE) & - , gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) & - , gbx%lidar_ice_type, y%beta_mol, beta_tot & - , betaperp_tot, tau_tot, refle ) - - y%betaperp_tot(:,i,:) = betaperp_tot(:,:) - y%beta_tot(:,i,:) = beta_tot(:,:) - y%tau_tot(:,i,:) = tau_tot(:,:) - y%refl(:,i,:) = refle(:,:) - enddo - -END SUBROUTINE COSP_LIDAR - -END MODULE MOD_COSP_LIDAR Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_misr_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_misr_simulator.F90 (revision 3231) +++ (revision ) @@ -1,80 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_misr_simulator.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! History: -! Nov 2008 - A. Bodas-Salcedo - Initial version -! -! - -MODULE MOD_COSP_MISR_SIMULATOR - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - IMPLICIT NONE - -CONTAINS - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------- SUBROUTINE COSP_MISR_SIMULATOR ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_MISR_SIMULATOR(gbx,sgx,y) - - ! Arguments - type(cosp_gridbox),intent(in) :: gbx ! Gridbox info - type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info - type(cosp_misr),intent(inout) :: y ! MISR simulator output - - ! Local variables - integer :: Nlevels,Npoints - real :: dtau_s(gbx%Npoints, gbx%Nlevels) - real :: dtau_c(gbx%Npoints, gbx%Nlevels) - real :: at(gbx%Npoints, gbx%Nlevels) - real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) - integer :: sunlit(gbx%Npoints) - - real :: zfull(gbx%Npoints, gbx%Nlevels) ! height (in meters) of full model levels (i.e. midpoints) - ! zfull(npoints,1) is top level of model - ! zfull(npoints,nlev) is bottom level of model - - - Nlevels = gbx%Nlevels - Npoints = gbx%Npoints - ! Levels from TOA to surface - zfull = gbx%zlev(:,Nlevels:1:-1) - at = gbx%T(:,Nlevels:1:-1) - dtau_s = gbx%dtau_s(:,Nlevels:1:-1) - dtau_c = gbx%dtau_c(:,Nlevels:1:-1) - frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) - sunlit = int(gbx%sunlit) - - call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,& - sunlit,zfull,at,dtau_s,dtau_c,frac_out, R_UNDEF, & - y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea) - -END SUBROUTINE COSP_MISR_SIMULATOR - -END MODULE MOD_COSP_MISR_SIMULATOR Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_modis_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_modis_simulator.F90 (revision 3231) +++ (revision ) @@ -1,487 +1,0 @@ -! (c) 2009, Regents of the Unversity of Colorado -! Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_modis_simulator.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! - -! -! History: -! May 2009 - Robert Pincus - Initial version -! Dec 2009 - Robert Pincus - Tiny revisions -! -MODULE MOD_COSP_Modis_Simulator - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - use mod_modis_sim, numModisTauBins => numTauHistogramBins, & - numModisPressureBins => numPressureHistogramBins, & - MODIS_TAU => nominalTauHistogramCenters, & - MODIS_TAU_BNDS => nominalTauHistogramBoundaries, & - MODIS_PC => nominalPressureHistogramCenters, & - MODIS_PC_BNDS => nominalPressureHistogramBoundaries - implicit none - !------------------------------------------------------------------------------------------------ - ! Public type - ! - ! Summary statistics from MODIS retrievals - type COSP_MODIS - ! Dimensions - integer :: Npoints ! Number of gridpoints - - ! - ! Grid means; dimension nPoints - ! - real, dimension(:), pointer :: & - 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_LogMean, Optical_Thickness_Water_LogMean, Optical_Thickness_Ice_LogMean, & - Cloud_Particle_Size_Water_Mean, Cloud_Particle_Size_Ice_Mean, & - Cloud_Top_Pressure_Total_Mean, & - Liquid_Water_Path_Mean, Ice_Water_Path_Mean - ! - ! Also need the ISCCP-type optical thickness/cloud top pressure histogram - ! - real, dimension(:, :, :), pointer :: Optical_Thickness_vs_Cloud_Top_Pressure - real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffICE - real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffLIQ - end type COSP_MODIS - -contains - !------------------------------------------------------------------------------------------------ - subroutine COSP_Modis_Simulator(gridBox, subCols, subcolHydro, isccpSim, modisSim) - ! Arguments - type(cosp_gridbox), intent(in ) :: gridBox ! Gridbox info - type(cosp_subgrid), intent(in ) :: subCols ! subCol indicators of convective/stratiform - type(cosp_sghydro), intent(in ) :: subcolHydro ! subcol hydrometeor contens - type(cosp_isccp), intent(in ) :: isccpSim ! ISCCP simulator output - type(cosp_modis), intent( out) :: modisSim ! MODIS simulator subcol output - - ! ------------------------------------------------------------ - ! Local variables - ! Leave space only for sunlit points - - integer :: nPoints, nSubCols, nLevels, nSunlit, i, j, k - - ! Grid-mean quanties; dimensions nPoints, nLevels - real, & - dimension(count(gridBox%sunlit(:) > 0), gridBox%nLevels) :: & - temperature, pressureLayers - real, & - dimension(count(gridBox%sunlit(:) > 0), gridBox%nLevels + 1) :: & - pressureLevels - - ! Subcol quantities, dimension nPoints, nSubCols, nLevels - real, & - dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns, gridBox%nLevels) :: & - opticalThickness, cloudWater, cloudIce, waterSize, iceSize - - ! Vertically-integrated subcol quantities; dimensions nPoints, nSubcols - integer, & - dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & - retrievedPhase - real, & - dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & - isccpTau, isccpCloudTopPressure, retrievedCloudTopPressure, retrievedTau, retrievedSize - - ! Vertically-integrated results - real, dimension(count(gridBox%sunlit(:) > 0)) :: & - cfTotal, cfLiquid, cfIce, & - cfHigh, cfMid, cfLow, & - meanTauTotal, meanTauLiquid, meanTauIce, & - meanLogTauTotal, meanLogTauLiquid, meanLogTauIce , & - meanSizeLiquid, meanSizeIce, & - meanCloudTopPressure, & - meanLiquidWaterPath, meanIceWaterPath - - real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numModisPressureBins) :: & - jointHistogram - real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffIceBins) :: & - jointHistogram2 - real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffLiqBins) :: & - jointHistogram3 - - integer, dimension(count(gridBox%sunlit(:) > 0)) :: sunlit - integer, dimension(count(gridBox%sunlit(:) <= 0)) :: notSunlit - ! ------------------------------------------------------------ - - ! - ! Are there any sunlit points? - ! - nSunlit = count(gridBox%sunlit(:) > 0) - if(nSunlit > 0) then - nLevels = gridBox%Nlevels - nPoints = gridBox%Npoints - nSubCols = subCols%Ncolumns - ! - ! This is a vector index indicating which points are sunlit - ! - sunlit(:) = pack((/ (i, i = 1, nPoints ) /), mask = gridBox%sunlit(:) > 0) - notSunlit(:) = pack((/ (i, i = 1, nPoints ) /), mask = .not. gridBox%sunlit(:) > 0) - - ! - ! Copy needed quantities, reversing vertical order and removing points with no sunlight - ! - pressureLevels(:, 1) = 0.0 ! Top of model, following ISCCP sim - temperature(:, :) = gridBox%T (sunlit(:), nLevels:1:-1) - pressureLayers(:, :) = gridBox%p (sunlit(:), nLevels:1:-1) - pressureLevels(:, 2:) = gridBox%ph(sunlit(:), nLevels:1:-1) - - ! - ! Subcolumn properties - first stratiform cloud... - ! - where(subCols%frac_out(sunlit(:), :, :) == I_LSC) - !opticalThickness(:, :, :) = & - ! spread(gridBox%dtau_s (sunlit(:), :), dim = 2, nCopies = nSubCols) - cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCLIQ) - waterSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_LSCLIQ) - cloudIce (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCICE) - iceSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_LSCICE) - elsewhere - opticalThickness(:, :, :) = 0. - cloudWater (:, :, :) = 0. - cloudIce (:, :, :) = 0. - waterSize (:, :, :) = 0. - iceSize (:, :, :) = 0. - end where - - ! Loop version of spread above - intrinsic doesn't work on certain platforms. - do k = 1, nLevels - do j = 1, nSubCols - do i = 1, nSunlit - if(subCols%frac_out(sunlit(i), j, k) == I_LSC) then - opticalThickness(i, j, k) = gridBox%dtau_s(sunlit(i), k) - else - opticalThickness(i, j, k) = 0. - end if - end do - end do - end do - - ! - ! .. then add convective cloud... - ! - where(subCols%frac_out(sunlit(:), :, :) == I_CVC) - !opticalThickness(:, :, :) = & - ! spread(gridBox%dtau_c( sunlit(:), :), dim = 2, nCopies = nSubCols) - cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCLIQ) - waterSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_CVCLIQ) - cloudIce (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCICE) - iceSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_CVCICE) - end where - - ! Loop version of spread above - intrinsic doesn't work on certain platforms. - do k = 1, nLevels - do j = 1, nSubCols - do i = 1, nSunlit - if(subCols%frac_out(sunlit(i), j, k) == I_CVC) opticalThickness(i, j, k) = gridBox%dtau_c(sunlit(i), k) - end do - end do - end do - - ! - ! Reverse vertical order - ! - opticalThickness(:, :, :) = opticalThickness(:, :, nLevels:1:-1) - cloudWater (:, :, :) = cloudWater (:, :, nLevels:1:-1) - waterSize (:, :, :) = waterSize (:, :, nLevels:1:-1) - cloudIce (:, :, :) = cloudIce (:, :, nLevels:1:-1) - iceSize (:, :, :) = iceSize (:, :, nLevels:1:-1) - - isccpTau(:, :) = isccpSim%boxtau (sunlit(:), :) - isccpCloudTopPressure(:, :) = isccpSim%boxptop(sunlit(:), :) - - do i = 1, nSunlit - call modis_L2_simulator(temperature(i, :), pressureLayers(i, :), pressureLevels(i, :), & - opticalThickness(i, :, :), cloudWater(i, :, :), cloudIce(i, :, :), & - waterSize(i, :, :), iceSize(i, :, :), & - isccpTau(i, :), isccpCloudTopPressure(i, :), & - retrievedPhase(i, :), retrievedCloudTopPressure(i, :), & - retrievedTau(i, :), retrievedSize(i, :)) - end do - - ! DJS2015: Call L3 modis simulator used by cospv2.0 - ! call modis_L3_simulator(retrievedPhase, & - ! retrievedCloudTopPressure, & - ! retrievedTau, retrievedSize, & - ! cfTotal, cfLiquid, cfIce, & - ! cfHigh, cfMid, cfLow, & - ! meanTauTotal, meanTauLiquid, meanTauIce, & - ! meanLogTauTotal, meanLogTauLiquid, meanLogTauIce, & - ! meanSizeLiquid, meanSizeIce, & - ! meanCloudTopPressure, & - ! meanLiquidWaterPath, meanIceWaterPath, & - ! jointHistogram) - call modis_column(nSunlit,nSubcols,retrievedPhase,retrievedCloudTopPressure, & - retrievedTau,retrievedSize,cfTotal,cfLiquid,cfIce,cfHigh, & - cfMid,cfLow,meanTauTotal,meanTauLiquid,meanTauIce, & - meanLogTauTotal,meanLogTauLiquid,meanLogTauIce, & - meanSizeLiquid,meanSizeIce,meanCloudTopPressure, & - meanLiquidWaterPath, meanIceWaterPath, & - jointHistogram,jointHistogram2,jointHistogram3) - ! DJS2015: END - - ! - ! Copy results into COSP structure - ! - modisSim%Cloud_Fraction_Total_Mean(sunlit(:)) = cfTotal(:) - modisSim%Cloud_Fraction_Water_Mean(sunlit(:)) = cfLiquid - modisSim%Cloud_Fraction_Ice_Mean (sunlit(:)) = cfIce - - modisSim%Cloud_Fraction_High_Mean(sunlit(:)) = cfHigh - modisSim%Cloud_Fraction_Mid_Mean (sunlit(:)) = cfMid - modisSim%Cloud_Fraction_Low_Mean (sunlit(:)) = cfLow - - modisSim%Optical_Thickness_Total_Mean(sunlit(:)) = meanTauTotal - modisSim%Optical_Thickness_Water_Mean(sunlit(:)) = meanTauLiquid - modisSim%Optical_Thickness_Ice_Mean (sunlit(:)) = meanTauIce - - modisSim%Optical_Thickness_Total_LogMean(sunlit(:)) = meanLogTauTotal - modisSim%Optical_Thickness_Water_LogMean(sunlit(:)) = meanLogTauLiquid - modisSim%Optical_Thickness_Ice_LogMean (sunlit(:)) = meanLogTauIce - - modisSim%Cloud_Particle_Size_Water_Mean(sunlit(:)) = meanSizeLiquid - modisSim%Cloud_Particle_Size_Ice_Mean (sunlit(:)) = meanSizeIce - - modisSim%Cloud_Top_Pressure_Total_Mean(sunlit(:)) = meanCloudTopPressure - - modisSim%Liquid_Water_Path_Mean(sunlit(:)) = meanLiquidWaterPath - modisSim%Ice_Water_Path_Mean (sunlit(:)) = meanIceWaterPath - - modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(sunlit(:), 2:numModisTauBins+1, :) = jointHistogram(:, :, :) - modisSim%Optical_Thickness_vs_ReffICE(sunlit(:),2:numModisTauBins+1,:) = jointHistogram2(:, :, :) - modisSim%Optical_Thickness_vs_ReffLIQ(sunlit(:),2:numModisTauBins+1,:) = jointHistogram3(:, :, :) - ! - ! Reorder pressure bins in joint histogram to go from surface to TOA - ! - modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, numModisPressureBins:1:-1) - if(nSunlit < nPoints) then - ! - ! Where it's night and we haven't done the retrievals the values are undefined - ! - modisSim%Cloud_Fraction_Total_Mean(notSunlit(:)) = R_UNDEF - modisSim%Cloud_Fraction_Water_Mean(notSunlit(:)) = R_UNDEF - modisSim%Cloud_Fraction_Ice_Mean (notSunlit(:)) = R_UNDEF - - modisSim%Cloud_Fraction_High_Mean(notSunlit(:)) = R_UNDEF - modisSim%Cloud_Fraction_Mid_Mean (notSunlit(:)) = R_UNDEF - modisSim%Cloud_Fraction_Low_Mean (notSunlit(:)) = R_UNDEF - - modisSim%Optical_Thickness_Total_Mean(notSunlit(:)) = R_UNDEF - modisSim%Optical_Thickness_Water_Mean(notSunlit(:)) = R_UNDEF - modisSim%Optical_Thickness_Ice_Mean (notSunlit(:)) = R_UNDEF - - modisSim%Optical_Thickness_Total_LogMean(notSunlit(:)) = R_UNDEF - modisSim%Optical_Thickness_Water_LogMean(notSunlit(:)) = R_UNDEF - modisSim%Optical_Thickness_Ice_LogMean (notSunlit(:)) = R_UNDEF - - modisSim%Cloud_Particle_Size_Water_Mean(notSunlit(:)) = R_UNDEF - modisSim%Cloud_Particle_Size_Ice_Mean (notSunlit(:)) = R_UNDEF - - modisSim%Cloud_Top_Pressure_Total_Mean(notSunlit(:)) = R_UNDEF - - modisSim%Liquid_Water_Path_Mean(notSunlit(:)) = R_UNDEF - modisSim%Ice_Water_Path_Mean (notSunlit(:)) = R_UNDEF - - modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(notSunlit(:), :, :) = R_UNDEF - modisSim%Optical_Thickness_vs_ReffICE(notSunlit(:), :, :) = R_UNDEF - modisSim%Optical_Thickness_vs_ReffLIQ(notSunlit(:), :, :) = R_UNDEF - end if - else - ! - ! It's nightime everywhere - everything is undefined - ! - modisSim%Cloud_Fraction_Total_Mean(:) = R_UNDEF - modisSim%Cloud_Fraction_Water_Mean(:) = R_UNDEF - modisSim%Cloud_Fraction_Ice_Mean (:) = R_UNDEF - - modisSim%Cloud_Fraction_High_Mean(:) = R_UNDEF - modisSim%Cloud_Fraction_Mid_Mean (:) = R_UNDEF - modisSim%Cloud_Fraction_Low_Mean (:) = R_UNDEF - - modisSim%Optical_Thickness_Total_Mean(:) = R_UNDEF - modisSim%Optical_Thickness_Water_Mean(:) = R_UNDEF - modisSim%Optical_Thickness_Ice_Mean (:) = R_UNDEF - - modisSim%Optical_Thickness_Total_LogMean(:) = R_UNDEF - modisSim%Optical_Thickness_Water_LogMean(:) = R_UNDEF - modisSim%Optical_Thickness_Ice_LogMean (:) = R_UNDEF - - modisSim%Cloud_Particle_Size_Water_Mean(:) = R_UNDEF - modisSim%Cloud_Particle_Size_Ice_Mean (:) = R_UNDEF - - modisSim%Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF - - modisSim%Liquid_Water_Path_Mean(:) = R_UNDEF - modisSim%Ice_Water_Path_Mean (:) = R_UNDEF - - modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF - modisSim%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF - modisSim%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF - end if - - end subroutine COSP_Modis_Simulator - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !------------- SUBROUTINE CONSTRUCT_COSP_MODIS ------------------ - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_MODIS(cfg, nPoints, x) - type(cosp_config), intent(in) :: cfg ! Configuration options - integer, intent(in) :: Npoints ! Number of sampled points - type(cosp_MODIS), intent(out) :: x - ! - ! Allocate minumum storage if simulator not used - ! - if (cfg%LMODIS_sim) then - x%nPoints = nPoints - else - x%Npoints = 1 - endif - - ! --- Allocate arrays --- - allocate(x%Cloud_Fraction_Total_Mean(x%nPoints)) - allocate(x%Cloud_Fraction_Water_Mean(x%nPoints)) - allocate(x%Cloud_Fraction_Ice_Mean(x%nPoints)) - - allocate(x%Cloud_Fraction_High_Mean(x%nPoints)) - allocate(x%Cloud_Fraction_Mid_Mean(x%nPoints)) - allocate(x%Cloud_Fraction_Low_Mean(x%nPoints)) - - allocate(x%Optical_Thickness_Total_Mean(x%nPoints)) - allocate(x%Optical_Thickness_Water_Mean(x%nPoints)) - allocate(x%Optical_Thickness_Ice_Mean(x%nPoints)) - - allocate(x%Optical_Thickness_Total_LogMean(x%nPoints)) - allocate(x%Optical_Thickness_Water_LogMean(x%nPoints)) - allocate(x%Optical_Thickness_Ice_LogMean(x%nPoints)) - - allocate(x%Cloud_Particle_Size_Water_Mean(x%nPoints)) - allocate(x%Cloud_Particle_Size_Ice_Mean(x%nPoints)) - - allocate(x%Cloud_Top_Pressure_Total_Mean(x%nPoints)) - - allocate(x%Liquid_Water_Path_Mean(x%nPoints)) - allocate(x%Ice_Water_Path_Mean(x%nPoints)) - - allocate(x%Optical_Thickness_vs_Cloud_Top_Pressure(nPoints, numModisTauBins+1, numModisPressureBins)) - allocate(x%Optical_Thickness_vs_ReffICE(nPoints, numModisTauBins+1, numModisReffIceBins)) - allocate(x%Optical_Thickness_vs_ReffLIQ(nPoints, numModisTauBins+1, numModisReffLiqBins)) - x%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF - x%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF - x%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF - - END SUBROUTINE CONSTRUCT_COSP_MODIS - - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !------------- SUBROUTINE FREE_COSP_MODIS ----------------------- - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_MODIS(x) - type(cosp_MODIS),intent(inout) :: x - ! - ! Free space used by cosp_modis variable. - ! - - if(associated(x%Cloud_Fraction_Total_Mean)) deallocate(x%Cloud_Fraction_Total_Mean) - if(associated(x%Cloud_Fraction_Water_Mean)) deallocate(x%Cloud_Fraction_Water_Mean) - if(associated(x%Cloud_Fraction_Ice_Mean )) deallocate(x%Cloud_Fraction_Ice_Mean) - - if(associated(x%Cloud_Fraction_High_Mean)) deallocate(x%Cloud_Fraction_High_Mean) - if(associated(x%Cloud_Fraction_Mid_Mean )) deallocate(x%Cloud_Fraction_Mid_Mean) - if(associated(x%Cloud_Fraction_Low_Mean )) deallocate(x%Cloud_Fraction_Low_Mean) - - if(associated(x%Optical_Thickness_Total_Mean)) deallocate(x%Optical_Thickness_Total_Mean) - if(associated(x%Optical_Thickness_Water_Mean)) deallocate(x%Optical_Thickness_Water_Mean) - if(associated(x%Optical_Thickness_Ice_Mean )) deallocate(x%Optical_Thickness_Ice_Mean) - - if(associated(x%Optical_Thickness_Total_LogMean)) deallocate(x%Optical_Thickness_Total_LogMean) - if(associated(x%Optical_Thickness_Water_LogMean)) deallocate(x%Optical_Thickness_Water_LogMean) - if(associated(x%Optical_Thickness_Ice_LogMean )) deallocate(x%Optical_Thickness_Ice_LogMean) - - if(associated(x%Cloud_Particle_Size_Water_Mean)) deallocate(x%Cloud_Particle_Size_Water_Mean) - if(associated(x%Cloud_Particle_Size_Ice_Mean )) deallocate(x%Cloud_Particle_Size_Ice_Mean) - - if(associated(x%Cloud_Top_Pressure_Total_Mean )) deallocate(x%Cloud_Top_Pressure_Total_Mean ) - - if(associated(x%Liquid_Water_Path_Mean)) deallocate(x%Liquid_Water_Path_Mean ) - if(associated(x%Ice_Water_Path_Mean )) deallocate(x%Ice_Water_Path_Mean ) - - if(associated(x%Optical_Thickness_vs_Cloud_Top_Pressure)) deallocate(x%Optical_Thickness_vs_Cloud_Top_Pressure ) - if(associated(x%Optical_Thickness_vs_ReffIce)) deallocate(x%Optical_Thickness_vs_ReffIce) - if(associated(x%Optical_Thickness_vs_ReffLiq)) deallocate(x%Optical_Thickness_vs_ReffLiq) - END SUBROUTINE FREE_COSP_MODIS - ! ----------------------------------------------------- - - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - !------------- SUBROUTINE COSP_MODIS_CPSECTION ----------------- - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE COSP_MODIS_CPSECTION(ix, iy, orig, copy) - integer, dimension(2), intent(in) :: ix, iy - type(cosp_modis), intent(in ) :: orig - type(cosp_modis), intent( out) :: copy - ! - ! Copy a set of grid points from one cosp_modis variable to another. - ! Should test to be sure ix and iy refer to the same number of grid points - ! - integer :: orig_start, orig_end, copy_start, copy_end - - orig_start = ix(1); orig_end = ix(2) - copy_start = iy(1); copy_end = iy(2) - - copy%Cloud_Fraction_Total_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Total_Mean(orig_start:orig_end) - copy%Cloud_Fraction_Water_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Water_Mean(orig_start:orig_end) - copy%Cloud_Fraction_Ice_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Ice_Mean (orig_start:orig_end) - - copy%Cloud_Fraction_High_Mean(copy_start:copy_end) = orig%Cloud_Fraction_High_Mean(orig_start:orig_end) - copy%Cloud_Fraction_Mid_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Mid_Mean (orig_start:orig_end) - copy%Cloud_Fraction_Low_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Low_Mean (orig_start:orig_end) - - copy%Optical_Thickness_Total_Mean(copy_start:copy_end) = orig%Optical_Thickness_Total_Mean(orig_start:orig_end) - copy%Optical_Thickness_Water_Mean(copy_start:copy_end) = orig%Optical_Thickness_Water_Mean(orig_start:orig_end) - copy%Optical_Thickness_Ice_Mean (copy_start:copy_end) = orig%Optical_Thickness_Ice_Mean (orig_start:orig_end) - - copy%Optical_Thickness_Total_LogMean(copy_start:copy_end) = & - orig%Optical_Thickness_Total_LogMean(orig_start:orig_end) - copy%Optical_Thickness_Water_LogMean(copy_start:copy_end) = & - orig%Optical_Thickness_Water_LogMean(orig_start:orig_end) - copy%Optical_Thickness_Ice_LogMean (copy_start:copy_end) = & - orig%Optical_Thickness_Ice_LogMean (orig_start:orig_end) - - copy%Cloud_Particle_Size_Water_Mean(copy_start:copy_end) = orig%Cloud_Particle_Size_Water_Mean(orig_start:orig_end) - copy%Cloud_Particle_Size_Ice_Mean (copy_start:copy_end) = orig%Cloud_Particle_Size_Ice_Mean (orig_start:orig_end) - - copy%Cloud_Top_Pressure_Total_Mean(copy_start:copy_end) = orig%Cloud_Top_Pressure_Total_Mean(orig_start:orig_end) - - copy%Liquid_Water_Path_Mean(copy_start:copy_end) = orig%Liquid_Water_Path_Mean(orig_start:orig_end) - copy%Ice_Water_Path_Mean (copy_start:copy_end) = orig%Ice_Water_Path_Mean (orig_start:orig_end) - - copy%Optical_Thickness_vs_Cloud_Top_Pressure(copy_start:copy_end, :, :) = & - orig%Optical_Thickness_vs_Cloud_Top_Pressure(orig_start:orig_end, :, :) - copy%Optical_Thickness_vs_ReffIce(copy_start:copy_end, :, :) = & - orig%Optical_Thickness_vs_ReffIce(orig_start:orig_end, :, :) - copy%Optical_Thickness_vs_ReffLiq(copy_start:copy_end, :, :) = & - orig%Optical_Thickness_vs_ReffLiq(orig_start:orig_end, :, :) - - END SUBROUTINE COSP_MODIS_CPSECTION - ! ----------------------------------------------------- - -END MODULE MOD_COSP_Modis_Simulator Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_radar.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_radar.F90 (revision 3231) +++ (revision ) @@ -1,193 +1,0 @@ -! (c) British Crown Copyright 2008, 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: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -MODULE MOD_COSP_RADAR - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - USE MOD_COSP_UTILS - use radar_simulator_types - use array_lib - use atmos_lib - use format_input - IMPLICIT NONE - - INTERFACE - subroutine radar_simulator(hp,nprof,ngate,undef, & - hgt_matrix,hm_matrix,re_matrix,Np_matrix, & - p_matrix,t_matrix,rh_matrix, & - Ze_non,Ze_ray,g_to_vol,a_to_vol,dBZe, & - g_to_vol_in,g_to_vol_out) - - use m_mrgrnk - use array_lib - use math_lib - use optics_lib - use radar_simulator_types - implicit none - - ! ----- INPUTS ----- - type(class_param) :: hp - - integer, intent(in) :: nprof,ngate - - real undef - real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, & - t_matrix,rh_matrix - real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix - real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix - real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: Np_matrix - - ! ----- OUTPUTS ----- - real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, & - g_to_vol,dBZe,a_to_vol - ! ----- OPTIONAL ----- - real*8, optional, dimension(nprof,ngate) :: & - g_to_vol_in,g_to_vol_out - end subroutine radar_simulator - END INTERFACE - -CONTAINS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------- SUBROUTINE COSP_RADAR ------------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_RADAR(gbx,sgx,sghydro,z) - IMPLICIT NONE - - ! Arguments - type(cosp_gridbox),intent(inout) :: gbx ! Gridbox info - type(cosp_subgrid),intent(in) :: sgx ! Subgrid info - type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors - type(cosp_sgradar),intent(inout) :: z ! Output from simulator, subgrid - - ! Local variables - integer :: & - nsizes ! num of discrete drop sizes - - real*8, dimension(:,:), allocatable :: & - g_to_vol ! integrated atten due to gases, r>v (dB) - - real*8, dimension(:,:), allocatable :: & - Ze_non, & ! radar reflectivity withOUT attenuation (dBZ) - Ze_ray, & ! Rayleigh reflectivity (dBZ) - h_atten_to_vol, & ! attenuation by hydromets, radar to vol (dB) - g_atten_to_vol, & ! gaseous atteunation, radar to vol (dB) - dBZe, & ! effective radar reflectivity factor (dBZ) - hgt_matrix, & ! height of hydrometeors (km) - t_matrix, & !temperature (k) - p_matrix, & !pressure (hPa) - rh_matrix !relative humidity (%) - - real*8, dimension(:,:,:), allocatable :: & - hm_matrix, & ! hydrometeor mixing ratio (g kg^-1) - re_matrix, & ! effective radius (microns). Optional. 0 ==> use Np_matrix or defaults - Np_matrix ! total number concentration (kg^-1). Optional 0==> use defaults - - integer, parameter :: one = 1 - ! logical :: hgt_reversed - logical :: hgt_descending - integer :: pr,i,j,k,unt,ngate - -! ----- main program settings ------ - - ! Inputs to Quickbeam - allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), & - t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels)) - allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) - allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) - allocate(Np_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) - - ! Outputs from Quickbeam - allocate(Ze_non(gbx%Npoints,gbx%Nlevels)) - allocate(Ze_ray(gbx%Npoints,gbx%Nlevels)) - allocate(h_atten_to_vol(gbx%Npoints,gbx%Nlevels)) - allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels)) - allocate(dBZe(gbx%Npoints,gbx%Nlevels)) - - ! Optional argument. It is computed and returned in the first call to - ! radar_simulator, and passed as input in the rest - allocate(g_to_vol(gbx%Npoints,gbx%Nlevels)) - - ! Even if there is no unit conversion, they are needed for type conversion - p_matrix = gbx%p/100.0 ! From Pa to hPa - hgt_matrix = gbx%zlev/1000.0 ! From m to km - t_matrix = gbx%T - rh_matrix = gbx%q - re_matrix = 0.0 - - - ! set flag denoting position of radar relative to hgt_matrix orientation - ngate = size(hgt_matrix,2) - - hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate) - - if ( & - (gbx%surface_radar == 1 .and. hgt_descending) .or. & - (gbx%surface_radar == 0 .and. (.not. hgt_descending)) & - ) & - then - gbx%hp%radar_at_layer_one = .false. - else - gbx%hp%radar_at_layer_one = .true. - endif - - ! ----- loop over subcolumns ----- - do pr=1,sgx%Ncolumns - - ! NOTE: - ! atmospheric profiles are the same within the same gridbox - ! only hydrometeor profiles will be different for each subgridbox - - do i=1,gbx%Nhydro - hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg - if (gbx%use_reff) then - re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6 ! Units from m to micron - Np_matrix(i,:,:) = sghydro%Np(:,pr,:,i) ! Units [#/kg] - endif - enddo - - ! ----- call radar simulator ----- - if (pr == 1) then ! Compute gaseous attenuation for all profiles - call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, & - hgt_matrix,hm_matrix,re_matrix,Np_matrix, & - p_matrix,t_matrix,rh_matrix, & - Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol) - else ! Use gaseous atteunuation for pr = 1 - call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, & - hgt_matrix,hm_matrix,re_matrix,Np_matrix, & - p_matrix,t_matrix,rh_matrix, & - Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol) - endif - - ! store caluculated dBZe values for later output/processing - z%Ze_tot(:,pr,:)=dBZe(:,:) - enddo !pr - - deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix) - deallocate(hm_matrix,re_matrix, & - Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe) - deallocate(g_to_vol) -END SUBROUTINE COSP_RADAR - -END MODULE MOD_COSP_RADAR Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_simulator.F90 (revision 3231) +++ (revision ) @@ -1,247 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_simulator.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! History: -! Jul 2007 - A. Bodas-Salcedo - Initial version -! Jan 2013 - G. Cesana - Add new variables linked to the lidar cloud phase -! - -#include "cosp_defs.h" -MODULE MOD_COSP_SIMULATOR - USE MOD_COSP_CONSTANTS, ONLY: I_RADAR, I_LIDAR, I_ISCCP, I_MISR, I_MODIS, & - I_RTTOV, I_STATS, tsim - USE MOD_COSP_TYPES - USE MOD_COSP_RADAR - USE MOD_COSP_LIDAR - USE MOD_COSP_ISCCP_SIMULATOR - USE MOD_COSP_MODIS_SIMULATOR - USE MOD_COSP_MISR_SIMULATOR -!#ifdef RTTOV -! USE MOD_COSP_RTTOV_SIMULATOR -!#endif - USE MOD_COSP_STATS - IMPLICIT NONE - -CONTAINS - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!--------------------- SUBROUTINE COSP_SIMULATOR ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!#ifdef RTTOV -!SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) -!#else -SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) -!#endif - - ! Arguments - type(cosp_gridbox),intent(inout) :: gbx ! Grid-box inputs - type(cosp_subgrid),intent(in) :: sgx ! Subgrid inputs - type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors - type(cosp_config),intent(in) :: cfg ! Configuration options - type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats - type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator - type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator - type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator - type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator - type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator -!#ifdef RTTOV -! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV -!#endif - type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator - type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator - ! Local variables - integer :: i,j,k,isim - logical :: inconsistent - ! Timing variables - integer :: t0,t1 - - t0 = 0 - t1 = 0 - - inconsistent=.false. -! do k=1,gbx%Nhydro -! do j=1,gbx%Nlevels -! do i=1,gbx%Npoints -! if ((gbx%mr_hydro(i,j,k)>0.0).and.(gbx%Reff(i,j,k)<=0.0)) inconsistent=.true. -! enddo -! enddo -! enddo -! if (inconsistent) print *, '%%%% COSP_SIMULATOR: inconsistency in mr_hydro and Reff' - - - !+++++++++ Radar model ++++++++++ - isim = I_RADAR - if (cfg%Lradar_sim) then - call system_clock(t0) - call cosp_radar(gbx,sgx,sghydro,sgradar) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ Lidar model ++++++++++ - isim = I_LIDAR - if (cfg%Llidar_sim) then - call system_clock(t0) - call cosp_lidar(gbx,sgx,sghydro,sglidar) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ ISCCP simulator ++++++++++ - isim = I_ISCCP - if (cfg%Lisccp_sim) then - call system_clock(t0) - call cosp_isccp_simulator(gbx,sgx,isccp) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ MISR simulator ++++++++++ - isim = I_MISR - if (cfg%Lmisr_sim) then - call system_clock(t0) - call cosp_misr_simulator(gbx,sgx,misr) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ MODIS simulator ++++++++++ - isim = I_MODIS - if (cfg%Lmodis_sim) then - call system_clock(t0) - call cosp_modis_simulator(gbx,sgx,sghydro,isccp, modis) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++ RTTOV ++++++++++ - isim = I_RTTOV -!#ifdef RTTOV -! if (cfg%Lrttov_sim) then -! call system_clock(t0) -! call cosp_rttov_simulator(gbx,rttov) -! call system_clock(t1) -! tsim(isim) = tsim(isim) + (t1 -t0) -! endif -!#endif - - !+++++++++++ Summary statistics +++++++++++ - isim = I_STATS - if (cfg%Lstats) then - call system_clock(t0) - call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) - call system_clock(t1) - tsim(isim) = tsim(isim) + (t1 -t0) - endif - - !+++++++++++ Change of units after computation of statistics +++++++++++ - ! This avoids using UDUNITS in CMOR - - ! Cloud fractions from 1 to % -! if (cfg%Lclcalipso) then -! where(stlidar%lidarcld /= R_UNDEF) stlidar%lidarcld = stlidar%lidarcld*100.0 -! endif -! if (cfg%Lcltcalipso.OR.cfg%Lcllcalipso.OR.cfg%Lclmcalipso.OR.cfg%Lclhcalipso) then -! where(stlidar%cldlayer /= R_UNDEF) stlidar%cldlayer = stlidar%cldlayer*100.0 -! endif - if (cfg%Lclcalipso2) then - where(stradar%lidar_only_freq_cloud /= R_UNDEF) stradar%lidar_only_freq_cloud = stradar%lidar_only_freq_cloud*100.0 - endif - - if (cfg%Lcltcalipsoliq.OR.cfg%Lcllcalipsoliq.OR.cfg%Lclmcalipsoliq.OR.cfg%Lclhcalipsoliq.OR. & - cfg%Lcltcalipsoice.OR.cfg%Lcllcalipsoice.OR.cfg%Lclmcalipsoice.OR.cfg%Lclhcalipsoice.OR. & - cfg%Lcltcalipsoun.OR.cfg%Lcllcalipsoun.OR.cfg%Lclmcalipsoun.OR.cfg%Lclhcalipsoun ) then - where(stlidar%cldlayerphase /= R_UNDEF) stlidar%cldlayerphase = stlidar%cldlayerphase*100.0 - endif - if (cfg%Lclcalipsoliq.OR.cfg%Lclcalipsoice.OR.cfg%Lclcalipsoun) then - where(stlidar%lidarcldphase /= R_UNDEF) stlidar%lidarcldphase = stlidar%lidarcldphase*100.0 - endif - if (cfg%Lclcalipsotmp.OR.cfg%Lclcalipsotmpliq.OR.cfg%Lclcalipsotmpice.OR.cfg%Lclcalipsotmpun) then - where(stlidar%lidarcldtmp /= R_UNDEF) stlidar%lidarcldtmp = stlidar%lidarcldtmp*100.0 - endif - - if (cfg%Lcltisccp) then - where(isccp%totalcldarea /= R_UNDEF) isccp%totalcldarea = isccp%totalcldarea*100.0 - endif - if (cfg%Lclisccp) then - where(isccp%fq_isccp /= R_UNDEF) isccp%fq_isccp = isccp%fq_isccp*100.0 - endif - - if (cfg%LclMISR) then - where(misr%fq_MISR /= R_UNDEF) misr%fq_MISR = misr%fq_MISR*100.0 - endif - - if (cfg%Lcltlidarradar) then - where(stradar%radar_lidar_tcc /= R_UNDEF) stradar%radar_lidar_tcc = stradar%radar_lidar_tcc*100.0 - endif - - if (cfg%Lclmodis) then - where(modis%Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) modis%Optical_Thickness_vs_Cloud_Top_Pressure = & - modis%Optical_Thickness_vs_Cloud_Top_Pressure*100.0 - endif - if (cfg%Lcrimodis) then - where(modis%Optical_Thickness_vs_ReffICE /= R_UNDEF) modis%Optical_Thickness_vs_ReffICE = & - modis%Optical_Thickness_vs_ReffICE*100.0 - endif - if (cfg%Lcrlmodis) then - where(modis%Optical_Thickness_vs_ReffLIQ /= R_UNDEF) modis%Optical_Thickness_vs_ReffLIQ = & - modis%Optical_Thickness_vs_ReffLIQ*100.0 - endif - - if (cfg%Lcltmodis) then - where(modis%Cloud_Fraction_Total_Mean /= R_UNDEF) modis%Cloud_Fraction_Total_Mean = modis%Cloud_Fraction_Total_Mean*100.0 - endif - if (cfg%Lclwmodis) then - where(modis%Cloud_Fraction_Water_Mean /= R_UNDEF) modis%Cloud_Fraction_Water_Mean = modis%Cloud_Fraction_Water_Mean*100.0 - endif - if (cfg%Lclimodis) then - where(modis%Cloud_Fraction_Ice_Mean /= R_UNDEF) modis%Cloud_Fraction_Ice_Mean = modis%Cloud_Fraction_Ice_Mean*100.0 - endif - - if (cfg%Lclhmodis) then - where(modis%Cloud_Fraction_High_Mean /= R_UNDEF) modis%Cloud_Fraction_High_Mean = modis%Cloud_Fraction_High_Mean*100.0 - endif - if (cfg%Lclmmodis) then - where(modis%Cloud_Fraction_Mid_Mean /= R_UNDEF) modis%Cloud_Fraction_Mid_Mean = modis%Cloud_Fraction_Mid_Mean*100.0 - endif - if (cfg%Lcllmodis) then - where(modis%Cloud_Fraction_Low_Mean /= R_UNDEF) modis%Cloud_Fraction_Low_Mean = modis%Cloud_Fraction_Low_Mean*100.0 - endif - - ! Change pressure from hPa to Pa. - if (cfg%Lboxptopisccp) then - where(isccp%boxptop /= R_UNDEF) isccp%boxptop = isccp%boxptop*100.0 - endif - if (cfg%Lpctisccp) then - where(isccp%meanptop /= R_UNDEF) isccp%meanptop = isccp%meanptop*100.0 - endif - - -END SUBROUTINE COSP_SIMULATOR - -END MODULE MOD_COSP_SIMULATOR Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_stats.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_stats.F90 (revision 3231) +++ (revision ) @@ -1,304 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_stats.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! 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 -! -! -#include "cosp_defs.h" -MODULE MOD_COSP_STATS - USE MOD_COSP_CONSTANTS - USE MOD_COSP_TYPES - USE MOD_LLNL_STATS - USE MOD_LMD_IPSL_STATS - IMPLICIT NONE - -CONTAINS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------- SUBROUTINE COSP_STATS ------------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) - - ! Input arguments - type(cosp_gridbox),intent(in) :: gbx - type(cosp_subgrid),intent(in) :: sgx - type(cosp_config),intent(in) :: cfg - type(cosp_sgradar),intent(in) :: sgradar - type(cosp_sglidar),intent(in) :: sglidar - type(cosp_vgrid),intent(in) :: vgrid - ! Output arguments - type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar - type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar - - ! Local variables - integer :: Npoints !# of grid points - integer :: Nlevels !# of levels - integer :: Nhydro !# of hydrometeors - integer :: Ncolumns !# of columns - integer :: Nlr - logical :: ok_lidar_cfad = .false. - real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out - real,dimension(:,:),allocatable :: ph_c,betamol_c - real,dimension(:,:,:),allocatable :: betaperptot_out, temp_in, temp_out - real,dimension(:,:),allocatable :: temp_c - - Npoints = gbx%Npoints - Nlevels = gbx%Nlevels - Nhydro = gbx%Nhydro - Ncolumns = gbx%Ncolumns - Nlr = vgrid%Nlvgrid - - if (cfg%LcfadLidarsr532) ok_lidar_cfad=.true. - - if (vgrid%use_vgrid) then ! Statistics in a different vertical grid - allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), & - betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), & - ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr)) - Ze_out = 0.0 - betatot_out = 0.0 - betamol_out= 0.0 - betamol_c = 0.0 - ph_in(:,1,:) = gbx%ph(:,:) - ph_out = 0.0 - ph_c = 0.0 - allocate(betaperptot_out(Npoints,Ncolumns,Nlr),temp_in(Npoints,1,Nlevels),temp_out(Npoints,1,Nlr), & - temp_c(Npoints,Nlr)) - betaperptot_out = 0.0 - temp_in = 0.0 - temp_out = 0.0 - temp_c = 0.0 - - !++++++++++++ Radar CFAD ++++++++++++++++ - if (cfg%Lradar_sim) then - call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, & - Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.) - stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, & - DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) - endif - !++++++++++++ Lidar CFAD ++++++++++++++++ - if (cfg%Llidar_sim) then - betamol_in(:,1,:) = sglidar%beta_mol(:,:) - call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, & - Nlr,vgrid%zl,vgrid%zu,betamol_out) - call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, & - Nlr,vgrid%zl,vgrid%zu,betatot_out) - - temp_in(:,1,:) = gbx%T(:,:) - call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%betaperp_tot, & - Nlr,vgrid%zl,vgrid%zu,betaperptot_out) - call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,temp_in, & - Nlr,vgrid%zl,vgrid%zu,temp_out) - temp_c(:,:) = temp_out(:,1,:) - stlidar%proftemp = temp_c !TIBO - where (stlidar%proftemp < 150.) stlidar%proftemp = R_UNDEF !TIBO - where (stlidar%proftemp > 350.) stlidar%proftemp = R_UNDEF !TIBO - - call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, & - Nlr,vgrid%zl,vgrid%zu,ph_out) - ph_c(:,:) = ph_out(:,1,:) - betamol_c(:,:) = betamol_out(:,1,:) - ! Stats from lidar_stat_summary - call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & - ,temp_c,betatot_out,betaperptot_out,betamol_c,sglidar%refl,gbx%land,ph_c & - ,LIDAR_UNDEF,ok_lidar_cfad & - ,stlidar%cfad_sr,stlidar%srbval & - ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ - ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ - ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ - ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO - endif - - !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ - if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & - temp_c,betatot_out,betaperptot_out,betamol_c,Ze_out, & - stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) - deallocate(temp_in,temp_out,temp_c,betaperptot_out) !TIBO +temp_in - - ! Deallocate arrays at coarse resolution - deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c) - else ! Statistics in model levels - !++++++++++++ Radar CFAD ++++++++++++++++ - if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, & - DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) - !++++++++++++ Lidar CFAD ++++++++++++++++ - ! Stats from lidar_stat_summary - if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & - ,sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph & - ,LIDAR_UNDEF,ok_lidar_cfad & - ,stlidar%cfad_sr,stlidar%srbval & - ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ - ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ - ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ - ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO - !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ - if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & - sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sgradar%Ze_tot, & - stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) - endif - ! Replace undef - where (stlidar%cfad_sr == LIDAR_UNDEF) stlidar%cfad_sr = R_UNDEF - where (stlidar%profSR == LIDAR_UNDEF) stlidar%profSR = R_UNDEF !TIBO - where (stlidar%lidarcld == LIDAR_UNDEF) stlidar%lidarcld = R_UNDEF - where (stlidar%lidarcldtype == LIDAR_UNDEF) stlidar%lidarcldtype = R_UNDEF !OPAQ - where (stlidar%cldlayer == LIDAR_UNDEF) stlidar%cldlayer = R_UNDEF - where (stlidar%cldtype == LIDAR_UNDEF) stlidar%cldtype = R_UNDEF !OPAQ - where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF - where (stlidar%cldlayerphase == LIDAR_UNDEF) stlidar%cldlayerphase = R_UNDEF - where (stlidar%lidarcldphase == LIDAR_UNDEF) stlidar%lidarcldphase = R_UNDEF - where (stlidar%lidarcldtmp == LIDAR_UNDEF) stlidar%lidarcldtmp = R_UNDEF - -END SUBROUTINE COSP_STATS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!---------- 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,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) - real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) - real,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,dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels [m] - real,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,dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid - - ! Local variables - integer :: i,j,k - logical :: lunits - integer :: l - real :: w ! Weight - real :: dbb, dtb, dbt, dtt ! Distances between edges of both grids - integer :: Nw ! Number of weights - real :: wt ! Sum of weights - real,dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid - real :: 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.0 - - 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.0 ! 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.0**(y(i,j,l)/10.0) - else - yp = 0.0 - 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.0*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 - -END MODULE MOD_COSP_STATS Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_types.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_types.F90 (revision 3231) +++ (revision ) @@ -1,1676 +1,0 @@ -! (c) British Crown Copyright 2008, 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: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -MODULE MOD_COSP_TYPES - USE MOD_COSP_CONSTANTS - USE MOD_COSP_UTILS - - use radar_simulator_types, only: class_param, nd, mt_nd, dmax, dmin - - IMPLICIT NONE - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------------- DERIVED TYPES ---------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - - ! Configuration choices (simulators, variables) - TYPE COSP_CONFIG - logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, & - Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, & - LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, & - Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, & - Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & - Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, & - Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, & - Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, & - Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, & - Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, & - Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, & - Lfracout,LlidarBetaMol532,Ltbrttov, & - Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, & - Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & - Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, & !OPAQ (2) - Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque, & !OPAQ (4) - Lclcalipsoopacity,LprofSR,Lproftemp !OPAQ (1) !TIBO (2) - - character(len=32) :: out_list(N_OUT_LIST) - END TYPE COSP_CONFIG - - ! Outputs from RTTOV - TYPE COSP_RTTOV - ! Dimensions - integer :: Npoints ! Number of gridpoints - integer :: Nchan ! Number of channels - - ! Brightness temperatures (Npoints,Nchan) - real,pointer :: tbs(:,:) - - END TYPE COSP_RTTOV - - ! Outputs from MISR simulator - TYPE COSP_MISR - ! Dimensions - integer :: Npoints ! Number of gridpoints - integer :: Ntau ! Number of tau intervals - integer :: Nlevels ! Number of cth levels - - ! --- (npoints,ntau,nlevels) - ! the fraction of the model grid box covered by each of the MISR cloud types - real,pointer :: fq_MISR(:,:,:) - - ! --- (npoints) - real,pointer :: MISR_meanztop(:), MISR_cldarea(:) - ! --- (npoints,nlevels) - real,pointer :: MISR_dist_model_layertops(:,:) - END TYPE COSP_MISR - - ! Outputs from ISCCP simulator - TYPE COSP_ISCCP - ! Dimensions - integer :: Npoints ! Number of gridpoints - integer :: Ncolumns ! Number of columns - integer :: Nlevels ! Number of levels - - - ! --- (npoints,tau=7,pressure=7) - ! the fraction of the model grid box covered by each of the 49 ISCCP D level cloud types - real,pointer :: fq_isccp(:,:,:) - - ! --- (npoints) --- - ! The fraction of model grid box columns with cloud somewhere in them. - ! This should equal the sum over all entries of fq_isccp - real,pointer :: totalcldarea(:) - ! mean all-sky 10.5 micron brightness temperature - real,pointer :: meantb(:) - ! mean clear-sky 10.5 micron brightness temperature - real,pointer :: meantbclr(:) - - ! The following three means are averages over the cloudy areas only. If no - ! clouds are in grid box all three quantities should equal zero. - - ! mean cloud top pressure (mb) - linear averaging in cloud top pressure. - real,pointer :: meanptop(:) - ! mean optical thickness linear averaging in albedo performed. - real,pointer :: meantaucld(:) - ! mean cloud albedo. linear averaging in albedo performed - real,pointer :: meanalbedocld(:) - - !--- (npoints,ncol) --- - ! optical thickness in each column - real,pointer :: boxtau(:,:) - ! cloud top pressure (mb) in each column - real,pointer :: boxptop(:,:) - END TYPE COSP_ISCCP - - ! Summary statistics from radar - TYPE COSP_VGRID - logical :: use_vgrid ! Logical flag that indicates change of grid - logical :: csat_vgrid ! Flag for Cloudsat grid - integer :: Npoints ! Number of sampled points - integer :: Ncolumns ! Number of subgrid columns - integer :: Nlevels ! Number of model levels - integer :: Nlvgrid ! Number of levels of new grid - ! Array with dimensions (Nlvgrid) - real, dimension(:), pointer :: z,zl,zu ! Height and lower and upper boundaries of new levels - ! Array with dimensions (Nlevels) - real, dimension(:), pointer :: mz,mzl,mzu ! Height and lower and upper boundaries of model levels - END TYPE COSP_VGRID - - ! Output data from lidar code - TYPE COSP_SGLIDAR - ! Dimensions - integer :: Npoints ! Number of gridpoints - integer :: Ncolumns ! Number of columns - integer :: Nlevels ! Number of levels - integer :: Nhydro ! Number of hydrometeors - integer :: Nrefl ! Number of parasol reflectances - ! Arrays with dimensions (Npoints,Nlevels) - real,dimension(:,:),pointer :: beta_mol ! Molecular backscatter - real,dimension(:,:),pointer :: temp_tot - ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) - real,dimension(:,:,:),pointer :: betaperp_tot ! Total backscattered signal - real,dimension(:,:,:),pointer :: beta_tot ! Total backscattered signal - real,dimension(:,:,:),pointer :: tau_tot ! Optical thickness integrated from top to level z - ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) - real,dimension(:,:,:),pointer :: refl ! parasol reflectances - END TYPE COSP_SGLIDAR - - ! Output data from radar code - TYPE COSP_SGRADAR - ! Dimensions - integer :: Npoints ! Number of gridpoints - integer :: Ncolumns ! Number of columns - integer :: Nlevels ! Number of levels - integer :: Nhydro ! Number of hydrometeors - ! output vertical levels: spaceborne radar -> from TOA to SURFACE - ! Arrays with dimensions (Npoints,Nlevels) - real,dimension(:,:),pointer :: att_gas ! 2-way attenuation by gases [dBZ] - ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) - real,dimension(:,:,:),pointer :: Ze_tot ! Effective reflectivity factor [dBZ] - - END TYPE COSP_SGRADAR - - - ! Summary statistics from radar - TYPE COSP_RADARSTATS - integer :: Npoints ! Number of sampled points - integer :: Ncolumns ! Number of subgrid columns - integer :: Nlevels ! Number of model levels - integer :: Nhydro ! Number of hydrometeors - ! Array with dimensions (Npoints,dBZe_bins,Nlevels) - real, dimension(:,:,:), pointer :: cfad_ze ! Ze CFAD - ! Array with dimensions (Npoints) - real,dimension(:),pointer :: radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale - ! Arrays with dimensions (Npoints,Nlevels) - real, dimension(:,:),pointer :: lidar_only_freq_cloud - END TYPE COSP_RADARSTATS - - ! Summary statistics from lidar - TYPE COSP_LIDARSTATS - integer :: Npoints ! Number of sampled points - integer :: Ncolumns ! Number of subgrid columns - integer :: Nlevels ! Number of model levels - integer :: Nhydro ! Number of hydrometeors - integer :: Nrefl ! Number of parasol reflectances - - ! Arrays with dimensions (SR_BINS) - real, dimension(:),pointer :: srbval ! SR bins in cfad_sr - ! Arrays with dimensions (Npoints,SR_BINS,Nlevels) - real, dimension(:,:,:),pointer :: cfad_sr ! CFAD of scattering ratio - ! Arrays with dimensions (Npoints,Nlevels) - real, dimension(:,:),pointer :: lidarcld ! 3D "lidar" cloud fraction - real, dimension(:,:),pointer :: proftemp ! Temperature profiles 40 levs !TIBO - ! Arrays with dimensions (Npoints,LIDAR_NCAT) - real, dimension(:,:),pointer :: cldlayer ! low, mid, high-level, total lidar cloud cover - ! Arrays with dimensions (Npoints,LIDAR_NTYPE) !OPAQ - real, dimension(:,:),pointer :: cldtype ! opaque and thin cloud covers, z_opaque !OPAQ - ! Arrays with dimensions (Npoints,Nlevels,Nphase) - real, dimension(:,:,:),pointer :: lidarcldphase ! 3D "lidar" phase cloud fraction - ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1) !OPAQ - real, dimension(:,:,:),pointer :: lidarcldtype ! 3D "lidar" OPAQ type fraction + opacity !OPAQ - ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase) - real, dimension(:,:,:),pointer :: cldlayerphase ! low, mid, high-level lidar phase cloud cover - ! Arrays with dimensions (Npoints,Ntemps,Nphase) - real, dimension(:,:,:),pointer :: lidarcldtmp ! 3D "lidar" phase cloud temperature - ! Arrays with dimensions (Npoints,PARASOL_NREFL) - real, dimension(:,:),pointer :: parasolrefl ! mean parasol reflectance -! ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) !TIBO -! real, dimension(:,:,:),pointer :: profSR ! subcolumns for each day !TIBO - ! Arrays with dimensions (Npoints,Nlevels,Ncolumns) !TIBO2 - real, dimension(:,:,:),pointer :: profSR ! subcolumns for each day !TIBO2 - - END TYPE COSP_LIDARSTATS - - - ! Input data for simulator. Subgrid scale. - ! Input data from SURFACE to TOA - TYPE COSP_SUBGRID - ! Dimensions - integer :: Npoints ! Number of gridpoints - integer :: Ncolumns ! Number of columns - integer :: Nlevels ! Number of levels - integer :: Nhydro ! Number of hydrometeors - - real,dimension(:,:,:),pointer :: prec_frac ! Subgrid precip array. Dimensions (Npoints,Ncolumns,Nlevels) - real,dimension(:,:,:),pointer :: frac_out ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) - END TYPE COSP_SUBGRID - - ! Input data for simulator at Subgrid scale. - ! Used on a reduced number of points - TYPE COSP_SGHYDRO - ! Dimensions - integer :: Npoints ! Number of gridpoints - integer :: Ncolumns ! Number of columns - integer :: Nlevels ! Number of levels - integer :: Nhydro ! Number of hydrometeors - real,dimension(:,:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor - ! (Npoints,Ncolumns,Nlevels,Nhydro) [kg/kg] - real,dimension(:,:,:,:),pointer :: Reff ! Effective Radius of each hydrometeor - ! (Reff==0 means use default size) - ! (Npoints,Ncolumns,Nlevels,Nhydro) [m] - real,dimension(:,:,:,:),pointer :: Np ! Total # concentration each hydrometeor - ! (Optional, ignored if Reff > 0). - ! (Npoints,Ncolumns,Nlevels,Nhydro) [#/kg] - ! Np = Ntot / rho_a = [#/m^3] / [kg/m^3) - ! added by Roj with Quickbeam V3 - END TYPE COSP_SGHYDRO - - ! Input data for simulator. Gridbox scale. - TYPE COSP_GRIDBOX - ! Scalars and dimensions - integer :: Npoints ! Number of gridpoints - integer :: Nlevels ! Number of levels - integer :: Ncolumns ! Number of columns - integer :: Nhydro ! Number of hydrometeors - integer :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions - integer :: Naero ! Number of aerosol species - integer :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions - integer :: Npoints_it ! Max number of gridpoints to be processed in one iteration - - ! Time [days] - double precision :: time - double precision :: time_bnds(2) - - ! Radar ancillary info - real :: radar_freq, & ! Radar frequency [GHz] - k2 ! |K|^2, -1=use frequency dependent default - integer :: surface_radar, & ! surface=1, spaceborne=0 - use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0 - use_gas_abs, & ! include gaseous absorption? yes=1,no=0 - do_ray, & ! calculate/output Rayleigh refl=1, not=0 - melt_lay ! melting layer model off=0, on=1 - - ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008 - type(class_param) :: hp ! structure used by radar simulator to store Ze and N scaling constants and other information - integer :: nsizes ! number of discrete drop sizes (um) used to represent the distribution - - ! Lidar - integer :: lidar_ice_type !ice particle shape hypothesis in lidar calculations - !(ice_type=0 for spheres, ice_type=1 for non spherical particles) - - ! Radar - logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm - logical :: use_reff ! True if Reff is to be used by radar (memory not allocated - - - ! Geolocation (Npoints) - real,dimension(:),pointer :: toffset ! Time offset of esch point from the value in time - real,dimension(:),pointer :: longitude ! longitude [degrees East] - real,dimension(:),pointer :: latitude ! latitude [deg North] - ! Gridbox information (Npoints,Nlevels) - real,dimension(:,:),pointer :: zlev ! Height of model levels [m] - real,dimension(:,:),pointer :: zlev_half ! Height at half model levels [m] (Bottom of model layer) - real,dimension(:,:),pointer :: dlev ! Depth of model levels [m] - real,dimension(:,:),pointer :: p ! Pressure at full model levels [Pa] - real,dimension(:,:),pointer :: ph ! Pressure at half model levels [Pa] - real,dimension(:,:),pointer :: T ! Temperature at model levels [K] - real,dimension(:,:),pointer :: q ! Relative humidity to water (%) - real,dimension(:,:),pointer :: sh ! Specific humidity to water [kg/kg] - real,dimension(:,:),pointer :: dtau_s ! mean 0.67 micron optical depth of stratiform - ! clouds in each model level - ! NOTE: this the cloud optical depth of only the - ! cloudy part of the grid box, it is not weighted - ! with the 0 cloud optical depth of the clear - ! part of the grid box - real,dimension(:,:),pointer :: dtau_c ! mean 0.67 micron optical depth of convective - ! clouds in each model level. Same note applies as in dtau_s. - real,dimension(:,:),pointer :: dem_s ! 10.5 micron longwave emissivity of stratiform - ! clouds in each model level. Same note applies as in dtau_s. - real,dimension(:,:),pointer :: dem_c ! 10.5 micron longwave emissivity of convective - ! clouds in each model level. Same note applies as in dtau_s. - real,dimension(:,:),pointer :: mr_ozone ! Ozone mass mixing ratio [kg/kg] - - ! Point information (Npoints) - real,dimension(:),pointer :: land !Landmask [0 - Ocean, 1 - Land] - real,dimension(:),pointer :: psfc !Surface pressure [Pa] - real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime - real,dimension(:),pointer :: skt ! Skin temperature (K) - real,dimension(:),pointer :: u_wind ! eastward wind [m s-1] - real,dimension(:),pointer :: v_wind ! northward wind [m s-1] - - ! TOTAL and CONV cloud fraction for SCOPS - real,dimension(:,:),pointer :: tca ! Total cloud fraction - real,dimension(:,:),pointer :: cca ! Convective cloud fraction - ! Precipitation fluxes on model levels - real,dimension(:,:),pointer :: rain_ls ! large-scale precipitation flux of rain [kg/m2.s] - real,dimension(:,:),pointer :: rain_cv ! convective precipitation flux of rain [kg/m2.s] - real,dimension(:,:),pointer :: snow_ls ! large-scale precipitation flux of snow [kg/m2.s] - real,dimension(:,:),pointer :: snow_cv ! convective precipitation flux of snow [kg/m2.s] - real,dimension(:,:),pointer :: grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s] - ! Hydrometeors concentration and distribution parameters -! real,dimension(:,:,:),pointer :: fr_hydro ! Fraction of the gridbox occupied by each hydrometeor (Npoints,Nlevels,Nhydro) - real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg] - real,dimension(:,:),pointer :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro) - - ! Effective radius [m]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default - real,dimension(:,:,:),pointer :: Reff - - ! Total Number Concentration [#/kg]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default - real,dimension(:,:,:),pointer :: Np ! added by Roj with Quickbeam V3 - - ! Aerosols concentration and distribution parameters - real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero) - integer,dimension(:),pointer :: dist_type_aero ! Particle size distribution type for each aerosol species (Naero) - real,dimension(:,:,:,:),pointer :: dist_prmts_aero ! Distributional parameters for aerosols - ! (Npoints,Nlevels,Nprmts_max_aero,Naero) - ! ISCCP simulator inputs - integer :: isccp_top_height ! 1 = adjust top height using both a computed - ! infrared brightness temperature and the visible - ! optical depth to adjust cloud top pressure. Note - ! that this calculation is most appropriate to compare - ! to ISCCP data during sunlit hours. - ! 2 = do not adjust top height, that is cloud top - ! pressure is the actual cloud top pressure - ! in the model - ! 3 = adjust top height using only the computed - ! infrared brightness temperature. Note that this - ! calculation is most appropriate to compare to ISCCP - ! IR only algortihm (i.e. you can compare to nighttime - ! ISCCP data with this option) - integer :: isccp_top_height_direction ! direction for finding atmosphere pressure level - ! with interpolated temperature equal to the radiance - ! determined cloud-top temperature - ! 1 = find the *lowest* altitude (highest pressure) level - ! with interpolated temperature equal to the radiance - ! determined cloud-top temperature - ! 2 = find the *highest* altitude (lowest pressure) level - ! with interpolated temperature equal to the radiance - ! determined cloud-top temperature - ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 - ! 1 = default setting, and matches all versions of - ! ISCCP simulator with versions numbers 3.5.1 and lower - ! 2 = experimental setting - integer :: isccp_overlap ! overlap type (1=max, 2=rand, 3=max/rand) - real :: isccp_emsfc_lw ! 10.5 micron emissivity of surface (fraction) - - ! RTTOV inputs/options - integer :: plat ! satellite platform - integer :: sat ! satellite - integer :: inst ! instrument - integer :: Nchan ! Number of channels to be computed - integer, dimension(:), pointer :: Ichan ! Channel numbers - real, dimension(:), pointer :: Surfem ! Surface emissivity - real :: ZenAng ! Satellite Zenith Angles - real :: co2,ch4,n2o,co ! Mixing ratios of trace gases - - END TYPE COSP_GRIDBOX - -CONTAINS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV ------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_RTTOV(cfg,Npoints,Nchan,x) - type(cosp_config),intent(in) :: cfg ! Configuration options - integer,intent(in) :: Npoints ! Number of sampled points - integer,intent(in) :: Nchan ! Number of channels - type(cosp_rttov),intent(out) :: x - ! Local variables - integer :: i,j - - ! Allocate minumum storage if simulator not used - if (cfg%Lrttov_sim) then - i = Npoints - j = Nchan - else - i = 1 - j = 1 - endif - x%Npoints = i - x%Nchan = j - - ! --- Allocate arrays --- - allocate(x%tbs(i, j)) - ! --- Initialise to zero --- - x%tbs = 0.0 - END SUBROUTINE CONSTRUCT_COSP_RTTOV - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE FREE_COSP_RTTOV ------------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_RTTOV(x) - type(cosp_rttov),intent(inout) :: x - - ! --- Deallocate arrays --- - deallocate(x%tbs) - END SUBROUTINE FREE_COSP_RTTOV - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_MISR ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_MISR(cfg,Npoints,x) - type(cosp_config),intent(in) :: cfg ! Configuration options - integer,intent(in) :: Npoints ! Number of gridpoints - type(cosp_misr),intent(out) :: x - ! Local variables - integer :: i,j,k - - - ! Allocate minumum storage if simulator not used - if (cfg%Lmisr_sim) then - i = Npoints - j = 7 - k = MISR_N_CTH - else - i = 1 - j = 1 - k = 1 - endif - - ! Dimensions - x%Npoints = i - x%Ntau = j - x%Nlevels = k - - ! allocate space for MISR simulator outputs ... - allocate(x%fq_MISR(i,j,k), x%MISR_meanztop(i),x%MISR_cldarea(i), x%MISR_dist_model_layertops(i,k)) - x%fq_MISR = 0.0 - x%MISR_meanztop = 0.0 - x%MISR_cldarea = 0.0 - x%MISR_dist_model_layertops = 0.0 - - END SUBROUTINE CONSTRUCT_COSP_MISR -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE FREE_COSP_MISR ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_MISR(x) - type(cosp_misr),intent(inout) :: x - deallocate(x%fq_MISR, x%MISR_meanztop,x%MISR_cldarea, x%MISR_dist_model_layertops) - - END SUBROUTINE FREE_COSP_MISR - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_ISCCP ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_ISCCP(cfg,Npoints,Ncolumns,Nlevels,x) - type(cosp_config),intent(in) :: cfg ! Configuration options - integer,intent(in) :: Npoints ! Number of sampled points - integer,intent(in) :: Ncolumns ! Number of subgrid columns - integer,intent(in) :: Nlevels ! Number of model levels - type(cosp_isccp),intent(out) :: x - ! Local variables - integer :: i,j,k - - ! Allocate minumum storage if simulator not used - if (cfg%Lisccp_sim) then - i = Npoints - j = Ncolumns - k = Nlevels - else - i = 1 - j = 1 - k = 1 - endif - - ! Dimensions - x%Npoints = i - x%Ncolumns = j - x%Nlevels = k - - ! --- Allocate arrays --- - allocate(x%fq_isccp(i,7,7), x%totalcldarea(i), & - x%meanptop(i), x%meantaucld(i), & - x%meantb(i), x%meantbclr(i), & - x%boxtau(i,j), x%boxptop(i,j), & - x%meanalbedocld(i)) - ! --- Initialise to zero --- - x%fq_isccp = 0.0 - x%totalcldarea = 0.0 - x%meanptop = 0.0 - x%meantaucld = 0.0 - x%meantb = 0.0 - x%meantbclr = 0.0 - x%boxtau = 0.0 - x%boxptop = 0.0 - x%meanalbedocld= 0.0 - END SUBROUTINE CONSTRUCT_COSP_ISCCP - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE FREE_COSP_ISCCP ----------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_ISCCP(x) - type(cosp_isccp),intent(inout) :: x - - deallocate(x%fq_isccp, x%totalcldarea, & - x%meanptop, x%meantaucld, x%meantb, x%meantbclr, & - x%boxtau, x%boxptop, x%meanalbedocld) - END SUBROUTINE FREE_COSP_ISCCP - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_VGRID ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x) - type(cosp_gridbox),intent(in) :: gbx ! Gridbox information - integer,intent(in) :: Nlvgrid ! Number of new levels - logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid - logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested - type(cosp_vgrid),intent(out) :: x - - ! Local variables - integer :: i - real :: zstep - - x%use_vgrid = use_vgrid - x%csat_vgrid = cloudsat - - ! Dimensions - x%Npoints = gbx%Npoints - x%Ncolumns = gbx%Ncolumns - x%Nlevels = gbx%Nlevels - - ! --- Allocate arrays --- - if (use_vgrid) then - x%Nlvgrid = Nlvgrid - else - x%Nlvgrid = gbx%Nlevels - endif - allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid)) - allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels)) - - ! --- Model vertical levels --- - ! Use height levels of first model gridbox - x%mz = gbx%zlev(1,:) - x%mzl = gbx%zlev_half(1,:) - x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels) - x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels)) - - if (use_vgrid) then - ! --- Initialise to zero --- - x%z = 0.0 - x%zl = 0.0 - x%zu = 0.0 - if (cloudsat) then ! --- CloudSat grid requested --- - zstep = 480.0 - else - ! Other grid requested. Constant vertical spacing with top at 20 km - zstep = 20000.0/x%Nlvgrid - endif - do i=1,x%Nlvgrid - x%zl(i) = (i-1)*zstep - x%zu(i) = i*zstep - enddo - x%z = (x%zl + x%zu)/2.0 - else - x%z = x%mz - x%zl = x%mzl - x%zu = x%mzu - endif - - END SUBROUTINE CONSTRUCT_COSP_VGRID - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------ SUBROUTINE FREE_COSP_VGRID ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_VGRID(x) - type(cosp_vgrid),intent(inout) :: x - - deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu) - END SUBROUTINE FREE_COSP_VGRID - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_SGLIDAR ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_SGLIDAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) - type(cosp_config),intent(in) :: cfg ! Configuration options - integer,intent(in) :: Npoints ! Number of sampled points - integer,intent(in) :: Ncolumns ! Number of subgrid columns - integer,intent(in) :: Nlevels ! Number of model levels - integer,intent(in) :: Nhydro ! Number of hydrometeors - integer,intent(in) :: Nrefl ! Number of parasol reflectances ! parasol - type(cosp_sglidar),intent(out) :: x - ! Local variables - integer :: i,j,k,l,m - - ! Allocate minumum storage if simulator not used - if (cfg%Llidar_sim) then - i = Npoints - j = Ncolumns - k = Nlevels - l = Nhydro - m = Nrefl - else - i = 1 - j = 1 - k = 1 - l = 1 - m = 1 - endif - - ! Dimensions - x%Npoints = i - x%Ncolumns = j - x%Nlevels = k - x%Nhydro = l - x%Nrefl = m - - ! --- Allocate arrays --- - allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), & - x%tau_tot(i,j,k),x%refl(i,j,m), & - x%temp_tot(i,k),x%betaperp_tot(i,j,k)) - ! --- Initialise to zero --- - x%beta_mol = 0.0 - x%beta_tot = 0.0 - x%tau_tot = 0.0 - x%refl = 0.0 ! parasol - x%temp_tot = 0.0 - x%betaperp_tot = 0.0 - END SUBROUTINE CONSTRUCT_COSP_SGLIDAR - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------ SUBROUTINE FREE_COSP_SGLIDAR ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_SGLIDAR(x) - type(cosp_sglidar),intent(inout) :: x - - deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl, & - x%temp_tot, x%betaperp_tot) - - END SUBROUTINE FREE_COSP_SGLIDAR - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_SGRADAR ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_SGRADAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) - type(cosp_config),intent(in) :: cfg ! Configuration options - integer,intent(in) :: Npoints ! Number of sampled points - integer,intent(in) :: Ncolumns ! Number of subgrid columns - integer,intent(in) :: Nlevels ! Number of model levels - integer,intent(in) :: Nhydro ! Number of hydrometeors - type(cosp_sgradar),intent(out) :: x - ! Local variables - integer :: i,j,k,l - - if (cfg%Lradar_sim) then - i = Npoints - j = Ncolumns - k = Nlevels - l = Nhydro - else ! Allocate minumum storage if simulator not used - i = 1 - j = 1 - k = 1 - l = 1 - endif - - ! Dimensions - x%Npoints = i - x%Ncolumns = j - x%Nlevels = k - x%Nhydro = l - - ! --- Allocate arrays --- - allocate(x%att_gas(i,k), x%Ze_tot(i,j,k)) - ! --- Initialise to zero --- - x%att_gas = 0.0 - x%Ze_tot = 0.0 - ! The following line give a compilation error on the Met Office NEC -! call zero_real(x%Z_hydro, x%att_hydro) -! f90: error(666): cosp_types.f90, line nnn: -! Actual argument corresponding to dummy -! argument of ELEMENTAL subroutine -! "zero_real" with INTENET(OUT) attribute -! is not array. - END SUBROUTINE CONSTRUCT_COSP_SGRADAR - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------ SUBROUTINE FREE_COSP_SGRADAR ---------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_SGRADAR(x) - type(cosp_sgradar),intent(inout) :: x - - deallocate(x%att_gas, x%Ze_tot) - END SUBROUTINE FREE_COSP_SGRADAR - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------- SUBROUTINE CONSTRUCT_COSP_RADARSTATS --------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_RADARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) - type(cosp_config),intent(in) :: cfg ! Configuration options - integer,intent(in) :: Npoints ! Number of sampled points - integer,intent(in) :: Ncolumns ! Number of subgrid columns - integer,intent(in) :: Nlevels ! Number of model levels - integer,intent(in) :: Nhydro ! Number of hydrometeors - type(cosp_radarstats),intent(out) :: x - ! Local variables - integer :: i,j,k,l - - ! Allocate minumum storage if simulator not used - if (cfg%Lradar_sim) then - i = Npoints - j = Ncolumns - k = Nlevels - l = Nhydro - else - i = 1 - j = 1 - k = 1 - l = 1 - endif - - ! Dimensions - x%Npoints = i - x%Ncolumns = j - x%Nlevels = k - x%Nhydro = l - - ! --- Allocate arrays --- - allocate(x%cfad_ze(i,DBZE_BINS,k),x%lidar_only_freq_cloud(i,k)) - allocate(x%radar_lidar_tcc(i)) - ! --- Initialise to zero --- - x%cfad_ze = 0.0 - x%lidar_only_freq_cloud = 0.0 - x%radar_lidar_tcc = 0.0 - END SUBROUTINE CONSTRUCT_COSP_RADARSTATS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------ SUBROUTINE FREE_COSP_RADARSTATS ------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_RADARSTATS(x) - type(cosp_radarstats),intent(inout) :: x - - deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc) - END SUBROUTINE FREE_COSP_RADARSTATS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------- SUBROUTINE CONSTRUCT_COSP_LIDARSTATS --------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_LIDARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) - type(cosp_config),intent(in) :: cfg ! Configuration options - integer,intent(in) :: Npoints ! Number of sampled points - integer,intent(in) :: Ncolumns ! Number of subgrid columns - integer,intent(in) :: Nlevels ! Number of model levels - integer,intent(in) :: Nhydro ! Number of hydrometeors - integer,intent(in) :: Nrefl ! Number of parasol reflectance - type(cosp_lidarstats),intent(out) :: x - ! Local variables - integer :: i,j,k,l,m - - ! Allocate minumum storage if simulator not used - if (cfg%Llidar_sim) then - i = Npoints - j = Ncolumns - k = Nlevels - l = Nhydro - m = Nrefl - else - i = 1 - j = 1 - k = 1 - l = 1 - m = 1 - endif - - ! Dimensions - x%Npoints = i - x%Ncolumns = j - x%Nlevels = k - x%Nhydro = l - x%Nrefl = m - - ! --- Allocate arrays --- - allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), & - x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m)) - allocate(x%lidarcldphase(i,k,6),x%lidarcldtmp(i,LIDAR_NTEMP,5),& - x%cldlayerphase(i,LIDAR_NCAT,6)) - allocate(x%lidarcldtype(i,k,LIDAR_NTYPE+1),x%cldtype(i,LIDAR_NTYPE)) !OPAQ -! allocate(x%profSR(i,j,k),x%proftemp(i,k)) !TIBO - allocate(x%profSR(i,k,j),x%proftemp(i,k)) !TIBO2 - ! --- Initialise to zero --- - x%srbval = 0.0 - x%cfad_sr = 0.0 - x%lidarcld = 0.0 - x%cldlayer = 0.0 - x%parasolrefl = 0.0 - x%lidarcldphase = 0.0 - x%cldlayerphase = 0.0 - x%lidarcldtmp = 0.0 - x%lidarcldtype = 0.0 !OPAQ - x%cldtype = 0.0 !OPAQ - x%profSR = 0.0 !TIBO - x%proftemp = 0.0 !TIBO - - END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------ SUBROUTINE FREE_COSP_LIDARSTATS ------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_LIDARSTATS(x) - type(cosp_lidarstats),intent(inout) :: x - - deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl) - deallocate(x%cldlayerphase, x%lidarcldtmp, x%lidarcldphase) - deallocate(x%lidarcldtype, x%cldtype) !OPAQ - deallocate(x%profSR, x%proftemp) !TIBO - END SUBROUTINE FREE_COSP_LIDARSTATS - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_SUBGRID ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y) - integer,intent(in) :: Npoints, & ! Number of gridpoints - Ncolumns, & ! Number of columns - Nlevels ! Number of levels - type(cosp_subgrid),intent(out) :: y - - ! Dimensions - y%Npoints = Npoints - y%Ncolumns = Ncolumns - y%Nlevels = Nlevels - - ! --- Allocate arrays --- - allocate(y%frac_out(Npoints,Ncolumns,Nlevels)) - if (Ncolumns > 1) then - allocate(y%prec_frac(Npoints,Ncolumns,Nlevels)) - else ! CRM mode, not needed - allocate(y%prec_frac(1,1,1)) - endif - ! --- Initialise to zero --- - y%prec_frac = 0.0 - y%frac_out = 0.0 - ! The following line gives a compilation error on the Met Office NEC -! call zero_real(y%mr_hydro) -! f90: error(666): cosp_types.f90, line nnn: -! Actual argument corresponding to dummy -! argument of ELEMENTAL subroutine -! "zero_real" with INTENET(OUT) attribute -! is not array. - - END SUBROUTINE CONSTRUCT_COSP_SUBGRID - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE FREE_COSP_SUBGRID ----------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_SUBGRID(y) - type(cosp_subgrid),intent(inout) :: y - - ! --- Deallocate arrays --- - deallocate(y%prec_frac, y%frac_out) - - END SUBROUTINE FREE_COSP_SUBGRID - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_SGHYDRO ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_SGHYDRO(Npoints,Ncolumns,Nlevels,Nhydro,y) - integer,intent(in) :: Npoints, & ! Number of gridpoints - Ncolumns, & ! Number of columns - Nhydro, & ! Number of hydrometeors - Nlevels ! Number of levels - type(cosp_sghydro),intent(out) :: y - - ! Dimensions - y%Npoints = Npoints - y%Ncolumns = Ncolumns - y%Nlevels = Nlevels - y%Nhydro = Nhydro - - ! --- Allocate arrays --- - allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), & - y%Reff(Npoints,Ncolumns,Nlevels,Nhydro), & - y%Np(Npoints,Ncolumns,Nlevels,Nhydro)) ! added by roj with Quickbeam V3 - - ! --- Initialise to zero --- - y%mr_hydro = 0.0 - y%Reff = 0.0 - y%Np = 0.0 ! added by roj with Quickbeam V3 - - END SUBROUTINE CONSTRUCT_COSP_SGHYDRO - - !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE FREE_COSP_SGHYDRO ----------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_SGHYDRO(y) - type(cosp_sghydro),intent(inout) :: y - - ! --- Deallocate arrays --- - deallocate(y%mr_hydro, y%Reff, y%Np) ! added by Roj with Quickbeam V3 - - END SUBROUTINE FREE_COSP_SGHYDRO - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & - Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & - lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, & - use_precipitation_fluxes,use_reff, & - ! RTTOV inputs - Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,& - y,load_LUT) - double precision,intent(in) :: time ! Time since start of run [days] - double precision,intent(in) :: time_bnds(2) ! Time boundaries - real,intent(in) :: radar_freq, & ! Radar frequency [GHz] - k2 ! |K|^2, -1=use frequency dependent default - integer,intent(in) :: & - surface_radar, & ! surface=1,spaceborne=0 - use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first column everywhere - use_gas_abs, & ! include gaseous absorption? yes=1,no=0 - do_ray, & ! calculate/output Rayleigh refl=1, not=0 - melt_lay ! melting layer model off=0, on=1 - integer,intent(in) :: Npoints ! Number of gridpoints - integer,intent(in) :: Nlevels ! Number of levels - integer,intent(in) :: Ncolumns ! Number of columns - integer,intent(in) :: Nhydro ! Number of hydrometeors - integer,intent(in) :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions - integer,intent(in) :: Naero ! Number of aerosol species - integer,intent(in) :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions - integer,intent(in) :: Npoints_it ! Number of gridpoints processed in one iteration - integer,intent(in) :: lidar_ice_type ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical) - integer,intent(in) :: isccp_top_height - integer,intent(in) :: isccp_top_height_direction - integer,intent(in) :: isccp_overlap - real,intent(in) :: isccp_emsfc_lw - logical,intent(in) :: use_precipitation_fluxes,use_reff - integer,intent(in) :: Plat - integer,intent(in) :: Sat - integer,intent(in) :: Inst - integer,intent(in) :: Nchan - integer,intent(in) :: Ichan(Nchan) - real,intent(in) :: SurfEm(Nchan) - real,intent(in) :: ZenAng - real,intent(in) :: co2,ch4,n2o,co - type(cosp_gridbox),intent(out) :: y - logical,intent(in),optional :: load_LUT - - - ! local variables - character*240 :: LUT_file_name - logical :: local_load_LUT - - if (present(load_LUT)) then - local_load_LUT = load_LUT - else - local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag - endif - - ! Dimensions and scalars - y%radar_freq = radar_freq - y%surface_radar = surface_radar - y%use_mie_tables = use_mie_tables - y%use_gas_abs = use_gas_abs - y%do_ray = do_ray - y%melt_lay = melt_lay - y%k2 = k2 - y%Npoints = Npoints - y%Nlevels = Nlevels - y%Ncolumns = Ncolumns - y%Nhydro = Nhydro - y%Nprmts_max_hydro = Nprmts_max_hydro - y%Naero = Naero - y%Nprmts_max_aero = Nprmts_max_aero - y%Npoints_it = Npoints_it - y%lidar_ice_type = lidar_ice_type - y%isccp_top_height = isccp_top_height - y%isccp_top_height_direction = isccp_top_height_direction - y%isccp_overlap = isccp_overlap - y%isccp_emsfc_lw = isccp_emsfc_lw - y%use_precipitation_fluxes = use_precipitation_fluxes - y%use_reff = use_reff - - y%time = time - y%time_bnds = time_bnds - - ! RTTOV parameters - y%Plat = Plat - y%Sat = Sat - y%Inst = Inst - y%Nchan = Nchan - y%ZenAng = ZenAng - y%co2 = co2 - y%ch4 = ch4 - y%n2o = n2o - y%co = co - - ! --- Allocate arrays --- - ! Gridbox information (Npoints,Nlevels) - allocate(y%zlev(Npoints,Nlevels), y%zlev_half(Npoints,Nlevels), y%dlev(Npoints,Nlevels), & - y%p(Npoints,Nlevels), y%ph(Npoints,Nlevels), y%T(Npoints,Nlevels), & - y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), & - y%dtau_s(Npoints,Nlevels), y%dtau_c(Npoints,Nlevels), & - y%dem_s(Npoints,Nlevels), y%dem_c(Npoints,Nlevels), & - y%tca(Npoints,Nlevels), y%cca(Npoints,Nlevels), & - y%rain_ls(Npoints,Nlevels), y%rain_cv(Npoints,Nlevels), y%grpl_ls(Npoints,Nlevels), & - y%snow_ls(Npoints,Nlevels), y%snow_cv(Npoints,Nlevels),y%mr_ozone(Npoints,Nlevels)) - - - ! Surface information and geolocation (Npoints) - allocate(y%toffset(Npoints), y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), & - y%sunlit(Npoints),y%skt(Npoints),y%u_wind(Npoints),y%v_wind(Npoints)) - ! Hydrometeors concentration and distribution parameters - allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), & - y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), & - y%Reff(Npoints,Nlevels,Nhydro), & - y%Np(Npoints,Nlevels,Nhydro)) ! added by Roj with Quickbeam V3 - ! Aerosols concentration and distribution parameters - allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), & - y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero)) - - ! RTTOV channels and sfc. emissivity - allocate(y%ichan(Nchan),y%surfem(Nchan)) - - ! RTTOV parameters - y%ichan = ichan - y%surfem = surfem - - ! --- Initialise to zero --- - y%zlev = 0.0 - y%zlev_half = 0.0 - y%dlev = 0.0 - y%p = 0.0 - y%ph = 0.0 - y%T = 0.0 - y%q = 0.0 - y%sh = 0.0 - y%dtau_s = 0.0 - y%dtau_c = 0.0 - y%dem_s = 0.0 - y%dem_c = 0.0 - y%tca = 0.0 - y%cca = 0.0 - y%rain_ls = 0.0 - y%rain_cv = 0.0 - y%grpl_ls = 0.0 - y%snow_ls = 0.0 - y%snow_cv = 0.0 - y%Reff = 0.0 - y%Np = 0.0 ! added by Roj with Quickbeam V3 - y%mr_ozone = 0.0 - y%u_wind = 0.0 - y%v_wind = 0.0 - - - ! (Npoints) - y%toffset = 0.0 - y%longitude = 0.0 - y%latitude = 0.0 - y%psfc = 0.0 - y%land = 0.0 - y%sunlit = 0.0 - y%skt = 0.0 - ! (Npoints,Nlevels,Nhydro) -! y%fr_hydro = 0.0 - y%mr_hydro = 0.0 - ! Others - y%dist_prmts_hydro = 0.0 ! (Nprmts_max_hydro,Nhydro) - y%conc_aero = 0.0 ! (Npoints,Nlevels,Naero) - y%dist_type_aero = 0 ! (Naero) - y%dist_prmts_aero = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero) - - - ! NOTE: This location use to contain initialization of some radar simulator variables - ! this initialization (including use of the variable "dist_prmts_hydro" - now obselete) - ! has been unified in the quickbeam v3 subroutine "radar_simulator_init". Roj, June 2010 - - ! --- Initialize the distributional parameters for hydrometeors in radar simulator - - write(*,*) 'RADAR_SIM microphysics scheme is set to: ', & - trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME) - - - if(y%Nhydro.ne.N_HYDRO) then - - write(*,*) 'Number of hydrometeor input to subroutine', & - ' CONSTRUCT_COSP_GRIDBOX does not match value', & - ' specified in cosp_constants.f90!' - write(*,*) - endif - - ! NOTE: SAVE_scale_LUTs_flag is hard codded as .false. here - ! so that radar simulator will NOT update LUT each time it - ! is called, but rather will update when "Free_COSP_GRIDBOX" is called! - ! Roj, June 2010 - - LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // & - trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME) - - call radar_simulator_init(radar_freq,k2, & - use_gas_abs,do_ray,R_UNDEF, & - y%Nhydro, & - HCLASS_TYPE,HCLASS_PHASE, & - HCLASS_DMIN,HCLASS_DMAX, & - HCLASS_APM,HCLASS_BPM,HCLASS_RHO, & - HCLASS_P1,HCLASS_P2,HCLASS_P3, & - local_load_LUT, & - .false., & - LUT_file_name, & - y%hp) - -END SUBROUTINE CONSTRUCT_COSP_GRIDBOX - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE FREE_COSP_GRIDBOX ----------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal,save_LUT) - - use scale_LUTs_io - - type(cosp_gridbox),intent(inout) :: y - logical,intent(in),optional :: dglobal - logical,intent(in),optional :: save_LUT - - logical :: local_save_LUT - - if (present(save_LUT)) then - local_save_LUT = save_LUT - else - local_save_LUT = RADAR_SIM_UPDATE_scale_LUTs_flag - endif - - ! save any updates to radar simulator LUT - if (local_save_LUT) call save_scale_LUTs(y%hp) - - deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, & - y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, & - y%toffset, y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, & - y%mr_hydro, y%dist_prmts_hydro, & - y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, & - y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, & - y%sunlit, y%skt, y%Reff,y%Np, & - y%ichan,y%surfem, & - y%mr_ozone,y%u_wind,y%v_wind) - - END SUBROUTINE FREE_COSP_GRIDBOX - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_GRIDBOX_CPHP ---------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_GRIDBOX_CPHP(x,y) - type(cosp_gridbox),intent(in) :: x - type(cosp_gridbox),intent(inout) :: y - - integer :: i,j,k,sz(3) - double precision :: tny - - tny = tiny(tny) - y%hp%p1 = x%hp%p1 - y%hp%p2 = x%hp%p2 - y%hp%p3 = x%hp%p3 - y%hp%dmin = x%hp%dmin - y%hp%dmax = x%hp%dmax - y%hp%apm = x%hp%apm - y%hp%bpm = x%hp%bpm - y%hp%rho = x%hp%rho - y%hp%dtype = x%hp%dtype - y%hp%col = x%hp%col - y%hp%cp = x%hp%cp - y%hp%phase = x%hp%phase - - y%hp%fc = x%hp%fc - y%hp%rho_eff = x%hp%rho_eff - ! y%hp%ifc = x%hp%ifc obsolete, Roj, June 2010 - ! y%hp%idd = x%hp%idd - sz = shape(x%hp%Z_scale_flag) - do k=1,sz(3) - do j=1,sz(2) - do i=1,sz(1) - if (x%hp%N_scale_flag(i,k)) y%hp%N_scale_flag(i,k) = .true. - if (x%hp%Z_scale_flag(i,j,k)) y%hp%Z_scale_flag(i,j,k) = .true. - if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k) - if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k) - if (abs(x%hp%kr_scaled(i,j,k)) > tny) y%hp%kr_scaled(i,j,k) = x%hp%kr_scaled(i,j,k) - enddo - enddo - enddo - -END SUBROUTINE COSP_GRIDBOX_CPHP - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_GRIDBOX_CPSECTION ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_GRIDBOX_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_gridbox),intent(in) :: x - type(cosp_gridbox),intent(inout) :: y - - ! --- Copy arrays without Npoints as dimension --- - y%dist_prmts_hydro = x%dist_prmts_hydro - y%dist_type_aero = x%dist_type_aero - - -! call cosp_gridbox_cphp(x,y) - - ! 1D - y%longitude(iy(1):iy(2)) = x%longitude(ix(1):ix(2)) - y%latitude(iy(1):iy(2)) = x%latitude(ix(1):ix(2)) - y%psfc(iy(1):iy(2)) = x%psfc(ix(1):ix(2)) - y%land(iy(1):iy(2)) = x%land(ix(1):ix(2)) - y%sunlit(iy(1):iy(2)) = x%sunlit(ix(1):ix(2)) - y%skt(iy(1):iy(2)) = x%skt(ix(1):ix(2)) - y%u_wind(iy(1):iy(2)) = x%u_wind(ix(1):ix(2)) - y%v_wind(iy(1):iy(2)) = x%v_wind(ix(1):ix(2)) - ! 2D - y%zlev(iy(1):iy(2),:) = x%zlev(ix(1):ix(2),:) - y%zlev_half(iy(1):iy(2),:) = x%zlev_half(ix(1):ix(2),:) - y%dlev(iy(1):iy(2),:) = x%dlev(ix(1):ix(2),:) - y%p(iy(1):iy(2),:) = x%p(ix(1):ix(2),:) - y%ph(iy(1):iy(2),:) = x%ph(ix(1):ix(2),:) - y%T(iy(1):iy(2),:) = x%T(ix(1):ix(2),:) - y%q(iy(1):iy(2),:) = x%q(ix(1):ix(2),:) - y%sh(iy(1):iy(2),:) = x%sh(ix(1):ix(2),:) - y%dtau_s(iy(1):iy(2),:) = x%dtau_s(ix(1):ix(2),:) - y%dtau_c(iy(1):iy(2),:) = x%dtau_c(ix(1):ix(2),:) - y%dem_s(iy(1):iy(2),:) = x%dem_s(ix(1):ix(2),:) - y%dem_c(iy(1):iy(2),:) = x%dem_c(ix(1):ix(2),:) - y%tca(iy(1):iy(2),:) = x%tca(ix(1):ix(2),:) - y%cca(iy(1):iy(2),:) = x%cca(ix(1):ix(2),:) - y%rain_ls(iy(1):iy(2),:) = x%rain_ls(ix(1):ix(2),:) - y%rain_cv(iy(1):iy(2),:) = x%rain_cv(ix(1):ix(2),:) - y%grpl_ls(iy(1):iy(2),:) = x%grpl_ls(ix(1):ix(2),:) - y%snow_ls(iy(1):iy(2),:) = x%snow_ls(ix(1):ix(2),:) - y%snow_cv(iy(1):iy(2),:) = x%snow_cv(ix(1):ix(2),:) - y%mr_ozone(iy(1):iy(2),:) = x%mr_ozone(ix(1):ix(2),:) - ! 3D - y%Reff(iy(1):iy(2),:,:) = x%Reff(ix(1):ix(2),:,:) - y%Np(iy(1):iy(2),:,:) = x%Np(ix(1):ix(2),:,:) ! added by Roj with Quickbeam V3 - y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:) - y%mr_hydro(iy(1):iy(2),:,:) = x%mr_hydro(ix(1):ix(2),:,:) - ! 4D - y%dist_prmts_aero(iy(1):iy(2),:,:,:) = x%dist_prmts_aero(ix(1):ix(2),:,:,:) - -END SUBROUTINE COSP_GRIDBOX_CPSECTION - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_SUBGRID_CPSECTION ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_SUBGRID_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_subgrid),intent(in) :: x - type(cosp_subgrid),intent(inout) :: y - - y%prec_frac(iy(1):iy(2),:,:) = x%prec_frac(ix(1):ix(2),:,:) - y%frac_out(iy(1):iy(2),:,:) = x%frac_out(ix(1):ix(2),:,:) -END SUBROUTINE COSP_SUBGRID_CPSECTION - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_SGRADAR_CPSECTION ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_SGRADAR_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_sgradar),intent(in) :: x - type(cosp_sgradar),intent(inout) :: y - - y%att_gas(iy(1):iy(2),:) = x%att_gas(ix(1):ix(2),:) - y%Ze_tot(iy(1):iy(2),:,:) = x%Ze_tot(ix(1):ix(2),:,:) -END SUBROUTINE COSP_SGRADAR_CPSECTION - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_SGLIDAR_CPSECTION ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_SGLIDAR_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_sglidar),intent(in) :: x - type(cosp_sglidar),intent(inout) :: y - - y%temp_tot(iy(1):iy(2),:) = x%temp_tot(ix(1):ix(2),:) - y%betaperp_tot(iy(1):iy(2),:,:) = x%betaperp_tot(ix(1):ix(2),:,:) - y%beta_mol(iy(1):iy(2),:) = x%beta_mol(ix(1):ix(2),:) - y%beta_tot(iy(1):iy(2),:,:) = x%beta_tot(ix(1):ix(2),:,:) - y%tau_tot(iy(1):iy(2),:,:) = x%tau_tot(ix(1):ix(2),:,:) - y%refl(iy(1):iy(2),:,:) = x%refl(ix(1):ix(2),:,:) -END SUBROUTINE COSP_SGLIDAR_CPSECTION - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_ISCCP_CPSECTION ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_ISCCP_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_isccp),intent(in) :: x - type(cosp_isccp),intent(inout) :: y - - y%fq_isccp(iy(1):iy(2),:,:) = x%fq_isccp(ix(1):ix(2),:,:) - y%totalcldarea(iy(1):iy(2)) = x%totalcldarea(ix(1):ix(2)) - y%meantb(iy(1):iy(2)) = x%meantb(ix(1):ix(2)) - y%meantbclr(iy(1):iy(2)) = x%meantbclr(ix(1):ix(2)) - y%meanptop(iy(1):iy(2)) = x%meanptop(ix(1):ix(2)) - y%meantaucld(iy(1):iy(2)) = x%meantaucld(ix(1):ix(2)) - y%meanalbedocld(iy(1):iy(2)) = x%meanalbedocld(ix(1):ix(2)) - y%boxtau(iy(1):iy(2),:) = x%boxtau(ix(1):ix(2),:) - y%boxptop(iy(1):iy(2),:) = x%boxptop(ix(1):ix(2),:) -END SUBROUTINE COSP_ISCCP_CPSECTION - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_MISR_CPSECTION ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_MISR_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_misr),intent(in) :: x - type(cosp_misr),intent(inout) :: y - - y%fq_MISR(iy(1):iy(2),:,:) = x%fq_MISR(ix(1):ix(2),:,:) - y%MISR_meanztop(iy(1):iy(2)) = x%MISR_meanztop(ix(1):ix(2)) - y%MISR_cldarea(iy(1):iy(2)) = x%MISR_cldarea(ix(1):ix(2)) - y%MISR_dist_model_layertops(iy(1):iy(2),:) = x%MISR_dist_model_layertops(ix(1):ix(2),:) -END SUBROUTINE COSP_MISR_CPSECTION - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_RTTOV_CPSECTION ------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_RTTOV_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_rttov),intent(in) :: x - type(cosp_rttov),intent(inout) :: y - - y%tbs(iy(1):iy(2),:) = x%tbs(ix(1):ix(2),:) -END SUBROUTINE COSP_RTTOV_CPSECTION - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_RADARSTATS_CPSECTION -------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_RADARSTATS_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_radarstats),intent(in) :: x - type(cosp_radarstats),intent(inout) :: y - - y%cfad_ze(iy(1):iy(2),:,:) = x%cfad_ze(ix(1):ix(2),:,:) - y%radar_lidar_tcc(iy(1):iy(2)) = x%radar_lidar_tcc(ix(1):ix(2)) - y%lidar_only_freq_cloud(iy(1):iy(2),:) = x%lidar_only_freq_cloud(ix(1):ix(2),:) -END SUBROUTINE COSP_RADARSTATS_CPSECTION - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_LIDARSTATS_CPSECTION -------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_LIDARSTATS_CPSECTION(ix,iy,x,y) - integer,intent(in),dimension(2) :: ix,iy - type(cosp_lidarstats),intent(in) :: x - type(cosp_lidarstats),intent(inout) :: y - - y%srbval = x%srbval - y%cfad_sr(iy(1):iy(2),:,:) = x%cfad_sr(ix(1):ix(2),:,:) - y%lidarcld(iy(1):iy(2),:) = x%lidarcld(ix(1):ix(2),:) - y%cldlayer(iy(1):iy(2),:) = x%cldlayer(ix(1):ix(2),:) - y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:) - y%lidarcldphase(iy(1):iy(2),:,:) = x%lidarcldphase(ix(1):ix(2),:,:) - y%cldlayerphase(iy(1):iy(2),:,:) = x%cldlayerphase(ix(1):ix(2),:,:) - y%lidarcldtmp(iy(1):iy(2),:,:) = x%lidarcldtmp(ix(1):ix(2),:,:) - y%lidarcldtype(iy(1):iy(2),:,:) = x%lidarcldtype(ix(1):ix(2),:,:) !OPAQ - y%cldtype(iy(1):iy(2),:) = x%cldtype(ix(1):ix(2),:) !OPAQ - y%profSR(iy(1):iy(2),:,:) = x%profSR(ix(1):ix(2),:,:) !TIBO - y%proftemp(iy(1):iy(2),:) = x%proftemp(ix(1):ix(2),:) !TIBO -END SUBROUTINE COSP_LIDARSTATS_CPSECTION -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- PRINT SUBROUTINES -------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_GRIDBOX_PRINT(x) - type(cosp_gridbox),intent(in) :: x - - print *, '%%%%----- Information on COSP_GRIDBOX ------' - ! Scalars and dimensions - print *, x%Npoints - print *, x%Nlevels - print *, x%Ncolumns - print *, x%Nhydro - print *, x%Nprmts_max_hydro - print *, x%Naero - print *, x%Nprmts_max_aero - print *, x%Npoints_it - - ! Time [days] - print *, x%time - - ! Radar ancillary info - print *, x%radar_freq, & - x%k2 - print *, x%surface_radar, & - x%use_mie_tables, & - x%use_gas_abs, & - x%do_ray, & - x%melt_lay - -! print *, 'shape(x%): ',shape(x%) - -! type(class_param) :: hp ! structure used by radar simulator to store Ze and N scaling constants and other information -! type(mie):: mt ! structure used by radar simulator to store mie LUT information - print *, x%nsizes - - ! Lidar - print *, x%lidar_ice_type - - ! Radar - print *, x%use_precipitation_fluxes - print *, x%use_reff - - ! Geolocation (Npoints) - print *, 'shape(x%longitude): ',shape(x%longitude) - print *, 'shape(x%latitude): ',shape(x%latitude) - ! Gridbox information (Npoints,Nlevels) - print *, 'shape(x%zlev): ',shape(x%zlev) - print *, 'shape(x%zlev_half): ',shape(x%zlev_half) - print *, 'shape(x%dlev): ',shape(x%dlev) - print *, 'shape(x%p): ',shape(x%p) - print *, 'shape(x%ph): ',shape(x%ph) - print *, 'shape(x%T): ',shape(x%T) - print *, 'shape(x%q): ',shape(x%q) - print *, 'shape(x%sh): ',shape(x%sh) - print *, 'shape(x%dtau_s): ',shape(x%dtau_s) - print *, 'shape(x%dtau_c): ',shape(x%dtau_c) - print *, 'shape(x%dem_s): ',shape(x%dem_s) - print *, 'shape(x%dem_c): ',shape(x%dem_c) - print *, 'shape(x%mr_ozone): ',shape(x%mr_ozone) - - ! Point information (Npoints) - print *, 'shape(x%land): ',shape(x%land) - print *, 'shape(x%psfc): ',shape(x%psfc) - print *, 'shape(x%sunlit): ',shape(x%sunlit) - print *, 'shape(x%skt): ',shape(x%skt) - print *, 'shape(x%u_wind): ',shape(x%u_wind) - print *, 'shape(x%v_wind): ',shape(x%v_wind) - - ! TOTAL and CONV cloud fraction for SCOPS - print *, 'shape(x%tca): ',shape(x%tca) - print *, 'shape(x%cca): ',shape(x%cca) - ! Precipitation fluxes on model levels - print *, 'shape(x%rain_ls): ',shape(x%rain_ls) - print *, 'shape(x%rain_cv): ',shape(x%rain_cv) - print *, 'shape(x%snow_ls): ',shape(x%snow_ls) - print *, 'shape(x%snow_cv): ',shape(x%snow_cv) - print *, 'shape(x%grpl_ls): ',shape(x%grpl_ls) - ! Hydrometeors concentration and distribution parameters - print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro) - print *, 'shape(x%dist_prmts_hydro): ',shape(x%dist_prmts_hydro) - ! Effective radius [m]. (Npoints,Nlevels,Nhydro) - print *, 'shape(x%Reff): ',shape(x%Reff) - print *, 'shape(x%Np): ',shape(x%Np) ! added by roj with Quickbeam V3 - ! Aerosols concentration and distribution parameters - print *, 'shape(x%conc_aero): ',shape(x%conc_aero) - print *, 'shape(x%dist_type_aero): ',shape(x%dist_type_aero) - print *, 'shape(x%dist_prmts_aero): ',shape(x%dist_prmts_aero) - ! ISCCP simulator inputs - print *, x%isccp_top_height - print *, x%isccp_top_height_direction - print *, x%isccp_overlap - print *, x%isccp_emsfc_lw - - ! RTTOV inputs/options - print *, x%plat - print *, x%sat - print *, x%inst - print *, x%Nchan - print *, 'shape(x%Ichan): ',x%Ichan - print *, 'shape(x%Surfem): ',x%Surfem - print *, x%ZenAng - print *, x%co2,x%ch4,x%n2o,x%co - -END SUBROUTINE COSP_GRIDBOX_PRINT - -SUBROUTINE COSP_MISR_PRINT(x) - type(cosp_misr),intent(in) :: x - - print *, '%%%%----- Information on COSP_MISR ------' - - ! Dimensions - print *, x%Npoints - print *, x%Ntau - print *, x%Nlevels - - ! --- (npoints,ntau,nlevels) - ! the fraction of the model grid box covered by each of the MISR cloud types - print *, 'shape(x%fq_MISR): ',shape(x%fq_MISR) - - ! --- (npoints) - print *, 'shape(x%MISR_meanztop): ',shape(x%MISR_meanztop) - print *, 'shape(x%MISR_cldarea): ',shape(x%MISR_cldarea) - ! --- (npoints,nlevels) - print *, 'shape(x%MISR_dist_model_layertops): ',shape(x%MISR_dist_model_layertops) - -END SUBROUTINE COSP_MISR_PRINT - -SUBROUTINE COSP_ISCCP_PRINT(x) - type(cosp_isccp),intent(in) :: x - - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - - print *, '%%%%----- Information on COSP_ISCCP ------' - - print *, 'shape(x%fq_isccp): ',shape(x%fq_isccp) - print *, 'shape(x%totalcldarea): ',shape(x%totalcldarea) - print *, 'shape(x%meantb): ',shape(x%meantb) - print *, 'shape(x%meantbclr): ',shape(x%meantbclr) - - print *, 'shape(x%meanptop): ',shape(x%meanptop) - print *, 'shape(x%meantaucld): ',shape(x%meantaucld) - print *, 'shape(x%meanalbedocld): ',shape(x%meanalbedocld) - print *, 'shape(x%boxtau): ',shape(x%boxtau) - print *, 'shape(x%boxptop): ',shape(x%boxptop) -END SUBROUTINE COSP_ISCCP_PRINT - -SUBROUTINE COSP_VGRID_PRINT(x) - type(cosp_vgrid),intent(in) :: x - - print *, '%%%%----- Information on COSP_VGRID ------' - print *, x%use_vgrid - print *, x%csat_vgrid - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - print *, x%Nlvgrid - ! Array with dimensions (Nlvgrid) - print *, 'shape(x%z): ',shape(x%z) - print *, 'shape(x%zl): ',shape(x%zl) - print *, 'shape(x%zu): ',shape(x%zu) - ! Array with dimensions (Nlevels) - print *, 'shape(x%mz): ',shape(x%mz) - print *, 'shape(x%mzl): ',shape(x%mzl) - print *, 'shape(x%mzu): ',shape(x%mzu) -END SUBROUTINE COSP_VGRID_PRINT - -SUBROUTINE COSP_SGLIDAR_PRINT(x) - type(cosp_sglidar),intent(in) :: x - - print *, '%%%%----- Information on COSP_SGLIDAR ------' - ! Dimensions - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - print *, x%Nhydro - print *, x%Nrefl - ! Arrays with dimensions (Npoints,Nlevels) - print *, 'shape(x%beta_mol): ',shape(x%beta_mol) - ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) - print *, 'shape(x%beta_tot): ',shape(x%beta_tot) - print *, 'shape(x%tau_tot): ',shape(x%tau_tot) - ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) - print *, 'shape(x%refl): ',shape(x%refl) -END SUBROUTINE COSP_SGLIDAR_PRINT - -SUBROUTINE COSP_SGRADAR_PRINT(x) - type(cosp_sgradar),intent(in) :: x - - print *, '%%%%----- Information on COSP_SGRADAR ------' - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - print *, x%Nhydro - ! output vertical levels: spaceborne radar -> from TOA to SURFACE - ! Arrays with dimensions (Npoints,Nlevels) - print *, 'shape(x%att_gas): ', shape(x%att_gas) - ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) - print *, 'shape(x%Ze_tot): ', shape(x%Ze_tot) -END SUBROUTINE COSP_SGRADAR_PRINT - -SUBROUTINE COSP_RADARSTATS_PRINT(x) - type(cosp_radarstats),intent(in) :: x - - print *, '%%%%----- Information on COSP_SGRADAR ------' - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - print *, x%Nhydro - print *, 'shape(x%cfad_ze): ',shape(x%cfad_ze) - print *, 'shape(x%radar_lidar_tcc): ',shape(x%radar_lidar_tcc) - print *, 'shape(x%lidar_only_freq_cloud): ',shape(x%lidar_only_freq_cloud) -END SUBROUTINE COSP_RADARSTATS_PRINT - -SUBROUTINE COSP_LIDARSTATS_PRINT(x) - type(cosp_lidarstats),intent(in) :: x - - print *, '%%%%----- Information on COSP_SGLIDAR ------' - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - print *, x%Nhydro - print *, x%Nrefl - - ! Arrays with dimensions (SR_BINS) - print *, 'shape(x%srbval): ',shape(x%srbval) - ! Arrays with dimensions (Npoints,SR_BINS,Nlevels) - print *, 'shape(x%cfad_sr): ',shape(x%cfad_sr) -! ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) !TIBO -! print *, 'shape(x%profSR): ',shape(x%profSR) !TIBO - ! Arrays with dimensions (Npoints,Nlevels,Ncolumns) !TIBO2 - print *, 'shape(x%profSR): ',shape(x%profSR) !TIBO2 - ! Arrays with dimensions (Npoints,Nlevels) - print *, 'shape(x%lidarcld): ',shape(x%lidarcld) - print *, 'shape(x%proftemp): ',shape(x%proftemp) !TIBO - ! Arrays with dimensions (Npoints,LIDAR_NCAT) - print *, 'shape(x%cldlayer): ',shape(x%cldlayer) - ! Arrays with dimensions (Npoints,LIDAR_NTYPE) !OPAQ - print *, 'shape(x%cldtype): ',shape(x%cldtype) !OPAQ - ! Arrays with dimensions (Npoints,PARASOL_NREFL) - print *, 'shape(x%parasolrefl): ',shape(x%parasolrefl) - ! Arrays with dimensions (Npoints,Nlevels,Nphase) - print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldphase) - ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1) !OPAQ - print *, 'shape(x%lidarcldtype): ',shape(x%lidarcldtype) !OPAQ - ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase) - print *, 'shape(x%cldlayerphase): ',shape(x%cldlayerphase) - ! Arrays with dimensions (Npoints,Ntemps,Nphase) - print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldtmp) - -END SUBROUTINE COSP_LIDARSTATS_PRINT - -SUBROUTINE COSP_SUBGRID_PRINT(x) - type(cosp_subgrid),intent(in) :: x - - print *, '%%%%----- Information on COSP_SUBGRID ------' - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - print *, x%Nhydro - - print *, 'shape(x%prec_frac): ',shape(x%prec_frac) - print *, 'shape(x%frac_out): ',shape(x%frac_out) -END SUBROUTINE COSP_SUBGRID_PRINT - -SUBROUTINE COSP_SGHYDRO_PRINT(x) - type(cosp_sghydro),intent(in) :: x - - print *, '%%%%----- Information on COSP_SGHYDRO ------' - print *, x%Npoints - print *, x%Ncolumns - print *, x%Nlevels - print *, x%Nhydro - - print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro) - print *, 'shape(x%Reff): ',shape(x%Reff) - print *, 'shape(x%Np): ',shape(x%Np) ! added by roj with Quickbeam V3 -END SUBROUTINE COSP_SGHYDRO_PRINT - -END MODULE MOD_COSP_TYPES Index: LMDZ6/trunk/libf/phylmd/cosp/cosp_utils.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/cosp_utils.F90 (revision 3231) +++ (revision ) @@ -1,344 +1,0 @@ -! (c) British Crown Copyright 2008, the Met Office. -! All rights reserved. -! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_utils.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - -! -! History: -! Jul 2007 - A. Bodas-Salcedo - Initial version -! - -MODULE MOD_COSP_UTILS - USE MOD_COSP_CONSTANTS - IMPLICIT NONE - - INTERFACE Z_TO_DBZ - MODULE PROCEDURE Z_TO_DBZ_2D,Z_TO_DBZ_3D,Z_TO_DBZ_4D - END INTERFACE - - INTERFACE COSP_CHECK_INPUT - MODULE PROCEDURE COSP_CHECK_INPUT_1D,COSP_CHECK_INPUT_2D,COSP_CHECK_INPUT_3D - END INTERFACE -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,intent(in),dimension(Npoints,Nlevels) :: p,T,flux - real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac - real,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,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio - real,intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff - ! Local variables - integer :: i,j,k - real :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta - - mxratio = 0.0 - - if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed - xi = d_x/(alpha_x + b_x - n_bx + 1.0) - rho0 = 1.29 - sigma = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi - one_over_xip1 = 1.0/(xi + 1.0) - gamma_4_3_2 = 0.5*gamma4/gamma3 - delta = (alpha_x + b_x + d_x - n_bx + 1.0) - - 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*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.0).and.(flux(i,k) /= 0.0)) then - lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1./delta) - reff(i,j,k) = gamma_4_3_2/lambda_x - endif - endif - enddo - enddo - enddo - endif -END SUBROUTINE COSP_PRECIP_MXRATIO - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------- SUBROUTINE ZERO_INT ------------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -ELEMENTAL SUBROUTINE ZERO_INT(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & - y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & - y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) - - integer,intent(inout) :: x - integer,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & - y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & - y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 - x = 0 - if (present(y01)) y01 = 0 - if (present(y02)) y02 = 0 - if (present(y03)) y03 = 0 - if (present(y04)) y04 = 0 - if (present(y05)) y05 = 0 - if (present(y06)) y06 = 0 - if (present(y07)) y07 = 0 - if (present(y08)) y08 = 0 - if (present(y09)) y09 = 0 - if (present(y10)) y10 = 0 - if (present(y11)) y11 = 0 - if (present(y12)) y12 = 0 - if (present(y13)) y13 = 0 - if (present(y14)) y14 = 0 - if (present(y15)) y15 = 0 - if (present(y16)) y16 = 0 - if (present(y17)) y17 = 0 - if (present(y18)) y18 = 0 - if (present(y19)) y19 = 0 - if (present(y20)) y20 = 0 - if (present(y21)) y21 = 0 - if (present(y22)) y22 = 0 - if (present(y23)) y23 = 0 - if (present(y24)) y24 = 0 - if (present(y25)) y25 = 0 - if (present(y26)) y26 = 0 - if (present(y27)) y27 = 0 - if (present(y28)) y28 = 0 - if (present(y29)) y29 = 0 - if (present(y30)) y30 = 0 -END SUBROUTINE ZERO_INT - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------------- SUBROUTINE ZERO_REAL ------------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -ELEMENTAL SUBROUTINE ZERO_REAL(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & - y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & - y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) - - real,intent(inout) :: x - real,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & - y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & - y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 - x = 0.0 - if (present(y01)) y01 = 0.0 - if (present(y02)) y02 = 0.0 - if (present(y03)) y03 = 0.0 - if (present(y04)) y04 = 0.0 - if (present(y05)) y05 = 0.0 - if (present(y06)) y06 = 0.0 - if (present(y07)) y07 = 0.0 - if (present(y08)) y08 = 0.0 - if (present(y09)) y09 = 0.0 - if (present(y10)) y10 = 0.0 - if (present(y11)) y11 = 0.0 - if (present(y12)) y12 = 0.0 - if (present(y13)) y13 = 0.0 - if (present(y14)) y14 = 0.0 - if (present(y15)) y15 = 0.0 - if (present(y16)) y16 = 0.0 - if (present(y17)) y17 = 0.0 - if (present(y18)) y18 = 0.0 - if (present(y19)) y19 = 0.0 - if (present(y20)) y20 = 0.0 - if (present(y21)) y21 = 0.0 - if (present(y22)) y22 = 0.0 - if (present(y23)) y23 = 0.0 - if (present(y24)) y24 = 0.0 - if (present(y25)) y25 = 0.0 - if (present(y26)) y26 = 0.0 - if (present(y27)) y27 = 0.0 - if (present(y28)) y28 = 0.0 - if (present(y29)) y29 = 0.0 - if (present(y30)) y30 = 0.0 -END SUBROUTINE ZERO_REAL - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!--------------------- SUBROUTINE Z_TO_DBZ_2D -------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE Z_TO_DBZ_2D(mdi,z) - real,intent(in) :: mdi - real,dimension(:,:),intent(inout) :: z - ! Reflectivity Z: - ! Input in [m3] - ! Output in dBZ, with Z in [mm6 m-3] - - ! 1.e18 to convert from [m3] to [mm6 m-3] - z = 1.e18*z - where (z > 1.0e-6) ! Limit to -60 dBZ - z = 10.0*log10(z) - elsewhere - z = mdi - end where - END SUBROUTINE Z_TO_DBZ_2D -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!--------------------- SUBROUTINE Z_TO_DBZ_3D -------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE Z_TO_DBZ_3D(mdi,z) - real,intent(in) :: mdi - real,dimension(:,:,:),intent(inout) :: z - ! Reflectivity Z: - ! Input in [m3] - ! Output in dBZ, with Z in [mm6 m-3] - - ! 1.e18 to convert from [m3] to [mm6 m-3] - z = 1.e18*z - where (z > 1.0e-6) ! Limit to -60 dBZ - z = 10.0*log10(z) - elsewhere - z = mdi - end where - END SUBROUTINE Z_TO_DBZ_3D -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!--------------------- SUBROUTINE Z_TO_DBZ_4D -------------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE Z_TO_DBZ_4D(mdi,z) - real,intent(in) :: mdi - real,dimension(:,:,:,:),intent(inout) :: z - ! Reflectivity Z: - ! Input in [m3] - ! Output in dBZ, with Z in [mm6 m-3] - - ! 1.e18 to convert from [m3] to [mm6 m-3] - z = 1.e18*z - where (z > 1.0e-6) ! Limit to -60 dBZ - z = 10.0*log10(z) - elsewhere - z = mdi - end where - END SUBROUTINE Z_TO_DBZ_4D - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------- SUBROUTINES COSP_CHECK_INPUT_1D --------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE COSP_CHECK_INPUT_1D(vname,x,min_val,max_val) - character(len=*) :: vname - real,intent(inout) :: x(:) - real,intent(in),optional :: min_val,max_val - logical :: l_min,l_max - character(len=128) :: pro_name='COSP_CHECK_INPUT_1D' - - l_min=.false. - l_max=.false. - - if (present(min_val)) then -! if (x < min_val) x = min_val - if (any(x < min_val)) then - l_min = .true. - where (x < min_val) - x = min_val - end where - endif - endif - if (present(max_val)) then -! if (x > max_val) x = max_val - if (any(x > max_val)) then - l_max = .true. - where (x > max_val) - x = max_val - end where - endif - endif - - if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val - if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val - END SUBROUTINE COSP_CHECK_INPUT_1D -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------- SUBROUTINES COSP_CHECK_INPUT_2D --------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE COSP_CHECK_INPUT_2D(vname,x,min_val,max_val) - character(len=*) :: vname - real,intent(inout) :: x(:,:) - real,intent(in),optional :: min_val,max_val - logical :: l_min,l_max - character(len=128) :: pro_name='COSP_CHECK_INPUT_2D' - - l_min=.false. - l_max=.false. - - if (present(min_val)) then -! if (x < min_val) x = min_val - if (any(x < min_val)) then - l_min = .true. - where (x < min_val) - x = min_val - end where - endif - endif - if (present(max_val)) then -! if (x > max_val) x = max_val - if (any(x > max_val)) then - l_max = .true. - where (x > max_val) - x = max_val - end where - endif - endif - - if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val - if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val - END SUBROUTINE COSP_CHECK_INPUT_2D -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!----------------- SUBROUTINES COSP_CHECK_INPUT_3D --------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE COSP_CHECK_INPUT_3D(vname,x,min_val,max_val) - character(len=*) :: vname - real,intent(inout) :: x(:,:,:) - real,intent(in),optional :: min_val,max_val - logical :: l_min,l_max - character(len=128) :: pro_name='COSP_CHECK_INPUT_3D' - - l_min=.false. - l_max=.false. - - if (present(min_val)) then -! if (x < min_val) x = min_val - if (any(x < min_val)) then - l_min = .true. - where (x < min_val) - x = min_val - end where - endif - endif - if (present(max_val)) then -! if (x > max_val) x = max_val - if (any(x > max_val)) then - l_max = .true. - where (x > max_val) - x = max_val - end where - endif - endif - - if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val - if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val - END SUBROUTINE COSP_CHECK_INPUT_3D - - -END MODULE MOD_COSP_UTILS Index: LMDZ6/trunk/libf/phylmd/cosp/format_input.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/format_input.F90 (revision 3231) +++ LMDZ6/trunk/libf/phylmd/cosp/format_input.F90 (revision 3233) Index: LMDZ6/trunk/libf/phylmd/cosp/llnl_stats.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/llnl_stats.F90 (revision 3231) +++ (revision ) @@ -1,138 +1,0 @@ -! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/llnl_stats.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation -! nor the names of its contributors may be used to endorse or promote products derived from -! this software without specific prior written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! -! History -! -! Jan 2013 - G. Cesana - Added betaperp_tot and temp_tot arguments -! - - -MODULE MOD_LLNL_STATS - USE MOD_COSP_CONSTANTS - IMPLICIT NONE - -CONTAINS - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------------- FUNCTION COSP_CFAD ------------------------ -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -FUNCTION COSP_CFAD(Npoints,Ncolumns,Nlevels,Nbins,x,xmin,xmax,bmin,bwidth) - ! Input arguments - integer,intent(in) :: Npoints,Ncolumns,Nlevels,Nbins - real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: x - real,intent(in) :: xmin,xmax - real,intent(in) :: bmin,bwidth - - real,dimension(Npoints,Nbins,Nlevels) :: cosp_cfad - ! Local variables - integer :: i, j, k - integer :: ibin - - !--- Input arguments - ! Npoints: Number of horizontal points - ! Ncolumns: Number of subcolumns - ! Nlevels: Number of levels - ! Nbins: Number of x axis bins - ! x: variable to process (Npoints,Ncolumns,Nlevels) - ! xmin: minimum value allowed for x - ! xmax: minimum value allowed for x - ! bmin: mimumum value of first bin - ! bwidth: bin width - ! - ! Output: 2D histogram on each horizontal point (Npoints,Nbins,Nlevels) - - cosp_cfad = 0.0 - ! bwidth intervals in the range [bmin,bmax=bmin+Nbins*hwidth] - ! Valid x values smaller than bmin and larger than bmax are set - ! into the smallest bin and largest bin, respectively. - do j = 1, Nlevels, 1 - do k = 1, Ncolumns, 1 - do i = 1, Npoints, 1 - if (x(i,k,j) == R_GROUND) then - cosp_cfad(i,:,j) = R_UNDEF - elseif ((x(i,k,j) >= xmin) .and. (x(i,k,j) <= xmax)) then - ibin = ceiling((x(i,k,j) - bmin)/bwidth) - if (ibin > Nbins) ibin = Nbins - if (ibin < 1) ibin = 1 - cosp_cfad(i,ibin,j) = cosp_cfad(i,ibin,j) + 1.0 - end if - enddo !i - enddo !k - enddo !j - where ((cosp_cfad /= R_UNDEF).and.(cosp_cfad /= 0.0)) cosp_cfad = cosp_cfad / Ncolumns -END FUNCTION COSP_CFAD - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD ----------------- -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,temp_tot,beta_tot, & - betaperp_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc) - ! Input arguments - integer,intent(in) :: Npoints,Ncolumns,Nlevels - real,dimension(Npoints,Nlevels),intent(in) :: beta_mol ! Molecular backscatter - real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot ! Total backscattered signal - real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: temp_tot ! Total backscattered signal - real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: betaperp_tot ! perpendicular Total backscattered signal - real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot ! Radar reflectivity - ! Output arguments - real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud - real,dimension(Npoints),intent(out) :: tcc - - ! local variables - real :: sc_ratio - real :: s_cld, s_att - parameter (S_cld = 5.0) - parameter (s_att = 0.01) - integer :: flag_sat !first saturated level encountered from top - integer :: flag_cld !cloudy column - integer :: pr,i,j - - lidar_only_freq_cloud = 0.0 - tcc = 0.0 - do pr=1,Npoints - do i=1,Ncolumns - flag_sat = 0 - flag_cld = 0 - do j=Nlevels,1,-1 !top->surf - sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j) - if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j - if (Ze_tot(pr,i,j) .lt. -30.) then !radar can't detect cloud - if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then !lidar sense cloud - lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf - flag_cld=1 - endif - else !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.) - flag_cld=1 - endif - enddo !levels - if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1. - enddo !columns - enddo !points - lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns - tcc=tcc/Ncolumns - -END SUBROUTINE COSP_LIDAR_ONLY_CLOUD -END MODULE MOD_LLNL_STATS Index: LMDZ6/trunk/libf/phylmd/cosp/lmd_ipsl_stats.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/lmd_ipsl_stats.F90 (revision 3231) +++ (revision ) @@ -1,1181 +1,0 @@ -! Copyright (c) 2009, Centre National de la Recherche Scientifique -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lmd_ipsl_stats.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its -! contributors may be used to endorse or promote products derived from this software without -! specific prior written permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. - - -!------------------------------------------------------------------------------------ -! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). -!------------------------------------------------------------------------------------ -MODULE MOD_LMD_IPSL_STATS - USE MOD_LLNL_STATS - IMPLICIT NONE - -CONTAINS - SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl & - ,tmp,pnorm,pnorm_perp,pmol,refl,land,pplay,undef,ok_lidar_cfad & - ,cfad2,srbval,ncat,ntype,lidarcld,lidarcldtype,lidarcldphase,cldlayer & !OPAQ - ,cldtype,cldlayerphase,lidarcldtmp,parasolrefl,vgrid_z,profSR) !OPAQ !TIBO -! -! ----------------------------------------------------------------------------------- -! Lidar outputs : -! -! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction) -! and phase cloud fraction (3D, low/mid/high/total and 3D temperature) -! from the lidar signals (ATB, ATBperp and molecular ATB) computed from model outputs -! + -! Compute CFADs of lidar scattering ratio SR and of depolarization index -! -! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). -! -! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : -! - change of the cloud detection threshold S_cld from 3 to 5, for better -! with both day and night observations. The optical thinest clouds are missed. -! - remove of the detection of the first fully attenuated layer encountered from above. -! December 2008, A. Bodas-Salcedo: -! - Dimensions of pmol reduced to (npoints,llm) -! August 2009, A. Bodas-Salcedo: -! - Warning message regarding PARASOL being valid only over ocean deleted. -! February 2010, A. Bodas-Salcedo: -! - Undef passed into cosp_cfad_sr -! June 2010, T. Yokohata, T. Nishimura and K. Ogochi -! Optimisation of COSP_CFAD_SR -! -! January 2013, G. Cesana, H. Chepfer: -! - Add the perpendicular component of the backscattered signal (pnorm_perp) in the arguments -! - Add the temperature (tmp) in the arguments -! - Add the 3D Phase cloud fraction (lidarcldphase) in the arguments -! - Add the Phase low mid high cloud fraction (cldlayerphase) in the arguments -! - Add the 3D Phase cloud fraction as a function of temperature (lidarcldtmp) in the arguments -! - Modification of the phase diagnosis within the COSP_CLDFRAC routine to integrate the phase -! diagnosis (3D, low/mid/high, 3D temperature) -! 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 -! -! ------------------------------------------------------------------------------------ - -! c inputs : - integer npoints - integer ncol - integer llm - integer max_bin ! nb of bins for SR CFADs - integer ncat ! nb of cloud layer types (low,mid,high,total) - integer ntype ! nb of OPAQ products (opaque and thin clouds, z_opaque) !OPAQ - integer nrefl ! nb of solar zenith angles for parasol reflectances - - real undef ! undefined value - real pnorm(npoints,ncol,llm) ! lidar ATB - real pmol(npoints,llm) ! molecular ATB - real land(npoints) ! Landmask [0 - Ocean, 1 - Land] - real pplay(npoints,llm) ! pressure on model levels (Pa) - logical ok_lidar_cfad ! true if lidar CFAD diagnostics need to be computed - real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol - real tmp(npoints,llm) ! temp at each levels - real pnorm_perp(npoints,ncol,llm) ! lidar perpendicular ATB - real vgrid_z(llm) ! mid-level altitude of the output vertical grid !OPAQ - -! c outputs : - real lidarcld(npoints,llm) ! 3D "lidar" cloud fraction - real lidarcldtype(npoints,llm,ntype+1) ! 3D "lidar" OPAQ type fraction + opacity !OPAQ - real sub(npoints,llm) ! 3D "lidar" indice - real cldlayer(npoints,ncat) ! "lidar" cloud layer fraction (low, mid, high, total) - real cldtype(npoints,ntype) ! "lidar" OPAQ type covers (opaque/thin cloud + z_opaque) !OPAQ - - real cfad2(npoints,max_bin,llm) ! CFADs of SR - real srbval(max_bin) ! SR bins in CFADs - real parasolrefl(npoints,nrefl)! grid-averaged parasol reflectance -! real profSR(npoints,ncol,llm) ! tableau avec les subcolumns SR !TIBO - real profSR(npoints,llm,ncol) ! tableau avec les subcolumns SR !TIBO2 - -! c threshold for cloud detection : - real S_clr - parameter (S_clr = 1.2) - real S_cld - parameter (S_cld = 5.) ! Thresold for cloud detection - real S_att - parameter (S_att = 0.01) -! parameter (S_att = 0.06) !OPAQ ! Threshold for "surface detection" equivalent - -! c local variables : - integer ic,k,i,j - real x3d(npoints,ncol,llm) - real x3d_c(npoints,llm),pnorm_c(npoints,llm) - real xmax - -! Output variables - integer,parameter :: nphase = 6 ! nb of cloud layer phase types (ice,liquid,undefined,false ice,false liquid,Percent of ice) - real lidarcldphase(npoints,llm,nphase) ! 3D "lidar" phase cloud fraction - real lidarcldtmp(npoints,40,5) ! 3D "lidar" phase cloud fraction as a function of temp - real cldlayerphase(npoints,ncat,nphase) ! "lidar" phase low mid high cloud fraction - -! SR detection threshold - real, parameter :: S_cld_att = 30. ! New threshold for undefine cloud phase detection - - -! -! c ------------------------------------------------------- -! c 0- Initializations -! c ------------------------------------------------------- -! -! Should be modified in future version - xmax=undef-1.0 - -! c ------------------------------------------------------- -! c 1- Lidar scattering ratio : -! c ------------------------------------------------------- - - 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 = undef - end where - x3d(:,ic,:) = x3d_c -! profSR(:,ic,:) = x3d(:,ic,:) !TIBO - profSR(:,:,ic) = x3d(:,ic,:) !TIBO2 - enddo - -! c ------------------------------------------------------- -! c 2- Diagnose cloud fractions (3D, low, middle, high, total) -! c from subgrid-scale lidar scattering ratios : -! c ------------------------------------------------------- - - CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase, & - tmp,x3d,pnorm,pnorm_perp,pplay, S_att,S_cld,S_cld_att,undef,lidarcld, & - cldlayer,lidarcldphase,sub,cldlayerphase,lidarcldtmp) - - CALL COSP_OPAQ(npoints,ncol,llm,ntype,x3d,S_cld,undef,lidarcldtype, & !OPAQ - cldtype,vgrid_z) !OPAQ - -! c ------------------------------------------------------- -! c 3- CFADs -! c ------------------------------------------------------- - if (ok_lidar_cfad) then -! -! c CFADs of subgrid-scale lidar scattering ratios : -! c ------------------------------------------------------- - CALL COSP_CFAD_SR(npoints,ncol,llm,max_bin,undef, & - x3d, & - S_att,S_clr,xmax,cfad2,srbval) - - endif ! ok_lidar_cfad -! c ------------------------------------------------------- - -! c ------------------------------------------------------- -! c 4- Compute grid-box averaged Parasol reflectances -! c ------------------------------------------------------- - - parasolrefl(:,:) = 0.0 - - 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=undef -! if land=0 -> parasolrefl=parasolrefl - parasolrefl(:,k) = parasolrefl(:,k) * MAX(1.0-land(:),0.0) & - + (1.0 - MAX(1.0-land(:),0.0))*undef - enddo - - RETURN - END SUBROUTINE diag_lidar - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------------- FUNCTION COSP_CFAD_SR ------------------------ -! Author: Sandrine Bony (LMD/IPSL, CNRS, Paris) -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE COSP_CFAD_SR(Npoints,Ncolumns,Nlevels,Nbins,undef, & - x,S_att,S_clr,xmax,cfad,srbval) - IMPLICIT NONE - -!--- Input arguments -! Npoints: Number of horizontal points -! Ncolumns: Number of subcolumns -! Nlevels: Number of levels -! Nbins: Number of x axis bins -! xmax: maximum value allowed for x -! S_att: Threshold for full attenuation -! S_clr: Threshold for clear-sky layer -! -!--- Input-Outout arguments -! x: variable to process (Npoints,Ncolumns,Nlevels), mofified where saturation occurs -! -! -- Output arguments -! srbval : values of the histogram bins -! cfad: 2D histogram on each horizontal point - -! Input arguments - integer Npoints,Ncolumns,Nlevels,Nbins - real xmax,S_att,S_clr,undef -! Input-output arguments - real x(Npoints,Ncolumns,Nlevels) -! Output : - real cfad(Npoints,Nbins,Nlevels) - real srbval(Nbins) -! Local variables - integer i, j, k, ib - real srbval_ext(0:Nbins) - -! c ------------------------------------------------------- -! c 0- Initializations -! c ------------------------------------------------------- - if ( Nbins .lt. 6) return - - srbval(1) = S_att - srbval(2) = S_clr - srbval(3) = 3.0 - srbval(4) = 5.0 - srbval(5) = 7.0 - srbval(6) = 10.0 - do i = 7, MIN(10,Nbins) - srbval(i) = srbval(i-1) + 5.0 - enddo - DO i = 11, MIN(13,Nbins) - srbval(i) = srbval(i-1) + 10.0 - enddo - srbval(MIN(14,Nbins)) = 80.0 - srbval(Nbins) = xmax - cfad(:,:,:) = 0.0 - - srbval_ext(1:Nbins) = srbval - srbval_ext(0) = -1.0 -! c ------------------------------------------------------- -! c c- Compute CFAD -! c ------------------------------------------------------- - do j = 1, Nlevels - do ib = 1, Nbins - do k = 1, Ncolumns - do i = 1, Npoints - if (x(i,k,j) /= undef) then - if ((x(i,k,j).gt.srbval_ext(ib-1)).and.(x(i,k,j).le.srbval_ext(ib))) & - cfad(i,ib,j) = cfad(i,ib,j) + 1.0 - else - cfad(i,ib,j) = undef - endif - enddo - enddo - enddo - enddo - - where (cfad .ne. undef) cfad = cfad / float(Ncolumns) - -! c ------------------------------------------------------- - RETURN - END SUBROUTINE COSP_CFAD_SR - - -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% -!-------------------- SUBROUTINE COSP_CLDFRAC ------------------- -! c Purpose: Cloud fraction diagnosed from lidar measurements -!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% - SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase, & - tmp,x,ATB,ATBperp,pplay,S_att,S_cld,S_cld_att,undef,lidarcld, & - cldlayer,lidarcldphase,nsub,cldlayerphase,lidarcldtemp) - - - IMPLICIT NONE -! Input arguments - integer Npoints,Ncolumns,Nlevels,Ncat - real x(Npoints,Ncolumns,Nlevels) - - -! Local parameters - integer nphase ! nb of cloud layer phase types - ! (ice,liquid,undefined,false ice,false liquid,Percent of ice) - integer,parameter :: Ntemp=40 ! indice of the temperature vector - integer ip, k, iz, ic, ncol, nlev, i, itemp ! loop indice - real S_cld_att ! New threshold for undefine cloud phase detection (SR=30) - integer toplvlsat ! level of the first cloud with SR>30 - real alpha50, beta50, gamma50, delta50, epsilon50, zeta50 ! Polynomial Coef of the phase - ! discrimination line - -! Input variables - real tmp(Npoints,Nlevels) ! temperature - real ATB(Npoints,Ncolumns,Nlevels) ! 3D Attenuated backscatter - real ATBperp(Npoints,Ncolumns,Nlevels) ! 3D perpendicular attenuated backscatter - real pplay(Npoints,Nlevels) - real S_att,S_cld - real undef - -! Output variables - real lidarcldtemp(Npoints,Ntemp,5) ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq - real tempmod(Ntemp+1) ! temperature bins - real lidarcldphase(Npoints,Nlevels,Nphase) ! 3D cloud phase fraction - real cldlayerphase(Npoints,Ncat,Nphase) ! low, middle, high, total cloud fractions for ice liquid and undefine phase - real lidarcld(Npoints,Nlevels) ! 3D cloud fraction - real cldlayer(Npoints,Ncat) ! low, middle, high, total cloud fractions - -! Local variables - real tmpi(Npoints,Ncolumns,Nlevels) ! temperature of ice cld - real tmpl(Npoints,Ncolumns,Nlevels) ! temperature of liquid cld - real tmpu(Npoints,Ncolumns,Nlevels) ! temperature of undef cld - - real checktemp, ATBperp_tmp ! temporary variable - real checkcldlayerphase, checkcldlayerphase2 ! temporary variable - real sumlidarcldtemp(Npoints,Ntemp) ! temporary variable - - real cldlayphase(Npoints,Ncolumns,Ncat,Nphase) ! subgrided low mid high phase cloud fraction - real cldlayerphasetmp(Npoints,Ncat) ! temporary variable - real cldlayerphasesum(Npoints,Ncat) ! temporary variable - real lidarcldtempind(Npoints,Ntemp) ! 3D Temperature indice - real lidarcldphasetmp(Npoints,Nlevels) ! 3D sum of ice and liquid cloud occurences - - -! Local variables - real p1 - real cldy(Npoints,Ncolumns,Nlevels) - real srok(Npoints,Ncolumns,Nlevels) - real cldlay(Npoints,Ncolumns,Ncat) - real nsublay(Npoints,Ncolumns,Ncat), nsublayer(Npoints,Ncat) - real nsub(Npoints,Nlevels) - -#ifdef SYS_SX - real cldlay1(Npoints,Ncolumns) - real cldlay2(Npoints,Ncolumns) - real cldlay3(Npoints,Ncolumns) - real nsublay1(Npoints,Ncolumns) - real nsublay2(Npoints,Ncolumns) - real nsublay3(Npoints,Ncolumns) -#endif - - - - -! --------------------------------------------------------------- -! 1- initialization -! --------------------------------------------------------------- - - if ( Ncat .ne. 4 ) then - print *,'Error in lmd_ipsl_stats.cosp_cldfrac, Ncat must be 4, not',Ncat - stop - endif - - lidarcld = 0.0 - nsub = 0.0 - cldlay = 0.0 - nsublay = 0.0 - - ATBperp_tmp = 0. - lidarcldphase(:,:,:) = 0. - cldlayphase(:,:,:,:) = 0. - cldlayerphase(:,:,:) = 0. - tmpi(:,:,:) = 0. - tmpl(:,:,:) = 0. - tmpu(:,:,:) = 0. - cldlayerphasesum(:,:) = 0. - lidarcldtemp(:,:,:) = 0. - lidarcldtempind(:,:) = 0. - sumlidarcldtemp(:,:) = 0. - toplvlsat=0 - lidarcldphasetmp(:,:) = 0. - -! temperature bins - tempmod=(/-273.15,-90.,-87.,-84.,-81.,-78.,-75.,-72.,-69.,-66.,-63.,-60.,-57., & - -54.,-51.,-48.,-45.,-42.,-39.,-36.,-33.,-30.,-27.,-24.,-21.,-18., & - -15.,-12.,-9.,-6.,-3.,0.,3.,6.,9.,12.,15.,18.,21.,24.,200. /) - -! convert C to K - tempmod=tempmod+273.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 - alpha50 = 9.0322e+15 - beta50 = -2.1358e+12 - gamma50 = 173.3963e06 - delta50 = -3.9514e03 - epsilon50 = 0.2559 - zeta50 = -9.4776e-07 - - -! --------------------------------------------------------------- -! 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.0 - elsewhere - cldy(:,:,k)=0.0 - endwhere - -! number of usefull sub-columns: - where ( (x(:,:,k).gt.S_att) .and. (x(:,:,k).ne. undef) ) - srok(:,:,k)=1.0 - elsewhere - srok(:,:,k)=0.0 - endwhere - - enddo ! k - - -! --------------------------------------------------------------- -! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure -! categories) : -! --------------------------------------------------------------- - lidarcld = 0.0 - nsub = 0.0 -#ifdef SYS_SX -!! XXX: Use cldlay[1-3] and nsublay[1-3] to avoid bank-conflicts. - cldlay1 = 0.0 - cldlay2 = 0.0 - cldlay3 = 0.0 - cldlay(:,:,4) = 0.0 !! XXX: Ncat == 4 - nsublay1 = 0.0 - nsublay2 = 0.0 - nsublay3 = 0.0 - nsublay(:,:,4) = 0.0 - - do k = Nlevels, 1, -1 - do ic = 1, Ncolumns - do ip = 1, Npoints - - if(srok(ip,ic,k).gt.0.)then - ! Computation of the cloud fraction as a function of the temperature - ! instead of height, for ice,liquid and all clouds - 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. - 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. - endif - enddo - endif - - p1 = pplay(ip,k) - - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds - cldlay3(ip,ic) = MAX(cldlay3(ip,ic), cldy(ip,ic,k)) - nsublay3(ip,ic) = MAX(nsublay3(ip,ic), srok(ip,ic,k)) - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid clouds - cldlay2(ip,ic) = MAX(cldlay2(ip,ic), cldy(ip,ic,k)) - nsublay2(ip,ic) = MAX(nsublay2(ip,ic), srok(ip,ic,k)) - else - cldlay1(ip,ic) = MAX(cldlay1(ip,ic), cldy(ip,ic,k)) - nsublay1(ip,ic) = MAX(nsublay1(ip,ic), srok(ip,ic,k)) - endif - - 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,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k)) - nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k) - enddo - enddo - enddo - cldlay(:,:,1) = cldlay1 - cldlay(:,:,2) = cldlay2 - cldlay(:,:,3) = cldlay3 - nsublay(:,:,1) = nsublay1 - nsublay(:,:,2) = nsublay2 - nsublay(:,:,3) = nsublay3 -#else - cldlay = 0.0 - nsublay = 0.0 - do k = Nlevels, 1, -1 - 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. - 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. - endif - enddo - endif -! - - iz=1 - p1 = pplay(ip,k) - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds - iz=3 - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) 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 -#endif - - -! -- grid-box 3D cloud fraction - - where ( nsub(:,:).gt.0.0 ) - lidarcld(:,:) = lidarcld(:,:)/nsub(:,:) - elsewhere - lidarcld(:,:) = undef - endwhere - -! -- layered cloud fractions - - cldlayer = 0.0 - nsublayer = 0.0 - - 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=Nlevels,18,-1 ! from 19.2km until 8.16km - p1 = pplay(i,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. ! false ice detection ==> added to Liquid - tmpl(i,ncol,nlev)=tmp(i,nlev) - lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1. ! 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.*100.)) then ! high cloud - cldlayphase(i,ncol,3,2) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,2) = 1. - else ! low cloud - cldlayphase(i,ncol,1,2) = 1. - endif - cldlayphase(i,ncol,4,5) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,5) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,5) = 1. - else ! low cloud - cldlayphase(i,ncol,1,5) = 1. - endif - - else - ! ICE with temperature below 273,15°K - lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1. - tmpi(i,ncol,nlev)=tmp(i,nlev) - cldlayphase(i,ncol,4,1) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,1) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,1) = 1. - else ! low cloud - cldlayphase(i,ncol,1,1) = 1. - endif - - endif - -!____________________________________________________________________________________________________ -! -! 4.1.b Liquid: ATBperp below the phase discrimination line -!____________________________________________________________________________________________________ -! - else ! Liquid clouds - ! Liquid with temperature above 231,15°K - if(tmp(i,nlev).gt.231.15)then - lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1. - tmpl(i,ncol,nlev)=tmp(i,nlev) - cldlayphase(i,ncol,4,2) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,2) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,2) = 1. - else ! low cloud - cldlayphase(i,ncol,1,2) = 1. - 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. ! false liquid detection ==> added to ice - lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1. ! keep the information "temperature criterium used" - ! to classify the phase cloud - cldlayphase(i,ncol,4,4) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,4) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,4) = 1. - else ! low cloud - cldlayphase(i,ncol,1,4) = 1. - endif - cldlayphase(i,ncol,4,1) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,1) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,1) = 1. - else ! low cloud - cldlayphase(i,ncol,1,1) = 1. - 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=17,1,-1 ! from 8.16km until 0km - p1 = pplay(i,nlev) - - if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then -! Phase discrimination line : ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 -! + ATB*epsilon50 + zeta50 -! 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. ! false ice ==> liq - tmpl(i,ncol,nlev)=tmp(i,nlev) - lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1. - - cldlayphase(i,ncol,4,2) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,2) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,2) = 1. - else ! low cloud - cldlayphase(i,ncol,1,2) = 1. - endif - - cldlayphase(i,ncol,4,5) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,5) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,5) = 1. - else ! low cloud - cldlayphase(i,ncol,1,5) = 1. - endif - - else - ! ICE with temperature below 273,15°K - lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1. - tmpi(i,ncol,nlev)=tmp(i,nlev) - - cldlayphase(i,ncol,4,1) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,1) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,1) = 1. - else ! low cloud - cldlayphase(i,ncol,1,1) = 1. - 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. - tmpl(i,ncol,nlev)=tmp(i,nlev) - - cldlayphase(i,ncol,4,2) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,2) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,2) = 1. - else ! low cloud - cldlayphase(i,ncol,1,2) = 1. - 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. ! false liq ==> ice - lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1. ! false liq ==> ice - - cldlayphase(i,ncol,4,4) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,4) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,4) = 1. - else ! low cloud - cldlayphase(i,ncol,1,4) = 1. - endif - - cldlayphase(i,ncol,4,1) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,1) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,1) = 1. - else ! low cloud - cldlayphase(i,ncol,1,1) = 1. - 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,1,-1 - p1 = pplay(i,nlev) - if(cldy(i,ncol,nlev).eq.1.)then - lidarcldphase(i,nlev,3)=lidarcldphase(i,nlev,3)+1. - tmpu(i,ncol,nlev)=tmp(i,nlev) - - cldlayphase(i,ncol,4,3) = 1. ! tot cloud - if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud - cldlayphase(i,ncol,3,3) = 1. - else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud - cldlayphase(i,ncol,2,3) = 1. - else ! low cloud - cldlayphase(i,ncol,1,3) = 1. - 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(:,:).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. - 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. - 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. - 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=sum(lidarcldtemp(:,:,2:3),3) - sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3) - -WHERE(sumlidarcldtemp(:,:)>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 -! --------------------------------------------------------------- - -! BEGINNING OF OPAQ CHANGES - ! #################################################################################### - ! SUBROUTINE cosp_opaq - ! Conventions: Ntype must be equal to 3 (opaque cloud, thin cloud, z_opaque) - ! #################################################################################### - SUBROUTINE COSP_OPAQ(Npoints,Ncolumns,Nlevels,Ntype,x,S_cld,undef,lidarcldtype, & - cldtype,vgrid_z) - - IMPLICIT NONE -! Input arguments - integer Npoints,Ncolumns,Nlevels,Ntype - real x(Npoints,Ncolumns,Nlevels) - real S_cld - real undef - real vgrid_z(Nlevels) -! Output : - real lidarcldtype(Npoints,Nlevels,Ntype+1) ! 3D "lidar" OPAQ type + opacity fraction - real cldtype(Npoints,Ntype) ! opaque and thin cloud covers, z_opaque -! Local variables - integer ip, k, iz, ic, zopac - real p1 - real cldy(Npoints,Ncolumns,Nlevels) - real cldyopaq(Npoints,Ncolumns,Nlevels) - real srok(Npoints,Ncolumns,Nlevels) - real srokopaq(Npoints,Ncolumns,Nlevels) - real cldlay(Npoints,Ncolumns,Ntype+1) ! opaque, thin, z_opaque and all cloud cover - real nsublay(Npoints,Ncolumns,Ntype+1) ! opaque, thin, z_opaque and all cloud cover - real nsublayer(Npoints,Ntype) - real nsub(Npoints,Nlevels) - real nsubopaq(Npoints,Nlevels) - real S_att_opaq - real S_att - - ! #################################################################################### - ! 1) Initialize - ! #################################################################################### - cldtype = 0.0 - lidarcldtype = 0.0 - nsub = 0.0 - nsubopaq = 0.0 - cldlay = 0.0 - nsublay = 0.0 - nsublayer = 0.0 - S_att_opaq = 0.06 ! Fully Attenuated threshold, from Guzman et al. 2017, JGR-A - S_att = 0.01 - - ! #################################################################################### - ! 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.0 - elsewhere - cldy(:,:,k)=0.0 - endwhere - ! Fully attenuated layer detection at subgrid-scale: - where ( (x(:,:,k) .gt. 0.0) .and. (x(:,:,k) .lt. S_att_opaq) .and. (x(:,:,k) .ne. undef) ) - cldyopaq(:,:,k)=1.0 - elsewhere - cldyopaq(:,:,k)=0.0 - endwhere - - ! Number of useful sub-column layers: - where ( (x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) ) - srok(:,:,k)=1.0 - elsewhere - srok(:,:,k)=0.0 - endwhere - ! Number of useful sub-columns layers for z_opaque 3D fraction: - where ( (x(:,:,k) .gt. 0.0) .and. (x(:,:,k) .ne. undef) ) - srokopaq(:,:,k)=1.0 - elsewhere - srokopaq(:,:,k)=0.0 - endwhere - enddo - - ! #################################################################################### - ! 3) Grid-box 3D OPAQ product fraction and cloud type cover (opaque/thin) + mean z_opaque - ! #################################################################################### - - do k= Nlevels,1,-1 - do ic = 1, Ncolumns - do ip = 1, Npoints - - cldlay(ip,ic,1) = MAX(cldlay(ip,ic,1),cldyopaq(ip,ic,k)) ! Opaque clouds - cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k)) ! All clouds - - 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) .eq. 1.0) .and. (cldlay(ip,ic,1) .eq. 0.0) ) then - cldlay(ip,ic,2) = 1.0 - endif - - ! Filling in 3D and 2D variables - - ! Opaque cloud profiles - if ( cldlay(ip,ic,1) .eq. 1.0 ) then - zopac = 0.0 - do k=2,Nlevels - ! Declaring opaque cloud fraction and z_opaque altitude for 3D and 2D variables - if ( (cldy(ip,ic,k) .eq. 1.0) .and. (zopac .eq. 0.0) ) then - lidarcldtype(ip,k-1,3) = lidarcldtype(ip,k-1,3) + 1.0 - cldlay(ip,ic,3) = vgrid_z(k-1) !z_opaque altitude - nsublay(ip,ic,3) = 1.0 - zopac = 1.0 - endif - if ( cldy(ip,ic,k) .eq. 1.0 ) then - lidarcldtype(ip,k,1) = lidarcldtype(ip,k,1) + 1.0 - endif - enddo - endif - - ! Thin cloud profiles - if ( cldlay(ip,ic,2) .eq. 1.0 ) then - do k=1,Nlevels - ! Declaring thin cloud fraction for 3D variable - if ( cldy(ip,ic,k) .eq. 1.0 ) then - lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1.0 - endif - enddo - endif - - enddo - enddo - - ! 3D cloud types fraction (opaque=1 and thin=2) - where ( nsub(:,:) .gt. 0.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.0 ) - lidarcldtype(:,:,3) = lidarcldtype(:,:,3)/nsubopaq(:,:) - elsewhere - lidarcldtype(:,:,3) = undef - endwhere - ! 3D opacity fraction (=4) !Summing z_opaque fraction from TOA(k=Nlevels) to SFC(k=1) - lidarcldtype(:,Nlevels,4) = lidarcldtype(:,Nlevels,3) - do ip = 1, Npoints - do k = Nlevels-1, 1, -1 - if ( lidarcldtype(ip,k,3) .ne. undef ) then - lidarcldtype(ip,k,4) = lidarcldtype(ip,k+1,4) + lidarcldtype(ip,k,3) - endif - enddo - enddo - where ( nsubopaq(:,:) .eq. 0.0 ) - lidarcldtype(:,:,4) = undef - endwhere - - ! 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 - where (nsublayer(:,:) .gt. 0.0) - cldtype(:,:) = cldtype(:,:)/nsublayer(:,:) - elsewhere - cldtype(:,:) = undef - endwhere - - END SUBROUTINE COSP_OPAQ -! END OF OPAQ CHANGES - - -END MODULE MOD_LMD_IPSL_STATS Index: LMDZ6/trunk/libf/phylmd/cosp/m_mrgrnk.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/m_mrgrnk.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/m_mrgrnk.F90 (revision 3233) @@ -0,0 +1,410 @@ +Module m_mrgrnk +Integer, Parameter :: kdp = selected_real_kind(15) +public :: mrgrnk +private :: kdp +private :: I_mrgrnk, D_mrgrnk +interface mrgrnk + module procedure D_mrgrnk, I_mrgrnk +end interface mrgrnk +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 (kind=kdp), Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT +! __________________________________________________________ + Real (kind=kdp) :: 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 I_mrgrnk (XDONT, IRNGT) +! __________________________________________________________ +! MRGRNK = Merge-sort ranking of an array +! For performance reasons, the first 2 passes are taken +! out of the standard loop, and use dedicated coding. +! __________________________________________________________ +! __________________________________________________________ + Integer, Dimension (:), Intent (In) :: XDONT + Integer, Dimension (:), Intent (Out) :: IRNGT +! __________________________________________________________ + Integer :: XVALA, XVALB +! + Integer, Dimension (SIZE(IRNGT)) :: JWRKT + Integer :: LMTNA, LMTNC, IRNG1, IRNG2 + Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB +! + NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) + Select Case (NVAL) + Case (:0) + Return + Case (1) + IRNGT (1) = 1 + Return + Case Default + Continue + End Select +! +! Fill-in the index array, creating ordered couples +! + Do IIND = 2, NVAL, 2 + If (XDONT(IIND-1) <= XDONT(IIND)) Then + IRNGT (IIND-1) = IIND - 1 + IRNGT (IIND) = IIND + Else + IRNGT (IIND-1) = IIND + IRNGT (IIND) = IIND - 1 + End If + End Do + If (Modulo(NVAL, 2) /= 0) Then + IRNGT (NVAL) = NVAL + End If +! +! We will now have ordered subsets A - B - A - B - ... +! and merge A and B couples into C - C - ... +! + LMTNA = 2 + LMTNC = 4 +! +! First iteration. The length of the ordered subsets goes from 2 to 4 +! + Do + If (NVAL <= 2) Exit +! +! Loop on merges of A and B into C +! + Do IWRKD = 0, NVAL - 1, 4 + If ((IWRKD+4) > NVAL) Then + If ((IWRKD+2) >= NVAL) Exit +! +! 1 2 3 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit +! +! 1 3 2 +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNG2 +! +! 3 1 2 +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + IRNGT (IWRKD+3) = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNG1 + End If + Exit + End If +! +! 1 2 3 4 +! + If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle +! +! 1 3 x x +! + If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+2) = IRNGT (IWRKD+3) + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 1 3 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 1 3 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If +! +! 3 x x x +! + Else + IRNG1 = IRNGT (IWRKD+1) + IRNG2 = IRNGT (IWRKD+2) + IRNGT (IWRKD+1) = IRNGT (IWRKD+3) + If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then + IRNGT (IWRKD+2) = IRNG1 + If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then +! 3 1 2 4 + IRNGT (IWRKD+3) = IRNG2 + Else +! 3 1 4 2 + IRNGT (IWRKD+3) = IRNGT (IWRKD+4) + IRNGT (IWRKD+4) = IRNG2 + End If + Else +! 3 4 1 2 + IRNGT (IWRKD+2) = IRNGT (IWRKD+4) + IRNGT (IWRKD+3) = IRNG1 + IRNGT (IWRKD+4) = IRNG2 + End If + End If + End Do +! +! The Cs become As and Bs +! + LMTNA = 4 + Exit + End Do +! +! Iteration loop. Each time, the length of the ordered subsets +! is doubled. +! + Do + If (LMTNA >= NVAL) Exit + IWRKF = 0 + LMTNC = 2 * LMTNC +! +! Loop on merges of A and B into C +! + Do + IWRK = IWRKF + IWRKD = IWRKF + 1 + JINDA = IWRKF + LMTNA + IWRKF = IWRKF + LMTNC + If (IWRKF >= NVAL) Then + If (JINDA >= NVAL) Exit + IWRKF = NVAL + End If + IINDA = 1 + IINDB = JINDA + 1 +! +! Shortcut for the case when the max of A is smaller +! than the min of B. This line may be activated when the +! initial set is already close to sorted. +! +! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE +! +! One steps in the C subset, that we build in the final rank array +! +! Make a copy of the rank array for the merge iteration +! + JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) +! + XVALA = XDONT (JWRKT(IINDA)) + XVALB = XDONT (IRNGT(IINDB)) +! + Do + IWRK = IWRK + 1 +! +! We still have unprocessed values in both A and B +! + If (XVALA > XVALB) Then + IRNGT (IWRK) = IRNGT (IINDB) + IINDB = IINDB + 1 + If (IINDB > IWRKF) Then +! Only A still with unprocessed values + IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) + Exit + End If + XVALB = XDONT (IRNGT(IINDB)) + Else + IRNGT (IWRK) = JWRKT (IINDA) + IINDA = IINDA + 1 + If (IINDA > LMTNA) Exit! Only B still with unprocessed values + XVALA = XDONT (JWRKT(IINDA)) + End If +! + End Do + End Do +! +! The Cs become As and Bs +! + LMTNA = 2 * LMTNA + End Do +! + Return +! +End Subroutine I_mrgrnk +end module m_mrgrnk Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp.F90 (revision 3233) @@ -0,0 +1,605 @@ +! (c) British Crown Copyright 2008, 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: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +#include "cosp_defs.h" +MODULE MOD_COSP + USE MOD_COSP_TYPES + USE MOD_COSP_SIMULATOR + USE MOD_COSP_MODIS_SIMULATOR + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP --------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!#ifdef RTTOV +!SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) +!#else +SUBROUTINE COSP(overlap,Ncolumns,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) +!#endif + ! Arguments + integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand + integer,intent(in) :: Ncolumns + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_gridbox),intent(inout) :: gbx + type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator +!#ifdef RTTOV +! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV +!#endif + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + + ! Local variables + integer :: Npoints ! Number of gridpoints + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Niter ! Number of calls to cosp_simulator + integer :: i_first,i_last ! First and last gridbox to be processed in each iteration + integer :: i,Ni + integer,dimension(2) :: ix,iy + logical :: reff_zero + real :: maxp,minp + integer,dimension(:),allocatable :: & ! Dimensions nPoints + seed ! It is recommended that the seed is set to a different value for each model + ! gridbox it is called on, as it is possible that the choice of the same + ! seed value every time may introduce some statistical bias in the results, + ! particularly for low values of NCOL. + ! Types used in one iteration + type(cosp_gridbox) :: gbx_it + type(cosp_subgrid) :: sgx_it + type(cosp_vgrid) :: vgrid_it + type(cosp_sgradar) :: sgradar_it + type(cosp_sglidar) :: sglidar_it + type(cosp_isccp) :: isccp_it + type(cosp_modis) :: modis_it + type(cosp_misr) :: misr_it +!#ifdef RTTOV +! type(cosp_rttov) :: rttov_it +!#endif + type(cosp_radarstats) :: stradar_it + type(cosp_lidarstats) :: stlidar_it + +!++++++++++ Dimensions ++++++++++++ + Npoints = gbx%Npoints + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + +!++++++++++ Depth of model layers ++++++++++++ + do i=1,Nlevels-1 + gbx%dlev(:,i) = gbx%zlev_half(:,i+1) - gbx%zlev_half(:,i) + enddo + gbx%dlev(:,Nlevels) = 2.0*(gbx%zlev(:,Nlevels) - gbx%zlev_half(:,Nlevels)) + +!++++++++++ Apply sanity checks to inputs ++++++++++ +! call cosp_check_input('longitude',gbx%longitude,min_val=0.0,max_val=360.0) + call cosp_check_input('longitude',gbx%longitude,min_val=-180.0,max_val=180.0) + call cosp_check_input('latitude',gbx%latitude,min_val=-90.0,max_val=90.0) + call cosp_check_input('dlev',gbx%dlev,min_val=0.0) + call cosp_check_input('p',gbx%p,min_val=0.0) + call cosp_check_input('ph',gbx%ph,min_val=0.0) + call cosp_check_input('T',gbx%T,min_val=0.0) + call cosp_check_input('q',gbx%q,min_val=0.0) + call cosp_check_input('sh',gbx%sh,min_val=0.0) + call cosp_check_input('dtau_s',gbx%dtau_s,min_val=0.0) + call cosp_check_input('dtau_c',gbx%dtau_c,min_val=0.0) + call cosp_check_input('dem_s',gbx%dem_s,min_val=0.0,max_val=1.0) + call cosp_check_input('dem_c',gbx%dem_c,min_val=0.0,max_val=1.0) + ! Point information (Npoints) + call cosp_check_input('land',gbx%land,min_val=0.0,max_val=1.0) + call cosp_check_input('psfc',gbx%psfc,min_val=0.0) + call cosp_check_input('sunlit',gbx%sunlit,min_val=0.0,max_val=1.0) + call cosp_check_input('skt',gbx%skt,min_val=0.0) + ! TOTAL and CONV cloud fraction for SCOPS + call cosp_check_input('tca',gbx%tca,min_val=0.0,max_val=1.0) + call cosp_check_input('cca',gbx%cca,min_val=0.0,max_val=1.0) + ! Precipitation fluxes on model levels + call cosp_check_input('rain_ls',gbx%rain_ls,min_val=0.0) + call cosp_check_input('rain_cv',gbx%rain_cv,min_val=0.0) + call cosp_check_input('snow_ls',gbx%snow_ls,min_val=0.0) + call cosp_check_input('snow_cv',gbx%snow_cv,min_val=0.0) + call cosp_check_input('grpl_ls',gbx%grpl_ls,min_val=0.0) + ! Hydrometeors concentration and distribution parameters + call cosp_check_input('mr_hydro',gbx%mr_hydro,min_val=0.0) + ! Effective radius [m]. (Npoints,Nlevels,Nhydro) + call cosp_check_input('Reff',gbx%Reff,min_val=0.0) + reff_zero=.true. + if (any(gbx%Reff > 1.e-8)) then + reff_zero=.false. + ! reff_zero == .false. + ! and gbx%use_reff == .true. Reff use in radar and lidar + ! and reff_zero == .false. Reff use in lidar and set to 0 for radar + endif + if ((.not. gbx%use_reff) .and. (reff_zero)) then ! No Reff in radar. Default in lidar + gbx%Reff = DEFAULT_LIDAR_REFF + print *, '---------- COSP WARNING ------------' + print *, '' + print *, 'Using default Reff in lidar simulations' + print *, '' + print *, '----------------------------------' + endif + + ! Aerosols concentration and distribution parameters + call cosp_check_input('conc_aero',gbx%conc_aero,min_val=0.0) + ! Checks for CRM mode + if (Ncolumns == 1) then + if (gbx%use_precipitation_fluxes) then + print *, '---------- COSP ERROR ------------' + print *, '' + print *, 'Use of precipitation fluxes not supported in CRM mode (Ncolumns=1)' + print *, '' + print *, '----------------------------------' + stop + endif + if ((maxval(gbx%dtau_c) > 0.0).or.(maxval(gbx%dem_c) > 0.0)) then + print *, '---------- COSP ERROR ------------' + print *, '' + print *, ' dtau_c > 0.0 or dem_c > 0.0. In CRM mode (Ncolumns=1), ' + print *, ' the optical depth (emmisivity) of all clouds must be ' + print *, ' passed through dtau_s (dem_s)' + print *, '' + print *, '----------------------------------' + stop + endif + endif + + ! We base the seed in the decimal part of the surface pressure. + allocate(seed(Npoints)) + seed = int(gbx%psfc) ! This is to avoid division by zero when Npoints = 1 + ! Roj Oct/2008 ... Note: seed value of 0 caused me some problems + I want to + ! randomize for each call to COSP even when Npoints ==1 + minp = minval(gbx%psfc) + maxp = maxval(gbx%psfc) + if (Npoints .gt. 1) seed=int((gbx%psfc-minp)/(maxp-minp)*100000) + 1 + ! Below it's how it was done in the original implementation of the ISCCP simulator. + ! The one above is better for offline data, when you may have packed data + ! that subsamples the decimal fraction of the surface pressure. +! if (Npoints .gt. 1) seed=(gbx%psfc-int(gbx%psfc))*1000000 + + + if (gbx%Npoints_it >= gbx%Npoints) then ! One iteration gbx%Npoints +!#ifdef RTTOV +! call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) +!#else + call cosp_iter(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) +!#endif + else ! Several iterations to save memory + Niter = gbx%Npoints/gbx%Npoints_it ! Integer division + if (Niter*gbx%Npoints_it < gbx%Npoints) Niter = Niter + 1 + do i=1,Niter + i_first = (i-1)*gbx%Npoints_it + 1 + i_last = i_first + gbx%Npoints_it - 1 + i_last = min(i_last,gbx%Npoints) + Ni = i_last - i_first + 1 + if (i == 1) then + ! Allocate types for all but last iteration + call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, & + gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, & + Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & + gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & + gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & + gbx%use_precipitation_fluxes,gbx%use_reff, & + gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & + gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & + gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & + gbx_it) + call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) + call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) + call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) + call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) + call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) + call construct_cosp_modis(cfg, Ni, modis_it) + call construct_cosp_misr(cfg,Ni,misr_it) +!#ifdef RTTOV +! call construct_cosp_rttov(Ni,gbx%nchan,rttov_it) +!#endif + call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) + call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) + elseif (i == Niter) then ! last iteration + call free_cosp_gridbox(gbx_it,.true.) + call free_cosp_subgrid(sgx_it) + call free_cosp_vgrid(vgrid_it) + call free_cosp_sgradar(sgradar_it) + call free_cosp_sglidar(sglidar_it) + call free_cosp_isccp(isccp_it) + call free_cosp_modis(modis_it) + call free_cosp_misr(misr_it) +!#ifdef RTTOV +! call free_cosp_rttov(rttov_it) +!#endif + call free_cosp_radarstats(stradar_it) + call free_cosp_lidarstats(stlidar_it) + ! Allocate types for iterations + call construct_cosp_gridbox(gbx%time,gbx%time_bnds,gbx%radar_freq,gbx%surface_radar,gbx%use_mie_tables, & + gbx%use_gas_abs,gbx%do_ray,gbx%melt_lay,gbx%k2,Ni,Nlevels, & + Ncolumns,N_HYDRO,gbx%Nprmts_max_hydro, & + gbx%Naero,gbx%Nprmts_max_aero,Ni,gbx%lidar_ice_type,gbx%isccp_top_height, & + gbx%isccp_top_height_direction,gbx%isccp_overlap,gbx%isccp_emsfc_lw, & + gbx%use_precipitation_fluxes,gbx%use_reff, & + gbx%plat,gbx%sat,gbx%inst,gbx%nchan,gbx%ZenAng, & + gbx%Ichan(1:gbx%nchan),gbx%surfem(1:gbx%nchan), & + gbx%co2,gbx%ch4,gbx%n2o,gbx%co, & + gbx_it) + ! --- Copy arrays without Npoints as dimension --- + gbx_it%dist_prmts_hydro = gbx%dist_prmts_hydro + gbx_it%dist_type_aero = gbx_it%dist_type_aero + call construct_cosp_vgrid(gbx_it,vgrid%Nlvgrid,vgrid%use_vgrid,vgrid%csat_vgrid,vgrid_it) + call construct_cosp_subgrid(Ni, Ncolumns, Nlevels, sgx_it) + call construct_cosp_sgradar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,sgradar_it) + call construct_cosp_sglidar(cfg,Ni,Ncolumns,Nlevels,N_HYDRO,PARASOL_NREFL,sglidar_it) + call construct_cosp_isccp(cfg,Ni,Ncolumns,Nlevels,isccp_it) + call construct_cosp_modis(cfg,Ni, modis_it) + call construct_cosp_misr(cfg,Ni,misr_it) +!#ifdef RTTOV +! call construct_cosp_rttov(Ni,gbx%nchan,rttov_it) +!#endif + call construct_cosp_radarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,stradar_it) + call construct_cosp_lidarstats(cfg,Ni,Ncolumns,vgrid%Nlvgrid,N_HYDRO,PARASOL_NREFL,stlidar_it) + endif + ! --- Copy sections of arrays with Npoints as dimension --- + ix=(/i_first,i_last/) + iy=(/1,Ni/) + call cosp_gridbox_cpsection(ix,iy,gbx,gbx_it) + ! These serve as initialisation of *_it types + call cosp_subgrid_cpsection(ix,iy,sgx,sgx_it) + if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar,sgradar_it) + if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar,sglidar_it) + if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp,isccp_it) + if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis,modis_it) + if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr,misr_it) +!#ifdef RTTOV +! if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov,rttov_it) +!#endif + if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar,stradar_it) + if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar,stlidar_it) +!#ifdef RTTOV +! call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, & +! sglidar_it,isccp_it,misr_it,modis_it,rttov_it,stradar_it,stlidar_it) +!#else + call cosp_iter(overlap,seed(ix(1):ix(2)),cfg,vgrid_it,gbx_it,sgx_it,sgradar_it, & + sglidar_it,isccp_it,misr_it,modis_it,stradar_it,stlidar_it) +!#endif + ! --- Copy results to output structures --- + ix=(/1,Ni/) + iy=(/i_first,i_last/) + call cosp_subgrid_cpsection(ix,iy,sgx_it,sgx) + if (cfg%Lradar_sim) call cosp_sgradar_cpsection(ix,iy,sgradar_it,sgradar) + if (cfg%Llidar_sim) call cosp_sglidar_cpsection(ix,iy,sglidar_it,sglidar) + if (cfg%Lisccp_sim) call cosp_isccp_cpsection(ix,iy,isccp_it,isccp) + if (cfg%Lmodis_sim) call cosp_modis_cpsection(ix,iy,modis_it,modis) + if (cfg%Lmisr_sim) call cosp_misr_cpsection(ix,iy,misr_it,misr) +!#ifdef RTTOV +! if (cfg%Lrttov_sim) call cosp_rttov_cpsection(ix,iy,rttov_it,rttov) +!#endif + if (cfg%Lradar_sim) call cosp_radarstats_cpsection(ix,iy,stradar_it,stradar) + if (cfg%Llidar_sim) call cosp_lidarstats_cpsection(ix,iy,stlidar_it,stlidar) + enddo + ! Deallocate types + call free_cosp_gridbox(gbx_it,.true.) + call free_cosp_subgrid(sgx_it) + call free_cosp_vgrid(vgrid_it) + call free_cosp_sgradar(sgradar_it) + call free_cosp_sglidar(sglidar_it) + call free_cosp_isccp(isccp_it) + call free_cosp_modis(modis_it) + call free_cosp_misr(misr_it) +!#ifdef RTTOV +! call free_cosp_rttov(rttov_it) +!#endif + call free_cosp_radarstats(stradar_it) + call free_cosp_lidarstats(stlidar_it) + endif + deallocate(seed) + + +END SUBROUTINE COSP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP_ITER ---------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!#ifdef RTTOV +!SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) +!#else +SUBROUTINE COSP_ITER(overlap,seed,cfg,vgrid,gbx,sgx,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) +!#endif + ! Arguments + integer,intent(in) :: overlap ! overlap type in SCOPS: 1=max, 2=rand, 3=max/rand + integer,dimension(:),intent(in) :: seed + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_gridbox),intent(inout) :: gbx + type(cosp_subgrid),intent(inout) :: sgx ! Subgrid info + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator +!#ifdef RTTOV +! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV +!#endif + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + + ! Local variables + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of subcolumns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: i,j,k + integer :: I_HYDRO + real,dimension(:,:),pointer :: column_frac_out ! Array with one column of frac_out + real,dimension(:,:),pointer :: column_prec_out ! Array with one column of prec_frac + integer :: scops_debug=0 ! set to non-zero value to print out inputs for debugging in SCOPS + real,dimension(:, :),allocatable :: cca_scops,ls_p_rate,cv_p_rate, & + tca_scops ! Cloud cover in each model level (HORIZONTAL gridbox fraction) of total cloud. + ! Levels are from TOA to SURFACE. (nPoints, nLev) + real,dimension(:,:),allocatable :: frac_ls,prec_ls,frac_cv,prec_cv ! Cloud/Precipitation fraction in each model level + ! Levels are from SURFACE to TOA + real,dimension(:,:),allocatable :: rho ! (Npoints, Nlevels). Atmospheric density + type(cosp_sghydro) :: sghydro ! Subgrid info for hydrometeors en each iteration + + + !++++++++++ Dimensions ++++++++++++ + Npoints = gbx%Npoints + Ncolumns = gbx%Ncolumns + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + + !++++++++++ Climate/NWP mode ++++++++++ + if (Ncolumns > 1) then + !++++++++++ Subgrid sampling ++++++++++ + ! Allocate arrays before calling SCOPS + allocate(frac_ls(Npoints,Nlevels),frac_cv(Npoints,Nlevels),prec_ls(Npoints,Nlevels),prec_cv(Npoints,Nlevels)) + allocate(tca_scops(Npoints,Nlevels),cca_scops(Npoints,Nlevels), & + ls_p_rate(Npoints,Nlevels),cv_p_rate(Npoints,Nlevels)) + ! Initialize to zero + frac_ls=0.0 + prec_ls=0.0 + frac_cv=0.0 + prec_cv=0.0 + ! Cloud fractions for SCOPS from TOA to SFC + tca_scops = gbx%tca(:,Nlevels:1:-1) + cca_scops = gbx%cca(:,Nlevels:1:-1) + + ! Call to SCOPS + ! strat and conv arrays are passed with levels from TOA to SURFACE. + call scops(Npoints,Nlevels,Ncolumns,seed,tca_scops,cca_scops,overlap,sgx%frac_out,scops_debug) + + ! temporarily use prec_ls/cv to transfer information about precipitation flux into prec_scops + if(gbx%use_precipitation_fluxes) then + ls_p_rate(:,Nlevels:1:-1)=gbx%rain_ls(:,1:Nlevels)+gbx%snow_ls(:,1:Nlevels)+gbx%grpl_ls(:,1:Nlevels) + cv_p_rate(:,Nlevels:1:-1)=gbx%rain_cv(:,1:Nlevels)+gbx%snow_cv(:,1:Nlevels) + else + ls_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_LSRAIN)+ & + gbx%mr_hydro(:,1:Nlevels,I_LSSNOW)+ & + gbx%mr_hydro(:,1:Nlevels,I_LSGRPL) + cv_p_rate(:,Nlevels:1:-1)=gbx%mr_hydro(:,1:Nlevels,I_CVRAIN)+ & + gbx%mr_hydro(:,1:Nlevels,I_CVSNOW) + endif + + call prec_scops(Npoints,Nlevels,Ncolumns,ls_p_rate,cv_p_rate,sgx%frac_out,sgx%prec_frac) + + ! Precipitation fraction + do j=1,Npoints,1 + do k=1,Nlevels,1 + do i=1,Ncolumns,1 + if (sgx%frac_out (j,i,Nlevels+1-k) == I_LSC) frac_ls(j,k)=frac_ls(j,k)+1. + if (sgx%frac_out (j,i,Nlevels+1-k) == I_CVC) frac_cv(j,k)=frac_cv(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 1) prec_ls(j,k)=prec_ls(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 2) prec_cv(j,k)=prec_cv(j,k)+1. + if (sgx%prec_frac(j,i,Nlevels+1-k) .eq. 3) then + prec_cv(j,k)=prec_cv(j,k)+1. + prec_ls(j,k)=prec_ls(j,k)+1. + endif + enddo !i + 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 !k + enddo !j + + ! Levels from SURFACE to TOA. + if (Npoints*Ncolumns*Nlevels < 10000) then + sgx%frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sgx%prec_frac(1:Npoints,:,1:Nlevels) = sgx%prec_frac(1:Npoints,:,Nlevels:1:-1) + else + ! This is done within a loop (unvectorized) over nPoints to save memory + do j=1,Npoints + sgx%frac_out(j,:,1:Nlevels) = sgx%frac_out(j,:,Nlevels:1:-1) + sgx%prec_frac(j,:,1:Nlevels) = sgx%prec_frac(j,:,Nlevels:1:-1) + enddo + endif + + ! Deallocate arrays that will no longer be used + deallocate(tca_scops,cca_scops,ls_p_rate,cv_p_rate) + + ! Populate the subgrid arrays + call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro) + do k=1,Ncolumns + !--------- Mixing ratios for clouds and Reff for Clouds and precip ------- + column_frac_out => sgx%frac_out(:,k,:) + where (column_frac_out == I_LSC) !+++++++++++ LS clouds ++++++++ + sghydro%mr_hydro(:,k,:,I_LSCLIQ) = gbx%mr_hydro(:,:,I_LSCLIQ) + sghydro%mr_hydro(:,k,:,I_LSCICE) = gbx%mr_hydro(:,:,I_LSCICE) + + sghydro%Reff(:,k,:,I_LSCLIQ) = gbx%Reff(:,:,I_LSCLIQ) + sghydro%Reff(:,k,:,I_LSCICE) = gbx%Reff(:,:,I_LSCICE) + + sghydro%Np(:,k,:,I_LSCLIQ) = gbx%Np(:,:,I_LSCLIQ) + sghydro%Np(:,k,:,I_LSCICE) = gbx%Np(:,:,I_LSCICE) + + elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV clouds ++++++++ + sghydro%mr_hydro(:,k,:,I_CVCLIQ) = gbx%mr_hydro(:,:,I_CVCLIQ) + sghydro%mr_hydro(:,k,:,I_CVCICE) = gbx%mr_hydro(:,:,I_CVCICE) + + sghydro%Reff(:,k,:,I_CVCLIQ) = gbx%Reff(:,:,I_CVCLIQ) + sghydro%Reff(:,k,:,I_CVCICE) = gbx%Reff(:,:,I_CVCICE) + + sghydro%Np(:,k,:,I_CVCLIQ) = gbx%Np(:,:,I_CVCLIQ) + sghydro%Np(:,k,:,I_CVCICE) = gbx%Np(:,:,I_CVCICE) + + end where + column_prec_out => sgx%prec_frac(:,k,:) + where ((column_prec_out == 1) .or. (column_prec_out == 3) ) !++++ LS precip ++++ + sghydro%Reff(:,k,:,I_LSRAIN) = gbx%Reff(:,:,I_LSRAIN) + sghydro%Reff(:,k,:,I_LSSNOW) = gbx%Reff(:,:,I_LSSNOW) + sghydro%Reff(:,k,:,I_LSGRPL) = gbx%Reff(:,:,I_LSGRPL) + + sghydro%Np(:,k,:,I_LSRAIN) = gbx%Np(:,:,I_LSRAIN) + sghydro%Np(:,k,:,I_LSSNOW) = gbx%Np(:,:,I_LSSNOW) + sghydro%Np(:,k,:,I_LSGRPL) = gbx%Np(:,:,I_LSGRPL) + elsewhere ((column_prec_out == 2) .or. (column_prec_out == 3)) !++++ CONV precip ++++ + sghydro%Reff(:,k,:,I_CVRAIN) = gbx%Reff(:,:,I_CVRAIN) + sghydro%Reff(:,k,:,I_CVSNOW) = gbx%Reff(:,:,I_CVSNOW) + + sghydro%Np(:,k,:,I_CVRAIN) = gbx%Np(:,:,I_CVRAIN) + sghydro%Np(:,k,:,I_CVSNOW) = gbx%Np(:,:,I_CVSNOW) + end where + !--------- Precip ------- + if (.not. gbx%use_precipitation_fluxes) then + where (column_frac_out == I_LSC) !+++++++++++ LS Precipitation ++++++++ + sghydro%mr_hydro(:,k,:,I_LSRAIN) = gbx%mr_hydro(:,:,I_LSRAIN) + sghydro%mr_hydro(:,k,:,I_LSSNOW) = gbx%mr_hydro(:,:,I_LSSNOW) + sghydro%mr_hydro(:,k,:,I_LSGRPL) = gbx%mr_hydro(:,:,I_LSGRPL) + elsewhere (column_frac_out == I_CVC) !+++++++++++ CONV Precipitation ++++++++ + sghydro%mr_hydro(:,k,:,I_CVRAIN) = gbx%mr_hydro(:,:,I_CVRAIN) + sghydro%mr_hydro(:,k,:,I_CVSNOW) = gbx%mr_hydro(:,:,I_CVSNOW) + end where + endif + enddo + ! convert the mixing ratio and precipitation flux from gridbox mean to the fraction-based values + do k=1,Nlevels + do j=1,Npoints + !--------- Clouds ------- + if (frac_ls(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_LSCLIQ) = sghydro%mr_hydro(j,:,k,I_LSCLIQ)/frac_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSCICE) = sghydro%mr_hydro(j,:,k,I_LSCICE)/frac_ls(j,k) + endif + if (frac_cv(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_CVCLIQ) = sghydro%mr_hydro(j,:,k,I_CVCLIQ)/frac_cv(j,k) + sghydro%mr_hydro(j,:,k,I_CVCICE) = sghydro%mr_hydro(j,:,k,I_CVCICE)/frac_cv(j,k) + endif + !--------- Precip ------- + if (gbx%use_precipitation_fluxes) then + if (prec_ls(j,k) .ne. 0.) then + gbx%rain_ls(j,k) = gbx%rain_ls(j,k)/prec_ls(j,k) + gbx%snow_ls(j,k) = gbx%snow_ls(j,k)/prec_ls(j,k) + gbx%grpl_ls(j,k) = gbx%grpl_ls(j,k)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + gbx%rain_cv(j,k) = gbx%rain_cv(j,k)/prec_cv(j,k) + gbx%snow_cv(j,k) = gbx%snow_cv(j,k)/prec_cv(j,k) + endif + else + if (prec_ls(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_LSRAIN) = sghydro%mr_hydro(j,:,k,I_LSRAIN)/prec_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSSNOW) = sghydro%mr_hydro(j,:,k,I_LSSNOW)/prec_ls(j,k) + sghydro%mr_hydro(j,:,k,I_LSGRPL) = sghydro%mr_hydro(j,:,k,I_LSGRPL)/prec_ls(j,k) + endif + if (prec_cv(j,k) .ne. 0.) then + sghydro%mr_hydro(j,:,k,I_CVRAIN) = sghydro%mr_hydro(j,:,k,I_CVRAIN)/prec_cv(j,k) + sghydro%mr_hydro(j,:,k,I_CVSNOW) = sghydro%mr_hydro(j,:,k,I_CVSNOW)/prec_cv(j,k) + endif + endif + enddo !k + enddo !j + deallocate(frac_ls,prec_ls,frac_cv,prec_cv) + + if (gbx%use_precipitation_fluxes) then + +#ifdef MMF_V3p5_TWO_MOMENT + + write(*,*) 'Precipitation Flux to Mixing Ratio conversion not (yet?) supported ', & + 'for MMF3.5 Two Moment Microphysics' + stop +#else + ! Density + allocate(rho(Npoints,Nlevels)) + I_HYDRO = I_LSRAIN + call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., & + n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & + g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & + gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & + gbx%rain_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) + I_HYDRO = I_LSSNOW + call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., & + n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & + g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & + gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & + gbx%snow_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) + I_HYDRO = I_CVRAIN + call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., & + n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & + g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & + gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & + gbx%rain_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) + I_HYDRO = I_CVSNOW + call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,2., & + n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & + g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & + gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & + gbx%snow_cv,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) + I_HYDRO = I_LSGRPL + call cosp_precip_mxratio(Npoints,Nlevels,Ncolumns,gbx%p,gbx%T,sgx%prec_frac,1., & + n_ax(I_HYDRO),n_bx(I_HYDRO),alpha_x(I_HYDRO),c_x(I_HYDRO),d_x(I_HYDRO), & + g_x(I_HYDRO),a_x(I_HYDRO),b_x(I_HYDRO), & + gamma_1(I_HYDRO),gamma_2(I_HYDRO),gamma_3(I_HYDRO),gamma_4(I_HYDRO), & + gbx%grpl_ls,sghydro%mr_hydro(:,:,:,I_HYDRO),sghydro%Reff(:,:,:,I_HYDRO)) + if(allocated(rho)) deallocate(rho) +#endif + + endif + !++++++++++ CRM mode ++++++++++ + else + call construct_cosp_sghydro(Npoints,Ncolumns,Nlevels,Nhydro,sghydro) + sghydro%mr_hydro(:,1,:,:) = gbx%mr_hydro + sghydro%Reff(:,1,:,:) = gbx%Reff + sghydro%Np(:,1,:,:) = gbx%Np ! added by Roj with Quickbeam V3.0 + + !--------- Clouds ------- + where ((gbx%dtau_s > 0.0)) + sgx%frac_out(:,1,:) = 1 ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) + endwhere + endif ! Ncolumns > 1 + + !++++++++++ Simulator ++++++++++ +!#ifdef RTTOV +! call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) +!#else + call cosp_simulator(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) +!#endif + + ! Deallocate subgrid arrays + call free_cosp_sghydro(sghydro) +END SUBROUTINE COSP_ITER + +END MODULE MOD_COSP Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_constants.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_constants.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_constants.F90 (revision 3233) @@ -0,0 +1,304 @@ +! (c) British Crown Copyright 2008, 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: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! 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 +! +! +! + +#include "cosp_defs.h" +MODULE MOD_COSP_CONSTANTS + IMPLICIT NONE + + character(len=32) :: COSP_VERSION='COSP v1.4' + + ! Indices to address arrays of LS and CONV hydrometeors + integer,parameter :: I_LSCLIQ = 1 + integer,parameter :: I_LSCICE = 2 + integer,parameter :: I_LSRAIN = 3 + integer,parameter :: I_LSSNOW = 4 + integer,parameter :: I_CVCLIQ = 5 + integer,parameter :: I_CVCICE = 6 + integer,parameter :: I_CVRAIN = 7 + integer,parameter :: I_CVSNOW = 8 + integer,parameter :: I_LSGRPL = 9 + + ! Missing value + real,parameter :: R_UNDEF = -1.0E30 + + ! Number of possible output variables + integer,parameter :: N_OUT_LIST = 74 !OPAQ 65+7 !TIBO 72+2 + integer,parameter :: N3D = 11 !TIBO 10+1 + integer,parameter :: N2D = 19 !OPAQ 14+4 !TIBO 18+1 + integer,parameter :: N1D = 43 !OPAQ 40+3 + + ! Value for forward model result from a level that is under the ground + real,parameter :: R_GROUND = -1.0E20 + + ! Stratiform and convective clouds in frac_out + integer, parameter :: I_LSC = 1, & ! Large-scale clouds + I_CVC = 2 ! Convective clouds + + ! Timing of different simulators, including statistics module + integer, parameter :: N_SIMULATORS = 7 + integer,parameter :: I_RADAR = 1 + integer,parameter :: I_LIDAR = 2 + integer,parameter :: I_ISCCP = 3 + integer,parameter :: I_MISR = 4 + integer,parameter :: I_MODIS = 5 + integer,parameter :: I_RTTOV = 6 + integer,parameter :: I_STATS = 7 + character*32, dimension(N_SIMULATORS) :: SIM_NAME = (/'Radar','Lidar','ISCCP','MISR ','MODIS','RTTOV','Stats'/) + integer,dimension(N_SIMULATORS) :: tsim + data tsim/N_SIMULATORS*0.0/ + + !--- Radar constants + ! CFAD constants + integer,parameter :: DBZE_BINS = 15 ! Number of dBZe bins in histogram (cfad) + real,parameter :: DBZE_MIN = -100.0 ! Minimum value for radar reflectivity + real,parameter :: DBZE_MAX = 80.0 ! Maximum value for radar reflectivity + real,parameter :: CFAD_ZE_MIN = -50.0 ! Lower value of the first CFAD Ze bin + real,parameter :: CFAD_ZE_WIDTH = 5.0 ! Bin width (dBZe) + + + !--- Lidar constants + ! CFAD constants + integer,parameter :: SR_BINS = 15 + integer,parameter :: DPOL_BINS = 6 + real,parameter :: LIDAR_UNDEF = 999.999 + + ! Other constants + integer,parameter :: LIDAR_NCAT = 4 + integer,parameter :: LIDAR_NTYPE = 3 !OPAQ + integer,parameter :: PARASOL_NREFL = 5 ! parasol + real,parameter,dimension(PARASOL_NREFL) :: PARASOL_SZA = (/0.0, 20.0, 40.0, 60.0, 80.0/) + real,parameter :: DEFAULT_LIDAR_REFF = 30.0e-6 ! Default lidar effective radius + + integer,parameter :: LIDAR_NTEMP = 40 + real,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,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/)) + + !--- MISR constants + integer,parameter :: MISR_N_CTH = 16 + + !--- RTTOV constants + integer,parameter :: RTTOV_MAX_CHANNELS = 20 + + ! ISCCP tau-Pc axes + real,parameter,dimension(7) :: ISCCP_TAU = (/0.15, 0.80, 2.45, 6.5, 16.2, 41.5, 100.0/) + real,parameter,dimension(2,7) :: ISCCP_TAU_BNDS = reshape(source=(/0.0,0.3,0.3,1.30,1.30,3.6,3.6,9.4, & + 9.4,23.0,23.0,60.0,60.0,100000.0/), shape=(/2,7/)) + + real,parameter,dimension(7) :: ISCCP_PC = (/90000., 74000., 62000., 50000., 37500., 24500., 9000./) + real,parameter,dimension(2,7) :: ISCCP_PC_BNDS = 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,7/)) + + real,parameter,dimension(MISR_N_CTH) :: MISR_CTH = 1000.0*(/ 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,parameter,dimension(2,MISR_N_CTH) :: MISR_CTH_BNDS = 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,MISR_N_CTH/)) + + + ! + ! The following code was modifed by Roj with implementation of quickbeam V3 + ! (1) use ifdef to support more than one microphyscis scheme + ! (2) added constants microphysic_scheme_name, LOAD_scale_LUTs, and SAVE_scale_LUTs + ! + + ! directory where LUTs will be stored + character*120 :: RADAR_SIM_LUT_DIRECTORY = './' + +#ifdef MMF_V3_SINGLE_MOMENT + + ! + ! Table hclass for quickbeam to support one-moment (bulk) microphysics scheme used by MMF V3.0 & V3.5 + ! + + ! + ! NOTE: if ANY value in this section of code is changed, the existing LUT + ! (i.e., the associated *.dat file) MUST be deleted so that a NEW + ! LUT will be created !!! + ! + character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3_single_moment' + + logical :: RADAR_SIM_LOAD_scale_LUTs_flag = .false. + logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false. + integer,parameter :: N_HYDRO = 9 + + integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO) + + real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), & + HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), & + HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO) + + ! HCLASS_CP is not used in the version of Quickbeam included in COSP + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + data HCLASS_TYPE/ 5, 1, 2, 2, 5, 1, 2, 2, 2/ + data HCLASS_PHASE/ 0, 1, 0, 1, 0, 1, 0, 1, 1/ + data HCLASS_DMIN/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + data HCLASS_DMAX/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + data HCLASS_APM/ 524, 110.8, 524, -1, 524, 110.8, 524, -1, -1/ + data HCLASS_BPM/ 3, 2.91, 3, -1, 3, 2.91, 3, -1, -1/ + data HCLASS_RHO/ -1, -1, -1, 100, -1, -1, -1, 100, 400/ + data HCLASS_P1/ -1, -1, 8.e6, 3.e6, -1, -1, 8.e6, 3.e6, 4.e6/ + data HCLASS_P2/ 6, 40, -1, -1, 6, 40, -1, -1, -1/ + data HCLASS_P3/ 0.3, 2, -1, -1, 0.3, 2, -1, -1, -1/ + + ! 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. + ! + + + real,dimension(N_HYDRO) :: N_ax,N_bx,alpha_x,c_x,d_x,g_x,a_x,b_x,gamma_1,gamma_2,gamma_3,gamma_4 + + ! Microphysical settings for the precipitation flux to mixing ratio conversion + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + data N_ax/ -1., -1., 8.e6, 3.e6, -1., -1., 8.e6, 3.e6, 4.e6/ + data N_bx/ -1., -1., 0.0, 0.0, -1., -1., 0.0, 0.0, 0.0/ + data alpha_x/ -1., -1., 0.0, 0.0, -1., -1., 0.0, 0.0, 0.0/ + data c_x/ -1., -1., 842.0, 4.84, -1., -1., 842.0, 4.84, 94.5/ + data d_x/ -1., -1., 0.8, 0.25, -1., -1., 0.8, 0.25, 0.5/ + data g_x/ -1., -1., 0.5, 0.5, -1., -1., 0.5, 0.5, 0.5/ + data a_x/ -1., -1., 524.0, 52.36, -1., -1., 524.0, 52.36, 209.44/ + data b_x/ -1., -1., 3.0, 3.0, -1., -1., 3.0, 3.0, 3.0/ + data gamma_1/ -1., -1., 17.83725, 8.284701, -1., -1., 17.83725, 8.284701, 11.63230/ + data gamma_2/ -1., -1., 6.0, 6.0, -1., -1., 6.0, 6.0, 6.0/ + data gamma_3/ -1., -1., 2.0, 2.0, -1., -1., 2.0, 2.0, 2.0/ + data gamma_4/ -1., -1., 6.0, 6.0, -1., -1., 6.0, 6.0, 6.0/ + + + +#endif + + +#ifdef MMF_V3p5_TWO_MOMENT + + ! + ! Table hclass for quickbeam to support two-moment "morrison" microphysics scheme used by V3.5 (SAM 6.8) + ! + ! This Number concentriation Np in [1/kg] MUST be input to COSP/radar simulator + ! + ! NOTE: Be sure to check that the ice-density (rho) set it this tables matches what you used + ! + + ! + ! NOTE: if ANY value in this section of code is changed, the existing LUT + ! (i.e., the associated *.dat file) MUST be deleted so that a NEW + ! LUT will be created !!! + ! + character*120 :: RADAR_SIM_MICROPHYSICS_SCHEME_NAME = 'MMF_v3.5_two_moment' + + logical :: RADAR_SIM_LOAD_scale_LUTs_flag = .false. + logical :: RADAR_SIM_UPDATE_scale_LUTs_flag = .false. + + integer,parameter :: N_HYDRO = 9 + + integer :: HCLASS_TYPE(N_HYDRO),HCLASS_PHASE(N_HYDRO) + + real :: HCLASS_DMIN(N_HYDRO),HCLASS_DMAX(N_HYDRO), & + HCLASS_APM(N_HYDRO),HCLASS_BPM(N_HYDRO),HCLASS_RHO(N_HYDRO), & + HCLASS_P1(N_HYDRO),HCLASS_P2(N_HYDRO),HCLASS_P3(N_HYDRO) + + ! HCLASS_CP is not used in the version of Quickbeam included in COSP + ! LSL LSI LSR LSS CVL CVI CVR CVS LSG + data HCLASS_TYPE/ 1, 1, 1, 1, 1, 1, 1, 1, 1/ + data HCLASS_PHASE/ 0, 1, 0, 1, 0, 1, 0, 1, 1/ + data HCLASS_DMIN/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + data HCLASS_DMAX/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + data HCLASS_APM/ 524, -1, 524, -1, 524, -1, 524, -1, -1/ + data HCLASS_BPM/ 3, -1, 3, -1, 3, -1, 3, -1, -1/ + data HCLASS_RHO/ -1, 500, -1, 100, -1, 500, -1, 100, 900/ + data HCLASS_P1/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + data HCLASS_P2/ -1, -1, -1, -1, -1, -1, -1, -1, -1/ + data HCLASS_P3/ -2, 1, 1, 1, -2, 1, 1, 1, 1/ + ! Note: value of "-2" for HCLASS_P3 uses martin 1994 parameteriztion of gamma function width with Number concentration +#endif + +END MODULE MOD_COSP_CONSTANTS Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_isccp_simulator.F90 (revision 3233) @@ -0,0 +1,96 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_isccp_simulator.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP_ISCCP_SIMULATOR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ISCCP_SIMULATOR(gbx,sgx,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info + type(cosp_isccp),intent(inout) :: y ! ISCCP simulator output + + ! Local variables + integer :: Nlevels,Npoints + real :: pfull(gbx%Npoints, gbx%Nlevels) + real :: phalf(gbx%Npoints, gbx%Nlevels + 1) + real :: qv(gbx%Npoints, gbx%Nlevels) + real :: cc(gbx%Npoints, gbx%Nlevels) + real :: conv(gbx%Npoints, gbx%Nlevels) + real :: dtau_s(gbx%Npoints, gbx%Nlevels) + real :: dtau_c(gbx%Npoints, gbx%Nlevels) + real :: at(gbx%Npoints, gbx%Nlevels) + real :: dem_s(gbx%Npoints, gbx%Nlevels) + real :: dem_c(gbx%Npoints, gbx%Nlevels) + real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) + integer :: sunlit(gbx%Npoints) + + Nlevels = gbx%Nlevels + Npoints = gbx%Npoints + ! Flip inputs. Levels from TOA to surface + pfull = gbx%p(:,Nlevels:1:-1) + phalf(:,1) = 0.0 ! Top level + phalf(:,2:Nlevels+1) = gbx%ph(:,Nlevels:1:-1) + qv = gbx%sh(:,Nlevels:1:-1) + cc = 0.999999*gbx%tca(:,Nlevels:1:-1) + conv = 0.999999*gbx%cca(:,Nlevels:1:-1) + dtau_s = gbx%dtau_s(:,Nlevels:1:-1) + dtau_c = gbx%dtau_c(:,Nlevels:1:-1) + at = gbx%T(:,Nlevels:1:-1) + dem_s = gbx%dem_s(:,Nlevels:1:-1) + dem_c = gbx%dem_c(:,Nlevels:1:-1) + frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sunlit = int(gbx%sunlit) + call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, & + pfull,phalf,qv,cc,conv,dtau_s,dtau_c, & + gbx%isccp_top_height,gbx%isccp_top_height_direction, & + gbx%isccp_overlap,frac_out, & + gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, & + y%meanptop,y%meantaucld,y%meanalbedocld, & + y%meantb,y%meantbclr,y%boxtau,y%boxptop) + + ! Flip outputs. Levels from surface to TOA + ! --- (npoints,tau=7,pressure=7) + y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1) + + + ! Check if there is any value slightly greater than 1 + where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5)) + y%totalcldarea = 1.0 + endwhere + +END SUBROUTINE COSP_ISCCP_SIMULATOR + +END MODULE MOD_COSP_ISCCP_SIMULATOR Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_lidar.F90 (revision 3233) @@ -0,0 +1,87 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_lidar.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Oct 2008 - S. Bony - Instructions "Call for large-scale cloud" removed -> sgx%frac_out is used instead. +! Call lidar_simulator changed (lsca, gbx%cca and depol removed; +! frac_out changed in sgx%frac_out) +! Jun 2011 - G. Cesana - Added betaperp_tot argument +! +! +MODULE MOD_COSP_LIDAR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_LIDAR ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDAR(gbx,sgx,sghydro,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgrid info + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_sglidar),intent(inout) :: y ! Subgrid output + + ! Local variables + integer :: i + real :: presf(sgx%Npoints, sgx%Nlevels + 1) + real,dimension(sgx%Npoints, sgx%Nlevels) :: lsca,mr_ll,mr_li,mr_cl,mr_ci + real,dimension(sgx%Npoints, sgx%Nlevels) :: beta_tot,tau_tot + real,dimension(sgx%Npoints, sgx%Nlevels) :: betaperp_tot + real,dimension(sgx%Npoints, PARASOL_NREFL) :: refle + + presf(:,1:sgx%Nlevels) = gbx%ph + presf(:,sgx%Nlevels + 1) = 0.0 + lsca = gbx%tca-gbx%cca + do i=1,sgx%Ncolumns + ! Temporary arrays for simulator call + mr_ll(:,:) = sghydro%mr_hydro(:,i,:,I_LSCLIQ) + mr_li(:,:) = sghydro%mr_hydro(:,i,:,I_LSCICE) + mr_cl(:,:) = sghydro%mr_hydro(:,i,:,I_CVCLIQ) + mr_ci(:,:) = sghydro%mr_hydro(:,i,:,I_CVCICE) + call lidar_simulator(sgx%Npoints, sgx%Nlevels, 4, PARASOL_NREFL, LIDAR_UNDEF & + , gbx%p, presf, gbx%T, mr_ll, mr_li, mr_cl, mr_ci & + , gbx%Reff(:,:,I_LSCLIQ), gbx%Reff(:,:,I_LSCICE) & + , gbx%Reff(:,:,I_CVCLIQ), gbx%Reff(:,:,I_CVCICE) & + , gbx%lidar_ice_type, y%beta_mol, beta_tot & + , betaperp_tot, tau_tot, refle ) + + y%betaperp_tot(:,i,:) = betaperp_tot(:,:) + y%beta_tot(:,i,:) = beta_tot(:,:) + y%tau_tot(:,i,:) = tau_tot(:,:) + y%refl(:,i,:) = refle(:,:) + enddo + +END SUBROUTINE COSP_LIDAR + +END MODULE MOD_COSP_LIDAR Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_misr_simulator.F90 (revision 3233) @@ -0,0 +1,80 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_misr_simulator.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Nov 2008 - A. Bodas-Salcedo - Initial version +! +! + +MODULE MOD_COSP_MISR_SIMULATOR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------- SUBROUTINE COSP_MISR_SIMULATOR ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_MISR_SIMULATOR(gbx,sgx,y) + + ! Arguments + type(cosp_gridbox),intent(in) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgridbox info + type(cosp_misr),intent(inout) :: y ! MISR simulator output + + ! Local variables + integer :: Nlevels,Npoints + real :: dtau_s(gbx%Npoints, gbx%Nlevels) + real :: dtau_c(gbx%Npoints, gbx%Nlevels) + real :: at(gbx%Npoints, gbx%Nlevels) + real :: frac_out(gbx%Npoints, gbx%Ncolumns, gbx%Nlevels) + integer :: sunlit(gbx%Npoints) + + real :: zfull(gbx%Npoints, gbx%Nlevels) ! height (in meters) of full model levels (i.e. midpoints) + ! zfull(npoints,1) is top level of model + ! zfull(npoints,nlev) is bottom level of model + + + Nlevels = gbx%Nlevels + Npoints = gbx%Npoints + ! Levels from TOA to surface + zfull = gbx%zlev(:,Nlevels:1:-1) + at = gbx%T(:,Nlevels:1:-1) + dtau_s = gbx%dtau_s(:,Nlevels:1:-1) + dtau_c = gbx%dtau_c(:,Nlevels:1:-1) + frac_out(1:Npoints,:,1:Nlevels) = sgx%frac_out(1:Npoints,:,Nlevels:1:-1) + sunlit = int(gbx%sunlit) + + call MISR_simulator(gbx%npoints,gbx%nlevels,gbx%ncolumns,& + sunlit,zfull,at,dtau_s,dtau_c,frac_out, R_UNDEF, & + y%fq_MISR,y%MISR_dist_model_layertops,y%MISR_meanztop,y%MISR_cldarea) + +END SUBROUTINE COSP_MISR_SIMULATOR + +END MODULE MOD_COSP_MISR_SIMULATOR Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_modis_simulator.F90 (revision 3233) @@ -0,0 +1,487 @@ +! (c) 2009, Regents of the Unversity of Colorado +! Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_modis_simulator.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! + +! +! History: +! May 2009 - Robert Pincus - Initial version +! Dec 2009 - Robert Pincus - Tiny revisions +! +MODULE MOD_COSP_Modis_Simulator + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + use mod_modis_sim, numModisTauBins => numTauHistogramBins, & + numModisPressureBins => numPressureHistogramBins, & + MODIS_TAU => nominalTauHistogramCenters, & + MODIS_TAU_BNDS => nominalTauHistogramBoundaries, & + MODIS_PC => nominalPressureHistogramCenters, & + MODIS_PC_BNDS => nominalPressureHistogramBoundaries + implicit none + !------------------------------------------------------------------------------------------------ + ! Public type + ! + ! Summary statistics from MODIS retrievals + type COSP_MODIS + ! Dimensions + integer :: Npoints ! Number of gridpoints + + ! + ! Grid means; dimension nPoints + ! + real, dimension(:), pointer :: & + 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_LogMean, Optical_Thickness_Water_LogMean, Optical_Thickness_Ice_LogMean, & + Cloud_Particle_Size_Water_Mean, Cloud_Particle_Size_Ice_Mean, & + Cloud_Top_Pressure_Total_Mean, & + Liquid_Water_Path_Mean, Ice_Water_Path_Mean + ! + ! Also need the ISCCP-type optical thickness/cloud top pressure histogram + ! + real, dimension(:, :, :), pointer :: Optical_Thickness_vs_Cloud_Top_Pressure + real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffICE + real, dimension(:, :, :), pointer :: Optical_Thickness_vs_ReffLIQ + end type COSP_MODIS + +contains + !------------------------------------------------------------------------------------------------ + subroutine COSP_Modis_Simulator(gridBox, subCols, subcolHydro, isccpSim, modisSim) + ! Arguments + type(cosp_gridbox), intent(in ) :: gridBox ! Gridbox info + type(cosp_subgrid), intent(in ) :: subCols ! subCol indicators of convective/stratiform + type(cosp_sghydro), intent(in ) :: subcolHydro ! subcol hydrometeor contens + type(cosp_isccp), intent(in ) :: isccpSim ! ISCCP simulator output + type(cosp_modis), intent( out) :: modisSim ! MODIS simulator subcol output + + ! ------------------------------------------------------------ + ! Local variables + ! Leave space only for sunlit points + + integer :: nPoints, nSubCols, nLevels, nSunlit, i, j, k + + ! Grid-mean quanties; dimensions nPoints, nLevels + real, & + dimension(count(gridBox%sunlit(:) > 0), gridBox%nLevels) :: & + temperature, pressureLayers + real, & + dimension(count(gridBox%sunlit(:) > 0), gridBox%nLevels + 1) :: & + pressureLevels + + ! Subcol quantities, dimension nPoints, nSubCols, nLevels + real, & + dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns, gridBox%nLevels) :: & + opticalThickness, cloudWater, cloudIce, waterSize, iceSize + + ! Vertically-integrated subcol quantities; dimensions nPoints, nSubcols + integer, & + dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & + retrievedPhase + real, & + dimension(count(gridBox%sunlit(:) > 0), subCols%nColumns) :: & + isccpTau, isccpCloudTopPressure, retrievedCloudTopPressure, retrievedTau, retrievedSize + + ! Vertically-integrated results + real, dimension(count(gridBox%sunlit(:) > 0)) :: & + cfTotal, cfLiquid, cfIce, & + cfHigh, cfMid, cfLow, & + meanTauTotal, meanTauLiquid, meanTauIce, & + meanLogTauTotal, meanLogTauLiquid, meanLogTauIce , & + meanSizeLiquid, meanSizeIce, & + meanCloudTopPressure, & + meanLiquidWaterPath, meanIceWaterPath + + real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numModisPressureBins) :: & + jointHistogram + real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffIceBins) :: & + jointHistogram2 + real, dimension(count(gridBox%sunlit(:) > 0), numModisTauBins, numMODISReffLiqBins) :: & + jointHistogram3 + + integer, dimension(count(gridBox%sunlit(:) > 0)) :: sunlit + integer, dimension(count(gridBox%sunlit(:) <= 0)) :: notSunlit + ! ------------------------------------------------------------ + + ! + ! Are there any sunlit points? + ! + nSunlit = count(gridBox%sunlit(:) > 0) + if(nSunlit > 0) then + nLevels = gridBox%Nlevels + nPoints = gridBox%Npoints + nSubCols = subCols%Ncolumns + ! + ! This is a vector index indicating which points are sunlit + ! + sunlit(:) = pack((/ (i, i = 1, nPoints ) /), mask = gridBox%sunlit(:) > 0) + notSunlit(:) = pack((/ (i, i = 1, nPoints ) /), mask = .not. gridBox%sunlit(:) > 0) + + ! + ! Copy needed quantities, reversing vertical order and removing points with no sunlight + ! + pressureLevels(:, 1) = 0.0 ! Top of model, following ISCCP sim + temperature(:, :) = gridBox%T (sunlit(:), nLevels:1:-1) + pressureLayers(:, :) = gridBox%p (sunlit(:), nLevels:1:-1) + pressureLevels(:, 2:) = gridBox%ph(sunlit(:), nLevels:1:-1) + + ! + ! Subcolumn properties - first stratiform cloud... + ! + where(subCols%frac_out(sunlit(:), :, :) == I_LSC) + !opticalThickness(:, :, :) = & + ! spread(gridBox%dtau_s (sunlit(:), :), dim = 2, nCopies = nSubCols) + cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCLIQ) + waterSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_LSCLIQ) + cloudIce (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_LSCICE) + iceSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_LSCICE) + elsewhere + opticalThickness(:, :, :) = 0. + cloudWater (:, :, :) = 0. + cloudIce (:, :, :) = 0. + waterSize (:, :, :) = 0. + iceSize (:, :, :) = 0. + end where + + ! Loop version of spread above - intrinsic doesn't work on certain platforms. + do k = 1, nLevels + do j = 1, nSubCols + do i = 1, nSunlit + if(subCols%frac_out(sunlit(i), j, k) == I_LSC) then + opticalThickness(i, j, k) = gridBox%dtau_s(sunlit(i), k) + else + opticalThickness(i, j, k) = 0. + end if + end do + end do + end do + + ! + ! .. then add convective cloud... + ! + where(subCols%frac_out(sunlit(:), :, :) == I_CVC) + !opticalThickness(:, :, :) = & + ! spread(gridBox%dtau_c( sunlit(:), :), dim = 2, nCopies = nSubCols) + cloudWater(:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCLIQ) + waterSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_CVCLIQ) + cloudIce (:, :, :) = subcolHydro%mr_hydro(sunlit(:), :, :, I_CVCICE) + iceSize (:, :, :) = subcolHydro%reff (sunlit(:), :, :, I_CVCICE) + end where + + ! Loop version of spread above - intrinsic doesn't work on certain platforms. + do k = 1, nLevels + do j = 1, nSubCols + do i = 1, nSunlit + if(subCols%frac_out(sunlit(i), j, k) == I_CVC) opticalThickness(i, j, k) = gridBox%dtau_c(sunlit(i), k) + end do + end do + end do + + ! + ! Reverse vertical order + ! + opticalThickness(:, :, :) = opticalThickness(:, :, nLevels:1:-1) + cloudWater (:, :, :) = cloudWater (:, :, nLevels:1:-1) + waterSize (:, :, :) = waterSize (:, :, nLevels:1:-1) + cloudIce (:, :, :) = cloudIce (:, :, nLevels:1:-1) + iceSize (:, :, :) = iceSize (:, :, nLevels:1:-1) + + isccpTau(:, :) = isccpSim%boxtau (sunlit(:), :) + isccpCloudTopPressure(:, :) = isccpSim%boxptop(sunlit(:), :) + + do i = 1, nSunlit + call modis_L2_simulator(temperature(i, :), pressureLayers(i, :), pressureLevels(i, :), & + opticalThickness(i, :, :), cloudWater(i, :, :), cloudIce(i, :, :), & + waterSize(i, :, :), iceSize(i, :, :), & + isccpTau(i, :), isccpCloudTopPressure(i, :), & + retrievedPhase(i, :), retrievedCloudTopPressure(i, :), & + retrievedTau(i, :), retrievedSize(i, :)) + end do + + ! DJS2015: Call L3 modis simulator used by cospv2.0 + ! call modis_L3_simulator(retrievedPhase, & + ! retrievedCloudTopPressure, & + ! retrievedTau, retrievedSize, & + ! cfTotal, cfLiquid, cfIce, & + ! cfHigh, cfMid, cfLow, & + ! meanTauTotal, meanTauLiquid, meanTauIce, & + ! meanLogTauTotal, meanLogTauLiquid, meanLogTauIce, & + ! meanSizeLiquid, meanSizeIce, & + ! meanCloudTopPressure, & + ! meanLiquidWaterPath, meanIceWaterPath, & + ! jointHistogram) + call modis_column(nSunlit,nSubcols,retrievedPhase,retrievedCloudTopPressure, & + retrievedTau,retrievedSize,cfTotal,cfLiquid,cfIce,cfHigh, & + cfMid,cfLow,meanTauTotal,meanTauLiquid,meanTauIce, & + meanLogTauTotal,meanLogTauLiquid,meanLogTauIce, & + meanSizeLiquid,meanSizeIce,meanCloudTopPressure, & + meanLiquidWaterPath, meanIceWaterPath, & + jointHistogram,jointHistogram2,jointHistogram3) + ! DJS2015: END + + ! + ! Copy results into COSP structure + ! + modisSim%Cloud_Fraction_Total_Mean(sunlit(:)) = cfTotal(:) + modisSim%Cloud_Fraction_Water_Mean(sunlit(:)) = cfLiquid + modisSim%Cloud_Fraction_Ice_Mean (sunlit(:)) = cfIce + + modisSim%Cloud_Fraction_High_Mean(sunlit(:)) = cfHigh + modisSim%Cloud_Fraction_Mid_Mean (sunlit(:)) = cfMid + modisSim%Cloud_Fraction_Low_Mean (sunlit(:)) = cfLow + + modisSim%Optical_Thickness_Total_Mean(sunlit(:)) = meanTauTotal + modisSim%Optical_Thickness_Water_Mean(sunlit(:)) = meanTauLiquid + modisSim%Optical_Thickness_Ice_Mean (sunlit(:)) = meanTauIce + + modisSim%Optical_Thickness_Total_LogMean(sunlit(:)) = meanLogTauTotal + modisSim%Optical_Thickness_Water_LogMean(sunlit(:)) = meanLogTauLiquid + modisSim%Optical_Thickness_Ice_LogMean (sunlit(:)) = meanLogTauIce + + modisSim%Cloud_Particle_Size_Water_Mean(sunlit(:)) = meanSizeLiquid + modisSim%Cloud_Particle_Size_Ice_Mean (sunlit(:)) = meanSizeIce + + modisSim%Cloud_Top_Pressure_Total_Mean(sunlit(:)) = meanCloudTopPressure + + modisSim%Liquid_Water_Path_Mean(sunlit(:)) = meanLiquidWaterPath + modisSim%Ice_Water_Path_Mean (sunlit(:)) = meanIceWaterPath + + modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(sunlit(:), 2:numModisTauBins+1, :) = jointHistogram(:, :, :) + modisSim%Optical_Thickness_vs_ReffICE(sunlit(:),2:numModisTauBins+1,:) = jointHistogram2(:, :, :) + modisSim%Optical_Thickness_vs_ReffLIQ(sunlit(:),2:numModisTauBins+1,:) = jointHistogram3(:, :, :) + ! + ! Reorder pressure bins in joint histogram to go from surface to TOA + ! + modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:,:,:) = modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, numModisPressureBins:1:-1) + if(nSunlit < nPoints) then + ! + ! Where it's night and we haven't done the retrievals the values are undefined + ! + modisSim%Cloud_Fraction_Total_Mean(notSunlit(:)) = R_UNDEF + modisSim%Cloud_Fraction_Water_Mean(notSunlit(:)) = R_UNDEF + modisSim%Cloud_Fraction_Ice_Mean (notSunlit(:)) = R_UNDEF + + modisSim%Cloud_Fraction_High_Mean(notSunlit(:)) = R_UNDEF + modisSim%Cloud_Fraction_Mid_Mean (notSunlit(:)) = R_UNDEF + modisSim%Cloud_Fraction_Low_Mean (notSunlit(:)) = R_UNDEF + + modisSim%Optical_Thickness_Total_Mean(notSunlit(:)) = R_UNDEF + modisSim%Optical_Thickness_Water_Mean(notSunlit(:)) = R_UNDEF + modisSim%Optical_Thickness_Ice_Mean (notSunlit(:)) = R_UNDEF + + modisSim%Optical_Thickness_Total_LogMean(notSunlit(:)) = R_UNDEF + modisSim%Optical_Thickness_Water_LogMean(notSunlit(:)) = R_UNDEF + modisSim%Optical_Thickness_Ice_LogMean (notSunlit(:)) = R_UNDEF + + modisSim%Cloud_Particle_Size_Water_Mean(notSunlit(:)) = R_UNDEF + modisSim%Cloud_Particle_Size_Ice_Mean (notSunlit(:)) = R_UNDEF + + modisSim%Cloud_Top_Pressure_Total_Mean(notSunlit(:)) = R_UNDEF + + modisSim%Liquid_Water_Path_Mean(notSunlit(:)) = R_UNDEF + modisSim%Ice_Water_Path_Mean (notSunlit(:)) = R_UNDEF + + modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(notSunlit(:), :, :) = R_UNDEF + modisSim%Optical_Thickness_vs_ReffICE(notSunlit(:), :, :) = R_UNDEF + modisSim%Optical_Thickness_vs_ReffLIQ(notSunlit(:), :, :) = R_UNDEF + end if + else + ! + ! It's nightime everywhere - everything is undefined + ! + modisSim%Cloud_Fraction_Total_Mean(:) = R_UNDEF + modisSim%Cloud_Fraction_Water_Mean(:) = R_UNDEF + modisSim%Cloud_Fraction_Ice_Mean (:) = R_UNDEF + + modisSim%Cloud_Fraction_High_Mean(:) = R_UNDEF + modisSim%Cloud_Fraction_Mid_Mean (:) = R_UNDEF + modisSim%Cloud_Fraction_Low_Mean (:) = R_UNDEF + + modisSim%Optical_Thickness_Total_Mean(:) = R_UNDEF + modisSim%Optical_Thickness_Water_Mean(:) = R_UNDEF + modisSim%Optical_Thickness_Ice_Mean (:) = R_UNDEF + + modisSim%Optical_Thickness_Total_LogMean(:) = R_UNDEF + modisSim%Optical_Thickness_Water_LogMean(:) = R_UNDEF + modisSim%Optical_Thickness_Ice_LogMean (:) = R_UNDEF + + modisSim%Cloud_Particle_Size_Water_Mean(:) = R_UNDEF + modisSim%Cloud_Particle_Size_Ice_Mean (:) = R_UNDEF + + modisSim%Cloud_Top_Pressure_Total_Mean(:) = R_UNDEF + + modisSim%Liquid_Water_Path_Mean(:) = R_UNDEF + modisSim%Ice_Water_Path_Mean (:) = R_UNDEF + + modisSim%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF + modisSim%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF + modisSim%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF + end if + + end subroutine COSP_Modis_Simulator + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------- SUBROUTINE CONSTRUCT_COSP_MODIS ------------------ + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_MODIS(cfg, nPoints, x) + type(cosp_config), intent(in) :: cfg ! Configuration options + integer, intent(in) :: Npoints ! Number of sampled points + type(cosp_MODIS), intent(out) :: x + ! + ! Allocate minumum storage if simulator not used + ! + if (cfg%LMODIS_sim) then + x%nPoints = nPoints + else + x%Npoints = 1 + endif + + ! --- Allocate arrays --- + allocate(x%Cloud_Fraction_Total_Mean(x%nPoints)) + allocate(x%Cloud_Fraction_Water_Mean(x%nPoints)) + allocate(x%Cloud_Fraction_Ice_Mean(x%nPoints)) + + allocate(x%Cloud_Fraction_High_Mean(x%nPoints)) + allocate(x%Cloud_Fraction_Mid_Mean(x%nPoints)) + allocate(x%Cloud_Fraction_Low_Mean(x%nPoints)) + + allocate(x%Optical_Thickness_Total_Mean(x%nPoints)) + allocate(x%Optical_Thickness_Water_Mean(x%nPoints)) + allocate(x%Optical_Thickness_Ice_Mean(x%nPoints)) + + allocate(x%Optical_Thickness_Total_LogMean(x%nPoints)) + allocate(x%Optical_Thickness_Water_LogMean(x%nPoints)) + allocate(x%Optical_Thickness_Ice_LogMean(x%nPoints)) + + allocate(x%Cloud_Particle_Size_Water_Mean(x%nPoints)) + allocate(x%Cloud_Particle_Size_Ice_Mean(x%nPoints)) + + allocate(x%Cloud_Top_Pressure_Total_Mean(x%nPoints)) + + allocate(x%Liquid_Water_Path_Mean(x%nPoints)) + allocate(x%Ice_Water_Path_Mean(x%nPoints)) + + allocate(x%Optical_Thickness_vs_Cloud_Top_Pressure(nPoints, numModisTauBins+1, numModisPressureBins)) + allocate(x%Optical_Thickness_vs_ReffICE(nPoints, numModisTauBins+1, numModisReffIceBins)) + allocate(x%Optical_Thickness_vs_ReffLIQ(nPoints, numModisTauBins+1, numModisReffLiqBins)) + x%Optical_Thickness_vs_Cloud_Top_Pressure(:, :, :) = R_UNDEF + x%Optical_Thickness_vs_ReffLIQ(:, :, :) = R_UNDEF + x%Optical_Thickness_vs_ReffICE(:, :, :) = R_UNDEF + + END SUBROUTINE CONSTRUCT_COSP_MODIS + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------- SUBROUTINE FREE_COSP_MODIS ----------------------- + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_MODIS(x) + type(cosp_MODIS),intent(inout) :: x + ! + ! Free space used by cosp_modis variable. + ! + + if(associated(x%Cloud_Fraction_Total_Mean)) deallocate(x%Cloud_Fraction_Total_Mean) + if(associated(x%Cloud_Fraction_Water_Mean)) deallocate(x%Cloud_Fraction_Water_Mean) + if(associated(x%Cloud_Fraction_Ice_Mean )) deallocate(x%Cloud_Fraction_Ice_Mean) + + if(associated(x%Cloud_Fraction_High_Mean)) deallocate(x%Cloud_Fraction_High_Mean) + if(associated(x%Cloud_Fraction_Mid_Mean )) deallocate(x%Cloud_Fraction_Mid_Mean) + if(associated(x%Cloud_Fraction_Low_Mean )) deallocate(x%Cloud_Fraction_Low_Mean) + + if(associated(x%Optical_Thickness_Total_Mean)) deallocate(x%Optical_Thickness_Total_Mean) + if(associated(x%Optical_Thickness_Water_Mean)) deallocate(x%Optical_Thickness_Water_Mean) + if(associated(x%Optical_Thickness_Ice_Mean )) deallocate(x%Optical_Thickness_Ice_Mean) + + if(associated(x%Optical_Thickness_Total_LogMean)) deallocate(x%Optical_Thickness_Total_LogMean) + if(associated(x%Optical_Thickness_Water_LogMean)) deallocate(x%Optical_Thickness_Water_LogMean) + if(associated(x%Optical_Thickness_Ice_LogMean )) deallocate(x%Optical_Thickness_Ice_LogMean) + + if(associated(x%Cloud_Particle_Size_Water_Mean)) deallocate(x%Cloud_Particle_Size_Water_Mean) + if(associated(x%Cloud_Particle_Size_Ice_Mean )) deallocate(x%Cloud_Particle_Size_Ice_Mean) + + if(associated(x%Cloud_Top_Pressure_Total_Mean )) deallocate(x%Cloud_Top_Pressure_Total_Mean ) + + if(associated(x%Liquid_Water_Path_Mean)) deallocate(x%Liquid_Water_Path_Mean ) + if(associated(x%Ice_Water_Path_Mean )) deallocate(x%Ice_Water_Path_Mean ) + + if(associated(x%Optical_Thickness_vs_Cloud_Top_Pressure)) deallocate(x%Optical_Thickness_vs_Cloud_Top_Pressure ) + if(associated(x%Optical_Thickness_vs_ReffIce)) deallocate(x%Optical_Thickness_vs_ReffIce) + if(associated(x%Optical_Thickness_vs_ReffLiq)) deallocate(x%Optical_Thickness_vs_ReffLiq) + END SUBROUTINE FREE_COSP_MODIS + ! ----------------------------------------------------- + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + !------------- SUBROUTINE COSP_MODIS_CPSECTION ----------------- + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_MODIS_CPSECTION(ix, iy, orig, copy) + integer, dimension(2), intent(in) :: ix, iy + type(cosp_modis), intent(in ) :: orig + type(cosp_modis), intent( out) :: copy + ! + ! Copy a set of grid points from one cosp_modis variable to another. + ! Should test to be sure ix and iy refer to the same number of grid points + ! + integer :: orig_start, orig_end, copy_start, copy_end + + orig_start = ix(1); orig_end = ix(2) + copy_start = iy(1); copy_end = iy(2) + + copy%Cloud_Fraction_Total_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Total_Mean(orig_start:orig_end) + copy%Cloud_Fraction_Water_Mean(copy_start:copy_end) = orig%Cloud_Fraction_Water_Mean(orig_start:orig_end) + copy%Cloud_Fraction_Ice_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Ice_Mean (orig_start:orig_end) + + copy%Cloud_Fraction_High_Mean(copy_start:copy_end) = orig%Cloud_Fraction_High_Mean(orig_start:orig_end) + copy%Cloud_Fraction_Mid_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Mid_Mean (orig_start:orig_end) + copy%Cloud_Fraction_Low_Mean (copy_start:copy_end) = orig%Cloud_Fraction_Low_Mean (orig_start:orig_end) + + copy%Optical_Thickness_Total_Mean(copy_start:copy_end) = orig%Optical_Thickness_Total_Mean(orig_start:orig_end) + copy%Optical_Thickness_Water_Mean(copy_start:copy_end) = orig%Optical_Thickness_Water_Mean(orig_start:orig_end) + copy%Optical_Thickness_Ice_Mean (copy_start:copy_end) = orig%Optical_Thickness_Ice_Mean (orig_start:orig_end) + + copy%Optical_Thickness_Total_LogMean(copy_start:copy_end) = & + orig%Optical_Thickness_Total_LogMean(orig_start:orig_end) + copy%Optical_Thickness_Water_LogMean(copy_start:copy_end) = & + orig%Optical_Thickness_Water_LogMean(orig_start:orig_end) + copy%Optical_Thickness_Ice_LogMean (copy_start:copy_end) = & + orig%Optical_Thickness_Ice_LogMean (orig_start:orig_end) + + copy%Cloud_Particle_Size_Water_Mean(copy_start:copy_end) = orig%Cloud_Particle_Size_Water_Mean(orig_start:orig_end) + copy%Cloud_Particle_Size_Ice_Mean (copy_start:copy_end) = orig%Cloud_Particle_Size_Ice_Mean (orig_start:orig_end) + + copy%Cloud_Top_Pressure_Total_Mean(copy_start:copy_end) = orig%Cloud_Top_Pressure_Total_Mean(orig_start:orig_end) + + copy%Liquid_Water_Path_Mean(copy_start:copy_end) = orig%Liquid_Water_Path_Mean(orig_start:orig_end) + copy%Ice_Water_Path_Mean (copy_start:copy_end) = orig%Ice_Water_Path_Mean (orig_start:orig_end) + + copy%Optical_Thickness_vs_Cloud_Top_Pressure(copy_start:copy_end, :, :) = & + orig%Optical_Thickness_vs_Cloud_Top_Pressure(orig_start:orig_end, :, :) + copy%Optical_Thickness_vs_ReffIce(copy_start:copy_end, :, :) = & + orig%Optical_Thickness_vs_ReffIce(orig_start:orig_end, :, :) + copy%Optical_Thickness_vs_ReffLiq(copy_start:copy_end, :, :) = & + orig%Optical_Thickness_vs_ReffLiq(orig_start:orig_end, :, :) + + END SUBROUTINE COSP_MODIS_CPSECTION + ! ----------------------------------------------------- + +END MODULE MOD_COSP_Modis_Simulator Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_radar.F90 (revision 3233) @@ -0,0 +1,193 @@ +! (c) British Crown Copyright 2008, 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: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP_RADAR + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_COSP_UTILS + use radar_simulator_types + use array_lib + use atmos_lib + use format_input + IMPLICIT NONE + + INTERFACE + subroutine radar_simulator(hp,nprof,ngate,undef, & + hgt_matrix,hm_matrix,re_matrix,Np_matrix, & + p_matrix,t_matrix,rh_matrix, & + Ze_non,Ze_ray,g_to_vol,a_to_vol,dBZe, & + g_to_vol_in,g_to_vol_out) + + use m_mrgrnk + use array_lib + use math_lib + use optics_lib + use radar_simulator_types + implicit none + + ! ----- INPUTS ----- + type(class_param) :: hp + + integer, intent(in) :: nprof,ngate + + real undef + real*8, dimension(nprof,ngate), intent(in) :: hgt_matrix, p_matrix, & + t_matrix,rh_matrix + real*8, dimension(hp%nhclass,nprof,ngate), intent(in) :: hm_matrix + real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: re_matrix + real*8, dimension(hp%nhclass,nprof,ngate), intent(inout) :: Np_matrix + + ! ----- OUTPUTS ----- + real*8, dimension(nprof,ngate), intent(out) :: Ze_non,Ze_ray, & + g_to_vol,dBZe,a_to_vol + ! ----- OPTIONAL ----- + real*8, optional, dimension(nprof,ngate) :: & + g_to_vol_in,g_to_vol_out + end subroutine radar_simulator + END INTERFACE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_RADAR ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RADAR(gbx,sgx,sghydro,z) + IMPLICIT NONE + + ! Arguments + type(cosp_gridbox),intent(inout) :: gbx ! Gridbox info + type(cosp_subgrid),intent(in) :: sgx ! Subgrid info + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_sgradar),intent(inout) :: z ! Output from simulator, subgrid + + ! Local variables + integer :: & + nsizes ! num of discrete drop sizes + + real*8, dimension(:,:), allocatable :: & + g_to_vol ! integrated atten due to gases, r>v (dB) + + real*8, dimension(:,:), allocatable :: & + Ze_non, & ! radar reflectivity withOUT attenuation (dBZ) + Ze_ray, & ! Rayleigh reflectivity (dBZ) + h_atten_to_vol, & ! attenuation by hydromets, radar to vol (dB) + g_atten_to_vol, & ! gaseous atteunation, radar to vol (dB) + dBZe, & ! effective radar reflectivity factor (dBZ) + hgt_matrix, & ! height of hydrometeors (km) + t_matrix, & !temperature (k) + p_matrix, & !pressure (hPa) + rh_matrix !relative humidity (%) + + real*8, dimension(:,:,:), allocatable :: & + hm_matrix, & ! hydrometeor mixing ratio (g kg^-1) + re_matrix, & ! effective radius (microns). Optional. 0 ==> use Np_matrix or defaults + Np_matrix ! total number concentration (kg^-1). Optional 0==> use defaults + + integer, parameter :: one = 1 + ! logical :: hgt_reversed + logical :: hgt_descending + integer :: pr,i,j,k,unt,ngate + +! ----- main program settings ------ + + ! Inputs to Quickbeam + allocate(hgt_matrix(gbx%Npoints,gbx%Nlevels),p_matrix(gbx%Npoints,gbx%Nlevels), & + t_matrix(gbx%Npoints,gbx%Nlevels),rh_matrix(gbx%Npoints,gbx%Nlevels)) + allocate(hm_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) + allocate(re_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) + allocate(Np_matrix(gbx%Nhydro,gbx%Npoints,gbx%Nlevels)) + + ! Outputs from Quickbeam + allocate(Ze_non(gbx%Npoints,gbx%Nlevels)) + allocate(Ze_ray(gbx%Npoints,gbx%Nlevels)) + allocate(h_atten_to_vol(gbx%Npoints,gbx%Nlevels)) + allocate(g_atten_to_vol(gbx%Npoints,gbx%Nlevels)) + allocate(dBZe(gbx%Npoints,gbx%Nlevels)) + + ! Optional argument. It is computed and returned in the first call to + ! radar_simulator, and passed as input in the rest + allocate(g_to_vol(gbx%Npoints,gbx%Nlevels)) + + ! Even if there is no unit conversion, they are needed for type conversion + p_matrix = gbx%p/100.0 ! From Pa to hPa + hgt_matrix = gbx%zlev/1000.0 ! From m to km + t_matrix = gbx%T + rh_matrix = gbx%q + re_matrix = 0.0 + + + ! set flag denoting position of radar relative to hgt_matrix orientation + ngate = size(hgt_matrix,2) + + hgt_descending = hgt_matrix(1,1) > hgt_matrix(1,ngate) + + if ( & + (gbx%surface_radar == 1 .and. hgt_descending) .or. & + (gbx%surface_radar == 0 .and. (.not. hgt_descending)) & + ) & + then + gbx%hp%radar_at_layer_one = .false. + else + gbx%hp%radar_at_layer_one = .true. + endif + + ! ----- loop over subcolumns ----- + do pr=1,sgx%Ncolumns + + ! NOTE: + ! atmospheric profiles are the same within the same gridbox + ! only hydrometeor profiles will be different for each subgridbox + + do i=1,gbx%Nhydro + hm_matrix(i,:,:) = sghydro%mr_hydro(:,pr,:,i)*1000.0 ! Units from kg/kg to g/kg + if (gbx%use_reff) then + re_matrix(i,:,:) = sghydro%Reff(:,pr,:,i)*1.e6 ! Units from m to micron + Np_matrix(i,:,:) = sghydro%Np(:,pr,:,i) ! Units [#/kg] + endif + enddo + + ! ----- call radar simulator ----- + if (pr == 1) then ! Compute gaseous attenuation for all profiles + call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, & + hgt_matrix,hm_matrix,re_matrix,Np_matrix, & + p_matrix,t_matrix,rh_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_out=g_to_vol) + else ! Use gaseous atteunuation for pr = 1 + call radar_simulator(gbx%hp,gbx%Npoints,gbx%Nlevels,R_UNDEF, & + hgt_matrix,hm_matrix,re_matrix,Np_matrix, & + p_matrix,t_matrix,rh_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe,g_to_vol_in=g_to_vol) + endif + + ! store caluculated dBZe values for later output/processing + z%Ze_tot(:,pr,:)=dBZe(:,:) + enddo !pr + + deallocate(hgt_matrix,p_matrix,t_matrix,rh_matrix) + deallocate(hm_matrix,re_matrix, & + Ze_non,Ze_ray,h_atten_to_vol,g_atten_to_vol,dBZe) + deallocate(g_to_vol) +END SUBROUTINE COSP_RADAR + +END MODULE MOD_COSP_RADAR Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_simulator.F90 (revision 3233) @@ -0,0 +1,247 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_simulator.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! Jan 2013 - G. Cesana - Add new variables linked to the lidar cloud phase +! + +#include "cosp_defs.h" +MODULE MOD_COSP_SIMULATOR + USE MOD_COSP_CONSTANTS, ONLY: I_RADAR, I_LIDAR, I_ISCCP, I_MISR, I_MODIS, & + I_RTTOV, I_STATS, tsim + USE MOD_COSP_TYPES + USE MOD_COSP_RADAR + USE MOD_COSP_LIDAR + USE MOD_COSP_ISCCP_SIMULATOR + USE MOD_COSP_MODIS_SIMULATOR + USE MOD_COSP_MISR_SIMULATOR +!#ifdef RTTOV +! USE MOD_COSP_RTTOV_SIMULATOR +!#endif + USE MOD_COSP_STATS + IMPLICIT NONE + +CONTAINS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE COSP_SIMULATOR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!#ifdef RTTOV +!SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,rttov,stradar,stlidar) +!#else +SUBROUTINE COSP_SIMULATOR(gbx,sgx,sghydro,cfg,vgrid,sgradar,sglidar,isccp,misr,modis,stradar,stlidar) +!#endif + + ! Arguments + type(cosp_gridbox),intent(inout) :: gbx ! Grid-box inputs + type(cosp_subgrid),intent(in) :: sgx ! Subgrid inputs + type(cosp_sghydro),intent(in) :: sghydro ! Subgrid info for hydrometeors + type(cosp_config),intent(in) :: cfg ! Configuration options + type(cosp_vgrid),intent(in) :: vgrid ! Information on vertical grid of stats + type(cosp_sgradar),intent(inout) :: sgradar ! Output from radar simulator + type(cosp_sglidar),intent(inout) :: sglidar ! Output from lidar simulator + type(cosp_isccp),intent(inout) :: isccp ! Output from ISCCP simulator + type(cosp_misr),intent(inout) :: misr ! Output from MISR simulator + type(cosp_modis),intent(inout) :: modis ! Output from MODIS simulator +!#ifdef RTTOV +! type(cosp_rttov),intent(inout) :: rttov ! Output from RTTOV +!#endif + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics from radar simulator + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics from lidar simulator + ! Local variables + integer :: i,j,k,isim + logical :: inconsistent + ! Timing variables + integer :: t0,t1 + + t0 = 0 + t1 = 0 + + inconsistent=.false. +! do k=1,gbx%Nhydro +! do j=1,gbx%Nlevels +! do i=1,gbx%Npoints +! if ((gbx%mr_hydro(i,j,k)>0.0).and.(gbx%Reff(i,j,k)<=0.0)) inconsistent=.true. +! enddo +! enddo +! enddo +! if (inconsistent) print *, '%%%% COSP_SIMULATOR: inconsistency in mr_hydro and Reff' + + + !+++++++++ Radar model ++++++++++ + isim = I_RADAR + if (cfg%Lradar_sim) then + call system_clock(t0) + call cosp_radar(gbx,sgx,sghydro,sgradar) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ Lidar model ++++++++++ + isim = I_LIDAR + if (cfg%Llidar_sim) then + call system_clock(t0) + call cosp_lidar(gbx,sgx,sghydro,sglidar) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ ISCCP simulator ++++++++++ + isim = I_ISCCP + if (cfg%Lisccp_sim) then + call system_clock(t0) + call cosp_isccp_simulator(gbx,sgx,isccp) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ MISR simulator ++++++++++ + isim = I_MISR + if (cfg%Lmisr_sim) then + call system_clock(t0) + call cosp_misr_simulator(gbx,sgx,misr) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ MODIS simulator ++++++++++ + isim = I_MODIS + if (cfg%Lmodis_sim) then + call system_clock(t0) + call cosp_modis_simulator(gbx,sgx,sghydro,isccp, modis) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++ RTTOV ++++++++++ + isim = I_RTTOV +!#ifdef RTTOV +! if (cfg%Lrttov_sim) then +! call system_clock(t0) +! call cosp_rttov_simulator(gbx,rttov) +! call system_clock(t1) +! tsim(isim) = tsim(isim) + (t1 -t0) +! endif +!#endif + + !+++++++++++ Summary statistics +++++++++++ + isim = I_STATS + if (cfg%Lstats) then + call system_clock(t0) + call cosp_stats(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) + call system_clock(t1) + tsim(isim) = tsim(isim) + (t1 -t0) + endif + + !+++++++++++ Change of units after computation of statistics +++++++++++ + ! This avoids using UDUNITS in CMOR + + ! Cloud fractions from 1 to % +! if (cfg%Lclcalipso) then +! where(stlidar%lidarcld /= R_UNDEF) stlidar%lidarcld = stlidar%lidarcld*100.0 +! endif +! if (cfg%Lcltcalipso.OR.cfg%Lcllcalipso.OR.cfg%Lclmcalipso.OR.cfg%Lclhcalipso) then +! where(stlidar%cldlayer /= R_UNDEF) stlidar%cldlayer = stlidar%cldlayer*100.0 +! endif + if (cfg%Lclcalipso2) then + where(stradar%lidar_only_freq_cloud /= R_UNDEF) stradar%lidar_only_freq_cloud = stradar%lidar_only_freq_cloud*100.0 + endif + + if (cfg%Lcltcalipsoliq.OR.cfg%Lcllcalipsoliq.OR.cfg%Lclmcalipsoliq.OR.cfg%Lclhcalipsoliq.OR. & + cfg%Lcltcalipsoice.OR.cfg%Lcllcalipsoice.OR.cfg%Lclmcalipsoice.OR.cfg%Lclhcalipsoice.OR. & + cfg%Lcltcalipsoun.OR.cfg%Lcllcalipsoun.OR.cfg%Lclmcalipsoun.OR.cfg%Lclhcalipsoun ) then + where(stlidar%cldlayerphase /= R_UNDEF) stlidar%cldlayerphase = stlidar%cldlayerphase*100.0 + endif + if (cfg%Lclcalipsoliq.OR.cfg%Lclcalipsoice.OR.cfg%Lclcalipsoun) then + where(stlidar%lidarcldphase /= R_UNDEF) stlidar%lidarcldphase = stlidar%lidarcldphase*100.0 + endif + if (cfg%Lclcalipsotmp.OR.cfg%Lclcalipsotmpliq.OR.cfg%Lclcalipsotmpice.OR.cfg%Lclcalipsotmpun) then + where(stlidar%lidarcldtmp /= R_UNDEF) stlidar%lidarcldtmp = stlidar%lidarcldtmp*100.0 + endif + + if (cfg%Lcltisccp) then + where(isccp%totalcldarea /= R_UNDEF) isccp%totalcldarea = isccp%totalcldarea*100.0 + endif + if (cfg%Lclisccp) then + where(isccp%fq_isccp /= R_UNDEF) isccp%fq_isccp = isccp%fq_isccp*100.0 + endif + + if (cfg%LclMISR) then + where(misr%fq_MISR /= R_UNDEF) misr%fq_MISR = misr%fq_MISR*100.0 + endif + + if (cfg%Lcltlidarradar) then + where(stradar%radar_lidar_tcc /= R_UNDEF) stradar%radar_lidar_tcc = stradar%radar_lidar_tcc*100.0 + endif + + if (cfg%Lclmodis) then + where(modis%Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) modis%Optical_Thickness_vs_Cloud_Top_Pressure = & + modis%Optical_Thickness_vs_Cloud_Top_Pressure*100.0 + endif + if (cfg%Lcrimodis) then + where(modis%Optical_Thickness_vs_ReffICE /= R_UNDEF) modis%Optical_Thickness_vs_ReffICE = & + modis%Optical_Thickness_vs_ReffICE*100.0 + endif + if (cfg%Lcrlmodis) then + where(modis%Optical_Thickness_vs_ReffLIQ /= R_UNDEF) modis%Optical_Thickness_vs_ReffLIQ = & + modis%Optical_Thickness_vs_ReffLIQ*100.0 + endif + + if (cfg%Lcltmodis) then + where(modis%Cloud_Fraction_Total_Mean /= R_UNDEF) modis%Cloud_Fraction_Total_Mean = modis%Cloud_Fraction_Total_Mean*100.0 + endif + if (cfg%Lclwmodis) then + where(modis%Cloud_Fraction_Water_Mean /= R_UNDEF) modis%Cloud_Fraction_Water_Mean = modis%Cloud_Fraction_Water_Mean*100.0 + endif + if (cfg%Lclimodis) then + where(modis%Cloud_Fraction_Ice_Mean /= R_UNDEF) modis%Cloud_Fraction_Ice_Mean = modis%Cloud_Fraction_Ice_Mean*100.0 + endif + + if (cfg%Lclhmodis) then + where(modis%Cloud_Fraction_High_Mean /= R_UNDEF) modis%Cloud_Fraction_High_Mean = modis%Cloud_Fraction_High_Mean*100.0 + endif + if (cfg%Lclmmodis) then + where(modis%Cloud_Fraction_Mid_Mean /= R_UNDEF) modis%Cloud_Fraction_Mid_Mean = modis%Cloud_Fraction_Mid_Mean*100.0 + endif + if (cfg%Lcllmodis) then + where(modis%Cloud_Fraction_Low_Mean /= R_UNDEF) modis%Cloud_Fraction_Low_Mean = modis%Cloud_Fraction_Low_Mean*100.0 + endif + + ! Change pressure from hPa to Pa. + if (cfg%Lboxptopisccp) then + where(isccp%boxptop /= R_UNDEF) isccp%boxptop = isccp%boxptop*100.0 + endif + if (cfg%Lpctisccp) then + where(isccp%meanptop /= R_UNDEF) isccp%meanptop = isccp%meanptop*100.0 + endif + + +END SUBROUTINE COSP_SIMULATOR + +END MODULE MOD_COSP_SIMULATOR Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_stats.F90 (revision 3233) @@ -0,0 +1,304 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_stats.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! 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 +! +! +#include "cosp_defs.h" +MODULE MOD_COSP_STATS + USE MOD_COSP_CONSTANTS + USE MOD_COSP_TYPES + USE MOD_LLNL_STATS + USE MOD_LMD_IPSL_STATS + IMPLICIT NONE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE COSP_STATS ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_STATS(gbx,sgx,cfg,sgradar,sglidar,vgrid,stradar,stlidar) + + ! Input arguments + type(cosp_gridbox),intent(in) :: gbx + type(cosp_subgrid),intent(in) :: sgx + type(cosp_config),intent(in) :: cfg + type(cosp_sgradar),intent(in) :: sgradar + type(cosp_sglidar),intent(in) :: sglidar + type(cosp_vgrid),intent(in) :: vgrid + ! Output arguments + type(cosp_radarstats),intent(inout) :: stradar ! Summary statistics for radar + type(cosp_lidarstats),intent(inout) :: stlidar ! Summary statistics for lidar + + ! Local variables + integer :: Npoints !# of grid points + integer :: Nlevels !# of levels + integer :: Nhydro !# of hydrometeors + integer :: Ncolumns !# of columns + integer :: Nlr + logical :: ok_lidar_cfad = .false. + real,dimension(:,:,:),allocatable :: Ze_out,betatot_out,betamol_in,betamol_out,ph_in,ph_out + real,dimension(:,:),allocatable :: ph_c,betamol_c + real,dimension(:,:,:),allocatable :: betaperptot_out, temp_in, temp_out + real,dimension(:,:),allocatable :: temp_c + + Npoints = gbx%Npoints + Nlevels = gbx%Nlevels + Nhydro = gbx%Nhydro + Ncolumns = gbx%Ncolumns + Nlr = vgrid%Nlvgrid + + if (cfg%LcfadLidarsr532) ok_lidar_cfad=.true. + + if (vgrid%use_vgrid) then ! Statistics in a different vertical grid + allocate(Ze_out(Npoints,Ncolumns,Nlr),betatot_out(Npoints,Ncolumns,Nlr), & + betamol_in(Npoints,1,Nlevels),betamol_out(Npoints,1,Nlr),betamol_c(Npoints,Nlr), & + ph_in(Npoints,1,Nlevels),ph_out(Npoints,1,Nlr),ph_c(Npoints,Nlr)) + Ze_out = 0.0 + betatot_out = 0.0 + betamol_out= 0.0 + betamol_c = 0.0 + ph_in(:,1,:) = gbx%ph(:,:) + ph_out = 0.0 + ph_c = 0.0 + allocate(betaperptot_out(Npoints,Ncolumns,Nlr),temp_in(Npoints,1,Nlevels),temp_out(Npoints,1,Nlr), & + temp_c(Npoints,Nlr)) + betaperptot_out = 0.0 + temp_in = 0.0 + temp_out = 0.0 + temp_c = 0.0 + + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) then + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sgradar%Ze_tot, & + Nlr,vgrid%zl,vgrid%zu,Ze_out,log_units=.true.) + stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,Ze_out, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + endif + !++++++++++++ Lidar CFAD ++++++++++++++++ + if (cfg%Llidar_sim) then + betamol_in(:,1,:) = sglidar%beta_mol(:,:) + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,betamol_in, & + Nlr,vgrid%zl,vgrid%zu,betamol_out) + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%beta_tot, & + Nlr,vgrid%zl,vgrid%zu,betatot_out) + + temp_in(:,1,:) = gbx%T(:,:) + call cosp_change_vertical_grid(Npoints,Ncolumns,Nlevels,gbx%zlev,gbx%zlev_half,sglidar%betaperp_tot, & + Nlr,vgrid%zl,vgrid%zu,betaperptot_out) + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,temp_in, & + Nlr,vgrid%zl,vgrid%zu,temp_out) + temp_c(:,:) = temp_out(:,1,:) + stlidar%proftemp = temp_c !TIBO + where (stlidar%proftemp < 150.) stlidar%proftemp = R_UNDEF !TIBO + where (stlidar%proftemp > 350.) stlidar%proftemp = R_UNDEF !TIBO + + call cosp_change_vertical_grid(Npoints,1,Nlevels,gbx%zlev,gbx%zlev_half,ph_in, & + Nlr,vgrid%zl,vgrid%zu,ph_out) + ph_c(:,:) = ph_out(:,1,:) + betamol_c(:,:) = betamol_out(:,1,:) + ! Stats from lidar_stat_summary + call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,temp_c,betatot_out,betaperptot_out,betamol_c,sglidar%refl,gbx%land,ph_c & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ + ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ + ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ + ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO + endif + + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + temp_c,betatot_out,betaperptot_out,betamol_c,Ze_out, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + deallocate(temp_in,temp_out,temp_c,betaperptot_out) !TIBO +temp_in + + ! Deallocate arrays at coarse resolution + deallocate(Ze_out,betatot_out,betamol_in,betamol_out,betamol_c,ph_in,ph_out,ph_c) + else ! Statistics in model levels + !++++++++++++ Radar CFAD ++++++++++++++++ + if (cfg%Lradar_sim) stradar%cfad_ze = cosp_cfad(Npoints,Ncolumns,Nlr,DBZE_BINS,sgradar%Ze_tot, & + DBZE_MIN,DBZE_MAX,CFAD_ZE_MIN,CFAD_ZE_WIDTH) + !++++++++++++ Lidar CFAD ++++++++++++++++ + ! Stats from lidar_stat_summary + if (cfg%Llidar_sim) call diag_lidar(Npoints,Ncolumns,Nlr,SR_BINS,PARASOL_NREFL & + ,sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sglidar%refl,gbx%land,gbx%ph & + ,LIDAR_UNDEF,ok_lidar_cfad & + ,stlidar%cfad_sr,stlidar%srbval & + ,LIDAR_NCAT,LIDAR_NTYPE,stlidar%lidarcld,stlidar%lidarcldtype & !OPAQ + ,stlidar%lidarcldphase,stlidar%cldlayer,stlidar%cldtype & !OPAQ + ,stlidar%cldlayerphase,stlidar%lidarcldtmp & !OPAQ + ,stlidar%parasolrefl,vgrid%z,stlidar%profSR) !OPAQ !TIBO + !++++++++++++ Lidar-only cloud amount and lidar&radar total cloud mount ++++++++++++++++ + if (cfg%Lradar_sim.and.cfg%Llidar_sim) call cosp_lidar_only_cloud(Npoints,Ncolumns,Nlr, & + sglidar%temp_tot,sglidar%beta_tot,sglidar%betaperp_tot,sglidar%beta_mol,sgradar%Ze_tot, & + stradar%lidar_only_freq_cloud,stradar%radar_lidar_tcc) + endif + ! Replace undef + where (stlidar%cfad_sr == LIDAR_UNDEF) stlidar%cfad_sr = R_UNDEF + where (stlidar%profSR == LIDAR_UNDEF) stlidar%profSR = R_UNDEF !TIBO + where (stlidar%lidarcld == LIDAR_UNDEF) stlidar%lidarcld = R_UNDEF + where (stlidar%lidarcldtype == LIDAR_UNDEF) stlidar%lidarcldtype = R_UNDEF !OPAQ + where (stlidar%cldlayer == LIDAR_UNDEF) stlidar%cldlayer = R_UNDEF + where (stlidar%cldtype == LIDAR_UNDEF) stlidar%cldtype = R_UNDEF !OPAQ + where (stlidar%parasolrefl == LIDAR_UNDEF) stlidar%parasolrefl = R_UNDEF + where (stlidar%cldlayerphase == LIDAR_UNDEF) stlidar%cldlayerphase = R_UNDEF + where (stlidar%lidarcldphase == LIDAR_UNDEF) stlidar%lidarcldphase = R_UNDEF + where (stlidar%lidarcldtmp == LIDAR_UNDEF) stlidar%lidarcldtmp = R_UNDEF + +END SUBROUTINE COSP_STATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!---------- 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,dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer) + real,dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer) + real,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,dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels [m] + real,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,dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid + + ! Local variables + integer :: i,j,k + logical :: lunits + integer :: l + real :: w ! Weight + real :: dbb, dtb, dbt, dtt ! Distances between edges of both grids + integer :: Nw ! Number of weights + real :: wt ! Sum of weights + real,dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid + real :: 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.0 + + 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.0 ! 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.0**(y(i,j,l)/10.0) + else + yp = 0.0 + 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.0*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 + +END MODULE MOD_COSP_STATS Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_types.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_types.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_types.F90 (revision 3233) @@ -0,0 +1,1676 @@ +! (c) British Crown Copyright 2008, 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: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +MODULE MOD_COSP_TYPES + USE MOD_COSP_CONSTANTS + USE MOD_COSP_UTILS + + use radar_simulator_types, only: class_param, nd, mt_nd, dmax, dmin + + IMPLICIT NONE + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------------- DERIVED TYPES ---------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + + ! Configuration choices (simulators, variables) + TYPE COSP_CONFIG + logical :: Lradar_sim,Llidar_sim,Lisccp_sim,Lmodis_sim,Lmisr_sim,Lrttov_sim,Lstats,Lwrite_output, & + Lalbisccp,Latb532,Lboxptopisccp,Lboxtauisccp,LcfadDbze94, & + LcfadLidarsr532,Lclcalipso2,Lclcalipso,Lclhcalipso,Lclisccp,Lcllcalipso, & + Lclmcalipso,Lcltcalipso,Lcltlidarradar,Lpctisccp,Ldbze94,Ltauisccp,Lcltisccp, & + Ltoffset,LparasolRefl,LclMISR,Lmeantbisccp,Lmeantbclrisccp, & + Lclcalipsoliq,Lclcalipsoice,Lclcalipsoun, & + Lclcalipsotmp,Lclcalipsotmpliq,Lclcalipsotmpice,Lclcalipsotmpun, & + Lcltcalipsoliq,Lcltcalipsoice,Lcltcalipsoun, & + Lclhcalipsoliq,Lclhcalipsoice,Lclhcalipsoun, & + Lclmcalipsoliq,Lclmcalipsoice,Lclmcalipsoun, & + Lcllcalipsoliq,Lcllcalipsoice,Lcllcalipsoun, & + Lfracout,LlidarBetaMol532,Ltbrttov, & + Lcltmodis,Lclwmodis,Lclimodis,Lclhmodis,Lclmmodis,Lcllmodis,Ltautmodis,Ltauwmodis,Ltauimodis,Ltautlogmodis, & + Ltauwlogmodis,Ltauilogmodis,Lreffclwmodis,Lreffclimodis,Lpctmodis,Llwpmodis, & + Liwpmodis,Lclmodis,Lcrimodis,Lcrlmodis,Lclopaquecalipso,Lclthincalipso, & !OPAQ (2) + Lclzopaquecalipso,Lclcalipsoopaque,Lclcalipsothin,Lclcalipsozopaque, & !OPAQ (4) + Lclcalipsoopacity,LprofSR,Lproftemp !OPAQ (1) !TIBO (2) + + character(len=32) :: out_list(N_OUT_LIST) + END TYPE COSP_CONFIG + + ! Outputs from RTTOV + TYPE COSP_RTTOV + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Nchan ! Number of channels + + ! Brightness temperatures (Npoints,Nchan) + real,pointer :: tbs(:,:) + + END TYPE COSP_RTTOV + + ! Outputs from MISR simulator + TYPE COSP_MISR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ntau ! Number of tau intervals + integer :: Nlevels ! Number of cth levels + + ! --- (npoints,ntau,nlevels) + ! the fraction of the model grid box covered by each of the MISR cloud types + real,pointer :: fq_MISR(:,:,:) + + ! --- (npoints) + real,pointer :: MISR_meanztop(:), MISR_cldarea(:) + ! --- (npoints,nlevels) + real,pointer :: MISR_dist_model_layertops(:,:) + END TYPE COSP_MISR + + ! Outputs from ISCCP simulator + TYPE COSP_ISCCP + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + + + ! --- (npoints,tau=7,pressure=7) + ! the fraction of the model grid box covered by each of the 49 ISCCP D level cloud types + real,pointer :: fq_isccp(:,:,:) + + ! --- (npoints) --- + ! The fraction of model grid box columns with cloud somewhere in them. + ! This should equal the sum over all entries of fq_isccp + real,pointer :: totalcldarea(:) + ! mean all-sky 10.5 micron brightness temperature + real,pointer :: meantb(:) + ! mean clear-sky 10.5 micron brightness temperature + real,pointer :: meantbclr(:) + + ! The following three means are averages over the cloudy areas only. If no + ! clouds are in grid box all three quantities should equal zero. + + ! mean cloud top pressure (mb) - linear averaging in cloud top pressure. + real,pointer :: meanptop(:) + ! mean optical thickness linear averaging in albedo performed. + real,pointer :: meantaucld(:) + ! mean cloud albedo. linear averaging in albedo performed + real,pointer :: meanalbedocld(:) + + !--- (npoints,ncol) --- + ! optical thickness in each column + real,pointer :: boxtau(:,:) + ! cloud top pressure (mb) in each column + real,pointer :: boxptop(:,:) + END TYPE COSP_ISCCP + + ! Summary statistics from radar + TYPE COSP_VGRID + logical :: use_vgrid ! Logical flag that indicates change of grid + logical :: csat_vgrid ! Flag for Cloudsat grid + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nlvgrid ! Number of levels of new grid + ! Array with dimensions (Nlvgrid) + real, dimension(:), pointer :: z,zl,zu ! Height and lower and upper boundaries of new levels + ! Array with dimensions (Nlevels) + real, dimension(:), pointer :: mz,mzl,mzu ! Height and lower and upper boundaries of model levels + END TYPE COSP_VGRID + + ! Output data from lidar code + TYPE COSP_SGLIDAR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + integer :: Nrefl ! Number of parasol reflectances + ! Arrays with dimensions (Npoints,Nlevels) + real,dimension(:,:),pointer :: beta_mol ! Molecular backscatter + real,dimension(:,:),pointer :: temp_tot + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: betaperp_tot ! Total backscattered signal + real,dimension(:,:,:),pointer :: beta_tot ! Total backscattered signal + real,dimension(:,:,:),pointer :: tau_tot ! Optical thickness integrated from top to level z + ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) + real,dimension(:,:,:),pointer :: refl ! parasol reflectances + END TYPE COSP_SGLIDAR + + ! Output data from radar code + TYPE COSP_SGRADAR + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + ! output vertical levels: spaceborne radar -> from TOA to SURFACE + ! Arrays with dimensions (Npoints,Nlevels) + real,dimension(:,:),pointer :: att_gas ! 2-way attenuation by gases [dBZ] + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: Ze_tot ! Effective reflectivity factor [dBZ] + + END TYPE COSP_SGRADAR + + + ! Summary statistics from radar + TYPE COSP_RADARSTATS + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nhydro ! Number of hydrometeors + ! Array with dimensions (Npoints,dBZe_bins,Nlevels) + real, dimension(:,:,:), pointer :: cfad_ze ! Ze CFAD + ! Array with dimensions (Npoints) + real,dimension(:),pointer :: radar_lidar_tcc ! Radar&lidar total cloud amount, grid-box scale + ! Arrays with dimensions (Npoints,Nlevels) + real, dimension(:,:),pointer :: lidar_only_freq_cloud + END TYPE COSP_RADARSTATS + + ! Summary statistics from lidar + TYPE COSP_LIDARSTATS + integer :: Npoints ! Number of sampled points + integer :: Ncolumns ! Number of subgrid columns + integer :: Nlevels ! Number of model levels + integer :: Nhydro ! Number of hydrometeors + integer :: Nrefl ! Number of parasol reflectances + + ! Arrays with dimensions (SR_BINS) + real, dimension(:),pointer :: srbval ! SR bins in cfad_sr + ! Arrays with dimensions (Npoints,SR_BINS,Nlevels) + real, dimension(:,:,:),pointer :: cfad_sr ! CFAD of scattering ratio + ! Arrays with dimensions (Npoints,Nlevels) + real, dimension(:,:),pointer :: lidarcld ! 3D "lidar" cloud fraction + real, dimension(:,:),pointer :: proftemp ! Temperature profiles 40 levs !TIBO + ! Arrays with dimensions (Npoints,LIDAR_NCAT) + real, dimension(:,:),pointer :: cldlayer ! low, mid, high-level, total lidar cloud cover + ! Arrays with dimensions (Npoints,LIDAR_NTYPE) !OPAQ + real, dimension(:,:),pointer :: cldtype ! opaque and thin cloud covers, z_opaque !OPAQ + ! Arrays with dimensions (Npoints,Nlevels,Nphase) + real, dimension(:,:,:),pointer :: lidarcldphase ! 3D "lidar" phase cloud fraction + ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1) !OPAQ + real, dimension(:,:,:),pointer :: lidarcldtype ! 3D "lidar" OPAQ type fraction + opacity !OPAQ + ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase) + real, dimension(:,:,:),pointer :: cldlayerphase ! low, mid, high-level lidar phase cloud cover + ! Arrays with dimensions (Npoints,Ntemps,Nphase) + real, dimension(:,:,:),pointer :: lidarcldtmp ! 3D "lidar" phase cloud temperature + ! Arrays with dimensions (Npoints,PARASOL_NREFL) + real, dimension(:,:),pointer :: parasolrefl ! mean parasol reflectance +! ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) !TIBO +! real, dimension(:,:,:),pointer :: profSR ! subcolumns for each day !TIBO + ! Arrays with dimensions (Npoints,Nlevels,Ncolumns) !TIBO2 + real, dimension(:,:,:),pointer :: profSR ! subcolumns for each day !TIBO2 + + END TYPE COSP_LIDARSTATS + + + ! Input data for simulator. Subgrid scale. + ! Input data from SURFACE to TOA + TYPE COSP_SUBGRID + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + + real,dimension(:,:,:),pointer :: prec_frac ! Subgrid precip array. Dimensions (Npoints,Ncolumns,Nlevels) + real,dimension(:,:,:),pointer :: frac_out ! Subgrid cloud array. Dimensions (Npoints,Ncolumns,Nlevels) + END TYPE COSP_SUBGRID + + ! Input data for simulator at Subgrid scale. + ! Used on a reduced number of points + TYPE COSP_SGHYDRO + ! Dimensions + integer :: Npoints ! Number of gridpoints + integer :: Ncolumns ! Number of columns + integer :: Nlevels ! Number of levels + integer :: Nhydro ! Number of hydrometeors + real,dimension(:,:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor + ! (Npoints,Ncolumns,Nlevels,Nhydro) [kg/kg] + real,dimension(:,:,:,:),pointer :: Reff ! Effective Radius of each hydrometeor + ! (Reff==0 means use default size) + ! (Npoints,Ncolumns,Nlevels,Nhydro) [m] + real,dimension(:,:,:,:),pointer :: Np ! Total # concentration each hydrometeor + ! (Optional, ignored if Reff > 0). + ! (Npoints,Ncolumns,Nlevels,Nhydro) [#/kg] + ! Np = Ntot / rho_a = [#/m^3] / [kg/m^3) + ! added by Roj with Quickbeam V3 + END TYPE COSP_SGHYDRO + + ! Input data for simulator. Gridbox scale. + TYPE COSP_GRIDBOX + ! Scalars and dimensions + integer :: Npoints ! Number of gridpoints + integer :: Nlevels ! Number of levels + integer :: Ncolumns ! Number of columns + integer :: Nhydro ! Number of hydrometeors + integer :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions + integer :: Naero ! Number of aerosol species + integer :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions + integer :: Npoints_it ! Max number of gridpoints to be processed in one iteration + + ! Time [days] + double precision :: time + double precision :: time_bnds(2) + + ! Radar ancillary info + real :: radar_freq, & ! Radar frequency [GHz] + k2 ! |K|^2, -1=use frequency dependent default + integer :: surface_radar, & ! surface=1, spaceborne=0 + use_mie_tables, & ! use a precomputed loopup table? yes=1,no=0 + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay ! melting layer model off=0, on=1 + + ! structures used by radar simulator that need to be set only ONCE per radar configuration (e.g. freq, pointing direction) ... added by roj Feb 2008 + type(class_param) :: hp ! structure used by radar simulator to store Ze and N scaling constants and other information + integer :: nsizes ! number of discrete drop sizes (um) used to represent the distribution + + ! Lidar + integer :: lidar_ice_type !ice particle shape hypothesis in lidar calculations + !(ice_type=0 for spheres, ice_type=1 for non spherical particles) + + ! Radar + logical :: use_precipitation_fluxes ! True if precipitation fluxes are input to the algorithm + logical :: use_reff ! True if Reff is to be used by radar (memory not allocated + + + ! Geolocation (Npoints) + real,dimension(:),pointer :: toffset ! Time offset of esch point from the value in time + real,dimension(:),pointer :: longitude ! longitude [degrees East] + real,dimension(:),pointer :: latitude ! latitude [deg North] + ! Gridbox information (Npoints,Nlevels) + real,dimension(:,:),pointer :: zlev ! Height of model levels [m] + real,dimension(:,:),pointer :: zlev_half ! Height at half model levels [m] (Bottom of model layer) + real,dimension(:,:),pointer :: dlev ! Depth of model levels [m] + real,dimension(:,:),pointer :: p ! Pressure at full model levels [Pa] + real,dimension(:,:),pointer :: ph ! Pressure at half model levels [Pa] + real,dimension(:,:),pointer :: T ! Temperature at model levels [K] + real,dimension(:,:),pointer :: q ! Relative humidity to water (%) + real,dimension(:,:),pointer :: sh ! Specific humidity to water [kg/kg] + real,dimension(:,:),pointer :: dtau_s ! mean 0.67 micron optical depth of stratiform + ! clouds in each model level + ! NOTE: this the cloud optical depth of only the + ! cloudy part of the grid box, it is not weighted + ! with the 0 cloud optical depth of the clear + ! part of the grid box + real,dimension(:,:),pointer :: dtau_c ! mean 0.67 micron optical depth of convective + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: dem_s ! 10.5 micron longwave emissivity of stratiform + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: dem_c ! 10.5 micron longwave emissivity of convective + ! clouds in each model level. Same note applies as in dtau_s. + real,dimension(:,:),pointer :: mr_ozone ! Ozone mass mixing ratio [kg/kg] + + ! Point information (Npoints) + real,dimension(:),pointer :: land !Landmask [0 - Ocean, 1 - Land] + real,dimension(:),pointer :: psfc !Surface pressure [Pa] + real,dimension(:),pointer :: sunlit ! (npoints) 1 for day points, 0 for nightime + real,dimension(:),pointer :: skt ! Skin temperature (K) + real,dimension(:),pointer :: u_wind ! eastward wind [m s-1] + real,dimension(:),pointer :: v_wind ! northward wind [m s-1] + + ! TOTAL and CONV cloud fraction for SCOPS + real,dimension(:,:),pointer :: tca ! Total cloud fraction + real,dimension(:,:),pointer :: cca ! Convective cloud fraction + ! Precipitation fluxes on model levels + real,dimension(:,:),pointer :: rain_ls ! large-scale precipitation flux of rain [kg/m2.s] + real,dimension(:,:),pointer :: rain_cv ! convective precipitation flux of rain [kg/m2.s] + real,dimension(:,:),pointer :: snow_ls ! large-scale precipitation flux of snow [kg/m2.s] + real,dimension(:,:),pointer :: snow_cv ! convective precipitation flux of snow [kg/m2.s] + real,dimension(:,:),pointer :: grpl_ls ! large-scale precipitation flux of graupel [kg/m2.s] + ! Hydrometeors concentration and distribution parameters +! real,dimension(:,:,:),pointer :: fr_hydro ! Fraction of the gridbox occupied by each hydrometeor (Npoints,Nlevels,Nhydro) + real,dimension(:,:,:),pointer :: mr_hydro ! Mixing ratio of each hydrometeor (Npoints,Nlevels,Nhydro) [kg/kg] + real,dimension(:,:),pointer :: dist_prmts_hydro !Distributional parameters for hydrometeors (Nprmts_max_hydro,Nhydro) + + ! Effective radius [m]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default + real,dimension(:,:,:),pointer :: Reff + + ! Total Number Concentration [#/kg]. (Npoints,Nlevels,Nhydro) -- OPTIONAL, value of 0 mean use fixed default + real,dimension(:,:,:),pointer :: Np ! added by Roj with Quickbeam V3 + + ! Aerosols concentration and distribution parameters + real,dimension(:,:,:),pointer :: conc_aero ! Aerosol concentration for each species (Npoints,Nlevels,Naero) + integer,dimension(:),pointer :: dist_type_aero ! Particle size distribution type for each aerosol species (Naero) + real,dimension(:,:,:,:),pointer :: dist_prmts_aero ! Distributional parameters for aerosols + ! (Npoints,Nlevels,Nprmts_max_aero,Naero) + ! ISCCP simulator inputs + integer :: isccp_top_height ! 1 = adjust top height using both a computed + ! infrared brightness temperature and the visible + ! optical depth to adjust cloud top pressure. Note + ! that this calculation is most appropriate to compare + ! to ISCCP data during sunlit hours. + ! 2 = do not adjust top height, that is cloud top + ! pressure is the actual cloud top pressure + ! in the model + ! 3 = adjust top height using only the computed + ! infrared brightness temperature. Note that this + ! calculation is most appropriate to compare to ISCCP + ! IR only algortihm (i.e. you can compare to nighttime + ! ISCCP data with this option) + integer :: isccp_top_height_direction ! direction for finding atmosphere pressure level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 1 = find the *lowest* altitude (highest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! 2 = find the *highest* altitude (lowest pressure) level + ! with interpolated temperature equal to the radiance + ! determined cloud-top temperature + ! ONLY APPLICABLE IF top_height EQUALS 1 or 3 + ! 1 = default setting, and matches all versions of + ! ISCCP simulator with versions numbers 3.5.1 and lower + ! 2 = experimental setting + integer :: isccp_overlap ! overlap type (1=max, 2=rand, 3=max/rand) + real :: isccp_emsfc_lw ! 10.5 micron emissivity of surface (fraction) + + ! RTTOV inputs/options + integer :: plat ! satellite platform + integer :: sat ! satellite + integer :: inst ! instrument + integer :: Nchan ! Number of channels to be computed + integer, dimension(:), pointer :: Ichan ! Channel numbers + real, dimension(:), pointer :: Surfem ! Surface emissivity + real :: ZenAng ! Satellite Zenith Angles + real :: co2,ch4,n2o,co ! Mixing ratios of trace gases + + END TYPE COSP_GRIDBOX + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_RTTOV ------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_RTTOV(cfg,Npoints,Nchan,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Nchan ! Number of channels + type(cosp_rttov),intent(out) :: x + ! Local variables + integer :: i,j + + ! Allocate minumum storage if simulator not used + if (cfg%Lrttov_sim) then + i = Npoints + j = Nchan + else + i = 1 + j = 1 + endif + x%Npoints = i + x%Nchan = j + + ! --- Allocate arrays --- + allocate(x%tbs(i, j)) + ! --- Initialise to zero --- + x%tbs = 0.0 + END SUBROUTINE CONSTRUCT_COSP_RTTOV + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_RTTOV ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_RTTOV(x) + type(cosp_rttov),intent(inout) :: x + + ! --- Deallocate arrays --- + deallocate(x%tbs) + END SUBROUTINE FREE_COSP_RTTOV + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_MISR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_MISR(cfg,Npoints,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of gridpoints + type(cosp_misr),intent(out) :: x + ! Local variables + integer :: i,j,k + + + ! Allocate minumum storage if simulator not used + if (cfg%Lmisr_sim) then + i = Npoints + j = 7 + k = MISR_N_CTH + else + i = 1 + j = 1 + k = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ntau = j + x%Nlevels = k + + ! allocate space for MISR simulator outputs ... + allocate(x%fq_MISR(i,j,k), x%MISR_meanztop(i),x%MISR_cldarea(i), x%MISR_dist_model_layertops(i,k)) + x%fq_MISR = 0.0 + x%MISR_meanztop = 0.0 + x%MISR_cldarea = 0.0 + x%MISR_dist_model_layertops = 0.0 + + END SUBROUTINE CONSTRUCT_COSP_MISR +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_MISR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_MISR(x) + type(cosp_misr),intent(inout) :: x + deallocate(x%fq_MISR, x%MISR_meanztop,x%MISR_cldarea, x%MISR_dist_model_layertops) + + END SUBROUTINE FREE_COSP_MISR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_ISCCP ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_ISCCP(cfg,Npoints,Ncolumns,Nlevels,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + type(cosp_isccp),intent(out) :: x + ! Local variables + integer :: i,j,k + + ! Allocate minumum storage if simulator not used + if (cfg%Lisccp_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + else + i = 1 + j = 1 + k = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + + ! --- Allocate arrays --- + allocate(x%fq_isccp(i,7,7), x%totalcldarea(i), & + x%meanptop(i), x%meantaucld(i), & + x%meantb(i), x%meantbclr(i), & + x%boxtau(i,j), x%boxptop(i,j), & + x%meanalbedocld(i)) + ! --- Initialise to zero --- + x%fq_isccp = 0.0 + x%totalcldarea = 0.0 + x%meanptop = 0.0 + x%meantaucld = 0.0 + x%meantb = 0.0 + x%meantbclr = 0.0 + x%boxtau = 0.0 + x%boxptop = 0.0 + x%meanalbedocld= 0.0 + END SUBROUTINE CONSTRUCT_COSP_ISCCP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_ISCCP ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_ISCCP(x) + type(cosp_isccp),intent(inout) :: x + + deallocate(x%fq_isccp, x%totalcldarea, & + x%meanptop, x%meantaucld, x%meantb, x%meantbclr, & + x%boxtau, x%boxptop, x%meanalbedocld) + END SUBROUTINE FREE_COSP_ISCCP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_VGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_VGRID(gbx,Nlvgrid,use_vgrid,cloudsat,x) + type(cosp_gridbox),intent(in) :: gbx ! Gridbox information + integer,intent(in) :: Nlvgrid ! Number of new levels + logical,intent(in) :: use_vgrid! Logical flag that controls the output on a different grid + logical,intent(in) :: cloudsat ! TRUE if a CloudSat like grid (480m) is requested + type(cosp_vgrid),intent(out) :: x + + ! Local variables + integer :: i + real :: zstep + + x%use_vgrid = use_vgrid + x%csat_vgrid = cloudsat + + ! Dimensions + x%Npoints = gbx%Npoints + x%Ncolumns = gbx%Ncolumns + x%Nlevels = gbx%Nlevels + + ! --- Allocate arrays --- + if (use_vgrid) then + x%Nlvgrid = Nlvgrid + else + x%Nlvgrid = gbx%Nlevels + endif + allocate(x%z(x%Nlvgrid),x%zl(x%Nlvgrid),x%zu(x%Nlvgrid)) + allocate(x%mz(x%Nlevels),x%mzl(x%Nlevels),x%mzu(x%Nlevels)) + + ! --- Model vertical levels --- + ! Use height levels of first model gridbox + x%mz = gbx%zlev(1,:) + x%mzl = gbx%zlev_half(1,:) + x%mzu(1:x%Nlevels-1) = gbx%zlev_half(1,2:x%Nlevels) + x%mzu(x%Nlevels) = gbx%zlev(1,x%Nlevels) + (gbx%zlev(1,x%Nlevels) - x%mzl(x%Nlevels)) + + if (use_vgrid) then + ! --- Initialise to zero --- + x%z = 0.0 + x%zl = 0.0 + x%zu = 0.0 + if (cloudsat) then ! --- CloudSat grid requested --- + zstep = 480.0 + else + ! Other grid requested. Constant vertical spacing with top at 20 km + zstep = 20000.0/x%Nlvgrid + endif + do i=1,x%Nlvgrid + x%zl(i) = (i-1)*zstep + x%zu(i) = i*zstep + enddo + x%z = (x%zl + x%zu)/2.0 + else + x%z = x%mz + x%zl = x%mzl + x%zu = x%mzu + endif + + END SUBROUTINE CONSTRUCT_COSP_VGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_VGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_VGRID(x) + type(cosp_vgrid),intent(inout) :: x + + deallocate(x%z, x%zl, x%zu, x%mz, x%mzl, x%mzu) + END SUBROUTINE FREE_COSP_VGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGLIDAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGLIDAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nrefl ! Number of parasol reflectances ! parasol + type(cosp_sglidar),intent(out) :: x + ! Local variables + integer :: i,j,k,l,m + + ! Allocate minumum storage if simulator not used + if (cfg%Llidar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + m = Nrefl + else + i = 1 + j = 1 + k = 1 + l = 1 + m = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + x%Nrefl = m + + ! --- Allocate arrays --- + allocate(x%beta_mol(i,k), x%beta_tot(i,j,k), & + x%tau_tot(i,j,k),x%refl(i,j,m), & + x%temp_tot(i,k),x%betaperp_tot(i,j,k)) + ! --- Initialise to zero --- + x%beta_mol = 0.0 + x%beta_tot = 0.0 + x%tau_tot = 0.0 + x%refl = 0.0 ! parasol + x%temp_tot = 0.0 + x%betaperp_tot = 0.0 + END SUBROUTINE CONSTRUCT_COSP_SGLIDAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_SGLIDAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGLIDAR(x) + type(cosp_sglidar),intent(inout) :: x + + deallocate(x%beta_mol, x%beta_tot, x%tau_tot, x%refl, & + x%temp_tot, x%betaperp_tot) + + END SUBROUTINE FREE_COSP_SGLIDAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGRADAR ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGRADAR(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_sgradar),intent(out) :: x + ! Local variables + integer :: i,j,k,l + + if (cfg%Lradar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + else ! Allocate minumum storage if simulator not used + i = 1 + j = 1 + k = 1 + l = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + + ! --- Allocate arrays --- + allocate(x%att_gas(i,k), x%Ze_tot(i,j,k)) + ! --- Initialise to zero --- + x%att_gas = 0.0 + x%Ze_tot = 0.0 + ! The following line give a compilation error on the Met Office NEC +! call zero_real(x%Z_hydro, x%att_hydro) +! f90: error(666): cosp_types.f90, line nnn: +! Actual argument corresponding to dummy +! argument of ELEMENTAL subroutine +! "zero_real" with INTENET(OUT) attribute +! is not array. + END SUBROUTINE CONSTRUCT_COSP_SGRADAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_SGRADAR ---------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGRADAR(x) + type(cosp_sgradar),intent(inout) :: x + + deallocate(x%att_gas, x%Ze_tot) + END SUBROUTINE FREE_COSP_SGRADAR + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------- SUBROUTINE CONSTRUCT_COSP_RADARSTATS --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_RADARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + type(cosp_radarstats),intent(out) :: x + ! Local variables + integer :: i,j,k,l + + ! Allocate minumum storage if simulator not used + if (cfg%Lradar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + else + i = 1 + j = 1 + k = 1 + l = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + + ! --- Allocate arrays --- + allocate(x%cfad_ze(i,DBZE_BINS,k),x%lidar_only_freq_cloud(i,k)) + allocate(x%radar_lidar_tcc(i)) + ! --- Initialise to zero --- + x%cfad_ze = 0.0 + x%lidar_only_freq_cloud = 0.0 + x%radar_lidar_tcc = 0.0 + END SUBROUTINE CONSTRUCT_COSP_RADARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_RADARSTATS ------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_RADARSTATS(x) + type(cosp_radarstats),intent(inout) :: x + + deallocate(x%cfad_ze,x%lidar_only_freq_cloud,x%radar_lidar_tcc) + END SUBROUTINE FREE_COSP_RADARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------- SUBROUTINE CONSTRUCT_COSP_LIDARSTATS --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_LIDARSTATS(cfg,Npoints,Ncolumns,Nlevels,Nhydro,Nrefl,x) + type(cosp_config),intent(in) :: cfg ! Configuration options + integer,intent(in) :: Npoints ! Number of sampled points + integer,intent(in) :: Ncolumns ! Number of subgrid columns + integer,intent(in) :: Nlevels ! Number of model levels + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nrefl ! Number of parasol reflectance + type(cosp_lidarstats),intent(out) :: x + ! Local variables + integer :: i,j,k,l,m + + ! Allocate minumum storage if simulator not used + if (cfg%Llidar_sim) then + i = Npoints + j = Ncolumns + k = Nlevels + l = Nhydro + m = Nrefl + else + i = 1 + j = 1 + k = 1 + l = 1 + m = 1 + endif + + ! Dimensions + x%Npoints = i + x%Ncolumns = j + x%Nlevels = k + x%Nhydro = l + x%Nrefl = m + + ! --- Allocate arrays --- + allocate(x%srbval(SR_BINS),x%cfad_sr(i,SR_BINS,k), & + x%lidarcld(i,k), x%cldlayer(i,LIDAR_NCAT), x%parasolrefl(i,m)) + allocate(x%lidarcldphase(i,k,6),x%lidarcldtmp(i,LIDAR_NTEMP,5),& + x%cldlayerphase(i,LIDAR_NCAT,6)) + allocate(x%lidarcldtype(i,k,LIDAR_NTYPE+1),x%cldtype(i,LIDAR_NTYPE)) !OPAQ +! allocate(x%profSR(i,j,k),x%proftemp(i,k)) !TIBO + allocate(x%profSR(i,k,j),x%proftemp(i,k)) !TIBO2 + ! --- Initialise to zero --- + x%srbval = 0.0 + x%cfad_sr = 0.0 + x%lidarcld = 0.0 + x%cldlayer = 0.0 + x%parasolrefl = 0.0 + x%lidarcldphase = 0.0 + x%cldlayerphase = 0.0 + x%lidarcldtmp = 0.0 + x%lidarcldtype = 0.0 !OPAQ + x%cldtype = 0.0 !OPAQ + x%profSR = 0.0 !TIBO + x%proftemp = 0.0 !TIBO + + END SUBROUTINE CONSTRUCT_COSP_LIDARSTATS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------ SUBROUTINE FREE_COSP_LIDARSTATS ------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_LIDARSTATS(x) + type(cosp_lidarstats),intent(inout) :: x + + deallocate(x%srbval, x%cfad_sr, x%lidarcld, x%cldlayer, x%parasolrefl) + deallocate(x%cldlayerphase, x%lidarcldtmp, x%lidarcldphase) + deallocate(x%lidarcldtype, x%cldtype) !OPAQ + deallocate(x%profSR, x%proftemp) !TIBO + END SUBROUTINE FREE_COSP_LIDARSTATS + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SUBGRID ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SUBGRID(Npoints,Ncolumns,Nlevels,y) + integer,intent(in) :: Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nlevels ! Number of levels + type(cosp_subgrid),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + + ! --- Allocate arrays --- + allocate(y%frac_out(Npoints,Ncolumns,Nlevels)) + if (Ncolumns > 1) then + allocate(y%prec_frac(Npoints,Ncolumns,Nlevels)) + else ! CRM mode, not needed + allocate(y%prec_frac(1,1,1)) + endif + ! --- Initialise to zero --- + y%prec_frac = 0.0 + y%frac_out = 0.0 + ! The following line gives a compilation error on the Met Office NEC +! call zero_real(y%mr_hydro) +! f90: error(666): cosp_types.f90, line nnn: +! Actual argument corresponding to dummy +! argument of ELEMENTAL subroutine +! "zero_real" with INTENET(OUT) attribute +! is not array. + + END SUBROUTINE CONSTRUCT_COSP_SUBGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_SUBGRID ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SUBGRID(y) + type(cosp_subgrid),intent(inout) :: y + + ! --- Deallocate arrays --- + deallocate(y%prec_frac, y%frac_out) + + END SUBROUTINE FREE_COSP_SUBGRID + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_SGHYDRO ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_SGHYDRO(Npoints,Ncolumns,Nlevels,Nhydro,y) + integer,intent(in) :: Npoints, & ! Number of gridpoints + Ncolumns, & ! Number of columns + Nhydro, & ! Number of hydrometeors + Nlevels ! Number of levels + type(cosp_sghydro),intent(out) :: y + + ! Dimensions + y%Npoints = Npoints + y%Ncolumns = Ncolumns + y%Nlevels = Nlevels + y%Nhydro = Nhydro + + ! --- Allocate arrays --- + allocate(y%mr_hydro(Npoints,Ncolumns,Nlevels,Nhydro), & + y%Reff(Npoints,Ncolumns,Nlevels,Nhydro), & + y%Np(Npoints,Ncolumns,Nlevels,Nhydro)) ! added by roj with Quickbeam V3 + + ! --- Initialise to zero --- + y%mr_hydro = 0.0 + y%Reff = 0.0 + y%Np = 0.0 ! added by roj with Quickbeam V3 + + END SUBROUTINE CONSTRUCT_COSP_SGHYDRO + + !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_SGHYDRO ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_SGHYDRO(y) + type(cosp_sghydro),intent(inout) :: y + + ! --- Deallocate arrays --- + deallocate(y%mr_hydro, y%Reff, y%Np) ! added by Roj with Quickbeam V3 + + END SUBROUTINE FREE_COSP_SGHYDRO + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE CONSTRUCT_COSP_GRIDBOX ------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE CONSTRUCT_COSP_GRIDBOX(time,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs,do_ray,melt_lay,k2, & + Npoints,Nlevels,Ncolumns,Nhydro,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & + lidar_ice_type,isccp_top_height,isccp_top_height_direction,isccp_overlap,isccp_emsfc_lw, & + use_precipitation_fluxes,use_reff, & + ! RTTOV inputs + Plat,Sat,Inst,Nchan,ZenAng,Ichan,SurfEm,co2,ch4,n2o,co,& + y,load_LUT) + double precision,intent(in) :: time ! Time since start of run [days] + double precision,intent(in) :: time_bnds(2) ! Time boundaries + real,intent(in) :: radar_freq, & ! Radar frequency [GHz] + k2 ! |K|^2, -1=use frequency dependent default + integer,intent(in) :: & + surface_radar, & ! surface=1,spaceborne=0 + use_mie_tables, & ! use a precomputed lookup table? yes=1,no=0,2=use first column everywhere + use_gas_abs, & ! include gaseous absorption? yes=1,no=0 + do_ray, & ! calculate/output Rayleigh refl=1, not=0 + melt_lay ! melting layer model off=0, on=1 + integer,intent(in) :: Npoints ! Number of gridpoints + integer,intent(in) :: Nlevels ! Number of levels + integer,intent(in) :: Ncolumns ! Number of columns + integer,intent(in) :: Nhydro ! Number of hydrometeors + integer,intent(in) :: Nprmts_max_hydro ! Max number of parameters for hydrometeor size distributions + integer,intent(in) :: Naero ! Number of aerosol species + integer,intent(in) :: Nprmts_max_aero ! Max number of parameters for aerosol size distributions + integer,intent(in) :: Npoints_it ! Number of gridpoints processed in one iteration + integer,intent(in) :: lidar_ice_type ! Ice particle shape in lidar calculations (0=ice-spheres ; 1=ice-non-spherical) + integer,intent(in) :: isccp_top_height + integer,intent(in) :: isccp_top_height_direction + integer,intent(in) :: isccp_overlap + real,intent(in) :: isccp_emsfc_lw + logical,intent(in) :: use_precipitation_fluxes,use_reff + integer,intent(in) :: Plat + integer,intent(in) :: Sat + integer,intent(in) :: Inst + integer,intent(in) :: Nchan + integer,intent(in) :: Ichan(Nchan) + real,intent(in) :: SurfEm(Nchan) + real,intent(in) :: ZenAng + real,intent(in) :: co2,ch4,n2o,co + type(cosp_gridbox),intent(out) :: y + logical,intent(in),optional :: load_LUT + + + ! local variables + character*240 :: LUT_file_name + logical :: local_load_LUT + + if (present(load_LUT)) then + local_load_LUT = load_LUT + else + local_load_LUT = RADAR_SIM_LOAD_scale_LUTs_flag + endif + + ! Dimensions and scalars + y%radar_freq = radar_freq + y%surface_radar = surface_radar + y%use_mie_tables = use_mie_tables + y%use_gas_abs = use_gas_abs + y%do_ray = do_ray + y%melt_lay = melt_lay + y%k2 = k2 + y%Npoints = Npoints + y%Nlevels = Nlevels + y%Ncolumns = Ncolumns + y%Nhydro = Nhydro + y%Nprmts_max_hydro = Nprmts_max_hydro + y%Naero = Naero + y%Nprmts_max_aero = Nprmts_max_aero + y%Npoints_it = Npoints_it + y%lidar_ice_type = lidar_ice_type + y%isccp_top_height = isccp_top_height + y%isccp_top_height_direction = isccp_top_height_direction + y%isccp_overlap = isccp_overlap + y%isccp_emsfc_lw = isccp_emsfc_lw + y%use_precipitation_fluxes = use_precipitation_fluxes + y%use_reff = use_reff + + y%time = time + y%time_bnds = time_bnds + + ! RTTOV parameters + y%Plat = Plat + y%Sat = Sat + y%Inst = Inst + y%Nchan = Nchan + y%ZenAng = ZenAng + y%co2 = co2 + y%ch4 = ch4 + y%n2o = n2o + y%co = co + + ! --- Allocate arrays --- + ! Gridbox information (Npoints,Nlevels) + allocate(y%zlev(Npoints,Nlevels), y%zlev_half(Npoints,Nlevels), y%dlev(Npoints,Nlevels), & + y%p(Npoints,Nlevels), y%ph(Npoints,Nlevels), y%T(Npoints,Nlevels), & + y%q(Npoints,Nlevels), y%sh(Npoints,Nlevels), & + y%dtau_s(Npoints,Nlevels), y%dtau_c(Npoints,Nlevels), & + y%dem_s(Npoints,Nlevels), y%dem_c(Npoints,Nlevels), & + y%tca(Npoints,Nlevels), y%cca(Npoints,Nlevels), & + y%rain_ls(Npoints,Nlevels), y%rain_cv(Npoints,Nlevels), y%grpl_ls(Npoints,Nlevels), & + y%snow_ls(Npoints,Nlevels), y%snow_cv(Npoints,Nlevels),y%mr_ozone(Npoints,Nlevels)) + + + ! Surface information and geolocation (Npoints) + allocate(y%toffset(Npoints), y%longitude(Npoints),y%latitude(Npoints),y%psfc(Npoints), y%land(Npoints), & + y%sunlit(Npoints),y%skt(Npoints),y%u_wind(Npoints),y%v_wind(Npoints)) + ! Hydrometeors concentration and distribution parameters + allocate(y%mr_hydro(Npoints,Nlevels,Nhydro), & + y%dist_prmts_hydro(Nprmts_max_hydro,Nhydro), & + y%Reff(Npoints,Nlevels,Nhydro), & + y%Np(Npoints,Nlevels,Nhydro)) ! added by Roj with Quickbeam V3 + ! Aerosols concentration and distribution parameters + allocate(y%conc_aero(Npoints,Nlevels,Naero), y%dist_type_aero(Naero), & + y%dist_prmts_aero(Npoints,Nlevels,Nprmts_max_aero,Naero)) + + ! RTTOV channels and sfc. emissivity + allocate(y%ichan(Nchan),y%surfem(Nchan)) + + ! RTTOV parameters + y%ichan = ichan + y%surfem = surfem + + ! --- Initialise to zero --- + y%zlev = 0.0 + y%zlev_half = 0.0 + y%dlev = 0.0 + y%p = 0.0 + y%ph = 0.0 + y%T = 0.0 + y%q = 0.0 + y%sh = 0.0 + y%dtau_s = 0.0 + y%dtau_c = 0.0 + y%dem_s = 0.0 + y%dem_c = 0.0 + y%tca = 0.0 + y%cca = 0.0 + y%rain_ls = 0.0 + y%rain_cv = 0.0 + y%grpl_ls = 0.0 + y%snow_ls = 0.0 + y%snow_cv = 0.0 + y%Reff = 0.0 + y%Np = 0.0 ! added by Roj with Quickbeam V3 + y%mr_ozone = 0.0 + y%u_wind = 0.0 + y%v_wind = 0.0 + + + ! (Npoints) + y%toffset = 0.0 + y%longitude = 0.0 + y%latitude = 0.0 + y%psfc = 0.0 + y%land = 0.0 + y%sunlit = 0.0 + y%skt = 0.0 + ! (Npoints,Nlevels,Nhydro) +! y%fr_hydro = 0.0 + y%mr_hydro = 0.0 + ! Others + y%dist_prmts_hydro = 0.0 ! (Nprmts_max_hydro,Nhydro) + y%conc_aero = 0.0 ! (Npoints,Nlevels,Naero) + y%dist_type_aero = 0 ! (Naero) + y%dist_prmts_aero = 0.0 ! (Npoints,Nlevels,Nprmts_max_aero,Naero) + + + ! NOTE: This location use to contain initialization of some radar simulator variables + ! this initialization (including use of the variable "dist_prmts_hydro" - now obselete) + ! has been unified in the quickbeam v3 subroutine "radar_simulator_init". Roj, June 2010 + + ! --- Initialize the distributional parameters for hydrometeors in radar simulator + + write(*,*) 'RADAR_SIM microphysics scheme is set to: ', & + trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME) + + + if(y%Nhydro.ne.N_HYDRO) then + + write(*,*) 'Number of hydrometeor input to subroutine', & + ' CONSTRUCT_COSP_GRIDBOX does not match value', & + ' specified in cosp_constants.f90!' + write(*,*) + endif + + ! NOTE: SAVE_scale_LUTs_flag is hard codded as .false. here + ! so that radar simulator will NOT update LUT each time it + ! is called, but rather will update when "Free_COSP_GRIDBOX" is called! + ! Roj, June 2010 + + LUT_file_name = trim(RADAR_SIM_LUT_DIRECTORY) // & + trim(RADAR_SIM_MICROPHYSICS_SCHEME_NAME) + + call radar_simulator_init(radar_freq,k2, & + use_gas_abs,do_ray,R_UNDEF, & + y%Nhydro, & + HCLASS_TYPE,HCLASS_PHASE, & + HCLASS_DMIN,HCLASS_DMAX, & + HCLASS_APM,HCLASS_BPM,HCLASS_RHO, & + HCLASS_P1,HCLASS_P2,HCLASS_P3, & + local_load_LUT, & + .false., & + LUT_file_name, & + y%hp) + +END SUBROUTINE CONSTRUCT_COSP_GRIDBOX + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE FREE_COSP_GRIDBOX ----------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE FREE_COSP_GRIDBOX(y,dglobal,save_LUT) + + use scale_LUTs_io + + type(cosp_gridbox),intent(inout) :: y + logical,intent(in),optional :: dglobal + logical,intent(in),optional :: save_LUT + + logical :: local_save_LUT + + if (present(save_LUT)) then + local_save_LUT = save_LUT + else + local_save_LUT = RADAR_SIM_UPDATE_scale_LUTs_flag + endif + + ! save any updates to radar simulator LUT + if (local_save_LUT) call save_scale_LUTs(y%hp) + + deallocate(y%zlev, y%zlev_half, y%dlev, y%p, y%ph, y%T, y%q, & + y%sh, y%dtau_s, y%dtau_c, y%dem_s, y%dem_c, & + y%toffset, y%longitude,y%latitude,y%psfc, y%land, y%tca, y%cca, & + y%mr_hydro, y%dist_prmts_hydro, & + y%conc_aero, y%dist_type_aero, y%dist_prmts_aero, & + y%rain_ls, y%rain_cv, y%snow_ls, y%snow_cv, y%grpl_ls, & + y%sunlit, y%skt, y%Reff,y%Np, & + y%ichan,y%surfem, & + y%mr_ozone,y%u_wind,y%v_wind) + + END SUBROUTINE FREE_COSP_GRIDBOX + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_GRIDBOX_CPHP ---------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_GRIDBOX_CPHP(x,y) + type(cosp_gridbox),intent(in) :: x + type(cosp_gridbox),intent(inout) :: y + + integer :: i,j,k,sz(3) + double precision :: tny + + tny = tiny(tny) + y%hp%p1 = x%hp%p1 + y%hp%p2 = x%hp%p2 + y%hp%p3 = x%hp%p3 + y%hp%dmin = x%hp%dmin + y%hp%dmax = x%hp%dmax + y%hp%apm = x%hp%apm + y%hp%bpm = x%hp%bpm + y%hp%rho = x%hp%rho + y%hp%dtype = x%hp%dtype + y%hp%col = x%hp%col + y%hp%cp = x%hp%cp + y%hp%phase = x%hp%phase + + y%hp%fc = x%hp%fc + y%hp%rho_eff = x%hp%rho_eff + ! y%hp%ifc = x%hp%ifc obsolete, Roj, June 2010 + ! y%hp%idd = x%hp%idd + sz = shape(x%hp%Z_scale_flag) + do k=1,sz(3) + do j=1,sz(2) + do i=1,sz(1) + if (x%hp%N_scale_flag(i,k)) y%hp%N_scale_flag(i,k) = .true. + if (x%hp%Z_scale_flag(i,j,k)) y%hp%Z_scale_flag(i,j,k) = .true. + if (abs(x%hp%Ze_scaled(i,j,k)) > tny) y%hp%Ze_scaled(i,j,k) = x%hp%Ze_scaled(i,j,k) + if (abs(x%hp%Zr_scaled(i,j,k)) > tny) y%hp%Zr_scaled(i,j,k) = x%hp%Zr_scaled(i,j,k) + if (abs(x%hp%kr_scaled(i,j,k)) > tny) y%hp%kr_scaled(i,j,k) = x%hp%kr_scaled(i,j,k) + enddo + enddo + enddo + +END SUBROUTINE COSP_GRIDBOX_CPHP + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_GRIDBOX_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_GRIDBOX_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_gridbox),intent(in) :: x + type(cosp_gridbox),intent(inout) :: y + + ! --- Copy arrays without Npoints as dimension --- + y%dist_prmts_hydro = x%dist_prmts_hydro + y%dist_type_aero = x%dist_type_aero + + +! call cosp_gridbox_cphp(x,y) + + ! 1D + y%longitude(iy(1):iy(2)) = x%longitude(ix(1):ix(2)) + y%latitude(iy(1):iy(2)) = x%latitude(ix(1):ix(2)) + y%psfc(iy(1):iy(2)) = x%psfc(ix(1):ix(2)) + y%land(iy(1):iy(2)) = x%land(ix(1):ix(2)) + y%sunlit(iy(1):iy(2)) = x%sunlit(ix(1):ix(2)) + y%skt(iy(1):iy(2)) = x%skt(ix(1):ix(2)) + y%u_wind(iy(1):iy(2)) = x%u_wind(ix(1):ix(2)) + y%v_wind(iy(1):iy(2)) = x%v_wind(ix(1):ix(2)) + ! 2D + y%zlev(iy(1):iy(2),:) = x%zlev(ix(1):ix(2),:) + y%zlev_half(iy(1):iy(2),:) = x%zlev_half(ix(1):ix(2),:) + y%dlev(iy(1):iy(2),:) = x%dlev(ix(1):ix(2),:) + y%p(iy(1):iy(2),:) = x%p(ix(1):ix(2),:) + y%ph(iy(1):iy(2),:) = x%ph(ix(1):ix(2),:) + y%T(iy(1):iy(2),:) = x%T(ix(1):ix(2),:) + y%q(iy(1):iy(2),:) = x%q(ix(1):ix(2),:) + y%sh(iy(1):iy(2),:) = x%sh(ix(1):ix(2),:) + y%dtau_s(iy(1):iy(2),:) = x%dtau_s(ix(1):ix(2),:) + y%dtau_c(iy(1):iy(2),:) = x%dtau_c(ix(1):ix(2),:) + y%dem_s(iy(1):iy(2),:) = x%dem_s(ix(1):ix(2),:) + y%dem_c(iy(1):iy(2),:) = x%dem_c(ix(1):ix(2),:) + y%tca(iy(1):iy(2),:) = x%tca(ix(1):ix(2),:) + y%cca(iy(1):iy(2),:) = x%cca(ix(1):ix(2),:) + y%rain_ls(iy(1):iy(2),:) = x%rain_ls(ix(1):ix(2),:) + y%rain_cv(iy(1):iy(2),:) = x%rain_cv(ix(1):ix(2),:) + y%grpl_ls(iy(1):iy(2),:) = x%grpl_ls(ix(1):ix(2),:) + y%snow_ls(iy(1):iy(2),:) = x%snow_ls(ix(1):ix(2),:) + y%snow_cv(iy(1):iy(2),:) = x%snow_cv(ix(1):ix(2),:) + y%mr_ozone(iy(1):iy(2),:) = x%mr_ozone(ix(1):ix(2),:) + ! 3D + y%Reff(iy(1):iy(2),:,:) = x%Reff(ix(1):ix(2),:,:) + y%Np(iy(1):iy(2),:,:) = x%Np(ix(1):ix(2),:,:) ! added by Roj with Quickbeam V3 + y%conc_aero(iy(1):iy(2),:,:) = x%conc_aero(ix(1):ix(2),:,:) + y%mr_hydro(iy(1):iy(2),:,:) = x%mr_hydro(ix(1):ix(2),:,:) + ! 4D + y%dist_prmts_aero(iy(1):iy(2),:,:,:) = x%dist_prmts_aero(ix(1):ix(2),:,:,:) + +END SUBROUTINE COSP_GRIDBOX_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SUBGRID_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SUBGRID_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_subgrid),intent(in) :: x + type(cosp_subgrid),intent(inout) :: y + + y%prec_frac(iy(1):iy(2),:,:) = x%prec_frac(ix(1):ix(2),:,:) + y%frac_out(iy(1):iy(2),:,:) = x%frac_out(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SUBGRID_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SGRADAR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SGRADAR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_sgradar),intent(in) :: x + type(cosp_sgradar),intent(inout) :: y + + y%att_gas(iy(1):iy(2),:) = x%att_gas(ix(1):ix(2),:) + y%Ze_tot(iy(1):iy(2),:,:) = x%Ze_tot(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SGRADAR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_SGLIDAR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_SGLIDAR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_sglidar),intent(in) :: x + type(cosp_sglidar),intent(inout) :: y + + y%temp_tot(iy(1):iy(2),:) = x%temp_tot(ix(1):ix(2),:) + y%betaperp_tot(iy(1):iy(2),:,:) = x%betaperp_tot(ix(1):ix(2),:,:) + y%beta_mol(iy(1):iy(2),:) = x%beta_mol(ix(1):ix(2),:) + y%beta_tot(iy(1):iy(2),:,:) = x%beta_tot(ix(1):ix(2),:,:) + y%tau_tot(iy(1):iy(2),:,:) = x%tau_tot(ix(1):ix(2),:,:) + y%refl(iy(1):iy(2),:,:) = x%refl(ix(1):ix(2),:,:) +END SUBROUTINE COSP_SGLIDAR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_ISCCP_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_ISCCP_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_isccp),intent(in) :: x + type(cosp_isccp),intent(inout) :: y + + y%fq_isccp(iy(1):iy(2),:,:) = x%fq_isccp(ix(1):ix(2),:,:) + y%totalcldarea(iy(1):iy(2)) = x%totalcldarea(ix(1):ix(2)) + y%meantb(iy(1):iy(2)) = x%meantb(ix(1):ix(2)) + y%meantbclr(iy(1):iy(2)) = x%meantbclr(ix(1):ix(2)) + y%meanptop(iy(1):iy(2)) = x%meanptop(ix(1):ix(2)) + y%meantaucld(iy(1):iy(2)) = x%meantaucld(ix(1):ix(2)) + y%meanalbedocld(iy(1):iy(2)) = x%meanalbedocld(ix(1):ix(2)) + y%boxtau(iy(1):iy(2),:) = x%boxtau(ix(1):ix(2),:) + y%boxptop(iy(1):iy(2),:) = x%boxptop(ix(1):ix(2),:) +END SUBROUTINE COSP_ISCCP_CPSECTION + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_MISR_CPSECTION ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_MISR_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_misr),intent(in) :: x + type(cosp_misr),intent(inout) :: y + + y%fq_MISR(iy(1):iy(2),:,:) = x%fq_MISR(ix(1):ix(2),:,:) + y%MISR_meanztop(iy(1):iy(2)) = x%MISR_meanztop(ix(1):ix(2)) + y%MISR_cldarea(iy(1):iy(2)) = x%MISR_cldarea(ix(1):ix(2)) + y%MISR_dist_model_layertops(iy(1):iy(2),:) = x%MISR_dist_model_layertops(ix(1):ix(2),:) +END SUBROUTINE COSP_MISR_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_RTTOV_CPSECTION ------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RTTOV_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_rttov),intent(in) :: x + type(cosp_rttov),intent(inout) :: y + + y%tbs(iy(1):iy(2),:) = x%tbs(ix(1):ix(2),:) +END SUBROUTINE COSP_RTTOV_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_RADARSTATS_CPSECTION -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_RADARSTATS_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_radarstats),intent(in) :: x + type(cosp_radarstats),intent(inout) :: y + + y%cfad_ze(iy(1):iy(2),:,:) = x%cfad_ze(ix(1):ix(2),:,:) + y%radar_lidar_tcc(iy(1):iy(2)) = x%radar_lidar_tcc(ix(1):ix(2)) + y%lidar_only_freq_cloud(iy(1):iy(2),:) = x%lidar_only_freq_cloud(ix(1):ix(2),:) +END SUBROUTINE COSP_RADARSTATS_CPSECTION + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_LIDARSTATS_CPSECTION -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDARSTATS_CPSECTION(ix,iy,x,y) + integer,intent(in),dimension(2) :: ix,iy + type(cosp_lidarstats),intent(in) :: x + type(cosp_lidarstats),intent(inout) :: y + + y%srbval = x%srbval + y%cfad_sr(iy(1):iy(2),:,:) = x%cfad_sr(ix(1):ix(2),:,:) + y%lidarcld(iy(1):iy(2),:) = x%lidarcld(ix(1):ix(2),:) + y%cldlayer(iy(1):iy(2),:) = x%cldlayer(ix(1):ix(2),:) + y%parasolrefl(iy(1):iy(2),:) = x%parasolrefl(ix(1):ix(2),:) + y%lidarcldphase(iy(1):iy(2),:,:) = x%lidarcldphase(ix(1):ix(2),:,:) + y%cldlayerphase(iy(1):iy(2),:,:) = x%cldlayerphase(ix(1):ix(2),:,:) + y%lidarcldtmp(iy(1):iy(2),:,:) = x%lidarcldtmp(ix(1):ix(2),:,:) + y%lidarcldtype(iy(1):iy(2),:,:) = x%lidarcldtype(ix(1):ix(2),:,:) !OPAQ + y%cldtype(iy(1):iy(2),:) = x%cldtype(ix(1):ix(2),:) !OPAQ + y%profSR(iy(1):iy(2),:,:) = x%profSR(ix(1):ix(2),:,:) !TIBO + y%proftemp(iy(1):iy(2),:) = x%proftemp(ix(1):ix(2),:) !TIBO +END SUBROUTINE COSP_LIDARSTATS_CPSECTION +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- PRINT SUBROUTINES -------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_GRIDBOX_PRINT(x) + type(cosp_gridbox),intent(in) :: x + + print *, '%%%%----- Information on COSP_GRIDBOX ------' + ! Scalars and dimensions + print *, x%Npoints + print *, x%Nlevels + print *, x%Ncolumns + print *, x%Nhydro + print *, x%Nprmts_max_hydro + print *, x%Naero + print *, x%Nprmts_max_aero + print *, x%Npoints_it + + ! Time [days] + print *, x%time + + ! Radar ancillary info + print *, x%radar_freq, & + x%k2 + print *, x%surface_radar, & + x%use_mie_tables, & + x%use_gas_abs, & + x%do_ray, & + x%melt_lay + +! print *, 'shape(x%): ',shape(x%) + +! type(class_param) :: hp ! structure used by radar simulator to store Ze and N scaling constants and other information +! type(mie):: mt ! structure used by radar simulator to store mie LUT information + print *, x%nsizes + + ! Lidar + print *, x%lidar_ice_type + + ! Radar + print *, x%use_precipitation_fluxes + print *, x%use_reff + + ! Geolocation (Npoints) + print *, 'shape(x%longitude): ',shape(x%longitude) + print *, 'shape(x%latitude): ',shape(x%latitude) + ! Gridbox information (Npoints,Nlevels) + print *, 'shape(x%zlev): ',shape(x%zlev) + print *, 'shape(x%zlev_half): ',shape(x%zlev_half) + print *, 'shape(x%dlev): ',shape(x%dlev) + print *, 'shape(x%p): ',shape(x%p) + print *, 'shape(x%ph): ',shape(x%ph) + print *, 'shape(x%T): ',shape(x%T) + print *, 'shape(x%q): ',shape(x%q) + print *, 'shape(x%sh): ',shape(x%sh) + print *, 'shape(x%dtau_s): ',shape(x%dtau_s) + print *, 'shape(x%dtau_c): ',shape(x%dtau_c) + print *, 'shape(x%dem_s): ',shape(x%dem_s) + print *, 'shape(x%dem_c): ',shape(x%dem_c) + print *, 'shape(x%mr_ozone): ',shape(x%mr_ozone) + + ! Point information (Npoints) + print *, 'shape(x%land): ',shape(x%land) + print *, 'shape(x%psfc): ',shape(x%psfc) + print *, 'shape(x%sunlit): ',shape(x%sunlit) + print *, 'shape(x%skt): ',shape(x%skt) + print *, 'shape(x%u_wind): ',shape(x%u_wind) + print *, 'shape(x%v_wind): ',shape(x%v_wind) + + ! TOTAL and CONV cloud fraction for SCOPS + print *, 'shape(x%tca): ',shape(x%tca) + print *, 'shape(x%cca): ',shape(x%cca) + ! Precipitation fluxes on model levels + print *, 'shape(x%rain_ls): ',shape(x%rain_ls) + print *, 'shape(x%rain_cv): ',shape(x%rain_cv) + print *, 'shape(x%snow_ls): ',shape(x%snow_ls) + print *, 'shape(x%snow_cv): ',shape(x%snow_cv) + print *, 'shape(x%grpl_ls): ',shape(x%grpl_ls) + ! Hydrometeors concentration and distribution parameters + print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro) + print *, 'shape(x%dist_prmts_hydro): ',shape(x%dist_prmts_hydro) + ! Effective radius [m]. (Npoints,Nlevels,Nhydro) + print *, 'shape(x%Reff): ',shape(x%Reff) + print *, 'shape(x%Np): ',shape(x%Np) ! added by roj with Quickbeam V3 + ! Aerosols concentration and distribution parameters + print *, 'shape(x%conc_aero): ',shape(x%conc_aero) + print *, 'shape(x%dist_type_aero): ',shape(x%dist_type_aero) + print *, 'shape(x%dist_prmts_aero): ',shape(x%dist_prmts_aero) + ! ISCCP simulator inputs + print *, x%isccp_top_height + print *, x%isccp_top_height_direction + print *, x%isccp_overlap + print *, x%isccp_emsfc_lw + + ! RTTOV inputs/options + print *, x%plat + print *, x%sat + print *, x%inst + print *, x%Nchan + print *, 'shape(x%Ichan): ',x%Ichan + print *, 'shape(x%Surfem): ',x%Surfem + print *, x%ZenAng + print *, x%co2,x%ch4,x%n2o,x%co + +END SUBROUTINE COSP_GRIDBOX_PRINT + +SUBROUTINE COSP_MISR_PRINT(x) + type(cosp_misr),intent(in) :: x + + print *, '%%%%----- Information on COSP_MISR ------' + + ! Dimensions + print *, x%Npoints + print *, x%Ntau + print *, x%Nlevels + + ! --- (npoints,ntau,nlevels) + ! the fraction of the model grid box covered by each of the MISR cloud types + print *, 'shape(x%fq_MISR): ',shape(x%fq_MISR) + + ! --- (npoints) + print *, 'shape(x%MISR_meanztop): ',shape(x%MISR_meanztop) + print *, 'shape(x%MISR_cldarea): ',shape(x%MISR_cldarea) + ! --- (npoints,nlevels) + print *, 'shape(x%MISR_dist_model_layertops): ',shape(x%MISR_dist_model_layertops) + +END SUBROUTINE COSP_MISR_PRINT + +SUBROUTINE COSP_ISCCP_PRINT(x) + type(cosp_isccp),intent(in) :: x + + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + + print *, '%%%%----- Information on COSP_ISCCP ------' + + print *, 'shape(x%fq_isccp): ',shape(x%fq_isccp) + print *, 'shape(x%totalcldarea): ',shape(x%totalcldarea) + print *, 'shape(x%meantb): ',shape(x%meantb) + print *, 'shape(x%meantbclr): ',shape(x%meantbclr) + + print *, 'shape(x%meanptop): ',shape(x%meanptop) + print *, 'shape(x%meantaucld): ',shape(x%meantaucld) + print *, 'shape(x%meanalbedocld): ',shape(x%meanalbedocld) + print *, 'shape(x%boxtau): ',shape(x%boxtau) + print *, 'shape(x%boxptop): ',shape(x%boxptop) +END SUBROUTINE COSP_ISCCP_PRINT + +SUBROUTINE COSP_VGRID_PRINT(x) + type(cosp_vgrid),intent(in) :: x + + print *, '%%%%----- Information on COSP_VGRID ------' + print *, x%use_vgrid + print *, x%csat_vgrid + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + print *, x%Nlvgrid + ! Array with dimensions (Nlvgrid) + print *, 'shape(x%z): ',shape(x%z) + print *, 'shape(x%zl): ',shape(x%zl) + print *, 'shape(x%zu): ',shape(x%zu) + ! Array with dimensions (Nlevels) + print *, 'shape(x%mz): ',shape(x%mz) + print *, 'shape(x%mzl): ',shape(x%mzl) + print *, 'shape(x%mzu): ',shape(x%mzu) +END SUBROUTINE COSP_VGRID_PRINT + +SUBROUTINE COSP_SGLIDAR_PRINT(x) + type(cosp_sglidar),intent(in) :: x + + print *, '%%%%----- Information on COSP_SGLIDAR ------' + ! Dimensions + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + print *, x%Nhydro + print *, x%Nrefl + ! Arrays with dimensions (Npoints,Nlevels) + print *, 'shape(x%beta_mol): ',shape(x%beta_mol) + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + print *, 'shape(x%beta_tot): ',shape(x%beta_tot) + print *, 'shape(x%tau_tot): ',shape(x%tau_tot) + ! Arrays with dimensions (Npoints,Ncolumns,Nrefl) + print *, 'shape(x%refl): ',shape(x%refl) +END SUBROUTINE COSP_SGLIDAR_PRINT + +SUBROUTINE COSP_SGRADAR_PRINT(x) + type(cosp_sgradar),intent(in) :: x + + print *, '%%%%----- Information on COSP_SGRADAR ------' + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + print *, x%Nhydro + ! output vertical levels: spaceborne radar -> from TOA to SURFACE + ! Arrays with dimensions (Npoints,Nlevels) + print *, 'shape(x%att_gas): ', shape(x%att_gas) + ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) + print *, 'shape(x%Ze_tot): ', shape(x%Ze_tot) +END SUBROUTINE COSP_SGRADAR_PRINT + +SUBROUTINE COSP_RADARSTATS_PRINT(x) + type(cosp_radarstats),intent(in) :: x + + print *, '%%%%----- Information on COSP_SGRADAR ------' + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + print *, x%Nhydro + print *, 'shape(x%cfad_ze): ',shape(x%cfad_ze) + print *, 'shape(x%radar_lidar_tcc): ',shape(x%radar_lidar_tcc) + print *, 'shape(x%lidar_only_freq_cloud): ',shape(x%lidar_only_freq_cloud) +END SUBROUTINE COSP_RADARSTATS_PRINT + +SUBROUTINE COSP_LIDARSTATS_PRINT(x) + type(cosp_lidarstats),intent(in) :: x + + print *, '%%%%----- Information on COSP_SGLIDAR ------' + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + print *, x%Nhydro + print *, x%Nrefl + + ! Arrays with dimensions (SR_BINS) + print *, 'shape(x%srbval): ',shape(x%srbval) + ! Arrays with dimensions (Npoints,SR_BINS,Nlevels) + print *, 'shape(x%cfad_sr): ',shape(x%cfad_sr) +! ! Arrays with dimensions (Npoints,Ncolumns,Nlevels) !TIBO +! print *, 'shape(x%profSR): ',shape(x%profSR) !TIBO + ! Arrays with dimensions (Npoints,Nlevels,Ncolumns) !TIBO2 + print *, 'shape(x%profSR): ',shape(x%profSR) !TIBO2 + ! Arrays with dimensions (Npoints,Nlevels) + print *, 'shape(x%lidarcld): ',shape(x%lidarcld) + print *, 'shape(x%proftemp): ',shape(x%proftemp) !TIBO + ! Arrays with dimensions (Npoints,LIDAR_NCAT) + print *, 'shape(x%cldlayer): ',shape(x%cldlayer) + ! Arrays with dimensions (Npoints,LIDAR_NTYPE) !OPAQ + print *, 'shape(x%cldtype): ',shape(x%cldtype) !OPAQ + ! Arrays with dimensions (Npoints,PARASOL_NREFL) + print *, 'shape(x%parasolrefl): ',shape(x%parasolrefl) + ! Arrays with dimensions (Npoints,Nlevels,Nphase) + print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldphase) + ! Arrays with dimensions (Npoints,Nlevels,LIDAR_NTYPE+1) !OPAQ + print *, 'shape(x%lidarcldtype): ',shape(x%lidarcldtype) !OPAQ + ! Arrays with dimensions (Npoints,LIDAR_NCAT,Nphase) + print *, 'shape(x%cldlayerphase): ',shape(x%cldlayerphase) + ! Arrays with dimensions (Npoints,Ntemps,Nphase) + print *, 'shape(x%lidarcldphase): ',shape(x%lidarcldtmp) + +END SUBROUTINE COSP_LIDARSTATS_PRINT + +SUBROUTINE COSP_SUBGRID_PRINT(x) + type(cosp_subgrid),intent(in) :: x + + print *, '%%%%----- Information on COSP_SUBGRID ------' + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + print *, x%Nhydro + + print *, 'shape(x%prec_frac): ',shape(x%prec_frac) + print *, 'shape(x%frac_out): ',shape(x%frac_out) +END SUBROUTINE COSP_SUBGRID_PRINT + +SUBROUTINE COSP_SGHYDRO_PRINT(x) + type(cosp_sghydro),intent(in) :: x + + print *, '%%%%----- Information on COSP_SGHYDRO ------' + print *, x%Npoints + print *, x%Ncolumns + print *, x%Nlevels + print *, x%Nhydro + + print *, 'shape(x%mr_hydro): ',shape(x%mr_hydro) + print *, 'shape(x%Reff): ',shape(x%Reff) + print *, 'shape(x%Np): ',shape(x%Np) ! added by roj with Quickbeam V3 +END SUBROUTINE COSP_SGHYDRO_PRINT + +END MODULE MOD_COSP_TYPES Index: LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_cosp_utils.F90 (revision 3233) @@ -0,0 +1,344 @@ +! (c) British Crown Copyright 2008, the Met Office. +! All rights reserved. +! $Revision: 23 $, $Date: 2011-03-31 15:41:37 +0200 (jeu. 31 mars 2011) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/cosp_utils.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + +! +! History: +! Jul 2007 - A. Bodas-Salcedo - Initial version +! + +MODULE MOD_COSP_UTILS + USE MOD_COSP_CONSTANTS + IMPLICIT NONE + + INTERFACE Z_TO_DBZ + MODULE PROCEDURE Z_TO_DBZ_2D,Z_TO_DBZ_3D,Z_TO_DBZ_4D + END INTERFACE + + INTERFACE COSP_CHECK_INPUT + MODULE PROCEDURE COSP_CHECK_INPUT_1D,COSP_CHECK_INPUT_2D,COSP_CHECK_INPUT_3D + END INTERFACE +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,intent(in),dimension(Npoints,Nlevels) :: p,T,flux + real,intent(in),dimension(Npoints,Ncolumns,Nlevels) :: prec_frac + real,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,intent(out),dimension(Npoints,Ncolumns,Nlevels) :: mxratio + real,intent(inout),dimension(Npoints,Ncolumns,Nlevels) :: reff + ! Local variables + integer :: i,j,k + real :: sigma,one_over_xip1,xi,rho0,rho,lambda_x,gamma_4_3_2,delta + + mxratio = 0.0 + + if (n_ax >= 0.0) then ! N_ax is used to control which hydrometeors need to be computed + xi = d_x/(alpha_x + b_x - n_bx + 1.0) + rho0 = 1.29 + sigma = (gamma2/(gamma1*c_x))*(n_ax*a_x*gamma2)**xi + one_over_xip1 = 1.0/(xi + 1.0) + gamma_4_3_2 = 0.5*gamma4/gamma3 + delta = (alpha_x + b_x + d_x - n_bx + 1.0) + + 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*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.0).and.(flux(i,k) /= 0.0)) then + lambda_x = (a_x*c_x*((rho0/rho)**g_x)*n_ax*gamma1/flux(i,k))**(1./delta) + reff(i,j,k) = gamma_4_3_2/lambda_x + endif + endif + enddo + enddo + enddo + endif +END SUBROUTINE COSP_PRECIP_MXRATIO + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE ZERO_INT ------------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ELEMENTAL SUBROUTINE ZERO_INT(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) + + integer,intent(inout) :: x + integer,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 + x = 0 + if (present(y01)) y01 = 0 + if (present(y02)) y02 = 0 + if (present(y03)) y03 = 0 + if (present(y04)) y04 = 0 + if (present(y05)) y05 = 0 + if (present(y06)) y06 = 0 + if (present(y07)) y07 = 0 + if (present(y08)) y08 = 0 + if (present(y09)) y09 = 0 + if (present(y10)) y10 = 0 + if (present(y11)) y11 = 0 + if (present(y12)) y12 = 0 + if (present(y13)) y13 = 0 + if (present(y14)) y14 = 0 + if (present(y15)) y15 = 0 + if (present(y16)) y16 = 0 + if (present(y17)) y17 = 0 + if (present(y18)) y18 = 0 + if (present(y19)) y19 = 0 + if (present(y20)) y20 = 0 + if (present(y21)) y21 = 0 + if (present(y22)) y22 = 0 + if (present(y23)) y23 = 0 + if (present(y24)) y24 = 0 + if (present(y25)) y25 = 0 + if (present(y26)) y26 = 0 + if (present(y27)) y27 = 0 + if (present(y28)) y28 = 0 + if (present(y29)) y29 = 0 + if (present(y30)) y30 = 0 +END SUBROUTINE ZERO_INT + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------------- SUBROUTINE ZERO_REAL ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +ELEMENTAL SUBROUTINE ZERO_REAL(x,y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30) + + real,intent(inout) :: x + real,intent(inout),optional :: y01,y02,y03,y04,y05,y06,y07,y08,y09,y10, & + y11,y12,y13,y14,y15,y16,y17,y18,y19,y20, & + y21,y22,y23,y24,y25,y26,y27,y28,y29,y30 + x = 0.0 + if (present(y01)) y01 = 0.0 + if (present(y02)) y02 = 0.0 + if (present(y03)) y03 = 0.0 + if (present(y04)) y04 = 0.0 + if (present(y05)) y05 = 0.0 + if (present(y06)) y06 = 0.0 + if (present(y07)) y07 = 0.0 + if (present(y08)) y08 = 0.0 + if (present(y09)) y09 = 0.0 + if (present(y10)) y10 = 0.0 + if (present(y11)) y11 = 0.0 + if (present(y12)) y12 = 0.0 + if (present(y13)) y13 = 0.0 + if (present(y14)) y14 = 0.0 + if (present(y15)) y15 = 0.0 + if (present(y16)) y16 = 0.0 + if (present(y17)) y17 = 0.0 + if (present(y18)) y18 = 0.0 + if (present(y19)) y19 = 0.0 + if (present(y20)) y20 = 0.0 + if (present(y21)) y21 = 0.0 + if (present(y22)) y22 = 0.0 + if (present(y23)) y23 = 0.0 + if (present(y24)) y24 = 0.0 + if (present(y25)) y25 = 0.0 + if (present(y26)) y26 = 0.0 + if (present(y27)) y27 = 0.0 + if (present(y28)) y28 = 0.0 + if (present(y29)) y29 = 0.0 + if (present(y30)) y30 = 0.0 +END SUBROUTINE ZERO_REAL + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_2D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_2D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_2D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_3D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_3D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_3D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!--------------------- SUBROUTINE Z_TO_DBZ_4D -------------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE Z_TO_DBZ_4D(mdi,z) + real,intent(in) :: mdi + real,dimension(:,:,:,:),intent(inout) :: z + ! Reflectivity Z: + ! Input in [m3] + ! Output in dBZ, with Z in [mm6 m-3] + + ! 1.e18 to convert from [m3] to [mm6 m-3] + z = 1.e18*z + where (z > 1.0e-6) ! Limit to -60 dBZ + z = 10.0*log10(z) + elsewhere + z = mdi + end where + END SUBROUTINE Z_TO_DBZ_4D + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_1D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_1D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_1D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_1D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_2D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_2D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:,:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_2D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_2D +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!----------------- SUBROUTINES COSP_CHECK_INPUT_3D --------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CHECK_INPUT_3D(vname,x,min_val,max_val) + character(len=*) :: vname + real,intent(inout) :: x(:,:,:) + real,intent(in),optional :: min_val,max_val + logical :: l_min,l_max + character(len=128) :: pro_name='COSP_CHECK_INPUT_3D' + + l_min=.false. + l_max=.false. + + if (present(min_val)) then +! if (x < min_val) x = min_val + if (any(x < min_val)) then + l_min = .true. + where (x < min_val) + x = min_val + end where + endif + endif + if (present(max_val)) then +! if (x > max_val) x = max_val + if (any(x > max_val)) then + l_max = .true. + where (x > max_val) + x = max_val + end where + endif + endif + + if (l_min) print *,'----- WARNING: '//trim(pro_name)//': minimum value of '//trim(vname)//' set to: ',min_val + if (l_max) print *,'----- WARNING: '//trim(pro_name)//': maximum value of '//trim(vname)//' set to: ',max_val + END SUBROUTINE COSP_CHECK_INPUT_3D + + +END MODULE MOD_COSP_UTILS Index: LMDZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_llnl_stats.F90 (revision 3233) @@ -0,0 +1,138 @@ +! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation. +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/llnl/llnl_stats.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Lawrence Livermore National Security Limited Liability Corporation +! nor the names of its contributors may be used to endorse or promote products derived from +! this software without specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! +! History +! +! Jan 2013 - G. Cesana - Added betaperp_tot and temp_tot arguments +! + + +MODULE MOD_LLNL_STATS + USE MOD_COSP_CONSTANTS + IMPLICIT NONE + +CONTAINS + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- FUNCTION COSP_CFAD ------------------------ +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +FUNCTION COSP_CFAD(Npoints,Ncolumns,Nlevels,Nbins,x,xmin,xmax,bmin,bwidth) + ! Input arguments + integer,intent(in) :: Npoints,Ncolumns,Nlevels,Nbins + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: x + real,intent(in) :: xmin,xmax + real,intent(in) :: bmin,bwidth + + real,dimension(Npoints,Nbins,Nlevels) :: cosp_cfad + ! Local variables + integer :: i, j, k + integer :: ibin + + !--- Input arguments + ! Npoints: Number of horizontal points + ! Ncolumns: Number of subcolumns + ! Nlevels: Number of levels + ! Nbins: Number of x axis bins + ! x: variable to process (Npoints,Ncolumns,Nlevels) + ! xmin: minimum value allowed for x + ! xmax: minimum value allowed for x + ! bmin: mimumum value of first bin + ! bwidth: bin width + ! + ! Output: 2D histogram on each horizontal point (Npoints,Nbins,Nlevels) + + cosp_cfad = 0.0 + ! bwidth intervals in the range [bmin,bmax=bmin+Nbins*hwidth] + ! Valid x values smaller than bmin and larger than bmax are set + ! into the smallest bin and largest bin, respectively. + do j = 1, Nlevels, 1 + do k = 1, Ncolumns, 1 + do i = 1, Npoints, 1 + if (x(i,k,j) == R_GROUND) then + cosp_cfad(i,:,j) = R_UNDEF + elseif ((x(i,k,j) >= xmin) .and. (x(i,k,j) <= xmax)) then + ibin = ceiling((x(i,k,j) - bmin)/bwidth) + if (ibin > Nbins) ibin = Nbins + if (ibin < 1) ibin = 1 + cosp_cfad(i,ibin,j) = cosp_cfad(i,ibin,j) + 1.0 + end if + enddo !i + enddo !k + enddo !j + where ((cosp_cfad /= R_UNDEF).and.(cosp_cfad /= 0.0)) cosp_cfad = cosp_cfad / Ncolumns +END FUNCTION COSP_CFAD + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD ----------------- +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints,Ncolumns,Nlevels,temp_tot,beta_tot, & + betaperp_tot,beta_mol,Ze_tot,lidar_only_freq_cloud,tcc) + ! Input arguments + integer,intent(in) :: Npoints,Ncolumns,Nlevels + real,dimension(Npoints,Nlevels),intent(in) :: beta_mol ! Molecular backscatter + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: beta_tot ! Total backscattered signal + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: temp_tot ! Total backscattered signal + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: betaperp_tot ! perpendicular Total backscattered signal + real,dimension(Npoints,Ncolumns,Nlevels),intent(in) :: Ze_tot ! Radar reflectivity + ! Output arguments + real,dimension(Npoints,Nlevels),intent(out) :: lidar_only_freq_cloud + real,dimension(Npoints),intent(out) :: tcc + + ! local variables + real :: sc_ratio + real :: s_cld, s_att + parameter (S_cld = 5.0) + parameter (s_att = 0.01) + integer :: flag_sat !first saturated level encountered from top + integer :: flag_cld !cloudy column + integer :: pr,i,j + + lidar_only_freq_cloud = 0.0 + tcc = 0.0 + do pr=1,Npoints + do i=1,Ncolumns + flag_sat = 0 + flag_cld = 0 + do j=Nlevels,1,-1 !top->surf + sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j) + if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j + if (Ze_tot(pr,i,j) .lt. -30.) then !radar can't detect cloud + if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then !lidar sense cloud + lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf + flag_cld=1 + endif + else !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.) + flag_cld=1 + endif + enddo !levels + if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1. + enddo !columns + enddo !points + lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns + tcc=tcc/Ncolumns + +END SUBROUTINE COSP_LIDAR_ONLY_CLOUD +END MODULE MOD_LLNL_STATS Index: LMDZ6/trunk/libf/phylmd/cosp/mod_lmd_ipsl_stats.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_lmd_ipsl_stats.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_lmd_ipsl_stats.F90 (revision 3233) @@ -0,0 +1,1181 @@ +! Copyright (c) 2009, Centre National de la Recherche Scientifique +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 15:08:38 +0100 (mer. 13 nov. 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/actsim/lmd_ipsl_stats.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the LMD/IPSL/CNRS/UPMC nor the names of its +! contributors may be used to endorse or promote products derived from this software without +! specific prior written permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. + + +!------------------------------------------------------------------------------------ +! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). +!------------------------------------------------------------------------------------ +MODULE MOD_LMD_IPSL_STATS + USE MOD_LLNL_STATS + IMPLICIT NONE + +CONTAINS + SUBROUTINE diag_lidar(npoints,ncol,llm,max_bin,nrefl & + ,tmp,pnorm,pnorm_perp,pmol,refl,land,pplay,undef,ok_lidar_cfad & + ,cfad2,srbval,ncat,ntype,lidarcld,lidarcldtype,lidarcldphase,cldlayer & !OPAQ + ,cldtype,cldlayerphase,lidarcldtmp,parasolrefl,vgrid_z,profSR) !OPAQ !TIBO +! +! ----------------------------------------------------------------------------------- +! Lidar outputs : +! +! Diagnose cloud fraction (3D cloud fraction + low/middle/high/total cloud fraction) +! and phase cloud fraction (3D, low/mid/high/total and 3D temperature) +! from the lidar signals (ATB, ATBperp and molecular ATB) computed from model outputs +! + +! Compute CFADs of lidar scattering ratio SR and of depolarization index +! +! Authors: Sandrine Bony and Helene Chepfer (LMD/IPSL, CNRS, UPMC, France). +! +! December 2008, S. Bony, H. Chepfer and J-L. Dufresne : +! - change of the cloud detection threshold S_cld from 3 to 5, for better +! with both day and night observations. The optical thinest clouds are missed. +! - remove of the detection of the first fully attenuated layer encountered from above. +! December 2008, A. Bodas-Salcedo: +! - Dimensions of pmol reduced to (npoints,llm) +! August 2009, A. Bodas-Salcedo: +! - Warning message regarding PARASOL being valid only over ocean deleted. +! February 2010, A. Bodas-Salcedo: +! - Undef passed into cosp_cfad_sr +! June 2010, T. Yokohata, T. Nishimura and K. Ogochi +! Optimisation of COSP_CFAD_SR +! +! January 2013, G. Cesana, H. Chepfer: +! - Add the perpendicular component of the backscattered signal (pnorm_perp) in the arguments +! - Add the temperature (tmp) in the arguments +! - Add the 3D Phase cloud fraction (lidarcldphase) in the arguments +! - Add the Phase low mid high cloud fraction (cldlayerphase) in the arguments +! - Add the 3D Phase cloud fraction as a function of temperature (lidarcldtmp) in the arguments +! - Modification of the phase diagnosis within the COSP_CLDFRAC routine to integrate the phase +! diagnosis (3D, low/mid/high, 3D temperature) +! 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 +! +! ------------------------------------------------------------------------------------ + +! c inputs : + integer npoints + integer ncol + integer llm + integer max_bin ! nb of bins for SR CFADs + integer ncat ! nb of cloud layer types (low,mid,high,total) + integer ntype ! nb of OPAQ products (opaque and thin clouds, z_opaque) !OPAQ + integer nrefl ! nb of solar zenith angles for parasol reflectances + + real undef ! undefined value + real pnorm(npoints,ncol,llm) ! lidar ATB + real pmol(npoints,llm) ! molecular ATB + real land(npoints) ! Landmask [0 - Ocean, 1 - Land] + real pplay(npoints,llm) ! pressure on model levels (Pa) + logical ok_lidar_cfad ! true if lidar CFAD diagnostics need to be computed + real refl(npoints,ncol,nrefl) ! subgrid parasol reflectance ! parasol + real tmp(npoints,llm) ! temp at each levels + real pnorm_perp(npoints,ncol,llm) ! lidar perpendicular ATB + real vgrid_z(llm) ! mid-level altitude of the output vertical grid !OPAQ + +! c outputs : + real lidarcld(npoints,llm) ! 3D "lidar" cloud fraction + real lidarcldtype(npoints,llm,ntype+1) ! 3D "lidar" OPAQ type fraction + opacity !OPAQ + real sub(npoints,llm) ! 3D "lidar" indice + real cldlayer(npoints,ncat) ! "lidar" cloud layer fraction (low, mid, high, total) + real cldtype(npoints,ntype) ! "lidar" OPAQ type covers (opaque/thin cloud + z_opaque) !OPAQ + + real cfad2(npoints,max_bin,llm) ! CFADs of SR + real srbval(max_bin) ! SR bins in CFADs + real parasolrefl(npoints,nrefl)! grid-averaged parasol reflectance +! real profSR(npoints,ncol,llm) ! tableau avec les subcolumns SR !TIBO + real profSR(npoints,llm,ncol) ! tableau avec les subcolumns SR !TIBO2 + +! c threshold for cloud detection : + real S_clr + parameter (S_clr = 1.2) + real S_cld + parameter (S_cld = 5.) ! Thresold for cloud detection + real S_att + parameter (S_att = 0.01) +! parameter (S_att = 0.06) !OPAQ ! Threshold for "surface detection" equivalent + +! c local variables : + integer ic,k,i,j + real x3d(npoints,ncol,llm) + real x3d_c(npoints,llm),pnorm_c(npoints,llm) + real xmax + +! Output variables + integer,parameter :: nphase = 6 ! nb of cloud layer phase types (ice,liquid,undefined,false ice,false liquid,Percent of ice) + real lidarcldphase(npoints,llm,nphase) ! 3D "lidar" phase cloud fraction + real lidarcldtmp(npoints,40,5) ! 3D "lidar" phase cloud fraction as a function of temp + real cldlayerphase(npoints,ncat,nphase) ! "lidar" phase low mid high cloud fraction + +! SR detection threshold + real, parameter :: S_cld_att = 30. ! New threshold for undefine cloud phase detection + + +! +! c ------------------------------------------------------- +! c 0- Initializations +! c ------------------------------------------------------- +! +! Should be modified in future version + xmax=undef-1.0 + +! c ------------------------------------------------------- +! c 1- Lidar scattering ratio : +! c ------------------------------------------------------- + + 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 = undef + end where + x3d(:,ic,:) = x3d_c +! profSR(:,ic,:) = x3d(:,ic,:) !TIBO + profSR(:,:,ic) = x3d(:,ic,:) !TIBO2 + enddo + +! c ------------------------------------------------------- +! c 2- Diagnose cloud fractions (3D, low, middle, high, total) +! c from subgrid-scale lidar scattering ratios : +! c ------------------------------------------------------- + + CALL COSP_CLDFRAC(npoints,ncol,llm,ncat,nphase, & + tmp,x3d,pnorm,pnorm_perp,pplay, S_att,S_cld,S_cld_att,undef,lidarcld, & + cldlayer,lidarcldphase,sub,cldlayerphase,lidarcldtmp) + + CALL COSP_OPAQ(npoints,ncol,llm,ntype,x3d,S_cld,undef,lidarcldtype, & !OPAQ + cldtype,vgrid_z) !OPAQ + +! c ------------------------------------------------------- +! c 3- CFADs +! c ------------------------------------------------------- + if (ok_lidar_cfad) then +! +! c CFADs of subgrid-scale lidar scattering ratios : +! c ------------------------------------------------------- + CALL COSP_CFAD_SR(npoints,ncol,llm,max_bin,undef, & + x3d, & + S_att,S_clr,xmax,cfad2,srbval) + + endif ! ok_lidar_cfad +! c ------------------------------------------------------- + +! c ------------------------------------------------------- +! c 4- Compute grid-box averaged Parasol reflectances +! c ------------------------------------------------------- + + parasolrefl(:,:) = 0.0 + + 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=undef +! if land=0 -> parasolrefl=parasolrefl + parasolrefl(:,k) = parasolrefl(:,k) * MAX(1.0-land(:),0.0) & + + (1.0 - MAX(1.0-land(:),0.0))*undef + enddo + + RETURN + END SUBROUTINE diag_lidar + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- FUNCTION COSP_CFAD_SR ------------------------ +! Author: Sandrine Bony (LMD/IPSL, CNRS, Paris) +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CFAD_SR(Npoints,Ncolumns,Nlevels,Nbins,undef, & + x,S_att,S_clr,xmax,cfad,srbval) + IMPLICIT NONE + +!--- Input arguments +! Npoints: Number of horizontal points +! Ncolumns: Number of subcolumns +! Nlevels: Number of levels +! Nbins: Number of x axis bins +! xmax: maximum value allowed for x +! S_att: Threshold for full attenuation +! S_clr: Threshold for clear-sky layer +! +!--- Input-Outout arguments +! x: variable to process (Npoints,Ncolumns,Nlevels), mofified where saturation occurs +! +! -- Output arguments +! srbval : values of the histogram bins +! cfad: 2D histogram on each horizontal point + +! Input arguments + integer Npoints,Ncolumns,Nlevels,Nbins + real xmax,S_att,S_clr,undef +! Input-output arguments + real x(Npoints,Ncolumns,Nlevels) +! Output : + real cfad(Npoints,Nbins,Nlevels) + real srbval(Nbins) +! Local variables + integer i, j, k, ib + real srbval_ext(0:Nbins) + +! c ------------------------------------------------------- +! c 0- Initializations +! c ------------------------------------------------------- + if ( Nbins .lt. 6) return + + srbval(1) = S_att + srbval(2) = S_clr + srbval(3) = 3.0 + srbval(4) = 5.0 + srbval(5) = 7.0 + srbval(6) = 10.0 + do i = 7, MIN(10,Nbins) + srbval(i) = srbval(i-1) + 5.0 + enddo + DO i = 11, MIN(13,Nbins) + srbval(i) = srbval(i-1) + 10.0 + enddo + srbval(MIN(14,Nbins)) = 80.0 + srbval(Nbins) = xmax + cfad(:,:,:) = 0.0 + + srbval_ext(1:Nbins) = srbval + srbval_ext(0) = -1.0 +! c ------------------------------------------------------- +! c c- Compute CFAD +! c ------------------------------------------------------- + do j = 1, Nlevels + do ib = 1, Nbins + do k = 1, Ncolumns + do i = 1, Npoints + if (x(i,k,j) /= undef) then + if ((x(i,k,j).gt.srbval_ext(ib-1)).and.(x(i,k,j).le.srbval_ext(ib))) & + cfad(i,ib,j) = cfad(i,ib,j) + 1.0 + else + cfad(i,ib,j) = undef + endif + enddo + enddo + enddo + enddo + + where (cfad .ne. undef) cfad = cfad / float(Ncolumns) + +! c ------------------------------------------------------- + RETURN + END SUBROUTINE COSP_CFAD_SR + + +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% +!-------------------- SUBROUTINE COSP_CLDFRAC ------------------- +! c Purpose: Cloud fraction diagnosed from lidar measurements +!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% + SUBROUTINE COSP_CLDFRAC(Npoints,Ncolumns,Nlevels,Ncat,Nphase, & + tmp,x,ATB,ATBperp,pplay,S_att,S_cld,S_cld_att,undef,lidarcld, & + cldlayer,lidarcldphase,nsub,cldlayerphase,lidarcldtemp) + + + IMPLICIT NONE +! Input arguments + integer Npoints,Ncolumns,Nlevels,Ncat + real x(Npoints,Ncolumns,Nlevels) + + +! Local parameters + integer nphase ! nb of cloud layer phase types + ! (ice,liquid,undefined,false ice,false liquid,Percent of ice) + integer,parameter :: Ntemp=40 ! indice of the temperature vector + integer ip, k, iz, ic, ncol, nlev, i, itemp ! loop indice + real S_cld_att ! New threshold for undefine cloud phase detection (SR=30) + integer toplvlsat ! level of the first cloud with SR>30 + real alpha50, beta50, gamma50, delta50, epsilon50, zeta50 ! Polynomial Coef of the phase + ! discrimination line + +! Input variables + real tmp(Npoints,Nlevels) ! temperature + real ATB(Npoints,Ncolumns,Nlevels) ! 3D Attenuated backscatter + real ATBperp(Npoints,Ncolumns,Nlevels) ! 3D perpendicular attenuated backscatter + real pplay(Npoints,Nlevels) + real S_att,S_cld + real undef + +! Output variables + real lidarcldtemp(Npoints,Ntemp,5) ! 3D Temperature 1=tot,2=ice,3=liq,4=undef,5=ice/ice+liq + real tempmod(Ntemp+1) ! temperature bins + real lidarcldphase(Npoints,Nlevels,Nphase) ! 3D cloud phase fraction + real cldlayerphase(Npoints,Ncat,Nphase) ! low, middle, high, total cloud fractions for ice liquid and undefine phase + real lidarcld(Npoints,Nlevels) ! 3D cloud fraction + real cldlayer(Npoints,Ncat) ! low, middle, high, total cloud fractions + +! Local variables + real tmpi(Npoints,Ncolumns,Nlevels) ! temperature of ice cld + real tmpl(Npoints,Ncolumns,Nlevels) ! temperature of liquid cld + real tmpu(Npoints,Ncolumns,Nlevels) ! temperature of undef cld + + real checktemp, ATBperp_tmp ! temporary variable + real checkcldlayerphase, checkcldlayerphase2 ! temporary variable + real sumlidarcldtemp(Npoints,Ntemp) ! temporary variable + + real cldlayphase(Npoints,Ncolumns,Ncat,Nphase) ! subgrided low mid high phase cloud fraction + real cldlayerphasetmp(Npoints,Ncat) ! temporary variable + real cldlayerphasesum(Npoints,Ncat) ! temporary variable + real lidarcldtempind(Npoints,Ntemp) ! 3D Temperature indice + real lidarcldphasetmp(Npoints,Nlevels) ! 3D sum of ice and liquid cloud occurences + + +! Local variables + real p1 + real cldy(Npoints,Ncolumns,Nlevels) + real srok(Npoints,Ncolumns,Nlevels) + real cldlay(Npoints,Ncolumns,Ncat) + real nsublay(Npoints,Ncolumns,Ncat), nsublayer(Npoints,Ncat) + real nsub(Npoints,Nlevels) + +#ifdef SYS_SX + real cldlay1(Npoints,Ncolumns) + real cldlay2(Npoints,Ncolumns) + real cldlay3(Npoints,Ncolumns) + real nsublay1(Npoints,Ncolumns) + real nsublay2(Npoints,Ncolumns) + real nsublay3(Npoints,Ncolumns) +#endif + + + + +! --------------------------------------------------------------- +! 1- initialization +! --------------------------------------------------------------- + + if ( Ncat .ne. 4 ) then + print *,'Error in lmd_ipsl_stats.cosp_cldfrac, Ncat must be 4, not',Ncat + stop + endif + + lidarcld = 0.0 + nsub = 0.0 + cldlay = 0.0 + nsublay = 0.0 + + ATBperp_tmp = 0. + lidarcldphase(:,:,:) = 0. + cldlayphase(:,:,:,:) = 0. + cldlayerphase(:,:,:) = 0. + tmpi(:,:,:) = 0. + tmpl(:,:,:) = 0. + tmpu(:,:,:) = 0. + cldlayerphasesum(:,:) = 0. + lidarcldtemp(:,:,:) = 0. + lidarcldtempind(:,:) = 0. + sumlidarcldtemp(:,:) = 0. + toplvlsat=0 + lidarcldphasetmp(:,:) = 0. + +! temperature bins + tempmod=(/-273.15,-90.,-87.,-84.,-81.,-78.,-75.,-72.,-69.,-66.,-63.,-60.,-57., & + -54.,-51.,-48.,-45.,-42.,-39.,-36.,-33.,-30.,-27.,-24.,-21.,-18., & + -15.,-12.,-9.,-6.,-3.,0.,3.,6.,9.,12.,15.,18.,21.,24.,200. /) + +! convert C to K + tempmod=tempmod+273.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 + alpha50 = 9.0322e+15 + beta50 = -2.1358e+12 + gamma50 = 173.3963e06 + delta50 = -3.9514e03 + epsilon50 = 0.2559 + zeta50 = -9.4776e-07 + + +! --------------------------------------------------------------- +! 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.0 + elsewhere + cldy(:,:,k)=0.0 + endwhere + +! number of usefull sub-columns: + where ( (x(:,:,k).gt.S_att) .and. (x(:,:,k).ne. undef) ) + srok(:,:,k)=1.0 + elsewhere + srok(:,:,k)=0.0 + endwhere + + enddo ! k + + +! --------------------------------------------------------------- +! 3- grid-box 3D cloud fraction and layered cloud fractions (ISCCP pressure +! categories) : +! --------------------------------------------------------------- + lidarcld = 0.0 + nsub = 0.0 +#ifdef SYS_SX +!! XXX: Use cldlay[1-3] and nsublay[1-3] to avoid bank-conflicts. + cldlay1 = 0.0 + cldlay2 = 0.0 + cldlay3 = 0.0 + cldlay(:,:,4) = 0.0 !! XXX: Ncat == 4 + nsublay1 = 0.0 + nsublay2 = 0.0 + nsublay3 = 0.0 + nsublay(:,:,4) = 0.0 + + do k = Nlevels, 1, -1 + do ic = 1, Ncolumns + do ip = 1, Npoints + + if(srok(ip,ic,k).gt.0.)then + ! Computation of the cloud fraction as a function of the temperature + ! instead of height, for ice,liquid and all clouds + 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. + 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. + endif + enddo + endif + + p1 = pplay(ip,k) + + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds + cldlay3(ip,ic) = MAX(cldlay3(ip,ic), cldy(ip,ic,k)) + nsublay3(ip,ic) = MAX(nsublay3(ip,ic), srok(ip,ic,k)) + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid clouds + cldlay2(ip,ic) = MAX(cldlay2(ip,ic), cldy(ip,ic,k)) + nsublay2(ip,ic) = MAX(nsublay2(ip,ic), srok(ip,ic,k)) + else + cldlay1(ip,ic) = MAX(cldlay1(ip,ic), cldy(ip,ic,k)) + nsublay1(ip,ic) = MAX(nsublay1(ip,ic), srok(ip,ic,k)) + endif + + 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,4) = MAX(nsublay(ip,ic,4),srok(ip,ic,k)) + nsub(ip,k)=nsub(ip,k) + srok(ip,ic,k) + enddo + enddo + enddo + cldlay(:,:,1) = cldlay1 + cldlay(:,:,2) = cldlay2 + cldlay(:,:,3) = cldlay3 + nsublay(:,:,1) = nsublay1 + nsublay(:,:,2) = nsublay2 + nsublay(:,:,3) = nsublay3 +#else + cldlay = 0.0 + nsublay = 0.0 + do k = Nlevels, 1, -1 + 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. + 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. + endif + enddo + endif +! + + iz=1 + p1 = pplay(ip,k) + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high clouds + iz=3 + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) 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 +#endif + + +! -- grid-box 3D cloud fraction + + where ( nsub(:,:).gt.0.0 ) + lidarcld(:,:) = lidarcld(:,:)/nsub(:,:) + elsewhere + lidarcld(:,:) = undef + endwhere + +! -- layered cloud fractions + + cldlayer = 0.0 + nsublayer = 0.0 + + 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=Nlevels,18,-1 ! from 19.2km until 8.16km + p1 = pplay(i,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. ! false ice detection ==> added to Liquid + tmpl(i,ncol,nlev)=tmp(i,nlev) + lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1. ! 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.*100.)) then ! high cloud + cldlayphase(i,ncol,3,2) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,2) = 1. + else ! low cloud + cldlayphase(i,ncol,1,2) = 1. + endif + cldlayphase(i,ncol,4,5) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,5) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,5) = 1. + else ! low cloud + cldlayphase(i,ncol,1,5) = 1. + endif + + else + ! ICE with temperature below 273,15°K + lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1. + tmpi(i,ncol,nlev)=tmp(i,nlev) + cldlayphase(i,ncol,4,1) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,1) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,1) = 1. + else ! low cloud + cldlayphase(i,ncol,1,1) = 1. + endif + + endif + +!____________________________________________________________________________________________________ +! +! 4.1.b Liquid: ATBperp below the phase discrimination line +!____________________________________________________________________________________________________ +! + else ! Liquid clouds + ! Liquid with temperature above 231,15°K + if(tmp(i,nlev).gt.231.15)then + lidarcldphase(i,nlev,2)=lidarcldphase(i,nlev,2)+1. + tmpl(i,ncol,nlev)=tmp(i,nlev) + cldlayphase(i,ncol,4,2) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,2) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,2) = 1. + else ! low cloud + cldlayphase(i,ncol,1,2) = 1. + 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. ! false liquid detection ==> added to ice + lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1. ! keep the information "temperature criterium used" + ! to classify the phase cloud + cldlayphase(i,ncol,4,4) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,4) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,4) = 1. + else ! low cloud + cldlayphase(i,ncol,1,4) = 1. + endif + cldlayphase(i,ncol,4,1) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,1) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,1) = 1. + else ! low cloud + cldlayphase(i,ncol,1,1) = 1. + 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=17,1,-1 ! from 8.16km until 0km + p1 = pplay(i,nlev) + + if( (cldy(i,ncol,nlev).eq.1.) .and. (ATBperp(i,ncol,nlev).gt.0.) )then +! Phase discrimination line : ATBperp = ATB^5*alpha50 + ATB^4*beta50 + ATB^3*gamma50 + ATB^2*delta50 +! + ATB*epsilon50 + zeta50 +! 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. ! false ice ==> liq + tmpl(i,ncol,nlev)=tmp(i,nlev) + lidarcldphase(i,nlev,5)=lidarcldphase(i,nlev,5)+1. + + cldlayphase(i,ncol,4,2) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,2) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,2) = 1. + else ! low cloud + cldlayphase(i,ncol,1,2) = 1. + endif + + cldlayphase(i,ncol,4,5) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,5) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,5) = 1. + else ! low cloud + cldlayphase(i,ncol,1,5) = 1. + endif + + else + ! ICE with temperature below 273,15°K + lidarcldphase(i,nlev,1)=lidarcldphase(i,nlev,1)+1. + tmpi(i,ncol,nlev)=tmp(i,nlev) + + cldlayphase(i,ncol,4,1) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,1) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,1) = 1. + else ! low cloud + cldlayphase(i,ncol,1,1) = 1. + 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. + tmpl(i,ncol,nlev)=tmp(i,nlev) + + cldlayphase(i,ncol,4,2) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,2) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,2) = 1. + else ! low cloud + cldlayphase(i,ncol,1,2) = 1. + 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. ! false liq ==> ice + lidarcldphase(i,nlev,4)=lidarcldphase(i,nlev,4)+1. ! false liq ==> ice + + cldlayphase(i,ncol,4,4) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,4) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,4) = 1. + else ! low cloud + cldlayphase(i,ncol,1,4) = 1. + endif + + cldlayphase(i,ncol,4,1) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,1) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,1) = 1. + else ! low cloud + cldlayphase(i,ncol,1,1) = 1. + 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,1,-1 + p1 = pplay(i,nlev) + if(cldy(i,ncol,nlev).eq.1.)then + lidarcldphase(i,nlev,3)=lidarcldphase(i,nlev,3)+1. + tmpu(i,ncol,nlev)=tmp(i,nlev) + + cldlayphase(i,ncol,4,3) = 1. ! tot cloud + if ( p1.gt.0. .and. p1.lt.(440.*100.)) then ! high cloud + cldlayphase(i,ncol,3,3) = 1. + else if(p1.ge.(440.*100.) .and. p1.lt.(680.*100.)) then ! mid cloud + cldlayphase(i,ncol,2,3) = 1. + else ! low cloud + cldlayphase(i,ncol,1,3) = 1. + 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(:,:).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. + 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. + 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. + 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=sum(lidarcldtemp(:,:,2:3),3) + sumlidarcldtemp(:,:)=lidarcldtemp(:,:,2)+lidarcldtemp(:,:,3) + +WHERE(sumlidarcldtemp(:,:)>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 +! --------------------------------------------------------------- + +! BEGINNING OF OPAQ CHANGES + ! #################################################################################### + ! SUBROUTINE cosp_opaq + ! Conventions: Ntype must be equal to 3 (opaque cloud, thin cloud, z_opaque) + ! #################################################################################### + SUBROUTINE COSP_OPAQ(Npoints,Ncolumns,Nlevels,Ntype,x,S_cld,undef,lidarcldtype, & + cldtype,vgrid_z) + + IMPLICIT NONE +! Input arguments + integer Npoints,Ncolumns,Nlevels,Ntype + real x(Npoints,Ncolumns,Nlevels) + real S_cld + real undef + real vgrid_z(Nlevels) +! Output : + real lidarcldtype(Npoints,Nlevels,Ntype+1) ! 3D "lidar" OPAQ type + opacity fraction + real cldtype(Npoints,Ntype) ! opaque and thin cloud covers, z_opaque +! Local variables + integer ip, k, iz, ic, zopac + real p1 + real cldy(Npoints,Ncolumns,Nlevels) + real cldyopaq(Npoints,Ncolumns,Nlevels) + real srok(Npoints,Ncolumns,Nlevels) + real srokopaq(Npoints,Ncolumns,Nlevels) + real cldlay(Npoints,Ncolumns,Ntype+1) ! opaque, thin, z_opaque and all cloud cover + real nsublay(Npoints,Ncolumns,Ntype+1) ! opaque, thin, z_opaque and all cloud cover + real nsublayer(Npoints,Ntype) + real nsub(Npoints,Nlevels) + real nsubopaq(Npoints,Nlevels) + real S_att_opaq + real S_att + + ! #################################################################################### + ! 1) Initialize + ! #################################################################################### + cldtype = 0.0 + lidarcldtype = 0.0 + nsub = 0.0 + nsubopaq = 0.0 + cldlay = 0.0 + nsublay = 0.0 + nsublayer = 0.0 + S_att_opaq = 0.06 ! Fully Attenuated threshold, from Guzman et al. 2017, JGR-A + S_att = 0.01 + + ! #################################################################################### + ! 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.0 + elsewhere + cldy(:,:,k)=0.0 + endwhere + ! Fully attenuated layer detection at subgrid-scale: + where ( (x(:,:,k) .gt. 0.0) .and. (x(:,:,k) .lt. S_att_opaq) .and. (x(:,:,k) .ne. undef) ) + cldyopaq(:,:,k)=1.0 + elsewhere + cldyopaq(:,:,k)=0.0 + endwhere + + ! Number of useful sub-column layers: + where ( (x(:,:,k) .gt. S_att) .and. (x(:,:,k) .ne. undef) ) + srok(:,:,k)=1.0 + elsewhere + srok(:,:,k)=0.0 + endwhere + ! Number of useful sub-columns layers for z_opaque 3D fraction: + where ( (x(:,:,k) .gt. 0.0) .and. (x(:,:,k) .ne. undef) ) + srokopaq(:,:,k)=1.0 + elsewhere + srokopaq(:,:,k)=0.0 + endwhere + enddo + + ! #################################################################################### + ! 3) Grid-box 3D OPAQ product fraction and cloud type cover (opaque/thin) + mean z_opaque + ! #################################################################################### + + do k= Nlevels,1,-1 + do ic = 1, Ncolumns + do ip = 1, Npoints + + cldlay(ip,ic,1) = MAX(cldlay(ip,ic,1),cldyopaq(ip,ic,k)) ! Opaque clouds + cldlay(ip,ic,4) = MAX(cldlay(ip,ic,4),cldy(ip,ic,k)) ! All clouds + + 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) .eq. 1.0) .and. (cldlay(ip,ic,1) .eq. 0.0) ) then + cldlay(ip,ic,2) = 1.0 + endif + + ! Filling in 3D and 2D variables + + ! Opaque cloud profiles + if ( cldlay(ip,ic,1) .eq. 1.0 ) then + zopac = 0.0 + do k=2,Nlevels + ! Declaring opaque cloud fraction and z_opaque altitude for 3D and 2D variables + if ( (cldy(ip,ic,k) .eq. 1.0) .and. (zopac .eq. 0.0) ) then + lidarcldtype(ip,k-1,3) = lidarcldtype(ip,k-1,3) + 1.0 + cldlay(ip,ic,3) = vgrid_z(k-1) !z_opaque altitude + nsublay(ip,ic,3) = 1.0 + zopac = 1.0 + endif + if ( cldy(ip,ic,k) .eq. 1.0 ) then + lidarcldtype(ip,k,1) = lidarcldtype(ip,k,1) + 1.0 + endif + enddo + endif + + ! Thin cloud profiles + if ( cldlay(ip,ic,2) .eq. 1.0 ) then + do k=1,Nlevels + ! Declaring thin cloud fraction for 3D variable + if ( cldy(ip,ic,k) .eq. 1.0 ) then + lidarcldtype(ip,k,2) = lidarcldtype(ip,k,2) + 1.0 + endif + enddo + endif + + enddo + enddo + + ! 3D cloud types fraction (opaque=1 and thin=2) + where ( nsub(:,:) .gt. 0.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.0 ) + lidarcldtype(:,:,3) = lidarcldtype(:,:,3)/nsubopaq(:,:) + elsewhere + lidarcldtype(:,:,3) = undef + endwhere + ! 3D opacity fraction (=4) !Summing z_opaque fraction from TOA(k=Nlevels) to SFC(k=1) + lidarcldtype(:,Nlevels,4) = lidarcldtype(:,Nlevels,3) + do ip = 1, Npoints + do k = Nlevels-1, 1, -1 + if ( lidarcldtype(ip,k,3) .ne. undef ) then + lidarcldtype(ip,k,4) = lidarcldtype(ip,k+1,4) + lidarcldtype(ip,k,3) + endif + enddo + enddo + where ( nsubopaq(:,:) .eq. 0.0 ) + lidarcldtype(:,:,4) = undef + endwhere + + ! 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 + where (nsublayer(:,:) .gt. 0.0) + cldtype(:,:) = cldtype(:,:)/nsublayer(:,:) + elsewhere + cldtype(:,:) = undef + endwhere + + END SUBROUTINE COSP_OPAQ +! END OF OPAQ CHANGES + + +END MODULE MOD_LMD_IPSL_STATS Index: LMDZ6/trunk/libf/phylmd/cosp/mod_modis_sim.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mod_modis_sim.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/mod_modis_sim.F90 (revision 3233) @@ -0,0 +1,1274 @@ +! (c) 2009-2010, Regents of the Unversity of Colorado +! Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences +! All rights reserved. +! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $ +! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MODIS_simulator/modis_simulator.F90 $ +! +! Redistribution and use in source and binary forms, with or without modification, are permitted +! provided that the following conditions are met: +! +! * Redistributions of source code must retain the above copyright notice, this list +! of conditions and the following disclaimer. +! * Redistributions in binary form must reproduce the above copyright notice, this list +! of conditions and the following disclaimer in the documentation and/or other materials +! provided with the distribution. +! * Neither the name of the Met Office nor the names of its contributors may be used +! to endorse or promote products derived from this software without specific prior written +! permission. +! +! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR +! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND +! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR +! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL +! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER +! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT +! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. +! + +! +! 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 +! + +! +! 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_TYPES, only: R_UNDEF + implicit none + ! ------------------------------ + ! Algorithmic parameters + ! + + real, parameter :: ice_density = 0.93 ! liquid density is 1. + ! + ! Retrieval parameters + ! + real, parameter :: min_OpticalThickness = 0.3, & ! Minimum detectable optical thickness + CO2Slicing_PressureLimit = 700. * 100., & ! Cloud with higher pressures use thermal methods, units Pa + CO2Slicing_TauLimit = 1., & ! How deep into the cloud does CO2 slicing see? + phase_TauLimit = 1., & ! How deep into the cloud does the phase detection see? + size_TauLimit = 2., & ! Depth of the re retreivals + phaseDiscrimination_Threshold = 0.7 ! What fraction of total extincton needs to be + ! in a single category to make phase discrim. work? + real, parameter :: re_fill= -999. + integer, parameter :: phaseIsNone = 0, phaseIsLiquid = 1, phaseIsIce = 2, phaseIsUndetermined = 3 + + logical, parameter :: useSimpleReScheme = .false. + ! + ! These are the limits of the libraries for the MODIS collection 5 algorithms + ! They are also the limits used in the fits for g and w0 + ! + real, parameter :: re_water_min= 4., re_water_max= 30., re_ice_min= 5., re_ice_max= 90. + integer, parameter :: num_trial_res = 15 ! increase to make the linear pseudo-retrieval of size more accurate +! DJS2015: Remove unused parameter +! logical, parameter :: use_two_re_iterations = .false. ! do two retrieval iterations? +! DJS2015 END + ! + ! Precompute near-IR optical params vs size for retrieval scheme + ! + integer, private :: i + real, dimension(num_trial_res), parameter :: & + trial_re_w = re_water_min + (re_water_max - re_water_min)/(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /), & + trial_re_i = re_ice_min + (re_ice_max - re_ice_min) /(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /) + + ! Can't initialze these during compilation, but do in before looping columns in retrievals + real, dimension(num_trial_res) :: g_w, g_i, w0_w, w0_i + ! ------------------------------ + ! Bin boundaries for the joint optical thickness/cloud top pressure histogram + ! + integer, parameter :: numTauHistogramBins = 6, numPressureHistogramBins = 7 + + real, private :: dummy_real + real, dimension(numTauHistogramBins + 1), parameter :: & + tauHistogramBoundaries = (/ min_OpticalThickness, 1.3, 3.6, 9.4, 23., 60., 10000. /) + real, dimension(numPressureHistogramBins + 1), parameter :: & ! Units Pa + pressureHistogramBoundaries = (/ 0., 18000., 31000., 44000., 56000., 68000., 80000., 1000000. /) + real, parameter :: highCloudPressureLimit = 440. * 100., lowCloudPressureLimit = 680. * 100. + ! + ! For output - nominal bin centers and bin boundaries. On output pressure bins are highest to lowest. + ! + integer, private :: k, l + real, parameter, dimension(2, numTauHistogramBins) :: & + nominalTauHistogramBoundaries = & + reshape(source = (/ tauHistogramBoundaries(1), & + ((tauHistogramBoundaries(k), l = 1, 2), k = 2, numTauHistogramBins), & + 100000. /), & + shape = (/2, numTauHistogramBins /) ) + real, parameter, dimension(numTauHistogramBins) :: & + nominalTauHistogramCenters = (nominalTauHistogramBoundaries(1, :) + & + nominalTauHistogramBoundaries(2, :) ) / 2. + + real, parameter, dimension(2, numPressureHistogramBins) :: & + nominalPressureHistogramBoundaries = & + reshape(source = (/ 100000., & + ((pressureHistogramBoundaries(k), l = 1, 2), k = numPressureHistogramBins, 2, -1), & + 0. /), & + shape = (/2, numPressureHistogramBins /) ) + real, parameter, dimension(numPressureHistogramBins) :: & + nominalPressureHistogramCenters = (nominalPressureHistogramBoundaries(1, :) + & + nominalPressureHistogramBoundaries(2, :) ) / 2. + ! DJS2015 START: Add bin descriptions for joint-histograms of partice-sizes and optical depth. This is + ! identical to what is done in COSPv.2.0.0 for histogram bin initialization. + integer :: j + integer,parameter :: & + numMODISReffLiqBins = 6, & ! Number of bins for tau/ReffLiq joint-histogram + numMODISReffIceBins = 6 ! Number of bins for tau/ReffICE joint-histogram + real,parameter,dimension(numMODISReffLiqBins+1) :: & + reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/) + real,parameter,dimension(numMODISReffIceBins+1) :: & + reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/) + real,parameter,dimension(2,numMODISReffIceBins) :: & + reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k), & + l=1,2),k=2,numMODISReffIceBins),reffICE_binBounds(numMODISReffIceBins+1)/), & + shape = (/2,numMODISReffIceBins/)) + real,parameter,dimension(2,numMODISReffLiqBins) :: & + reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k), & + l=1,2),k=2,numMODISReffLiqBins),reffLIQ_binBounds(numMODISReffIceBins+1)/), & + shape = (/2,numMODISReffLiqBins/)) + real,parameter,dimension(numMODISReffIceBins) :: & + reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2. + real,parameter,dimension(numMODISReffLiqBins) :: & + reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2. + ! DJS2015 END + + ! ------------------------------ + ! There are two ways to call the MODIS simulator: + ! 1) Provide total optical thickness and liquid/ice water content and we'll partition tau in + ! subroutine modis_L2_simulator_oneTau, or + ! 2) Provide ice and liquid optical depths in each layer + ! + interface modis_L2_simulator + module procedure modis_L2_simulator_oneTau, modis_L2_simulator_twoTaus + end interface +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_L2_simulator_twoTaus( & + temp, pressureLayers, pressureLevels, & + liquid_opticalThickness, ice_opticalThickness, & + waterSize, iceSize, & + isccpTau, isccpCloudTopPressure, & + retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize) + + ! Grid-mean quantities at layer centers, starting at the model top + ! dimension nLayers + real, dimension(:), intent(in ) :: temp, & ! Temperature, K + pressureLayers, & ! Pressure, Pa + pressureLevels ! Pressure at layer edges, Pa (dimension nLayers + 1) + ! Sub-column quantities + ! dimension nSubcols, nLayers + real, dimension(:, :), intent(in ) :: liquid_opticalThickness, & ! Layer optical thickness @ 0.67 microns due to liquid + ice_opticalThickness ! ditto, due to ice + real, dimension(:, :), intent(in ) :: waterSize, & ! Cloud drop effective radius, microns + iceSize ! Cloud ice effective radius, microns + + ! Cloud properties retrieved from ISCCP using top_height = 1 + ! dimension nSubcols + real, dimension(:), intent(in ) :: isccpTau, & ! Column-integrated optical thickness + isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) + + ! Properties retrieved by MODIS + ! dimension nSubcols + integer, dimension(:), intent(out) :: retrievedPhase ! liquid/ice/other - integer, defined in module header + real, dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers + retrievedTau, & ! unitless + retrievedSize ! microns + ! --------------------------------------------------- + ! Local variables + logical, dimension(size(retrievedTau)) :: cloudMask + real, dimension(size(waterSize, 1), size(waterSize, 2)) :: tauLiquidFraction, tauTotal + real :: integratedLiquidFraction + integer :: i, nSubcols, nLevels + + ! --------------------------------------------------- + nSubcols = size(liquid_opticalThickness, 1) + nLevels = size(liquid_opticalThickness, 2) + + ! + ! Initial error checks + ! + if(any((/ size(ice_opticalThickness, 1), size(waterSize, 1), size(iceSize, 1), & + size(isccpTau), size(isccpCloudTopPressure), & + size(retrievedPhase), size(retrievedCloudTopPressure), & + size(retrievedTau), size(retrievedSize) /) /= nSubcols )) & + call complain_and_die("Differing number of subcolumns in one or more arrays") + + if(any((/ size(ice_opticalThickness, 2), size(waterSize, 2), size(iceSize, 2), & + size(temp), size(pressureLayers), size(pressureLevels)-1 /) /= nLevels )) & + call complain_and_die("Differing number of levels in one or more arrays") + + + if(any( (/ any(temp <= 0.), any(pressureLayers <= 0.), & + any(liquid_opticalThickness < 0.), & + any(ice_opticalThickness < 0.), & + any(waterSize < 0.), any(iceSize < 0.) /) )) & + call complain_and_die("Input values out of bounds") + + ! --------------------------------------------------- + ! + ! Compute the total optical thickness and the proportion due to liquid in each cell + ! + where(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) > 0.) + tauLiquidFraction(:, :) = liquid_opticalThickness(:, :)/(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :)) + elsewhere + tauLiquidFraction(:, :) = 0. + end where + tauTotal(:, :) = liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) + + ! + ! 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(:) = sum(tauTotal(:, :), dim = 2) + + ! + ! Cloud detection - does optical thickness exceed detection threshold? + ! + cloudMask = retrievedTau(:) >= min_OpticalThickness + + ! + ! Initialize initial estimates for size retrievals + ! + if(any(cloudMask) .and. .not. useSimpleReScheme) then + g_w(:) = get_g_nir( phaseIsLiquid, trial_re_w(:)) + w0_w(:) = get_ssa_nir(phaseIsLiquid, trial_re_w(:)) + g_i(:) = get_g_nir( phaseIsIce, trial_re_i(:)) + w0_i(:) = get_ssa_nir(phaseIsIce, trial_re_i(:)) + end if + + 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((/ 0., tauTotal(i, :) /), & + pressureLevels, & + 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(tauTotal(i, :), & + tauLiquidFraction(i, :), & + phase_TauLimit) + if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then + retrievedPhase(i) = phaseIsLiquid + else if (integratedLiquidFraction <= 1.- phaseDiscrimination_Threshold) then + retrievedPhase(i) = phaseIsIce + else + retrievedPhase(i) = phaseIsUndetermined + end if + + ! + ! Size determination + ! + if(useSimpleReScheme) then + ! This is the extinction-weighted size considering only the phase we've chosen + ! + if(retrievedPhase(i) == phaseIsIce) then + retrievedSize(i) = weight_by_extinction(ice_opticalThickness(i, :), & + iceSize(i, :), & + (1. - integratedLiquidFraction) * size_TauLimit) + + else if(retrievedPhase(i) == phaseIsLiquid) then + retrievedSize(i) = weight_by_extinction(liquid_opticalThickness(i, :), & + waterSize(i, :), & + integratedLiquidFraction * size_TauLimit) + + else + retrievedSize(i) = 0. + end if + else + retrievedSize(i) = 1.0e-06*retrieve_re(retrievedPhase(i), retrievedTau(i), & + obs_Refl_nir = compute_nir_reflectance(liquid_opticalThickness(i, :), waterSize(i, :)*1.0e6, & + ice_opticalThickness(i, :), iceSize(i, :)*1.0e6)) + end if + 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(:) < 0.).and.(retrievedSize(:) /= R_UNDEF)) retrievedSize(:) = 1.0e-06*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(:) .and. retrievedCloudTopPressure(:) > CO2Slicing_PressureLimit) & + retrievedCloudTopPressure(:) = isccpCloudTopPressure * 100. + + end subroutine modis_L2_simulator_twoTaus + !------------------------------------------------------------------------------------------------ + ! + ! MODIS simulator: provide a single optical thickness and the cloud ice and liquid contents; + ! we'll partition this into ice and liquid optical thickness and call the full MODIS simulator + ! + subroutine modis_L2_simulator_oneTau( & + temp, pressureLayers, pressureLevels, & + opticalThickness, cloudWater, cloudIce, & + waterSize, iceSize, & + isccpTau, isccpCloudTopPressure, & + retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize) + ! Grid-mean quantities at layer centers, + ! dimension nLayers + real, dimension(:), intent(in ) :: temp, & ! Temperature, K + pressureLayers, & ! Pressure, Pa + pressureLevels ! Pressure at layer edges, Pa (dimension nLayers + 1) + ! Sub-column quantities + ! dimension nLayers, nSubcols + real, dimension(:, :), intent(in ) :: opticalThickness, & ! Layer optical thickness @ 0.67 microns + cloudWater, & ! Cloud water content, arbitrary units + cloudIce ! Cloud water content, same units as cloudWater + real, dimension(:, :), intent(in ) :: waterSize, & ! Cloud drop effective radius, microns + iceSize ! Cloud ice effective radius, microns + + ! Cloud properties retrieved from ISCCP using top_height = 1 + ! dimension nSubcols + + real, dimension(:), intent(in ) :: isccpTau, & ! Column-integrated optical thickness + isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) + + ! Properties retrieved by MODIS + ! dimension nSubcols + integer, dimension(:), intent(out) :: retrievedPhase ! liquid/ice/other - integer + real, dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers + retrievedTau, & ! unitless + retrievedSize ! microns (or whatever units + ! waterSize and iceSize are supplied in) + ! --------------------------------------------------- + ! Local variables + real, dimension(size(opticalThickness, 1), size(opticalThickness, 2)) :: & + liquid_opticalThickness, ice_opticalThickness, tauLiquidFraction + + ! --------------------------------------------------- + + where(cloudIce(:, :) <= 0.) + tauLiquidFraction(:, :) = 1. + elsewhere + where (cloudWater(:, :) <= 0.) + tauLiquidFraction(:, :) = 0. + elsewhere + ! + ! Geometic optics limit - tau as LWP/re (proportional to LWC/re) + ! + tauLiquidFraction(:, :) = (cloudWater(:, :)/waterSize(:, :)) / & + (cloudWater(:, :)/waterSize(:, :) + cloudIce(:, :)/(ice_density * iceSize(:, :)) ) + end where + end where + liquid_opticalThickness(:, :) = tauLiquidFraction(:, :) * opticalThickness(:, :) + ice_opticalThickness (:, :) = opticalThickness(:, :) - liquid_opticalThickness(:, :) + + call modis_L2_simulator_twoTaus(temp, pressureLayers, pressureLevels, & + liquid_opticalThickness, ice_opticalThickness, & + waterSize, iceSize, & + isccpTau, isccpCloudTopPressure, & + retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize) + + end subroutine modis_L2_simulator_oneTau + + ! ######################################################################################## + 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(:,:) :: & +!ds integer,intent(in), dimension(nPoints, nSubCols) :: & + phase + real,intent(in),dimension(:,:) :: & +!ds real,intent(in),dimension(nPoints, nSubCols) :: & + cloud_top_pressure, & + optical_thickness, & + particle_size + + ! OUTPUTS + real,intent(inout),dimension(:) :: & ! +!ds real,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,intent(inout),dimension(:,:,:) :: & +!ds real,intent(inout),dimension(nPoints,numTauHistogramBins,numPressureHistogramBins) :: & + Optical_Thickness_vs_Cloud_Top_Pressure + real,intent(inout),dimension(:,:,:) :: & +!ds real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffIceBins) :: & + Optical_Thickness_vs_ReffIce + real,intent(inout),dimension(:,:,:) :: & +!ds real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffLiqBins) :: & + Optical_Thickness_vs_ReffLiq + + ! LOCAL VARIABLES + real, parameter :: & + LWP_conversion = 2./3. * 1000. ! MKS units + integer :: i, j + logical, dimension(nPoints,nSubCols) :: & + cloudMask, & + waterCloudMask, & + iceCloudMask, & + validRetrievalMask + real,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 mean optical thickness. + ! ######################################################################################## + Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask, dim = 2) / & + Cloud_Fraction_Total_Mean(1:nPoints) + Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / & + Cloud_Fraction_Water_Mean(1:nPoints) + Optical_Thickness_Ice_Mean(1:nPoints) = sum(optical_thickness, mask = iceCloudMask, dim = 2) / & + Cloud_Fraction_Ice_Mean(1:nPoints) + + ! ######################################################################################## + ! We take the absolute value of optical thickness here to satisfy compilers that complains + ! when we evaluate the logarithm of a negative number, even though it's not included in + ! the sum. + ! ######################################################################################## + Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, & + dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints) + Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,& + dim = 2) / Cloud_Fraction_Water_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_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / & + Cloud_Fraction_Water_Mean(1:nPoints) + Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask, dim = 2) / & + Cloud_Fraction_Ice_Mean(1:nPoints) + Cloud_Top_Pressure_Total_Mean(1:nPoints) = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / & + max(1, count(cloudMask, dim = 2)) + Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, & + mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_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) + + ! ######################################################################################## + ! 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 + + ! ######################################################################################## + ! Set clear-scenes to undefined + ! ######################################################################################## + where (Cloud_Fraction_Total_Mean == 0) + Optical_Thickness_Total_Mean = R_UNDEF + Optical_Thickness_Total_MeanLog10 = R_UNDEF + Cloud_Top_Pressure_Total_Mean = R_UNDEF + endwhere + where (Cloud_Fraction_Water_Mean == 0) + 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 == 0) + 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 + where (Cloud_Fraction_High_Mean == 0) Cloud_Fraction_High_Mean = R_UNDEF + where (Cloud_Fraction_Mid_Mean == 0) Cloud_Fraction_Mid_Mean = R_UNDEF + where (Cloud_Fraction_Low_Mean == 0) Cloud_Fraction_Low_Mean = R_UNDEF + + ! ######################################################################################## + ! Joint histogram + ! ######################################################################################## + + ! 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. + ctpWRK(j,1:nSubCols) = -999. + endwhere + ! Joint histogram of tau/CTP + call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,& + tauHistogramBoundaries,numTauHistogramBins,& + pressureHistogramBoundaries,numPressureHistogramBins,& + Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numTauHistogramBins,1:numPressureHistogramBins)) + ! Joint histogram of tau/ReffICE + call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols, & + tauHistogramBoundaries,numTauHistogramBins,reffICE_binBounds, & + numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numTauHistogramBins,1:numMODISReffIceBins)) + ! Joint histogram of tau/ReffLIQ + call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols, & + tauHistogramBoundaries,numTauHistogramBins,reffLIQ_binBounds, & + numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numTauHistogramBins,1:numMODISReffLiqBins)) + + enddo + Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins) = & + Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins)/nSubCols + Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins) = & + Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins)/nSubCols + Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins) = & + Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins)/nSubCols + + end subroutine modis_column + ! ###################################################################################### + ! 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,intent(in),dimension(npts) :: & + var1, & ! Variable 1 to be sorted into bins + var2 ! variable 2 to be sorted into bins + real,intent(in),dimension(nbin1+1) :: & + bin1 ! Histogram bin 1 boundaries + real,intent(in),dimension(nbin2+1) :: & + bin2 ! Histogram bin 2 boundaries + ! OUTPUTS + real,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 + + !------------------------------------------------------------------------------------------------ + subroutine modis_L3_simulator(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) + ! + ! Inputs; dimension nPoints, nSubcols + ! + integer, dimension(:, :), intent(in) :: phase + real, dimension(:, :), intent(in) :: cloud_top_pressure, optical_thickness, particle_size + ! + ! Outputs; dimension nPoints + ! + real, dimension(:), intent(out) :: & + 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 + ! tau/ctp histogram; dimensions nPoints, numTauHistogramBins , numPressureHistogramBins + real, dimension(:, :, :), intent(out) :: Optical_Thickness_vs_Cloud_Top_Pressure + ! --------------------------- + ! Local variables + ! + real, parameter :: LWP_conversion = 2./3. * 1000. ! MKS units + integer :: i, j + integer :: nPoints, nSubcols + logical, dimension(size(phase, 1), size(phase, 2)) :: & + cloudMask, waterCloudMask, iceCloudMask, validRetrievalMask + logical, dimension(size(phase, 1), size(phase, 2), numTauHistogramBins ) :: tauMask + logical, dimension(size(phase, 1), size(phase, 2), numPressureHistogramBins) :: pressureMask + ! --------------------------- + + nPoints = size(phase, 1) + nSubcols = size(phase, 2) + ! + ! Array conformance checks + ! + if(any( (/ size(cloud_top_pressure, 1), size(optical_thickness, 1), size(particle_size, 1), & + size(Cloud_Fraction_Total_Mean), size(Cloud_Fraction_Water_Mean), size(Cloud_Fraction_Ice_Mean), & + size(Cloud_Fraction_High_Mean), size(Cloud_Fraction_Mid_Mean), size(Cloud_Fraction_Low_Mean), & + size(Optical_Thickness_Total_Mean), size(Optical_Thickness_Water_Mean), size(Optical_Thickness_Ice_Mean), & + size(Optical_Thickness_Total_MeanLog10), size(Optical_Thickness_Water_MeanLog10), & + size(Optical_Thickness_Ice_MeanLog10), size(Cloud_Particle_Size_Water_Mean), & + size(Cloud_Particle_Size_Ice_Mean), size(Cloud_Top_Pressure_Total_Mean), & + size(Liquid_Water_Path_Mean), size(Ice_Water_Path_Mean) /) /= nPoints)) & + call complain_and_die("Some L3 arrays have wrong number of grid points") + if(any( (/ size(cloud_top_pressure, 2), size(optical_thickness, 2), size(particle_size, 2) /) /= nSubcols)) & + call complain_and_die("Some L3 arrays have wrong number of subcolumns") + + + ! + ! Include only those pixels with successful retrievals in the statistics + ! + validRetrievalMask(:, :) = particle_size(:, :) > 0. + cloudMask = phase(:, :) /= phaseIsNone .and. validRetrievalMask(:, :) + waterCloudMask = phase(:, :) == phaseIsLiquid .and. validRetrievalMask(:, :) + iceCloudMask = phase(:, :) == phaseIsIce .and. validRetrievalMask(:, :) + ! + ! Use these as pixel counts at first + ! + Cloud_Fraction_Total_Mean(:) = real(count(cloudMask, dim = 2)) + Cloud_Fraction_Water_Mean(:) = real(count(waterCloudMask, dim = 2)) + Cloud_Fraction_Ice_Mean(:) = real(count(iceCloudMask, dim = 2)) + + Cloud_Fraction_High_Mean(:) = real(count(cloudMask .and. cloud_top_pressure <= highCloudPressureLimit, dim = 2)) + Cloud_Fraction_Low_Mean(:) = real(count(cloudMask .and. cloud_top_pressure > lowCloudPressureLimit, dim = 2)) + Cloud_Fraction_Mid_Mean(:) = Cloud_Fraction_Total_Mean(:) - Cloud_Fraction_High_Mean(:) - Cloud_Fraction_Low_Mean(:) + + ! + ! Don't want to divide by 0, even though the sums will be 0 where the pixel counts are 0. + ! + where (Cloud_Fraction_Total_Mean == 0) Cloud_Fraction_Total_Mean = -1. + where (Cloud_Fraction_Water_Mean == 0) Cloud_Fraction_Water_Mean = -1. + where (Cloud_Fraction_Ice_Mean == 0) Cloud_Fraction_Ice_Mean = -1. + + Optical_Thickness_Total_Mean = sum(optical_thickness, mask = cloudMask, dim = 2) / Cloud_Fraction_Total_Mean(:) + Optical_Thickness_Water_Mean = sum(optical_thickness, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:) + Optical_Thickness_Ice_Mean = sum(optical_thickness, mask = iceCloudMask, dim = 2) / Cloud_Fraction_Ice_Mean(:) + + ! We take the absolute value of optical thickness here to satisfy compilers that complains when we + ! evaluate the logarithm of a negative number, even though it's not included in the sum. + Optical_Thickness_Total_MeanLog10 = sum(log10(abs(optical_thickness)), mask = cloudMask, dim = 2) / & + Cloud_Fraction_Total_Mean(:) + Optical_Thickness_Water_MeanLog10 = sum(log10(abs(optical_thickness)), mask = waterCloudMask, dim = 2) / & + Cloud_Fraction_Water_Mean(:) + Optical_Thickness_Ice_MeanLog10 = sum(log10(abs(optical_thickness)), mask = iceCloudMask, dim = 2) / & + Cloud_Fraction_Ice_Mean(:) + + Cloud_Particle_Size_Water_Mean = sum(particle_size, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:) + Cloud_Particle_Size_Ice_Mean = sum(particle_size, mask = iceCloudMask, dim = 2) / Cloud_Fraction_Ice_Mean(:) + + Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / max(1, count(cloudMask, dim = 2)) + + Liquid_Water_Path_Mean = LWP_conversion & + * sum(particle_size * optical_thickness, mask = waterCloudMask, dim = 2) & + / Cloud_Fraction_Water_Mean(:) + Ice_Water_Path_Mean = LWP_conversion * ice_density & + * sum(particle_size * optical_thickness, mask = iceCloudMask, dim = 2) & + / Cloud_Fraction_Ice_Mean(:) + + ! + ! Normalize pixel counts to fraction + ! The first three cloud fractions have been set to -1 in cloud-free areas, so set those places to 0. + ! + Cloud_Fraction_Total_Mean(:) = max(0., Cloud_Fraction_Total_Mean(:)/nSubcols) + Cloud_Fraction_Water_Mean(:) = max(0., Cloud_Fraction_Water_Mean(:)/nSubcols) + Cloud_Fraction_Ice_Mean(:) = max(0., Cloud_Fraction_Ice_Mean(:) /nSubcols) + + Cloud_Fraction_High_Mean(:) = Cloud_Fraction_High_Mean(:) /nSubcols + Cloud_Fraction_Mid_Mean(:) = Cloud_Fraction_Mid_Mean(:) /nSubcols + Cloud_Fraction_Low_Mean(:) = Cloud_Fraction_Low_Mean(:) /nSubcols + + ! ---- + ! Joint histogram + ! + do i = 1, numTauHistogramBins + where(cloudMask(:, :)) + tauMask(:, :, i) = optical_thickness(:, :) >= tauHistogramBoundaries(i) .and. & + optical_thickness(:, :) < tauHistogramBoundaries(i+1) + elsewhere + tauMask(:, :, i) = .false. + end where + end do + + do i = 1, numPressureHistogramBins + where(cloudMask(:, :)) + pressureMask(:, :, i) = cloud_top_pressure(:, :) >= pressureHistogramBoundaries(i) .and. & + cloud_top_pressure(:, :) < pressureHistogramBoundaries(i+1) + elsewhere + pressureMask(:, :, i) = .false. + end where + end do + + do i = 1, numPressureHistogramBins + do j = 1, numTauHistogramBins + Optical_Thickness_vs_Cloud_Top_Pressure(:, j, i) = & + real(count(tauMask(:, :, j) .and. pressureMask(:, :, i), dim = 2)) / real(nSubcols) + end do + end do + + end subroutine modis_L3_simulator + !------------------------------------------------------------------------------------------------ + function cloud_top_pressure(tauIncrement, pressure, tauLimit) + real, dimension(:), intent(in) :: tauIncrement, pressure + real, intent(in) :: tauLimit + real :: cloud_top_pressure + ! + ! Find the extinction-weighted pressure. Assume that pressure varies linearly between + ! layers and use the trapezoidal rule. + ! + + real :: deltaX, totalTau, totalProduct + integer :: i + + totalTau = 0.; totalProduct = 0. + 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. * tauIncrement(i)) + else + totalTau = totalTau + tauIncrement(i) + totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2. + end if + if(totalTau >= tauLimit) exit + end do + cloud_top_pressure = totalProduct/totalTau + end function cloud_top_pressure + !------------------------------------------------------------------------------------------------ + function weight_by_extinction(tauIncrement, f, tauLimit) + real, dimension(:), intent(in) :: tauIncrement, f + real, intent(in) :: tauLimit + real :: weight_by_extinction + ! + ! Find the extinction-weighted value of f(tau), assuming constant f within each layer + ! + + real :: deltaX, totalTau, totalProduct + integer :: i + + totalTau = 0.; totalProduct = 0. + 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 + weight_by_extinction = totalProduct/totalTau + end function weight_by_extinction + !------------------------------------------------------------------------------------------------ + pure function compute_nir_reflectance(water_tau, water_size, ice_tau, ice_size) + real, dimension(:), intent(in) :: water_tau, water_size, ice_tau, ice_size + real :: compute_nir_reflectance + + real, dimension(size(water_tau)) :: water_g, water_w0, ice_g, ice_w0, & + tau, g, w0 + !---------------------------------------- + water_g(:) = get_g_nir( phaseIsLiquid, water_size) + water_w0(:) = get_ssa_nir(phaseIsLiquid, water_size) + ice_g(:) = get_g_nir( phaseIsIce, ice_size) + ice_w0(:) = get_ssa_nir(phaseIsIce, ice_size) + ! + ! Combine ice and water optical properties + ! + g(:) = 0; w0(:) = 0. + tau(:) = ice_tau(:) + water_tau(:) + where (tau(:) > 0) + w0(:) = (water_tau(:) * water_w0(:) + ice_tau(:) * ice_w0(:)) / & + tau(:) + g(:) = (water_tau(:) * water_g(:) * water_w0(:) + ice_tau(:) * ice_g(:) * ice_w0(:)) / & + (w0(:) * tau(:)) + end where + + compute_nir_reflectance = compute_toa_reflectace(tau, g, w0) + end function compute_nir_reflectance + !------------------------------------------------------------------------------------------------ + ! Retreivals + !------------------------------------------------------------------------------------------------ + elemental function retrieve_re (phase, tau, obs_Refl_nir) + integer, intent(in) :: phase + real, intent(in) :: tau, obs_Refl_nir + real :: retrieve_re + ! + ! Finds the re that produces the minimum mis-match between predicted and observed reflectance in + ! MODIS band 7 (near IR) + ! Uses + ! fits for asymmetry parameter g(re) and single scattering albedo w0(re) based on MODIS tables + ! two-stream for layer reflectance and transmittance as a function of optical thickness tau, g, and w0 + ! adding-doubling for total reflectance + ! + ! + ! + ! Local variables + ! + real, parameter :: min_distance_to_boundary = 0.01 + real :: re_min, re_max, delta_re + integer :: i + + real, dimension(num_trial_res) :: trial_re, g, w0, predicted_Refl_nir + ! -------------------------- + + if(any(phase == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then + if (phase == phaseIsLiquid .OR. phase == phaseIsUndetermined) then + re_min = re_water_min + re_max = re_water_max + trial_re(:) = trial_re_w + g(:) = g_w(:) + w0(:) = w0_w(:) + else + re_min = re_ice_min + re_max = re_ice_max + trial_re(:) = trial_re_i + g(:) = g_i(:) + w0(:) = w0_i(:) + end if + ! + ! 1st attempt at index: w/coarse re resolution + ! + predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:)) + retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) + ! + ! If first retrieval works, can try 2nd iteration using greater re resolution + ! +! DJS2015: Remove unused piece of code +! if(use_two_re_iterations .and. retrieve_re > 0.) then +! re_min = retrieve_re - delta_re +! re_max = retrieve_re + delta_re +! delta_re = (re_max - re_min)/real(num_trial_res-1) +! +! trial_re(:) = re_min + delta_re * (/ (i - 1, i = 1, num_trial_res) /) +! g(:) = get_g_nir( phase, trial_re(:)) +! w0(:) = get_ssa_nir(phase, trial_re(:)) +! predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:)) +! retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) +! end if +! DJS2015 END + else + retrieve_re = re_fill + end if + + end function retrieve_re + ! -------------------------------------------- + pure function interpolate_to_min(x, y, yobs) + real, dimension(:), intent(in) :: x, y + real, intent(in) :: yobs + real :: interpolate_to_min + ! + ! 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 + ! + real, dimension(size(x)) :: diff + integer :: nPoints, minDiffLoc, lowerBound, upperBound + ! --------------------------------- + nPoints = size(y) + diff(:) = y(:) - 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 (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, intent(in) :: re + real :: get_g_nir + + real, 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, 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, intent(in) :: re + real :: 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, dimension(4), parameter :: ice_coefficients = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/) + real, 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) + real, intent(in) :: x + real, dimension(:), intent(in) :: coefficients + real :: 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) + real, intent(in) :: x + real, dimension(:), intent(in) :: coefficients + real :: 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(tau, g, w0) + real, dimension(:), intent(in) :: tau, g, w0 + real :: compute_toa_reflectace + + logical, dimension(size(tau)) :: cloudMask + integer, dimension(count(tau(:) > 0)) :: cloudIndicies + real, dimension(count(tau(:) > 0)) :: Refl, Trans + real :: Refl_tot, Trans_tot + integer :: i + ! --------------------------------------- + ! + ! This wrapper reports reflectance only and strips out non-cloudy elements from the calculation + ! + cloudMask = tau(:) > 0. + cloudIndicies = pack((/ (i, i = 1, size(tau)) /), 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(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) + real, intent(in) :: tauint, gint, w0int + real, intent(out) :: ref, tra + ! + ! Compute reflectance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + ! + ! ------------------------ + ! 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, parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 + real :: 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 - w0int * f) * tauint + w0 = (1 - f) * w0int / (1 - w0int * f) + g = (gint - f) / (1 - f) + + ! delta-Eddington (Joseph et al. 1976) + gamma1 = (7 - w0* (4 + 3 * g)) / 4.0 + gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0 + gamma3 = (2 - 3*g*xmu) / 4.0 + gamma4 = 1 - gamma3 + + if (w0int > minConservativeW0) then + ! Conservative scattering + if (beam == 1) then + rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu))) + ref = rh / (1 + gamma1 * tau) + tra = 1 - ref + else if(beam == 2) then + ref = gamma1*tau/(1 + gamma1*tau) + tra = 1 - ref + endif + else + ! Non-conservative scattering + a1 = gamma1 * gamma4 + gamma2 * gamma3 + a2 = gamma1 * gamma3 + gamma2 * gamma4 + + rk = sqrt(gamma1**2 - gamma2**2) + + r1 = (1 - rk * xmu) * (a2 + rk * gamma3) + r2 = (1 + rk * xmu) * (a2 - rk * gamma3) + r3 = 2 * rk *(gamma3 - a2 * xmu) + r4 = (1 - (rk * xmu)**2) * (rk + gamma1) + r5 = (1 - (rk * xmu)**2) * (rk - gamma1) + + t1 = (1 + rk * xmu) * (a1 + rk * gamma4) + t2 = (1 - rk * xmu) * (a1 - rk * gamma4) + t3 = 2 * rk * (gamma4 + a1 * xmu) + t4 = r4 + t5 = r5 + + beta = -r5 / r4 + + e1 = min(rk * tau, 500.) + e2 = min(tau / xmu, 500.) + + 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-ef2))/((rk+gamma1)*(1-beta*ef2)) + tra = (2*rk*ef1)/((rk+gamma1)*(1-beta*ef2)) + endif + end if + end subroutine two_stream + ! -------------------------------------------------- + elemental function two_stream_reflectance(tauint, gint, w0int) + real, intent(in) :: tauint, gint, w0int + real :: two_stream_reflectance + ! + ! Compute reflectance in a single layer using the two stream approximation + ! The code itself is from Lazaros Oreopoulos via Steve Platnick + ! + ! ------------------------ + ! 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, parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 + real :: 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 - w0int * f) * tauint + w0 = (1 - f) * w0int / (1 - w0int * f) + g = (gint - f) / (1 - f) + + ! delta-Eddington (Joseph et al. 1976) + gamma1 = (7 - w0* (4 + 3 * g)) / 4.0 + gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0 + gamma3 = (2 - 3*g*xmu) / 4.0 + gamma4 = 1 - 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 + gamma1 * tau) + elseif (beam == 2) then + two_stream_reflectance = gamma1*tau/(1 + 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 - rk * xmu) * (a2 + rk * gamma3) + r2 = (1 + rk * xmu) * (a2 - rk * gamma3) + r3 = 2 * rk *(gamma3 - a2 * xmu) + r4 = (1 - (rk * xmu)**2) * (rk + gamma1) + r5 = (1 - (rk * xmu)**2) * (rk - gamma1) + + t1 = (1 + rk * xmu) * (a1 + rk * gamma4) + t2 = (1 - rk * xmu) * (a1 - rk * gamma4) + t3 = 2 * rk * (gamma4 + a1 * xmu) + t4 = r4 + t5 = r5 + + beta = -r5 / r4 + + e1 = min(rk * tau, 500.) + e2 = min(tau / xmu, 500.) + + 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-ef2))/((rk+gamma1)*(1-beta*ef2)) + endif + + end if + end function two_stream_reflectance + ! -------------------------------------------- + pure subroutine adding_doubling (Refl, Tran, Refl_tot, Tran_tot) + real, dimension(:), intent(in) :: Refl, Tran + real, intent(out) :: Refl_tot, Tran_tot + ! + ! Use adding/doubling formulas to compute total reflectance and transmittance from layer values + ! + + integer :: i + real, dimension(size(Refl)) :: Refl_cumulative, Tran_cumulative + + Refl_cumulative(1) = Refl(1); Tran_cumulative(1) = Tran(1) + + do i=2, size(Refl) + ! 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 - Refl_cumulative(i-1) * Refl(i)) + Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1 - Refl_cumulative(i-1) * Refl(i)) + end do + + Refl_tot = Refl_cumulative(size(Refl)) + Tran_tot = Tran_cumulative(size(Refl)) + + end subroutine adding_doubling + ! -------------------------------------------------- + subroutine complain_and_die(message) + character(len = *), intent(in) :: message + + write(6, *) "Failure in MODIS simulator" + write(6, *) trim(message) + stop + end subroutine complain_and_die + !------------------------------------------------------------------------------------------------ +end module mod_modis_sim Index: LMDZ6/trunk/libf/phylmd/cosp/modis_simulator.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/modis_simulator.F90 (revision 3231) +++ (revision ) @@ -1,1274 +1,0 @@ -! (c) 2009-2010, Regents of the Unversity of Colorado -! Author: Robert Pincus, Cooperative Institute for Research in the Environmental Sciences -! All rights reserved. -! $Revision: 88 $, $Date: 2013-11-13 07:08:38 -0700 (Wed, 13 Nov 2013) $ -! $URL: http://cfmip-obs-sim.googlecode.com/svn/stable/v1.4.0/MODIS_simulator/modis_simulator.F90 $ -! -! Redistribution and use in source and binary forms, with or without modification, are permitted -! provided that the following conditions are met: -! -! * Redistributions of source code must retain the above copyright notice, this list -! of conditions and the following disclaimer. -! * Redistributions in binary form must reproduce the above copyright notice, this list -! of conditions and the following disclaimer in the documentation and/or other materials -! provided with the distribution. -! * Neither the name of the Met Office nor the names of its contributors may be used -! to endorse or promote products derived from this software without specific prior written -! permission. -! -! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR -! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND -! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR -! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL -! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER -! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT -! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. -! - -! -! 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 -! - -! -! 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_TYPES, only: R_UNDEF - implicit none - ! ------------------------------ - ! Algorithmic parameters - ! - - real, parameter :: ice_density = 0.93 ! liquid density is 1. - ! - ! Retrieval parameters - ! - real, parameter :: min_OpticalThickness = 0.3, & ! Minimum detectable optical thickness - CO2Slicing_PressureLimit = 700. * 100., & ! Cloud with higher pressures use thermal methods, units Pa - CO2Slicing_TauLimit = 1., & ! How deep into the cloud does CO2 slicing see? - phase_TauLimit = 1., & ! How deep into the cloud does the phase detection see? - size_TauLimit = 2., & ! Depth of the re retreivals - phaseDiscrimination_Threshold = 0.7 ! What fraction of total extincton needs to be - ! in a single category to make phase discrim. work? - real, parameter :: re_fill= -999. - integer, parameter :: phaseIsNone = 0, phaseIsLiquid = 1, phaseIsIce = 2, phaseIsUndetermined = 3 - - logical, parameter :: useSimpleReScheme = .false. - ! - ! These are the limits of the libraries for the MODIS collection 5 algorithms - ! They are also the limits used in the fits for g and w0 - ! - real, parameter :: re_water_min= 4., re_water_max= 30., re_ice_min= 5., re_ice_max= 90. - integer, parameter :: num_trial_res = 15 ! increase to make the linear pseudo-retrieval of size more accurate -! DJS2015: Remove unused parameter -! logical, parameter :: use_two_re_iterations = .false. ! do two retrieval iterations? -! DJS2015 END - ! - ! Precompute near-IR optical params vs size for retrieval scheme - ! - integer, private :: i - real, dimension(num_trial_res), parameter :: & - trial_re_w = re_water_min + (re_water_max - re_water_min)/(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /), & - trial_re_i = re_ice_min + (re_ice_max - re_ice_min) /(num_trial_res-1) * (/ (i - 1, i = 1, num_trial_res) /) - - ! Can't initialze these during compilation, but do in before looping columns in retrievals - real, dimension(num_trial_res) :: g_w, g_i, w0_w, w0_i - ! ------------------------------ - ! Bin boundaries for the joint optical thickness/cloud top pressure histogram - ! - integer, parameter :: numTauHistogramBins = 6, numPressureHistogramBins = 7 - - real, private :: dummy_real - real, dimension(numTauHistogramBins + 1), parameter :: & - tauHistogramBoundaries = (/ min_OpticalThickness, 1.3, 3.6, 9.4, 23., 60., 10000. /) - real, dimension(numPressureHistogramBins + 1), parameter :: & ! Units Pa - pressureHistogramBoundaries = (/ 0., 18000., 31000., 44000., 56000., 68000., 80000., 1000000. /) - real, parameter :: highCloudPressureLimit = 440. * 100., lowCloudPressureLimit = 680. * 100. - ! - ! For output - nominal bin centers and bin boundaries. On output pressure bins are highest to lowest. - ! - integer, private :: k, l - real, parameter, dimension(2, numTauHistogramBins) :: & - nominalTauHistogramBoundaries = & - reshape(source = (/ tauHistogramBoundaries(1), & - ((tauHistogramBoundaries(k), l = 1, 2), k = 2, numTauHistogramBins), & - 100000. /), & - shape = (/2, numTauHistogramBins /) ) - real, parameter, dimension(numTauHistogramBins) :: & - nominalTauHistogramCenters = (nominalTauHistogramBoundaries(1, :) + & - nominalTauHistogramBoundaries(2, :) ) / 2. - - real, parameter, dimension(2, numPressureHistogramBins) :: & - nominalPressureHistogramBoundaries = & - reshape(source = (/ 100000., & - ((pressureHistogramBoundaries(k), l = 1, 2), k = numPressureHistogramBins, 2, -1), & - 0. /), & - shape = (/2, numPressureHistogramBins /) ) - real, parameter, dimension(numPressureHistogramBins) :: & - nominalPressureHistogramCenters = (nominalPressureHistogramBoundaries(1, :) + & - nominalPressureHistogramBoundaries(2, :) ) / 2. - ! DJS2015 START: Add bin descriptions for joint-histograms of partice-sizes and optical depth. This is - ! identical to what is done in COSPv.2.0.0 for histogram bin initialization. - integer :: j - integer,parameter :: & - numMODISReffLiqBins = 6, & ! Number of bins for tau/ReffLiq joint-histogram - numMODISReffIceBins = 6 ! Number of bins for tau/ReffICE joint-histogram - real,parameter,dimension(numMODISReffLiqBins+1) :: & - reffLIQ_binBounds = (/0., 8e-6, 1.0e-5, 1.3e-5, 1.5e-5, 2.0e-5, 3.0e-5/) - real,parameter,dimension(numMODISReffIceBins+1) :: & - reffICE_binBounds = (/0., 1.0e-5, 2.0e-5, 3.0e-5, 4.0e-5, 6.0e-5, 9.0e-5/) - real,parameter,dimension(2,numMODISReffIceBins) :: & - reffICE_binEdges = reshape(source=(/reffICE_binBounds(1),((reffICE_binBounds(k), & - l=1,2),k=2,numMODISReffIceBins),reffICE_binBounds(numMODISReffIceBins+1)/), & - shape = (/2,numMODISReffIceBins/)) - real,parameter,dimension(2,numMODISReffLiqBins) :: & - reffLIQ_binEdges = reshape(source=(/reffLIQ_binBounds(1),((reffLIQ_binBounds(k), & - l=1,2),k=2,numMODISReffLiqBins),reffLIQ_binBounds(numMODISReffIceBins+1)/), & - shape = (/2,numMODISReffLiqBins/)) - real,parameter,dimension(numMODISReffIceBins) :: & - reffICE_binCenters = (reffICE_binEdges(1,:)+reffICE_binEdges(2,:))/2. - real,parameter,dimension(numMODISReffLiqBins) :: & - reffLIQ_binCenters = (reffLIQ_binEdges(1,:)+reffLIQ_binEdges(2,:))/2. - ! DJS2015 END - - ! ------------------------------ - ! There are two ways to call the MODIS simulator: - ! 1) Provide total optical thickness and liquid/ice water content and we'll partition tau in - ! subroutine modis_L2_simulator_oneTau, or - ! 2) Provide ice and liquid optical depths in each layer - ! - interface modis_L2_simulator - module procedure modis_L2_simulator_oneTau, modis_L2_simulator_twoTaus - end interface -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_L2_simulator_twoTaus( & - temp, pressureLayers, pressureLevels, & - liquid_opticalThickness, ice_opticalThickness, & - waterSize, iceSize, & - isccpTau, isccpCloudTopPressure, & - retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize) - - ! Grid-mean quantities at layer centers, starting at the model top - ! dimension nLayers - real, dimension(:), intent(in ) :: temp, & ! Temperature, K - pressureLayers, & ! Pressure, Pa - pressureLevels ! Pressure at layer edges, Pa (dimension nLayers + 1) - ! Sub-column quantities - ! dimension nSubcols, nLayers - real, dimension(:, :), intent(in ) :: liquid_opticalThickness, & ! Layer optical thickness @ 0.67 microns due to liquid - ice_opticalThickness ! ditto, due to ice - real, dimension(:, :), intent(in ) :: waterSize, & ! Cloud drop effective radius, microns - iceSize ! Cloud ice effective radius, microns - - ! Cloud properties retrieved from ISCCP using top_height = 1 - ! dimension nSubcols - real, dimension(:), intent(in ) :: isccpTau, & ! Column-integrated optical thickness - isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) - - ! Properties retrieved by MODIS - ! dimension nSubcols - integer, dimension(:), intent(out) :: retrievedPhase ! liquid/ice/other - integer, defined in module header - real, dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers - retrievedTau, & ! unitless - retrievedSize ! microns - ! --------------------------------------------------- - ! Local variables - logical, dimension(size(retrievedTau)) :: cloudMask - real, dimension(size(waterSize, 1), size(waterSize, 2)) :: tauLiquidFraction, tauTotal - real :: integratedLiquidFraction - integer :: i, nSubcols, nLevels - - ! --------------------------------------------------- - nSubcols = size(liquid_opticalThickness, 1) - nLevels = size(liquid_opticalThickness, 2) - - ! - ! Initial error checks - ! - if(any((/ size(ice_opticalThickness, 1), size(waterSize, 1), size(iceSize, 1), & - size(isccpTau), size(isccpCloudTopPressure), & - size(retrievedPhase), size(retrievedCloudTopPressure), & - size(retrievedTau), size(retrievedSize) /) /= nSubcols )) & - call complain_and_die("Differing number of subcolumns in one or more arrays") - - if(any((/ size(ice_opticalThickness, 2), size(waterSize, 2), size(iceSize, 2), & - size(temp), size(pressureLayers), size(pressureLevels)-1 /) /= nLevels )) & - call complain_and_die("Differing number of levels in one or more arrays") - - - if(any( (/ any(temp <= 0.), any(pressureLayers <= 0.), & - any(liquid_opticalThickness < 0.), & - any(ice_opticalThickness < 0.), & - any(waterSize < 0.), any(iceSize < 0.) /) )) & - call complain_and_die("Input values out of bounds") - - ! --------------------------------------------------- - ! - ! Compute the total optical thickness and the proportion due to liquid in each cell - ! - where(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) > 0.) - tauLiquidFraction(:, :) = liquid_opticalThickness(:, :)/(liquid_opticalThickness(:, :) + ice_opticalThickness(:, :)) - elsewhere - tauLiquidFraction(:, :) = 0. - end where - tauTotal(:, :) = liquid_opticalThickness(:, :) + ice_opticalThickness(:, :) - - ! - ! 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(:) = sum(tauTotal(:, :), dim = 2) - - ! - ! Cloud detection - does optical thickness exceed detection threshold? - ! - cloudMask = retrievedTau(:) >= min_OpticalThickness - - ! - ! Initialize initial estimates for size retrievals - ! - if(any(cloudMask) .and. .not. useSimpleReScheme) then - g_w(:) = get_g_nir( phaseIsLiquid, trial_re_w(:)) - w0_w(:) = get_ssa_nir(phaseIsLiquid, trial_re_w(:)) - g_i(:) = get_g_nir( phaseIsIce, trial_re_i(:)) - w0_i(:) = get_ssa_nir(phaseIsIce, trial_re_i(:)) - end if - - 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((/ 0., tauTotal(i, :) /), & - pressureLevels, & - 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(tauTotal(i, :), & - tauLiquidFraction(i, :), & - phase_TauLimit) - if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then - retrievedPhase(i) = phaseIsLiquid - else if (integratedLiquidFraction <= 1.- phaseDiscrimination_Threshold) then - retrievedPhase(i) = phaseIsIce - else - retrievedPhase(i) = phaseIsUndetermined - end if - - ! - ! Size determination - ! - if(useSimpleReScheme) then - ! This is the extinction-weighted size considering only the phase we've chosen - ! - if(retrievedPhase(i) == phaseIsIce) then - retrievedSize(i) = weight_by_extinction(ice_opticalThickness(i, :), & - iceSize(i, :), & - (1. - integratedLiquidFraction) * size_TauLimit) - - else if(retrievedPhase(i) == phaseIsLiquid) then - retrievedSize(i) = weight_by_extinction(liquid_opticalThickness(i, :), & - waterSize(i, :), & - integratedLiquidFraction * size_TauLimit) - - else - retrievedSize(i) = 0. - end if - else - retrievedSize(i) = 1.0e-06*retrieve_re(retrievedPhase(i), retrievedTau(i), & - obs_Refl_nir = compute_nir_reflectance(liquid_opticalThickness(i, :), waterSize(i, :)*1.0e6, & - ice_opticalThickness(i, :), iceSize(i, :)*1.0e6)) - end if - 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(:) < 0.).and.(retrievedSize(:) /= R_UNDEF)) retrievedSize(:) = 1.0e-06*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(:) .and. retrievedCloudTopPressure(:) > CO2Slicing_PressureLimit) & - retrievedCloudTopPressure(:) = isccpCloudTopPressure * 100. - - end subroutine modis_L2_simulator_twoTaus - !------------------------------------------------------------------------------------------------ - ! - ! MODIS simulator: provide a single optical thickness and the cloud ice and liquid contents; - ! we'll partition this into ice and liquid optical thickness and call the full MODIS simulator - ! - subroutine modis_L2_simulator_oneTau( & - temp, pressureLayers, pressureLevels, & - opticalThickness, cloudWater, cloudIce, & - waterSize, iceSize, & - isccpTau, isccpCloudTopPressure, & - retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize) - ! Grid-mean quantities at layer centers, - ! dimension nLayers - real, dimension(:), intent(in ) :: temp, & ! Temperature, K - pressureLayers, & ! Pressure, Pa - pressureLevels ! Pressure at layer edges, Pa (dimension nLayers + 1) - ! Sub-column quantities - ! dimension nLayers, nSubcols - real, dimension(:, :), intent(in ) :: opticalThickness, & ! Layer optical thickness @ 0.67 microns - cloudWater, & ! Cloud water content, arbitrary units - cloudIce ! Cloud water content, same units as cloudWater - real, dimension(:, :), intent(in ) :: waterSize, & ! Cloud drop effective radius, microns - iceSize ! Cloud ice effective radius, microns - - ! Cloud properties retrieved from ISCCP using top_height = 1 - ! dimension nSubcols - - real, dimension(:), intent(in ) :: isccpTau, & ! Column-integrated optical thickness - isccpCloudTopPressure ! ISCCP-retrieved cloud top pressure (Pa) - - ! Properties retrieved by MODIS - ! dimension nSubcols - integer, dimension(:), intent(out) :: retrievedPhase ! liquid/ice/other - integer - real, dimension(:), intent(out) :: retrievedCloudTopPressure, & ! units of pressureLayers - retrievedTau, & ! unitless - retrievedSize ! microns (or whatever units - ! waterSize and iceSize are supplied in) - ! --------------------------------------------------- - ! Local variables - real, dimension(size(opticalThickness, 1), size(opticalThickness, 2)) :: & - liquid_opticalThickness, ice_opticalThickness, tauLiquidFraction - - ! --------------------------------------------------- - - where(cloudIce(:, :) <= 0.) - tauLiquidFraction(:, :) = 1. - elsewhere - where (cloudWater(:, :) <= 0.) - tauLiquidFraction(:, :) = 0. - elsewhere - ! - ! Geometic optics limit - tau as LWP/re (proportional to LWC/re) - ! - tauLiquidFraction(:, :) = (cloudWater(:, :)/waterSize(:, :)) / & - (cloudWater(:, :)/waterSize(:, :) + cloudIce(:, :)/(ice_density * iceSize(:, :)) ) - end where - end where - liquid_opticalThickness(:, :) = tauLiquidFraction(:, :) * opticalThickness(:, :) - ice_opticalThickness (:, :) = opticalThickness(:, :) - liquid_opticalThickness(:, :) - - call modis_L2_simulator_twoTaus(temp, pressureLayers, pressureLevels, & - liquid_opticalThickness, ice_opticalThickness, & - waterSize, iceSize, & - isccpTau, isccpCloudTopPressure, & - retrievedPhase, retrievedCloudTopPressure, retrievedTau, retrievedSize) - - end subroutine modis_L2_simulator_oneTau - - ! ######################################################################################## - 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(:,:) :: & -!ds integer,intent(in), dimension(nPoints, nSubCols) :: & - phase - real,intent(in),dimension(:,:) :: & -!ds real,intent(in),dimension(nPoints, nSubCols) :: & - cloud_top_pressure, & - optical_thickness, & - particle_size - - ! OUTPUTS - real,intent(inout),dimension(:) :: & ! -!ds real,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,intent(inout),dimension(:,:,:) :: & -!ds real,intent(inout),dimension(nPoints,numTauHistogramBins,numPressureHistogramBins) :: & - Optical_Thickness_vs_Cloud_Top_Pressure - real,intent(inout),dimension(:,:,:) :: & -!ds real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffIceBins) :: & - Optical_Thickness_vs_ReffIce - real,intent(inout),dimension(:,:,:) :: & -!ds real,intent(inout),dimension(nPoints,numTauHistogramBins,numMODISReffLiqBins) :: & - Optical_Thickness_vs_ReffLiq - - ! LOCAL VARIABLES - real, parameter :: & - LWP_conversion = 2./3. * 1000. ! MKS units - integer :: i, j - logical, dimension(nPoints,nSubCols) :: & - cloudMask, & - waterCloudMask, & - iceCloudMask, & - validRetrievalMask - real,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 mean optical thickness. - ! ######################################################################################## - Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask, dim = 2) / & - Cloud_Fraction_Total_Mean(1:nPoints) - Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / & - Cloud_Fraction_Water_Mean(1:nPoints) - Optical_Thickness_Ice_Mean(1:nPoints) = sum(optical_thickness, mask = iceCloudMask, dim = 2) / & - Cloud_Fraction_Ice_Mean(1:nPoints) - - ! ######################################################################################## - ! We take the absolute value of optical thickness here to satisfy compilers that complains - ! when we evaluate the logarithm of a negative number, even though it's not included in - ! the sum. - ! ######################################################################################## - Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, & - dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints) - Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,& - dim = 2) / Cloud_Fraction_Water_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_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / & - Cloud_Fraction_Water_Mean(1:nPoints) - Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask, dim = 2) / & - Cloud_Fraction_Ice_Mean(1:nPoints) - Cloud_Top_Pressure_Total_Mean(1:nPoints) = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / & - max(1, count(cloudMask, dim = 2)) - Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, & - mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_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) - - ! ######################################################################################## - ! 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 - - ! ######################################################################################## - ! Set clear-scenes to undefined - ! ######################################################################################## - where (Cloud_Fraction_Total_Mean == 0) - Optical_Thickness_Total_Mean = R_UNDEF - Optical_Thickness_Total_MeanLog10 = R_UNDEF - Cloud_Top_Pressure_Total_Mean = R_UNDEF - endwhere - where (Cloud_Fraction_Water_Mean == 0) - 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 == 0) - 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 - where (Cloud_Fraction_High_Mean == 0) Cloud_Fraction_High_Mean = R_UNDEF - where (Cloud_Fraction_Mid_Mean == 0) Cloud_Fraction_Mid_Mean = R_UNDEF - where (Cloud_Fraction_Low_Mean == 0) Cloud_Fraction_Low_Mean = R_UNDEF - - ! ######################################################################################## - ! Joint histogram - ! ######################################################################################## - - ! 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. - ctpWRK(j,1:nSubCols) = -999. - endwhere - ! Joint histogram of tau/CTP - call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,& - tauHistogramBoundaries,numTauHistogramBins,& - pressureHistogramBoundaries,numPressureHistogramBins,& - Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numTauHistogramBins,1:numPressureHistogramBins)) - ! Joint histogram of tau/ReffICE - call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols, & - tauHistogramBoundaries,numTauHistogramBins,reffICE_binBounds, & - numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numTauHistogramBins,1:numMODISReffIceBins)) - ! Joint histogram of tau/ReffLIQ - call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols, & - tauHistogramBoundaries,numTauHistogramBins,reffLIQ_binBounds, & - numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numTauHistogramBins,1:numMODISReffLiqBins)) - - enddo - Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins) = & - Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numTauHistogramBins,1:numPressureHistogramBins)/nSubCols - Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins) = & - Optical_Thickness_vs_ReffIce(1:nPoints,1:numTauHistogramBins,1:numMODISReffIceBins)/nSubCols - Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins) = & - Optical_Thickness_vs_ReffLiq(1:nPoints,1:numTauHistogramBins,1:numMODISReffLiqBins)/nSubCols - - end subroutine modis_column - ! ###################################################################################### - ! 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,intent(in),dimension(npts) :: & - var1, & ! Variable 1 to be sorted into bins - var2 ! variable 2 to be sorted into bins - real,intent(in),dimension(nbin1+1) :: & - bin1 ! Histogram bin 1 boundaries - real,intent(in),dimension(nbin2+1) :: & - bin2 ! Histogram bin 2 boundaries - ! OUTPUTS - real,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 - - !------------------------------------------------------------------------------------------------ - subroutine modis_L3_simulator(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) - ! - ! Inputs; dimension nPoints, nSubcols - ! - integer, dimension(:, :), intent(in) :: phase - real, dimension(:, :), intent(in) :: cloud_top_pressure, optical_thickness, particle_size - ! - ! Outputs; dimension nPoints - ! - real, dimension(:), intent(out) :: & - 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 - ! tau/ctp histogram; dimensions nPoints, numTauHistogramBins , numPressureHistogramBins - real, dimension(:, :, :), intent(out) :: Optical_Thickness_vs_Cloud_Top_Pressure - ! --------------------------- - ! Local variables - ! - real, parameter :: LWP_conversion = 2./3. * 1000. ! MKS units - integer :: i, j - integer :: nPoints, nSubcols - logical, dimension(size(phase, 1), size(phase, 2)) :: & - cloudMask, waterCloudMask, iceCloudMask, validRetrievalMask - logical, dimension(size(phase, 1), size(phase, 2), numTauHistogramBins ) :: tauMask - logical, dimension(size(phase, 1), size(phase, 2), numPressureHistogramBins) :: pressureMask - ! --------------------------- - - nPoints = size(phase, 1) - nSubcols = size(phase, 2) - ! - ! Array conformance checks - ! - if(any( (/ size(cloud_top_pressure, 1), size(optical_thickness, 1), size(particle_size, 1), & - size(Cloud_Fraction_Total_Mean), size(Cloud_Fraction_Water_Mean), size(Cloud_Fraction_Ice_Mean), & - size(Cloud_Fraction_High_Mean), size(Cloud_Fraction_Mid_Mean), size(Cloud_Fraction_Low_Mean), & - size(Optical_Thickness_Total_Mean), size(Optical_Thickness_Water_Mean), size(Optical_Thickness_Ice_Mean), & - size(Optical_Thickness_Total_MeanLog10), size(Optical_Thickness_Water_MeanLog10), & - size(Optical_Thickness_Ice_MeanLog10), size(Cloud_Particle_Size_Water_Mean), & - size(Cloud_Particle_Size_Ice_Mean), size(Cloud_Top_Pressure_Total_Mean), & - size(Liquid_Water_Path_Mean), size(Ice_Water_Path_Mean) /) /= nPoints)) & - call complain_and_die("Some L3 arrays have wrong number of grid points") - if(any( (/ size(cloud_top_pressure, 2), size(optical_thickness, 2), size(particle_size, 2) /) /= nSubcols)) & - call complain_and_die("Some L3 arrays have wrong number of subcolumns") - - - ! - ! Include only those pixels with successful retrievals in the statistics - ! - validRetrievalMask(:, :) = particle_size(:, :) > 0. - cloudMask = phase(:, :) /= phaseIsNone .and. validRetrievalMask(:, :) - waterCloudMask = phase(:, :) == phaseIsLiquid .and. validRetrievalMask(:, :) - iceCloudMask = phase(:, :) == phaseIsIce .and. validRetrievalMask(:, :) - ! - ! Use these as pixel counts at first - ! - Cloud_Fraction_Total_Mean(:) = real(count(cloudMask, dim = 2)) - Cloud_Fraction_Water_Mean(:) = real(count(waterCloudMask, dim = 2)) - Cloud_Fraction_Ice_Mean(:) = real(count(iceCloudMask, dim = 2)) - - Cloud_Fraction_High_Mean(:) = real(count(cloudMask .and. cloud_top_pressure <= highCloudPressureLimit, dim = 2)) - Cloud_Fraction_Low_Mean(:) = real(count(cloudMask .and. cloud_top_pressure > lowCloudPressureLimit, dim = 2)) - Cloud_Fraction_Mid_Mean(:) = Cloud_Fraction_Total_Mean(:) - Cloud_Fraction_High_Mean(:) - Cloud_Fraction_Low_Mean(:) - - ! - ! Don't want to divide by 0, even though the sums will be 0 where the pixel counts are 0. - ! - where (Cloud_Fraction_Total_Mean == 0) Cloud_Fraction_Total_Mean = -1. - where (Cloud_Fraction_Water_Mean == 0) Cloud_Fraction_Water_Mean = -1. - where (Cloud_Fraction_Ice_Mean == 0) Cloud_Fraction_Ice_Mean = -1. - - Optical_Thickness_Total_Mean = sum(optical_thickness, mask = cloudMask, dim = 2) / Cloud_Fraction_Total_Mean(:) - Optical_Thickness_Water_Mean = sum(optical_thickness, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:) - Optical_Thickness_Ice_Mean = sum(optical_thickness, mask = iceCloudMask, dim = 2) / Cloud_Fraction_Ice_Mean(:) - - ! We take the absolute value of optical thickness here to satisfy compilers that complains when we - ! evaluate the logarithm of a negative number, even though it's not included in the sum. - Optical_Thickness_Total_MeanLog10 = sum(log10(abs(optical_thickness)), mask = cloudMask, dim = 2) / & - Cloud_Fraction_Total_Mean(:) - Optical_Thickness_Water_MeanLog10 = sum(log10(abs(optical_thickness)), mask = waterCloudMask, dim = 2) / & - Cloud_Fraction_Water_Mean(:) - Optical_Thickness_Ice_MeanLog10 = sum(log10(abs(optical_thickness)), mask = iceCloudMask, dim = 2) / & - Cloud_Fraction_Ice_Mean(:) - - Cloud_Particle_Size_Water_Mean = sum(particle_size, mask = waterCloudMask, dim = 2) / Cloud_Fraction_Water_Mean(:) - Cloud_Particle_Size_Ice_Mean = sum(particle_size, mask = iceCloudMask, dim = 2) / Cloud_Fraction_Ice_Mean(:) - - Cloud_Top_Pressure_Total_Mean = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / max(1, count(cloudMask, dim = 2)) - - Liquid_Water_Path_Mean = LWP_conversion & - * sum(particle_size * optical_thickness, mask = waterCloudMask, dim = 2) & - / Cloud_Fraction_Water_Mean(:) - Ice_Water_Path_Mean = LWP_conversion * ice_density & - * sum(particle_size * optical_thickness, mask = iceCloudMask, dim = 2) & - / Cloud_Fraction_Ice_Mean(:) - - ! - ! Normalize pixel counts to fraction - ! The first three cloud fractions have been set to -1 in cloud-free areas, so set those places to 0. - ! - Cloud_Fraction_Total_Mean(:) = max(0., Cloud_Fraction_Total_Mean(:)/nSubcols) - Cloud_Fraction_Water_Mean(:) = max(0., Cloud_Fraction_Water_Mean(:)/nSubcols) - Cloud_Fraction_Ice_Mean(:) = max(0., Cloud_Fraction_Ice_Mean(:) /nSubcols) - - Cloud_Fraction_High_Mean(:) = Cloud_Fraction_High_Mean(:) /nSubcols - Cloud_Fraction_Mid_Mean(:) = Cloud_Fraction_Mid_Mean(:) /nSubcols - Cloud_Fraction_Low_Mean(:) = Cloud_Fraction_Low_Mean(:) /nSubcols - - ! ---- - ! Joint histogram - ! - do i = 1, numTauHistogramBins - where(cloudMask(:, :)) - tauMask(:, :, i) = optical_thickness(:, :) >= tauHistogramBoundaries(i) .and. & - optical_thickness(:, :) < tauHistogramBoundaries(i+1) - elsewhere - tauMask(:, :, i) = .false. - end where - end do - - do i = 1, numPressureHistogramBins - where(cloudMask(:, :)) - pressureMask(:, :, i) = cloud_top_pressure(:, :) >= pressureHistogramBoundaries(i) .and. & - cloud_top_pressure(:, :) < pressureHistogramBoundaries(i+1) - elsewhere - pressureMask(:, :, i) = .false. - end where - end do - - do i = 1, numPressureHistogramBins - do j = 1, numTauHistogramBins - Optical_Thickness_vs_Cloud_Top_Pressure(:, j, i) = & - real(count(tauMask(:, :, j) .and. pressureMask(:, :, i), dim = 2)) / real(nSubcols) - end do - end do - - end subroutine modis_L3_simulator - !------------------------------------------------------------------------------------------------ - function cloud_top_pressure(tauIncrement, pressure, tauLimit) - real, dimension(:), intent(in) :: tauIncrement, pressure - real, intent(in) :: tauLimit - real :: cloud_top_pressure - ! - ! Find the extinction-weighted pressure. Assume that pressure varies linearly between - ! layers and use the trapezoidal rule. - ! - - real :: deltaX, totalTau, totalProduct - integer :: i - - totalTau = 0.; totalProduct = 0. - 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. * tauIncrement(i)) - else - totalTau = totalTau + tauIncrement(i) - totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2. - end if - if(totalTau >= tauLimit) exit - end do - cloud_top_pressure = totalProduct/totalTau - end function cloud_top_pressure - !------------------------------------------------------------------------------------------------ - function weight_by_extinction(tauIncrement, f, tauLimit) - real, dimension(:), intent(in) :: tauIncrement, f - real, intent(in) :: tauLimit - real :: weight_by_extinction - ! - ! Find the extinction-weighted value of f(tau), assuming constant f within each layer - ! - - real :: deltaX, totalTau, totalProduct - integer :: i - - totalTau = 0.; totalProduct = 0. - 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 - weight_by_extinction = totalProduct/totalTau - end function weight_by_extinction - !------------------------------------------------------------------------------------------------ - pure function compute_nir_reflectance(water_tau, water_size, ice_tau, ice_size) - real, dimension(:), intent(in) :: water_tau, water_size, ice_tau, ice_size - real :: compute_nir_reflectance - - real, dimension(size(water_tau)) :: water_g, water_w0, ice_g, ice_w0, & - tau, g, w0 - !---------------------------------------- - water_g(:) = get_g_nir( phaseIsLiquid, water_size) - water_w0(:) = get_ssa_nir(phaseIsLiquid, water_size) - ice_g(:) = get_g_nir( phaseIsIce, ice_size) - ice_w0(:) = get_ssa_nir(phaseIsIce, ice_size) - ! - ! Combine ice and water optical properties - ! - g(:) = 0; w0(:) = 0. - tau(:) = ice_tau(:) + water_tau(:) - where (tau(:) > 0) - w0(:) = (water_tau(:) * water_w0(:) + ice_tau(:) * ice_w0(:)) / & - tau(:) - g(:) = (water_tau(:) * water_g(:) * water_w0(:) + ice_tau(:) * ice_g(:) * ice_w0(:)) / & - (w0(:) * tau(:)) - end where - - compute_nir_reflectance = compute_toa_reflectace(tau, g, w0) - end function compute_nir_reflectance - !------------------------------------------------------------------------------------------------ - ! Retreivals - !------------------------------------------------------------------------------------------------ - elemental function retrieve_re (phase, tau, obs_Refl_nir) - integer, intent(in) :: phase - real, intent(in) :: tau, obs_Refl_nir - real :: retrieve_re - ! - ! Finds the re that produces the minimum mis-match between predicted and observed reflectance in - ! MODIS band 7 (near IR) - ! Uses - ! fits for asymmetry parameter g(re) and single scattering albedo w0(re) based on MODIS tables - ! two-stream for layer reflectance and transmittance as a function of optical thickness tau, g, and w0 - ! adding-doubling for total reflectance - ! - ! - ! - ! Local variables - ! - real, parameter :: min_distance_to_boundary = 0.01 - real :: re_min, re_max, delta_re - integer :: i - - real, dimension(num_trial_res) :: trial_re, g, w0, predicted_Refl_nir - ! -------------------------- - - if(any(phase == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then - if (phase == phaseIsLiquid .OR. phase == phaseIsUndetermined) then - re_min = re_water_min - re_max = re_water_max - trial_re(:) = trial_re_w - g(:) = g_w(:) - w0(:) = w0_w(:) - else - re_min = re_ice_min - re_max = re_ice_max - trial_re(:) = trial_re_i - g(:) = g_i(:) - w0(:) = w0_i(:) - end if - ! - ! 1st attempt at index: w/coarse re resolution - ! - predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:)) - retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) - ! - ! If first retrieval works, can try 2nd iteration using greater re resolution - ! -! DJS2015: Remove unused piece of code -! if(use_two_re_iterations .and. retrieve_re > 0.) then -! re_min = retrieve_re - delta_re -! re_max = retrieve_re + delta_re -! delta_re = (re_max - re_min)/real(num_trial_res-1) -! -! trial_re(:) = re_min + delta_re * (/ (i - 1, i = 1, num_trial_res) /) -! g(:) = get_g_nir( phase, trial_re(:)) -! w0(:) = get_ssa_nir(phase, trial_re(:)) -! predicted_Refl_nir(:) = two_stream_reflectance(tau, g(:), w0(:)) -! retrieve_re = interpolate_to_min(trial_re(:), predicted_Refl_nir(:), obs_Refl_nir) -! end if -! DJS2015 END - else - retrieve_re = re_fill - end if - - end function retrieve_re - ! -------------------------------------------- - pure function interpolate_to_min(x, y, yobs) - real, dimension(:), intent(in) :: x, y - real, intent(in) :: yobs - real :: interpolate_to_min - ! - ! 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 - ! - real, dimension(size(x)) :: diff - integer :: nPoints, minDiffLoc, lowerBound, upperBound - ! --------------------------------- - nPoints = size(y) - diff(:) = y(:) - 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 (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, intent(in) :: re - real :: get_g_nir - - real, 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, 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, intent(in) :: re - real :: 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, dimension(4), parameter :: ice_coefficients = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/) - real, 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) - real, intent(in) :: x - real, dimension(:), intent(in) :: coefficients - real :: 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) - real, intent(in) :: x - real, dimension(:), intent(in) :: coefficients - real :: 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(tau, g, w0) - real, dimension(:), intent(in) :: tau, g, w0 - real :: compute_toa_reflectace - - logical, dimension(size(tau)) :: cloudMask - integer, dimension(count(tau(:) > 0)) :: cloudIndicies - real, dimension(count(tau(:) > 0)) :: Refl, Trans - real :: Refl_tot, Trans_tot - integer :: i - ! --------------------------------------- - ! - ! This wrapper reports reflectance only and strips out non-cloudy elements from the calculation - ! - cloudMask = tau(:) > 0. - cloudIndicies = pack((/ (i, i = 1, size(tau)) /), 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(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) - real, intent(in) :: tauint, gint, w0int - real, intent(out) :: ref, tra - ! - ! Compute reflectance in a single layer using the two stream approximation - ! The code itself is from Lazaros Oreopoulos via Steve Platnick - ! - ! ------------------------ - ! 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, parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 - real :: 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 - w0int * f) * tauint - w0 = (1 - f) * w0int / (1 - w0int * f) - g = (gint - f) / (1 - f) - - ! delta-Eddington (Joseph et al. 1976) - gamma1 = (7 - w0* (4 + 3 * g)) / 4.0 - gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0 - gamma3 = (2 - 3*g*xmu) / 4.0 - gamma4 = 1 - gamma3 - - if (w0int > minConservativeW0) then - ! Conservative scattering - if (beam == 1) then - rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu))) - ref = rh / (1 + gamma1 * tau) - tra = 1 - ref - else if(beam == 2) then - ref = gamma1*tau/(1 + gamma1*tau) - tra = 1 - ref - endif - else - ! Non-conservative scattering - a1 = gamma1 * gamma4 + gamma2 * gamma3 - a2 = gamma1 * gamma3 + gamma2 * gamma4 - - rk = sqrt(gamma1**2 - gamma2**2) - - r1 = (1 - rk * xmu) * (a2 + rk * gamma3) - r2 = (1 + rk * xmu) * (a2 - rk * gamma3) - r3 = 2 * rk *(gamma3 - a2 * xmu) - r4 = (1 - (rk * xmu)**2) * (rk + gamma1) - r5 = (1 - (rk * xmu)**2) * (rk - gamma1) - - t1 = (1 + rk * xmu) * (a1 + rk * gamma4) - t2 = (1 - rk * xmu) * (a1 - rk * gamma4) - t3 = 2 * rk * (gamma4 + a1 * xmu) - t4 = r4 - t5 = r5 - - beta = -r5 / r4 - - e1 = min(rk * tau, 500.) - e2 = min(tau / xmu, 500.) - - 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-ef2))/((rk+gamma1)*(1-beta*ef2)) - tra = (2*rk*ef1)/((rk+gamma1)*(1-beta*ef2)) - endif - end if - end subroutine two_stream - ! -------------------------------------------------- - elemental function two_stream_reflectance(tauint, gint, w0int) - real, intent(in) :: tauint, gint, w0int - real :: two_stream_reflectance - ! - ! Compute reflectance in a single layer using the two stream approximation - ! The code itself is from Lazaros Oreopoulos via Steve Platnick - ! - ! ------------------------ - ! 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, parameter :: xmu = 0.866, minConservativeW0 = 0.9999999 - real :: 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 - w0int * f) * tauint - w0 = (1 - f) * w0int / (1 - w0int * f) - g = (gint - f) / (1 - f) - - ! delta-Eddington (Joseph et al. 1976) - gamma1 = (7 - w0* (4 + 3 * g)) / 4.0 - gamma2 = -(1 - w0* (4 - 3 * g)) / 4.0 - gamma3 = (2 - 3*g*xmu) / 4.0 - gamma4 = 1 - 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 + gamma1 * tau) - elseif (beam == 2) then - two_stream_reflectance = gamma1*tau/(1 + 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 - rk * xmu) * (a2 + rk * gamma3) - r2 = (1 + rk * xmu) * (a2 - rk * gamma3) - r3 = 2 * rk *(gamma3 - a2 * xmu) - r4 = (1 - (rk * xmu)**2) * (rk + gamma1) - r5 = (1 - (rk * xmu)**2) * (rk - gamma1) - - t1 = (1 + rk * xmu) * (a1 + rk * gamma4) - t2 = (1 - rk * xmu) * (a1 - rk * gamma4) - t3 = 2 * rk * (gamma4 + a1 * xmu) - t4 = r4 - t5 = r5 - - beta = -r5 / r4 - - e1 = min(rk * tau, 500.) - e2 = min(tau / xmu, 500.) - - 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-ef2))/((rk+gamma1)*(1-beta*ef2)) - endif - - end if - end function two_stream_reflectance - ! -------------------------------------------- - pure subroutine adding_doubling (Refl, Tran, Refl_tot, Tran_tot) - real, dimension(:), intent(in) :: Refl, Tran - real, intent(out) :: Refl_tot, Tran_tot - ! - ! Use adding/doubling formulas to compute total reflectance and transmittance from layer values - ! - - integer :: i - real, dimension(size(Refl)) :: Refl_cumulative, Tran_cumulative - - Refl_cumulative(1) = Refl(1); Tran_cumulative(1) = Tran(1) - - do i=2, size(Refl) - ! 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 - Refl_cumulative(i-1) * Refl(i)) - Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1 - Refl_cumulative(i-1) * Refl(i)) - end do - - Refl_tot = Refl_cumulative(size(Refl)) - Tran_tot = Tran_cumulative(size(Refl)) - - end subroutine adding_doubling - ! -------------------------------------------------- - subroutine complain_and_die(message) - character(len = *), intent(in) :: message - - write(6, *) "Failure in MODIS simulator" - write(6, *) trim(message) - stop - end subroutine complain_and_die - !------------------------------------------------------------------------------------------------ -end module mod_modis_sim Index: LMDZ6/trunk/libf/phylmd/cosp/mrgrnk.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/mrgrnk.F90 (revision 3231) +++ (revision ) @@ -1,410 +1,0 @@ -Module m_mrgrnk -Integer, Parameter :: kdp = selected_real_kind(15) -public :: mrgrnk -private :: kdp -private :: I_mrgrnk, D_mrgrnk -interface mrgrnk - module procedure D_mrgrnk, I_mrgrnk -end interface mrgrnk -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 (kind=kdp), Dimension (:), Intent (In) :: XDONT - Integer, Dimension (:), Intent (Out) :: IRNGT -! __________________________________________________________ - Real (kind=kdp) :: 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 I_mrgrnk (XDONT, IRNGT) -! __________________________________________________________ -! MRGRNK = Merge-sort ranking of an array -! For performance reasons, the first 2 passes are taken -! out of the standard loop, and use dedicated coding. -! __________________________________________________________ -! __________________________________________________________ - Integer, Dimension (:), Intent (In) :: XDONT - Integer, Dimension (:), Intent (Out) :: IRNGT -! __________________________________________________________ - Integer :: XVALA, XVALB -! - Integer, Dimension (SIZE(IRNGT)) :: JWRKT - Integer :: LMTNA, LMTNC, IRNG1, IRNG2 - Integer :: NVAL, IIND, IWRKD, IWRK, IWRKF, JINDA, IINDA, IINDB -! - NVAL = Min (SIZE(XDONT), SIZE(IRNGT)) - Select Case (NVAL) - Case (:0) - Return - Case (1) - IRNGT (1) = 1 - Return - Case Default - Continue - End Select -! -! Fill-in the index array, creating ordered couples -! - Do IIND = 2, NVAL, 2 - If (XDONT(IIND-1) <= XDONT(IIND)) Then - IRNGT (IIND-1) = IIND - 1 - IRNGT (IIND) = IIND - Else - IRNGT (IIND-1) = IIND - IRNGT (IIND) = IIND - 1 - End If - End Do - If (Modulo(NVAL, 2) /= 0) Then - IRNGT (NVAL) = NVAL - End If -! -! We will now have ordered subsets A - B - A - B - ... -! and merge A and B couples into C - C - ... -! - LMTNA = 2 - LMTNC = 4 -! -! First iteration. The length of the ordered subsets goes from 2 to 4 -! - Do - If (NVAL <= 2) Exit -! -! Loop on merges of A and B into C -! - Do IWRKD = 0, NVAL - 1, 4 - If ((IWRKD+4) > NVAL) Then - If ((IWRKD+2) >= NVAL) Exit -! -! 1 2 3 -! - If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Exit -! -! 1 3 2 -! - If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then - IRNG2 = IRNGT (IWRKD+2) - IRNGT (IWRKD+2) = IRNGT (IWRKD+3) - IRNGT (IWRKD+3) = IRNG2 -! -! 3 1 2 -! - Else - IRNG1 = IRNGT (IWRKD+1) - IRNGT (IWRKD+1) = IRNGT (IWRKD+3) - IRNGT (IWRKD+3) = IRNGT (IWRKD+2) - IRNGT (IWRKD+2) = IRNG1 - End If - Exit - End If -! -! 1 2 3 4 -! - If (XDONT(IRNGT(IWRKD+2)) <= XDONT(IRNGT(IWRKD+3))) Cycle -! -! 1 3 x x -! - If (XDONT(IRNGT(IWRKD+1)) <= XDONT(IRNGT(IWRKD+3))) Then - IRNG2 = IRNGT (IWRKD+2) - IRNGT (IWRKD+2) = IRNGT (IWRKD+3) - If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then -! 1 3 2 4 - IRNGT (IWRKD+3) = IRNG2 - Else -! 1 3 4 2 - IRNGT (IWRKD+3) = IRNGT (IWRKD+4) - IRNGT (IWRKD+4) = IRNG2 - End If -! -! 3 x x x -! - Else - IRNG1 = IRNGT (IWRKD+1) - IRNG2 = IRNGT (IWRKD+2) - IRNGT (IWRKD+1) = IRNGT (IWRKD+3) - If (XDONT(IRNG1) <= XDONT(IRNGT(IWRKD+4))) Then - IRNGT (IWRKD+2) = IRNG1 - If (XDONT(IRNG2) <= XDONT(IRNGT(IWRKD+4))) Then -! 3 1 2 4 - IRNGT (IWRKD+3) = IRNG2 - Else -! 3 1 4 2 - IRNGT (IWRKD+3) = IRNGT (IWRKD+4) - IRNGT (IWRKD+4) = IRNG2 - End If - Else -! 3 4 1 2 - IRNGT (IWRKD+2) = IRNGT (IWRKD+4) - IRNGT (IWRKD+3) = IRNG1 - IRNGT (IWRKD+4) = IRNG2 - End If - End If - End Do -! -! The Cs become As and Bs -! - LMTNA = 4 - Exit - End Do -! -! Iteration loop. Each time, the length of the ordered subsets -! is doubled. -! - Do - If (LMTNA >= NVAL) Exit - IWRKF = 0 - LMTNC = 2 * LMTNC -! -! Loop on merges of A and B into C -! - Do - IWRK = IWRKF - IWRKD = IWRKF + 1 - JINDA = IWRKF + LMTNA - IWRKF = IWRKF + LMTNC - If (IWRKF >= NVAL) Then - If (JINDA >= NVAL) Exit - IWRKF = NVAL - End If - IINDA = 1 - IINDB = JINDA + 1 -! -! Shortcut for the case when the max of A is smaller -! than the min of B. This line may be activated when the -! initial set is already close to sorted. -! -! IF (XDONT(IRNGT(JINDA)) <= XDONT(IRNGT(IINDB))) CYCLE -! -! One steps in the C subset, that we build in the final rank array -! -! Make a copy of the rank array for the merge iteration -! - JWRKT (1:LMTNA) = IRNGT (IWRKD:JINDA) -! - XVALA = XDONT (JWRKT(IINDA)) - XVALB = XDONT (IRNGT(IINDB)) -! - Do - IWRK = IWRK + 1 -! -! We still have unprocessed values in both A and B -! - If (XVALA > XVALB) Then - IRNGT (IWRK) = IRNGT (IINDB) - IINDB = IINDB + 1 - If (IINDB > IWRKF) Then -! Only A still with unprocessed values - IRNGT (IWRK+1:IWRKF) = JWRKT (IINDA:LMTNA) - Exit - End If - XVALB = XDONT (IRNGT(IINDB)) - Else - IRNGT (IWRK) = JWRKT (IINDA) - IINDA = IINDA + 1 - If (IINDA > LMTNA) Exit! Only B still with unprocessed values - XVALA = XDONT (JWRKT(IINDA)) - End If -! - End Do - End Do -! -! The Cs become As and Bs -! - LMTNA = 2 * LMTNA - End Do -! - Return -! -End Subroutine I_mrgrnk -end module m_mrgrnk Index: LMDZ6/trunk/libf/phylmd/cosp/phys_cosp.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/phys_cosp.F90 (revision 3231) +++ LMDZ6/trunk/libf/phylmd/cosp/phys_cosp.F90 (revision 3233) @@ -142,4 +142,6 @@ !$OMP THREADPRIVATE(first_write) + logical, save :: ok_readxiosactive_cosp=.false. +!$OMP THREADPRIVATE(ok_readxiosactive_cosp) !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! Input variables from LMDZ-GCM integer :: overlaplmdz ! overlap type: 1=max, 2=rand, 3=max/rand ! cosp input (output lmdz) @@ -153,4 +155,7 @@ real :: dtime,freq_cosp real,dimension(2) :: time_bnds + + double precision :: d_dtime + double precision,dimension(2) :: d_time_bnds namelist/COSP_INPUT/overlap,isccp_topheight,isccp_topheight_direction, & @@ -192,13 +197,10 @@ !!! Ici on modifie les cles logiques selon les champs actives dans les .xml #ifdef CPP_XIOS + if (ok_readxiosactive_cosp) then if ((itap.gt.1).and.(first_write))then -! call read_xiosfieldactive(cfg) call read_cosp_output_nl(itap,cosp_output_nl,cfg) -! print*,' Dans cosp_write itap first_writ LcfadLidarsr532 =', & -! itap, first_write, cfg%LcfadLidarsr532 first_write=.false. endif -! print*,' Dans cosp_write itap LcfadLidarsr532 =', & -! itap, cfg%LcfadLidarsr532 + endif #endif @@ -206,4 +208,8 @@ time_bnds(1) = dtime-dtime/2. time_bnds(2) = dtime+dtime/2. + + d_time_bnds=time_bnds + d_dtime=dtime + ! print*,'Debut phys_cosp itap,dtime,freq_cosp,ecrit_mth,ecrit_day,ecrit_hf ', & @@ -225,5 +231,5 @@ emsfc_lw = 1. - call construct_cosp_gridbox(dtime,time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs, & + call construct_cosp_gridbox(d_dtime,d_time_bnds,radar_freq,surface_radar,use_mie_tables,use_gas_abs, & do_ray,melt_lay,k2, & Npoints,Nlevels,Ncolumns,N_HYDRO,Nprmts_max_hydro,Naero,Nprmts_max_aero,Npoints_it, & @@ -441,187 +447,3 @@ END SUBROUTINE read_cosp_input - SUBROUTINE read_xiosfieldactive(cfg) - - USE MOD_COSP_TYPES -#ifdef CPP_XIOS - USE xios, ONLY: xios_field_is_active -#endif - type(cosp_config),intent(out) :: cfg - -! 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")) cfg%Lcllcalipso=.TRUE. - IF (xios_field_is_active("clmcalipso")) cfg%Lclmcalipso=.TRUE. - IF (xios_field_is_active("clhcalipso")) cfg%Lclhcalipso=.TRUE. - IF (xios_field_is_active("cltcalipso")) cfg%Lcltcalipso=.TRUE. -! IF (xios_field_is_active("pcllcalipso")) cfg%Lcllcalipso=.TRUE. -! IF (xios_field_is_active("pclmcalipso")) cfg%Lclmcalipso=.TRUE. -! IF (xios_field_is_active("pclhcalipso")) cfg%Lclhcalipso=.TRUE. -! IF (xios_field_is_active("pcltcalipso")) cfg%Lcltcalipso=.TRUE. - IF (xios_field_is_active("cllcalipsoice")) cfg%Lcllcalipsoice=.TRUE. - IF (xios_field_is_active("clmcalipsoice")) cfg%Lclmcalipsoice=.TRUE. - IF (xios_field_is_active("clhcalipsoice")) cfg%Lclhcalipsoice=.TRUE. - IF (xios_field_is_active("cltcalipsoice")) cfg%Lcltcalipsoice=.TRUE. - IF (xios_field_is_active("cllcalipsoliq")) cfg%Lcllcalipsoliq=.TRUE. - IF (xios_field_is_active("clmcalipsoliq")) cfg%Lclmcalipsoliq=.TRUE. - IF (xios_field_is_active("clhcalipsoliq")) cfg%Lclhcalipsoliq=.TRUE. - IF (xios_field_is_active("cltcalipsoliq")) cfg%Lcltcalipsoliq=.TRUE. - IF (xios_field_is_active("cllcalipsoun")) cfg%Lcllcalipsoun=.TRUE. - IF (xios_field_is_active("clmcalipsoun")) cfg%Lclmcalipsoun=.TRUE. - IF (xios_field_is_active("clhcalipsoun")) cfg%Lclhcalipsoun=.TRUE. - IF (xios_field_is_active("cltcalipsoun")) cfg%Lcltcalipsoun=.TRUE. - IF (xios_field_is_active("clcalipso")) cfg%Lclcalipso=.TRUE. -! IF (xios_field_is_active("pclcalipso")) cfg%Lclcalipso=.TRUE. - IF (xios_field_is_active("clcalipsoice")) cfg%Lclcalipsoice=.TRUE. - IF (xios_field_is_active("clcalipsoliq")) cfg%Lclcalipsoliq=.TRUE. - IF (xios_field_is_active("clcalipsoun")) cfg%Lclcalipsoun=.TRUE. - IF (xios_field_is_active("clcalipsotmp")) cfg%Lclcalipsotmp=.TRUE. - IF (xios_field_is_active("clcalipsotmpice")) cfg%Lclcalipsotmpice=.TRUE. - IF (xios_field_is_active("clcalipsotmpliq")) cfg%Lclcalipsotmpliq=.TRUE. - IF (xios_field_is_active("clcalipsotmpun")) cfg%Lclcalipsotmpun=.TRUE. - IF (xios_field_is_active("parasol_refl")) cfg%LparasolRefl=.TRUE. - IF (xios_field_is_active("parasol_crefl")) cfg%LparasolRefl=.TRUE. - IF (xios_field_is_active("Ncrefl")) cfg%LparasolRefl=.TRUE. - IF (xios_field_is_active("cfad_lidarsr532")) cfg%LcfadLidarsr532=.TRUE. - IF (xios_field_is_active("atb532")) cfg%Latb532=.TRUE. - IF (xios_field_is_active("beta_mol532")) cfg%LlidarBetaMol532=.TRUE. - IF (xios_field_is_active("clopaquecalipso")) cfg%Lclopaquecalipso=.TRUE. - IF (xios_field_is_active("clthincalipso")) cfg%Lclthincalipso=.TRUE. - IF (xios_field_is_active("clzopaquecalipso")) cfg%Lclzopaquecalipso=.TRUE. - IF (xios_field_is_active("clcalipsoopaque")) cfg%Lclcalipsoopaque=.TRUE. - IF (xios_field_is_active("clcalipsothin")) cfg%Lclcalipsothin=.TRUE. - IF (xios_field_is_active("clcalipsozopaque")) cfg%Lclcalipsozopaque=.TRUE. - IF (xios_field_is_active("clcalipsoopacity")) cfg%Lclcalipsoopacity=.TRUE. - IF (xios_field_is_active("proftemp")) cfg%Lproftemp=.TRUE. - IF (xios_field_is_active("profSR")) cfg%LprofSR=.TRUE. - - IF (xios_field_is_active("cfadDbze94")) cfg%LcfadDbze94=.TRUE. - IF (xios_field_is_active("dbze94")) cfg%Ldbze94=.TRUE. - IF (xios_field_is_active("cltlidarradar")) cfg%Lcltlidarradar=.TRUE. - IF (xios_field_is_active("clcalipso2")) cfg%Lclcalipso2=.TRUE. - - IF (xios_field_is_active("clisccp2")) cfg%Lclisccp=.TRUE. - IF (xios_field_is_active("boxtauisccp")) cfg%Lboxtauisccp=.TRUE. - IF (xios_field_is_active("boxptopisccp")) cfg%Lboxptopisccp=.TRUE. - IF (xios_field_is_active("tclisccp")) cfg%Lcltisccp=.TRUE. - IF (xios_field_is_active("ctpisccp")) cfg%Lpctisccp=.TRUE. - IF (xios_field_is_active("tauisccp")) cfg%Ltauisccp=.TRUE. - IF (xios_field_is_active("albisccp")) cfg%Lalbisccp=.TRUE. - IF (xios_field_is_active("meantbisccp")) cfg%Lmeantbisccp=.TRUE. - IF (xios_field_is_active("meantbclrisccp")) cfg%Lmeantbclrisccp=.TRUE. - - IF (xios_field_is_active("clMISR")) cfg%LclMISR=.TRUE. - -IF (xios_field_is_active("cllmodis")) cfg%Lcllmodis=.TRUE. - IF (xios_field_is_active("clmmodis")) cfg%Lclmmodis=.TRUE. - IF (xios_field_is_active("clhmodis")) cfg%Lclhmodis=.TRUE. - IF (xios_field_is_active("cltmodis")) cfg%Lcltmodis=.TRUE. - IF (xios_field_is_active("clwmodis")) cfg%Lclwmodis=.TRUE. - IF (xios_field_is_active("climodis")) cfg%Lclimodis=.TRUE. - IF (xios_field_is_active("tautmodis")) cfg%Ltautmodis=.TRUE. - IF (xios_field_is_active("tauwmodis")) cfg%Ltauwmodis=.TRUE. - IF (xios_field_is_active("tauimodis")) cfg%Ltauimodis=.TRUE. - IF (xios_field_is_active("tautlogmodis")) cfg%Ltautlogmodis=.TRUE. - IF (xios_field_is_active("tauilogmodis")) cfg%Ltauilogmodis=.TRUE. - IF (xios_field_is_active("tauwlogmodis")) cfg%Ltauwlogmodis=.TRUE. - IF (xios_field_is_active("reffclwmodis")) cfg%Lreffclwmodis=.TRUE. - IF (xios_field_is_active("reffclimodis")) cfg%Lreffclimodis=.TRUE. - IF (xios_field_is_active("pctmodis")) cfg%Lpctmodis=.TRUE. - IF (xios_field_is_active("lwpmodis")) cfg%Llwpmodis=.TRUE. - IF (xios_field_is_active("iwpmodis")) cfg%Liwpmodis=.TRUE. - IF (xios_field_is_active("clmodis")) cfg%Lclmodis=.TRUE. - IF (xios_field_is_active("crimodis")) cfg%Lcrimodis=.TRUE. - IF (xios_field_is_active("crlmodis")) cfg%Lcrlmodis=.TRUE. - -! 2. si champs demande alors activer le simulateur correspondant - IF (xios_field_is_active("cllcalipso").OR. & - xios_field_is_active("clmcalipso").OR. & - xios_field_is_active("clhcalipso").OR. & - xios_field_is_active("cltcalipso").OR. & -! xios_field_is_active("pcllcalipso").OR. & -! xios_field_is_active("pclmcalipso").OR. & -! xios_field_is_active("pclhcalipso").OR. & -! xios_field_is_active("pcltcalipso").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("pclcalipso").OR. & - xios_field_is_active("clcalipsoice").OR. & - xios_field_is_active("clcalipsoliq").OR. & - xios_field_is_active("clcalipsoun").OR. & - xios_field_is_active("clcalipsotmp").OR. & - xios_field_is_active("clcalipsotmpice").OR. & - xios_field_is_active("clcalipsotmpliq").OR. & - xios_field_is_active("clcalipsotmpun").OR. & - xios_field_is_active("parasol_refl").OR. & - xios_field_is_active("parasol_crefl").OR. & - xios_field_is_active("Ncrefl").OR. & - xios_field_is_active("cfad_lidarsr532").OR. & - xios_field_is_active("atb532").OR. & - xios_field_is_active("beta_mol532").OR. & - xios_field_is_active("clopaquecalipso").OR. & - xios_field_is_active("clthincalipso").OR. & - xios_field_is_active("clzopaquecalipso").OR. & - xios_field_is_active("clcalipsoopaque").OR. & - xios_field_is_active("clcalipsothin").OR. & - xios_field_is_active("clcalipsozopaque").OR. & - xios_field_is_active("clcalipsoopacity").OR. & - xios_field_is_active("proftemp").OR. & - xios_field_is_active("profSR")) cfg%Llidar_sim=.TRUE. - - IF (xios_field_is_active("cfadDbze94").OR. & - xios_field_is_active("dbze94")) & - cfg%Lradar_sim=.TRUE. - - IF (xios_field_is_active("cltlidarradar").OR. & - xios_field_is_active("clcalipso2")) THEN - cfg%Lradar_sim=.TRUE. - cfg%Llidar_sim=.TRUE. - ENDIF - - IF (xios_field_is_active("clisccp2").OR. & - xios_field_is_active("boxtauisccp").OR. & - xios_field_is_active("boxptopisccp").OR. & - xios_field_is_active("tclisccp").OR. & - xios_field_is_active("ctpisccp").OR. & - xios_field_is_active("tauisccp").OR. & - xios_field_is_active("albisccp").OR. & - xios_field_is_active("meantbisccp").OR. & - xios_field_is_active("meantbclrisccp")) cfg%Lisccp_sim=.TRUE. - - IF (xios_field_is_active("clMISR")) cfg%Lmisr_sim=.TRUE. - - IF (xios_field_is_active("cllmodis").OR. & - xios_field_is_active("clmmodis").OR. & - xios_field_is_active("clhmodis").OR. & - xios_field_is_active("cltmodis").OR. & - xios_field_is_active("clwmodis").OR. & - xios_field_is_active("climodis").OR. & - xios_field_is_active("tautmodis").OR. & - xios_field_is_active("tauwmodis").OR. & - xios_field_is_active("tauimodis").OR. & - xios_field_is_active("tautlogmodis").OR. & - xios_field_is_active("tauilogmodis").OR. & - xios_field_is_active("tauwlogmodis").OR. & - xios_field_is_active("reffclwmodis").OR. & - xios_field_is_active("reffclimodis").OR. & - xios_field_is_active("pctmodis").OR. & - xios_field_is_active("lwpmodis").OR. & - xios_field_is_active("iwpmodis").OR. & - xios_field_is_active("clmodis").OR. & - xios_field_is_active("crimodis").OR. & - xios_field_is_active("crlmodis")) cfg%Lmodis_sim=.TRUE. - END SUBROUTINE read_xiosfieldactive - - end subroutine phys_cosp Index: LMDZ6/trunk/libf/phylmd/cosp/read_cosp_output_nl.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/read_cosp_output_nl.F90 (revision 3231) +++ LMDZ6/trunk/libf/phylmd/cosp/read_cosp_output_nl.F90 (revision 3233) @@ -127,5 +127,5 @@ CALL bcast(Lmeantbisccp) CALL bcast(Lmeantbclrisccp) - CALL bcast(Lfrac_out) + CALL bcast(Lfracout) CALL bcast(LlidarBetaMol532) CALL bcast(Lcltmodis) @@ -239,5 +239,5 @@ if ((.not.Lradar_sim).and.(.not.Llidar_sim).and. & (.not.Lisccp_sim).and.(.not.Lmisr_sim)) then - Lfrac_out = .false. + Lfracout = .false. endif if (.not.Lmodis_sim) then @@ -533,5 +533,6 @@ cfg%Lcrlmodis=Lcrlmodis - if (itap.gt.1) then +#ifdef CPP_XIOS + if (itap.gt.1) then ! VEREFIER LES CHAMPS DEMANDES DANS .XML @@ -709,6 +710,6 @@ xios_field_is_active("crlmodis")) cfg%Lmodis_sim=.TRUE. - endif - + endif +#endif END SUBROUTINE READ_COSP_OUTPUT_NL Index: LMDZ6/trunk/libf/phylmd/cosp/scale_LUTs_io.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/scale_LUTs_io.F90 (revision 3231) +++ (revision ) @@ -1,137 +1,0 @@ - ! scale_LUT_io: Contains subroutines to load and save scaling Look Up Tables (LUTs) to a file - ! - ! June 2010 Written by Roj Marchand - - module scale_LUTs_io - implicit none - - contains - - subroutine load_scale_LUTs(hp) - - use radar_simulator_types - - type(class_param), intent(inout) :: hp - - logical :: LUT_file_exists - integer :: i,j,k,ind - - ! - ! load scale LUT from file - ! - inquire(file=trim(hp%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(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' - write(*,*) 'Will calculated LUT values as needed' - write(*,*) '*************************************************' - - return - else - - OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& - form='unformatted', & - err= 89, & - access='DIRECT',& - recl=28) - - write(*,*) 'Loading radar LUT file: ', & - trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' - - do i=1,maxhclass - do j=1,mt_ntt - do k=1,nRe_types - - ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) - - read(12,rec=ind) hp%Z_scale_flag(i,j,k), & - hp%Ze_scaled(i,j,k), & - hp%Zr_scaled(i,j,k), & - hp%kr_scaled(i,j,k) - - ! if(ind==1482329) then - ! write (*,*) ind, hp%Z_scale_flag(i,j,k), & - ! hp%Ze_scaled(i,j,k), & - ! hp%Zr_scaled(i,j,k), & - ! hp%kr_scaled(i,j,k) - !endif - - enddo - enddo - enddo - - close(unit=12) - return - endif - - 89 write(*,*) 'Error: Found but could NOT READ radar LUT file: ', & - trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' - stop - - end subroutine load_scale_LUTs - - subroutine save_scale_LUTs(hp) - - use radar_simulator_types - - type(class_param), intent(inout) :: hp - - logical :: LUT_file_exists - integer :: i,j,k,ind - - inquire(file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', & - exist=LUT_file_exists) - - OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& - form='unformatted', & - err= 99, & - access='DIRECT',& - recl=28) - - write(*,*) 'Creating or Updating radar LUT file: ', & - trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' - - do i=1,maxhclass - do j=1,mt_ntt - do k=1,nRe_types - - ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) - - if(.not.LUT_file_exists .or. hp%Z_scale_added_flag(i,j,k)) then - - hp%Z_scale_added_flag(i,j,k)=.false. - - write(12,rec=ind) hp%Z_scale_flag(i,j,k), & - hp%Ze_scaled(i,j,k), & - hp%Zr_scaled(i,j,k), & - hp%kr_scaled(i,j,k) - - ! 1482329 T 0.170626345026495 0.00000000000000 1.827402935860823E-003 - - !if(ind==1482329) then - ! write (*,*) ind, hp%Z_scale_flag(i,j,k), & - ! hp%Ze_scaled(i,j,k), & - ! hp%Zr_scaled(i,j,k), & - ! hp%kr_scaled(i,j,k) - !endif - endif - enddo - enddo - enddo - - close(unit=12) - return - - 99 write(*,*) 'Error: Unable to create/update radar LUT file: ', & - trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' - return - - end subroutine save_scale_LUTs - - - end module scale_LUTs_io - Index: LMDZ6/trunk/libf/phylmd/cosp/scale_luts_io.F90 =================================================================== --- LMDZ6/trunk/libf/phylmd/cosp/scale_luts_io.F90 (revision 3233) +++ LMDZ6/trunk/libf/phylmd/cosp/scale_luts_io.F90 (revision 3233) @@ -0,0 +1,137 @@ + ! scale_LUT_io: Contains subroutines to load and save scaling Look Up Tables (LUTs) to a file + ! + ! June 2010 Written by Roj Marchand + + module scale_LUTs_io + implicit none + + contains + + subroutine load_scale_LUTs(hp) + + use radar_simulator_types + + type(class_param), intent(inout) :: hp + + logical :: LUT_file_exists + integer :: i,j,k,ind + + ! + ! load scale LUT from file + ! + inquire(file=trim(hp%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(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + write(*,*) 'Will calculated LUT values as needed' + write(*,*) '*************************************************' + + return + else + + OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& + form='unformatted', & + err= 89, & + access='DIRECT',& + recl=28) + + write(*,*) 'Loading radar LUT file: ', & + trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + do i=1,maxhclass + do j=1,mt_ntt + do k=1,nRe_types + + ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) + + read(12,rec=ind) hp%Z_scale_flag(i,j,k), & + hp%Ze_scaled(i,j,k), & + hp%Zr_scaled(i,j,k), & + hp%kr_scaled(i,j,k) + + ! if(ind==1482329) then + ! write (*,*) ind, hp%Z_scale_flag(i,j,k), & + ! hp%Ze_scaled(i,j,k), & + ! hp%Zr_scaled(i,j,k), & + ! hp%kr_scaled(i,j,k) + !endif + + enddo + enddo + enddo + + close(unit=12) + return + endif + + 89 write(*,*) 'Error: Found but could NOT READ radar LUT file: ', & + trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + stop + + end subroutine load_scale_LUTs + + subroutine save_scale_LUTs(hp) + + use radar_simulator_types + + type(class_param), intent(inout) :: hp + + logical :: LUT_file_exists + integer :: i,j,k,ind + + inquire(file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat', & + exist=LUT_file_exists) + + OPEN(unit=12,file=trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat',& + form='unformatted', & + err= 99, & + access='DIRECT',& + recl=28) + + write(*,*) 'Creating or Updating radar LUT file: ', & + trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + + do i=1,maxhclass + do j=1,mt_ntt + do k=1,nRe_types + + ind = i+(j-1)*maxhclass+(k-1)*(nRe_types*mt_ntt) + + if(.not.LUT_file_exists .or. hp%Z_scale_added_flag(i,j,k)) then + + hp%Z_scale_added_flag(i,j,k)=.false. + + write(12,rec=ind) hp%Z_scale_flag(i,j,k), & + hp%Ze_scaled(i,j,k), & + hp%Zr_scaled(i,j,k), & + hp%kr_scaled(i,j,k) + + ! 1482329 T 0.170626345026495 0.00000000000000 1.827402935860823E-003 + + !if(ind==1482329) then + ! write (*,*) ind, hp%Z_scale_flag(i,j,k), & + ! hp%Ze_scaled(i,j,k), & + ! hp%Zr_scaled(i,j,k), & + ! hp%kr_scaled(i,j,k) + !endif + endif + enddo + enddo + enddo + + close(unit=12) + return + + 99 write(*,*) 'Error: Unable to create/update radar LUT file: ', & + trim(hp%scale_LUT_file_name) // '_radar_Z_scale_LUT.dat' + return + + end subroutine save_scale_LUTs + + + end module scale_LUTs_io +