LCOV - code coverage report
Current view: top level - physics/cosp2/src/src/simulator/MODIS_simulator - modis_simulator.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 236 261 90.4 %
Date: 2025-03-13 19:12:29 Functions: 13 15 86.7 %

          Line data    Source code
       1             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
       2             : ! Copyright (c) 2015, Regents of the University of Colorado
       3             : ! All rights reserved.
       4             : !
       5             : ! Redistribution and use in source and binary forms, with or without modification, are 
       6             : ! permitted provided that the following conditions are met:
       7             : !
       8             : ! 1. Redistributions of source code must retain the above copyright notice, this list of 
       9             : !    conditions and the following disclaimer.
      10             : !
      11             : ! 2. Redistributions in binary form must reproduce the above copyright notice, this list
      12             : !    of conditions and the following disclaimer in the documentation and/or other 
      13             : !    materials provided with the distribution.
      14             : !
      15             : ! 3. Neither the name of the copyright holder nor the names of its contributors may be 
      16             : !    used to endorse or promote products derived from this software without specific prior
      17             : !    written permission.
      18             : !
      19             : ! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY 
      20             : ! EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF 
      21             : ! MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL 
      22             : ! THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 
      23             : ! SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT 
      24             : ! OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS 
      25             : ! INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT
      26             : ! LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE
      27             : ! OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
      28             : !
      29             : ! History
      30             : ! May 2009:      Robert Pincus - Initial version
      31             : ! June 2009:     Steve Platnick and Robert Pincus - Simple radiative transfer for size 
      32             : !                retrievals
      33             : ! August 2009:   Robert Pincus - Consistency and bug fixes suggested by Rick Hemler (GFDL) 
      34             : ! November 2009: Robert Pincus - Bux fixes and speed-ups after experience with Rick Hemler 
      35             : !                using AM2 (GFDL) 
      36             : ! January 2010:  Robert Pincus - Added high, middle, low cloud fractions
      37             : ! May 2015:      Dustin Swales - Modified for COSPv2.0
      38             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      39             : !
      40             : ! Notes on using the MODIS simulator: 
      41             : !  *) You may provide either layer-by-layer values of optical thickness at 0.67 and 2.1
      42             : !     microns, or optical thickness at 0.67 microns and ice- and liquid-water contents 
      43             : !     (in consistent units of your choosing)
      44             : !  *) Required input also includes the optical thickness and cloud top pressure 
      45             : !     derived from the ISCCP simulator run with parameter top_height = 1. 
      46             : !  *) Cloud particle sizes are specified as radii, measured in meters, though within the 
      47             : !     module we use units of microns. Where particle sizes are outside the bounds used in 
      48             : !     the MODIS retrieval libraries (parameters re_water_min, re_ice_min, etc.) the 
      49             : !     simulator returns missing values (re_fill)
      50             : !
      51             : ! When error conditions are encountered this code calls the function complain_and_die, 
      52             : ! supplied at the bottom of this module. Users probably want to replace this with 
      53             : ! something more graceful. 
      54             : !
      55             : module mod_modis_sim
      56             :   USE MOD_COSP_CONFIG, only: R_UNDEF,modis_histTau,modis_histPres,numMODISTauBins,       &
      57             :                              numMODISPresBins,numMODISReffIceBins,numMODISReffLiqBins,   &
      58             :                              modis_histReffIce,modis_histReffLiq
      59             :   USE COSP_KINDS,      ONLY: wp
      60             :   use MOD_COSP_STATS,  ONLY: hist2D
      61             : 
      62             :   implicit none
      63             :   ! ##########################################################################
      64             :   ! Retrieval parameters
      65             :    integer, parameter :: &
      66             :         num_trial_res = 15              ! Increase to make the linear pseudo-retrieval of size more accurate
      67             :    
      68             :    real(wp) :: &
      69             :        min_OpticalThickness,          & ! Minimum detectable optical thickness
      70             :        CO2Slicing_PressureLimit,      & ! Cloud with higher pressures use thermal methods, units Pa
      71             :        CO2Slicing_TauLimit,           & ! How deep into the cloud does CO2 slicing see? 
      72             :        phase_TauLimit,                & ! How deep into the cloud does the phase detection see?
      73             :        size_TauLimit,                 & ! Depth of the re retreivals
      74             :        phaseDiscrimination_Threshold, & ! What fraction of total extincton needs to be in a single
      75             :                                         ! category to make phase discrim. work? 
      76             :        re_fill,                       & !
      77             :        re_water_min,                  & ! Minimum effective radius (liquid)
      78             :        re_water_max,                  & ! Maximum effective radius (liquid)
      79             :        re_ice_min,                    & ! Minimum effective radius (ice)
      80             :        re_ice_max,                    & ! Minimum effective radius (ice)
      81             :        highCloudPressureLimit,        & ! High cloud pressure limit (Pa)
      82             :        lowCloudPressureLimit            ! Low cloud pressure limit (Pa)
      83             :   integer :: &
      84             :        phaseIsNone,                   & !
      85             :        phaseIsLiquid,                 & !
      86             :        phaseIsIce,                    & !
      87             :        phaseIsUndetermined              !
      88             :  
      89             :   real(wp),dimension(num_trial_res) :: &
      90             :        trial_re_w, & ! Near-IR optical params vs size for retrieval scheme (liquid)
      91             :        trial_re_i    ! Near-IR optical params vs size for retrieval scheme (ice)
      92             :   real(wp),dimension(num_trial_res) :: &
      93             :        g_w,        & ! Assymettry parameter for size retrieval (liquid)
      94             :        g_i,        & ! Assymettry parameter for size retrieval (ice)
      95             :        w0_w,       & ! Single-scattering albedo for size retrieval (liquid)
      96             :        w0_i          ! Single-scattering albedo for size retrieval (ice)
      97             :   ! Algorithmic parameters
      98             :   real(wp),parameter :: &
      99             :      ice_density = 0.93_wp ! Liquid density is 1. 
     100             :       
     101             : contains
     102             :   ! ########################################################################################
     103             :   ! MODIS simulator using specified liquid and ice optical thickness in each layer 
     104             :   !
     105             :   ! Note: this simulator operates on all points; to match MODIS itself night-time 
     106             :   !       points should be excluded
     107             :   !
     108             :   ! Note: the simulator requires as input the optical thickness and cloud top pressure 
     109             :   !       derived from the ISCCP simulator run with parameter top_height = 1. 
     110             :   !       If cloud top pressure is higher than about 700 mb, MODIS can't use CO2 slicing 
     111             :   !       and reverts to a thermal algorithm much like ISCCP's. Rather than replicate that 
     112             :   !       alogrithm in this simulator we simply report the values from the ISCCP simulator. 
     113             :   ! ########################################################################################
     114       72900 :   subroutine modis_subcolumn(nSubCols, nLevels, pressureLevels, optical_thickness,       & 
     115       72900 :                          tauLiquidFraction, g, w0,isccpCloudTopPressure,                 &
     116       72900 :                          retrievedPhase, retrievedCloudTopPressure,                      &
     117       72900 :                          retrievedTau,   retrievedSize)
     118             : 
     119             :     ! INPUTS
     120             :     integer,intent(in) :: &
     121             :          nSubCols,                  & ! Number of subcolumns
     122             :          nLevels                      ! Number of levels         
     123             :     real(wp),dimension(nLevels+1),intent(in) :: &
     124             :          pressureLevels               ! Gridmean pressure at layer edges (Pa)                  
     125             :     real(wp),dimension(nSubCols,nLevels),intent(in) :: &
     126             :          optical_thickness,         & ! Subcolumn optical thickness @ 0.67 microns.
     127             :          tauLiquidFraction,         & ! Liquid water fraction
     128             :          g,                         & ! Subcolumn assymetry parameter  
     129             :          w0                           ! Subcolumn single-scattering albedo 
     130             :     real(wp),dimension(nSubCols),intent(in) :: &
     131             :          isccpCloudTopPressure        ! ISCCP retrieved cloud top pressure (Pa)
     132             : 
     133             :     ! OUTPUTS
     134             :     integer, dimension(nSubCols), intent(inout) :: &
     135             :          retrievedPhase               ! MODIS retrieved phase (liquid/ice/other)              
     136             :     real(wp),dimension(nSubCols), intent(inout) :: &
     137             :          retrievedCloudTopPressure, & ! MODIS retrieved CTP (Pa)
     138             :          retrievedTau,              & ! MODIS retrieved optical depth (unitless)              
     139             :          retrievedSize                ! MODIS retrieved particle size (microns)              
     140             : 
     141             :     ! LOCAL VARIABLES
     142             :     logical, dimension(nSubCols)      :: &
     143      145800 :          cloudMask
     144             :     real(wp)                          :: &
     145             :          integratedLiquidFraction,       &
     146             :          obs_Refl_nir
     147             :     real(wp),dimension(num_trial_res) :: &
     148             :          predicted_Refl_nir
     149             :     integer                           :: &
     150             :          i
     151             : 
     152             :     ! ########################################################################################
     153             :     !                           Optical depth retrieval 
     154             :     ! This is simply a sum over the optical thickness in each layer. 
     155             :     ! It should agree with the ISCCP values after min values have been excluded.
     156             :     ! ########################################################################################
     157    62037900 :     retrievedTau(1:nSubCols) = sum(optical_thickness(1:nSubCols,1:nLevels), dim = 2)
     158             : 
     159             :     ! ########################################################################################
     160             :     !                                 Cloud detection
     161             :     ! does optical thickness exceed detection threshold? 
     162             :     ! ########################################################################################
     163      801900 :     cloudMask = retrievedTau(1:nSubCols) >= min_OpticalThickness
     164             :     
     165      801900 :     do i = 1, nSubCols
     166      801900 :        if(cloudMask(i)) then 
     167             :           ! ##################################################################################
     168             :           !                       Cloud top pressure determination 
     169             :           ! MODIS uses CO2 slicing for clouds with tops above about 700 mb and thermal 
     170             :           ! methods for clouds lower than that. For CO2 slicing we report the optical-depth
     171             :           ! weighted pressure, integrating to a specified optical depth.
     172             :           ! This assumes linear variation in p between levels. Linear in ln(p) is probably 
     173             :           ! better, though we'd need to deal with the lowest pressure gracefully. 
     174             :           ! ##################################################################################
     175             :           retrievedCloudTopPressure(i) = cloud_top_pressure(nLevels,(/ 0._wp, optical_thickness(i,1:nLevels) /), &
     176    65685280 :                                                             pressureLevels(1:nLevels),CO2Slicing_TauLimit)  
     177             :         
     178             :           ! ##################################################################################
     179             :           !                               Phase determination 
     180             :           ! Determine fraction of total tau that's liquid when ice and water contribute about 
     181             :           ! equally to the extinction we can't tell what the phase is.
     182             :           ! ##################################################################################
     183             :           integratedLiquidFraction = weight_by_extinction(nLevels,optical_thickness(i,1:nLevels),       &
     184             :                                                           tauLiquidFraction(i, 1:nLevels), &
     185    65298896 :                                                           phase_TauLimit)
     186      386384 :           if(integratedLiquidFraction >= phaseDiscrimination_Threshold) then 
     187       46226 :              retrievedPhase(i) = phaseIsLiquid
     188      340158 :           else if (integratedLiquidFraction <= 1._wp- phaseDiscrimination_Threshold) then 
     189      318657 :              retrievedPhase(i) = phaseIsIce
     190             :           else 
     191       21501 :              retrievedPhase(i) = phaseIsUndetermined
     192             :           end if
     193             :         
     194             :           ! ##################################################################################
     195             :           !                                 Size determination 
     196             :           ! ##################################################################################
     197             :           
     198             :           ! Compute observed reflectance
     199    97755152 :           obs_Refl_nir = compute_toa_reflectace(nLevels,optical_thickness(i,1:nLevels), g(i,1:nLevels), w0(i,1:nLevels))
     200             : 
     201             :           ! Compute predicted reflectance
     202     1045199 :           if(any(retrievedPhase(i) == (/ phaseIsLiquid, phaseIsUndetermined, phaseIsIce /))) then 
     203      386384 :              if (retrievedPhase(i) == phaseIsLiquid .OR. retrievedPhase(i) == phaseIsUndetermined) then
     204             :                 predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), &
     205     1083632 :                      g_w(1:num_trial_res), w0_w(1:num_trial_res))
     206             :                 retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_w(1:num_trial_res), &
     207       67727 :                      predicted_Refl_nir(1:num_trial_res), obs_Refl_nir)
     208             :              else
     209             :                 predicted_Refl_nir(1:num_trial_res) = two_stream_reflectance(retrievedTau(i), &
     210     5098512 :                      g_i(1:num_trial_res), w0_i(1:num_trial_res))
     211             :                 retrievedSize(i) = 1.0e-06_wp*interpolate_to_min(trial_re_i(1:num_trial_res), &
     212      318657 :                      predicted_Refl_nir(1:num_trial_res), obs_Refl_nir)
     213             :              endif
     214             :           else 
     215           0 :              retrievedSize(i) = re_fill
     216             :           endif
     217             :        else   
     218             :           ! Values when we don't think there's a cloud. 
     219      342616 :           retrievedCloudTopPressure(i) = R_UNDEF 
     220      342616 :           retrievedPhase(i)            = phaseIsNone
     221      342616 :           retrievedSize(i)             = R_UNDEF 
     222      342616 :           retrievedTau(i)              = R_UNDEF 
     223             :        end if
     224             :     end do
     225             :     where((retrievedSize(1:nSubCols) < 0.).and.(retrievedSize(1:nSubCols) /= R_UNDEF)) &
     226      801900 :          retrievedSize(1:nSubCols) = 1.0e-06_wp*re_fill
     227             : 
     228             :     ! We use the ISCCP-derived CTP for low clouds, since the ISCCP simulator ICARUS 
     229             :     ! mimics what MODIS does to first order. 
     230             :     ! Of course, ISCCP cloud top pressures are in mb.   
     231             :     where(cloudMask(1:nSubCols) .and. retrievedCloudTopPressure(1:nSubCols) > CO2Slicing_PressureLimit) &
     232      801900 :          retrievedCloudTopPressure(1:nSubCols) = isccpCloudTopPressure! * 100._wp
     233             :     
     234       72900 :   end subroutine modis_subcolumn
     235             : 
     236             :   ! ########################################################################################
     237        4861 :   subroutine modis_column(nPoints,nSubCols,phase, cloud_top_pressure, optical_thickness, particle_size,     &
     238        4861 :        Cloud_Fraction_Total_Mean,         Cloud_Fraction_Water_Mean,         Cloud_Fraction_Ice_Mean,        &
     239        4861 :        Cloud_Fraction_High_Mean,          Cloud_Fraction_Mid_Mean,           Cloud_Fraction_Low_Mean,        &
     240        4861 :        Optical_Thickness_Total_Mean,      Optical_Thickness_Water_Mean,      Optical_Thickness_Ice_Mean,     &
     241        4861 :        Optical_Thickness_Total_MeanLog10, Optical_Thickness_Water_MeanLog10, Optical_Thickness_Ice_MeanLog10,&
     242        4861 :        Cloud_Particle_Size_Water_Mean,    Cloud_Particle_Size_Ice_Mean,      Cloud_Top_Pressure_Total_Mean,  &
     243        4861 :        Liquid_Water_Path_Mean,            Ice_Water_Path_Mean,                                               &    
     244        4861 :        Optical_Thickness_vs_Cloud_Top_Pressure,Optical_Thickness_vs_ReffIce,Optical_Thickness_vs_ReffLiq)
     245             :     
     246             :     ! INPUTS
     247             :     integer,intent(in) :: &
     248             :          nPoints,                           & ! Number of horizontal gridpoints
     249             :          nSubCols                             ! Number of subcolumns
     250             :     integer,intent(in), dimension(nPoints, nSubCols) ::  &
     251             :          phase                             
     252             :     real(wp),intent(in),dimension(nPoints, nSubCols) ::  &
     253             :          cloud_top_pressure,                &
     254             :          optical_thickness,                 &
     255             :          particle_size
     256             :  
     257             :     ! OUTPUTS 
     258             :     real(wp),intent(inout),dimension(nPoints)  ::   & !
     259             :          Cloud_Fraction_Total_Mean,         & !
     260             :          Cloud_Fraction_Water_Mean,         & !
     261             :          Cloud_Fraction_Ice_Mean,           & !
     262             :          Cloud_Fraction_High_Mean,          & !
     263             :          Cloud_Fraction_Mid_Mean,           & !
     264             :          Cloud_Fraction_Low_Mean,           & !
     265             :          Optical_Thickness_Total_Mean,      & !
     266             :          Optical_Thickness_Water_Mean,      & !
     267             :          Optical_Thickness_Ice_Mean,        & !
     268             :          Optical_Thickness_Total_MeanLog10, & !
     269             :          Optical_Thickness_Water_MeanLog10, & !
     270             :          Optical_Thickness_Ice_MeanLog10,   & !
     271             :          Cloud_Particle_Size_Water_Mean,    & !
     272             :          Cloud_Particle_Size_Ice_Mean,      & !
     273             :          Cloud_Top_Pressure_Total_Mean,     & !
     274             :          Liquid_Water_Path_Mean,            & !
     275             :          Ice_Water_Path_Mean                  !
     276             :     real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISPresBins) :: &
     277             :          Optical_Thickness_vs_Cloud_Top_Pressure
     278             :     real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffIceBins) :: &    
     279             :          Optical_Thickness_vs_ReffIce
     280             :     real(wp),intent(inout),dimension(nPoints,numMODISTauBins,numMODISReffLiqBins) :: &    
     281             :          Optical_Thickness_vs_ReffLiq         
     282             : 
     283             :     ! LOCAL VARIABLES
     284             :     real(wp), parameter :: &
     285             :          LWP_conversion = 2._wp/3._wp * 1000._wp ! MKS units  
     286             :     integer :: j
     287             :     logical, dimension(nPoints,nSubCols) :: &
     288        9722 :          cloudMask,      &
     289        9722 :          waterCloudMask, &
     290        9722 :          iceCloudMask,   &
     291        9722 :          validRetrievalMask
     292             :     real(wp),dimension(nPoints,nSubCols) :: &
     293        4861 :          tauWRK,ctpWRK,reffIceWRK,reffLiqWRK
     294             : 
     295             :     ! ########################################################################################
     296             :     ! Include only those pixels with successful retrievals in the statistics 
     297             :     ! ########################################################################################
     298      782471 :     validRetrievalMask(1:nPoints,1:nSubCols) = particle_size(1:nPoints,1:nSubCols) > 0.
     299             :     cloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) /= phaseIsNone .and.       &
     300      782471 :          validRetrievalMask(1:nPoints,1:nSubCols)
     301             :     waterCloudMask(1:nPoints,1:nSubCols) = phase(1:nPoints,1:nSubCols) == phaseIsLiquid .and. &
     302      782471 :          validRetrievalMask(1:nPoints,1:nSubCols)
     303             :     iceCloudMask(1:nPoints,1:nSubCols)   = phase(1:nPoints,1:nSubCols) == phaseIsIce .and.    &
     304      782471 :          validRetrievalMask(1:nPoints,1:nSubCols)
     305             :     
     306             :     ! ########################################################################################
     307             :     ! Use these as pixel counts at first 
     308             :     ! ########################################################################################
     309       77761 :     Cloud_Fraction_Total_Mean(1:nPoints) = real(count(cloudMask,      dim = 2))
     310       77761 :     Cloud_Fraction_Water_Mean(1:nPoints) = real(count(waterCloudMask, dim = 2))
     311       77761 :     Cloud_Fraction_Ice_Mean(1:nPoints)   = real(count(iceCloudMask,   dim = 2))
     312             :     Cloud_Fraction_High_Mean(1:nPoints)  = real(count(cloudMask .and. cloud_top_pressure <=          &
     313      855371 :                                            highCloudPressureLimit, dim = 2)) 
     314             :     Cloud_Fraction_Low_Mean(1:nPoints)   = real(count(cloudMask .and. cloud_top_pressure >           &
     315      855371 :                                            lowCloudPressureLimit,  dim = 2)) 
     316             :     Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Total_Mean(1:nPoints) - Cloud_Fraction_High_Mean(1:nPoints)&
     317       77761 :                                            - Cloud_Fraction_Low_Mean(1:nPoints)
     318             : 
     319             :     ! ########################################################################################
     320             :     ! Compute column amounts.
     321             :     ! ########################################################################################
     322      651681 :     where(Cloud_Fraction_Total_Mean(1:nPoints) > 0)
     323             :        Optical_Thickness_Total_Mean(1:nPoints) = sum(optical_thickness, mask = cloudMask,      dim = 2) / &
     324             :             Cloud_Fraction_Total_Mean(1:nPoints)
     325             :        Optical_Thickness_Total_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = cloudMask, &
     326             :             dim = 2) / Cloud_Fraction_Total_Mean(1:nPoints)
     327             :     elsewhere
     328             :        Optical_Thickness_Total_Mean      = R_UNDEF
     329             :        Optical_Thickness_Total_MeanLog10 = R_UNDEF
     330             :     endwhere
     331      906881 :     where(Cloud_Fraction_Water_Mean(1:nPoints) > 0)
     332             :        Optical_Thickness_Water_Mean(1:nPoints) = sum(optical_thickness, mask = waterCloudMask, dim = 2) / &
     333             :             Cloud_Fraction_Water_Mean(1:nPoints)
     334             :        Liquid_Water_Path_Mean(1:nPoints) = LWP_conversion*sum(particle_size*optical_thickness, &
     335             :             mask=waterCloudMask,dim=2)/Cloud_Fraction_Water_Mean(1:nPoints)
     336             :        Optical_Thickness_Water_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = waterCloudMask,&
     337             :             dim = 2) / Cloud_Fraction_Water_Mean(1:nPoints)
     338             :        Cloud_Particle_Size_Water_Mean(1:nPoints) = sum(particle_size, mask = waterCloudMask, dim = 2) / &
     339             :             Cloud_Fraction_Water_Mean(1:nPoints)
     340             :     elsewhere
     341             :        Optical_Thickness_Water_Mean      = R_UNDEF
     342             :        Optical_Thickness_Water_MeanLog10 = R_UNDEF
     343             :        Cloud_Particle_Size_Water_Mean    = R_UNDEF
     344             :        Liquid_Water_Path_Mean            = R_UNDEF
     345             :     endwhere
     346      979521 :     where(Cloud_Fraction_Ice_Mean(1:nPoints) > 0)
     347             :        Optical_Thickness_Ice_Mean(1:nPoints)   = sum(optical_thickness, mask = iceCloudMask,   dim = 2) / &
     348             :             Cloud_Fraction_Ice_Mean(1:nPoints)
     349             :        Ice_Water_Path_Mean(1:nPoints) = LWP_conversion * ice_density*sum(particle_size*optical_thickness,&
     350             :             mask=iceCloudMask,dim = 2) /Cloud_Fraction_Ice_Mean(1:nPoints) 
     351             :        Optical_Thickness_Ice_MeanLog10(1:nPoints) = sum(log10(abs(optical_thickness)), mask = iceCloudMask,&
     352             :             dim = 2) / Cloud_Fraction_Ice_Mean(1:nPoints)
     353             :        Cloud_Particle_Size_Ice_Mean(1:nPoints) = sum(particle_size, mask = iceCloudMask,   dim = 2) / &
     354             :             Cloud_Fraction_Ice_Mean(1:nPoints)    
     355             :     elsewhere
     356             :        Optical_Thickness_Ice_Mean        = R_UNDEF
     357             :        Optical_Thickness_Ice_MeanLog10   = R_UNDEF
     358             :        Cloud_Particle_Size_Ice_Mean      = R_UNDEF
     359             :        Ice_Water_Path_Mean               = R_UNDEF
     360             :     endwhere
     361             :     Cloud_Top_Pressure_Total_Mean  = sum(cloud_top_pressure, mask = cloudMask, dim = 2) / &
     362      806761 :                                      max(1, count(cloudMask, dim = 2))
     363             : 
     364             :     ! ########################################################################################
     365             :     ! Normalize pixel counts to fraction. 
     366             :     ! ########################################################################################
     367       77761 :     Cloud_Fraction_High_Mean(1:nPoints)  = Cloud_Fraction_High_Mean(1:nPoints)  /nSubcols
     368       77761 :     Cloud_Fraction_Mid_Mean(1:nPoints)   = Cloud_Fraction_Mid_Mean(1:nPoints)   /nSubcols
     369       77761 :     Cloud_Fraction_Low_Mean(1:nPoints)   = Cloud_Fraction_Low_Mean(1:nPoints)   /nSubcols
     370       77761 :     Cloud_Fraction_Total_Mean(1:nPoints) = Cloud_Fraction_Total_Mean(1:nPoints) /nSubcols
     371       77761 :     Cloud_Fraction_Ice_Mean(1:nPoints)   = Cloud_Fraction_Ice_Mean(1:nPoints)   /nSubcols
     372       77761 :     Cloud_Fraction_Water_Mean(1:nPoints) = Cloud_Fraction_Water_Mean(1:nPoints) /nSubcols
     373             :     
     374             :     ! ########################################################################################
     375             :     ! Joint histograms
     376             :     ! ########################################################################################
     377             :     ! Loop over all points
     378      782471 :     tauWRK(1:nPoints,1:nSubCols)     = optical_thickness(1:nPoints,1:nSubCols)
     379      782471 :     ctpWRK(1:nPoints,1:nSubCols)     = cloud_top_pressure(1:nPoints,1:nSubCols)
     380      782471 :     reffIceWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,iceCloudMask)
     381      782471 :     reffLiqWRK(1:nPoints,1:nSubCols) = merge(particle_size,R_UNDEF,waterCloudMask)
     382       77761 :     do j=1,nPoints
     383             : 
     384             :        ! Fill clear and optically thin subcolumns with fill
     385     2259900 :        where(.not. cloudMask(j,1:nSubCols)) 
     386             :           tauWRK(j,1:nSubCols) = -999._wp
     387             :           ctpWRK(j,1:nSubCols) = -999._wp
     388             :        endwhere
     389             :        ! Joint histogram of tau/CTP
     390             :        call hist2D(tauWRK(j,1:nSubCols),ctpWRK(j,1:nSubCols),nSubCols,&
     391             :                    modis_histTau,numMODISTauBins,&
     392             :                    modis_histPres,numMODISPresBins,&
     393     5610032 :                    Optical_Thickness_vs_Cloud_Top_Pressure(j,1:numMODISTauBins,1:numMODISPresBins))
     394             :        ! Joint histogram of tau/ReffICE
     395             :        call hist2D(tauWRK(j,1:nSubCols),reffIceWrk(j,1:nSubCols),nSubCols,               &
     396             :                    modis_histTau,numMODISTauBins,modis_histReffIce,         &
     397     5027176 :                    numMODISReffIceBins, Optical_Thickness_vs_ReffIce(j,1:numMODISTauBins,1:numMODISReffIceBins))
     398             :        ! Joint histogram of tau/ReffLIQ
     399             :        call hist2D(tauWRK(j,1:nSubCols),reffLiqWrk(j,1:nSubCols),nSubCols,               &
     400             :                    modis_histTau,numMODISTauBins,modis_histReffLiq,         &
     401     5032037 :                    numMODISReffLiqBins, Optical_Thickness_vs_ReffLiq(j,1:numMODISTauBins,1:numMODISReffLiqBins))                   
     402             : 
     403             :     enddo   
     404             :     Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins) = &
     405     3849177 :          Optical_Thickness_vs_Cloud_Top_Pressure(1:nPoints,1:numMODISTauBins,1:numMODISPresBins)/nSubCols
     406             :     Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins) = &
     407     3299989 :          Optical_Thickness_vs_ReffIce(1:nPoints,1:numMODISTauBins,1:numMODISReffIceBins)/nSubCols
     408             :     Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins) = &
     409     3299989 :          Optical_Thickness_vs_ReffLiq(1:nPoints,1:numMODISTauBins,1:numMODISReffLiqBins)/nSubCols 
     410             :                  
     411             : 
     412             :     ! Unit conversion
     413             :     where(Optical_Thickness_vs_Cloud_Top_Pressure /= R_UNDEF) &
     414     3849177 :       Optical_Thickness_vs_Cloud_Top_Pressure = Optical_Thickness_vs_Cloud_Top_Pressure*100._wp
     415     3299989 :     where(Optical_Thickness_vs_ReffIce /= R_UNDEF) Optical_Thickness_vs_ReffIce = Optical_Thickness_vs_ReffIce*100._wp
     416     3299989 :     where(Optical_Thickness_vs_ReffLiq /= R_UNDEF) Optical_Thickness_vs_ReffLiq = Optical_Thickness_vs_ReffLiq*100._wp
     417       77761 :     where(Cloud_Fraction_Total_Mean /= R_UNDEF) Cloud_Fraction_Total_Mean = Cloud_Fraction_Total_Mean*100._wp
     418       77761 :     where(Cloud_Fraction_Water_Mean /= R_UNDEF) Cloud_Fraction_Water_Mean = Cloud_Fraction_Water_Mean*100._wp
     419       77761 :     where(Cloud_Fraction_Ice_Mean /= R_UNDEF)   Cloud_Fraction_Ice_Mean = Cloud_Fraction_Ice_Mean*100._wp
     420       77761 :     where(Cloud_Fraction_High_Mean /= R_UNDEF)  Cloud_Fraction_High_Mean = Cloud_Fraction_High_Mean*100._wp
     421       77761 :     where(Cloud_Fraction_Mid_Mean /= R_UNDEF)   Cloud_Fraction_Mid_Mean = Cloud_Fraction_Mid_Mean*100._wp
     422       77761 :     where(Cloud_Fraction_Low_Mean /= R_UNDEF)   Cloud_Fraction_Low_Mean = Cloud_Fraction_Low_Mean*100._wp
     423             : 
     424        4861 :   end subroutine modis_column
     425             : 
     426             :   ! ########################################################################################
     427      386384 :   function cloud_top_pressure(nLevels,tauIncrement, pressure, tauLimit) 
     428             :     ! INPUTS
     429             :     integer, intent(in)                    :: nLevels
     430             :     real(wp),intent(in),dimension(nLevels) :: tauIncrement, pressure
     431             :     real(wp),intent(in)                    :: tauLimit
     432             :     ! OUTPUTS
     433             :     real(wp)                               :: cloud_top_pressure
     434             :     ! LOCAL VARIABLES
     435             :     real(wp)                               :: deltaX, totalTau, totalProduct
     436             :     integer                                :: i 
     437             :     
     438             :     ! Find the extinction-weighted pressure. Assume that pressure varies linearly between 
     439             :     !   layers and use the trapezoidal rule.
     440      386384 :     totalTau = 0._wp; totalProduct = 0._wp
     441    26298181 :     do i = 2, size(tauIncrement)
     442    26247997 :       if(totalTau + tauIncrement(i) > tauLimit) then 
     443      336200 :         deltaX = tauLimit - totalTau
     444      336200 :         totalTau = totalTau + deltaX
     445             :         !
     446             :         ! Result for trapezoidal rule when you take less than a full step
     447             :         !   tauIncrement is a layer-integrated value
     448             :         !
     449             :         totalProduct = totalProduct           &
     450      336200 :                      + pressure(i-1) * deltaX &
     451      336200 :                      + (pressure(i) - pressure(i-1)) * deltaX**2/(2._wp * tauIncrement(i)) 
     452             :       else
     453    25911797 :         totalTau =     totalTau     + tauIncrement(i) 
     454    25911797 :         totalProduct = totalProduct + tauIncrement(i) * (pressure(i) + pressure(i-1)) / 2._wp
     455             :       end if 
     456    26298181 :       if(totalTau >= tauLimit) exit
     457             :     end do 
     458             : 
     459      386384 :     if (totalTau > 0._wp) then
     460      386335 :        cloud_top_pressure = totalProduct/totalTau
     461             :     else
     462             :        cloud_top_pressure = 0._wp
     463             :     endif
     464             :     
     465      386384 :   end function cloud_top_pressure
     466             : 
     467             :   ! ########################################################################################
     468      386384 :   function weight_by_extinction(nLevels,tauIncrement, f, tauLimit) 
     469             :     ! INPUTS
     470             :     integer, intent(in)                    :: nLevels
     471             :     real(wp),intent(in),dimension(nLevels) :: tauIncrement, f
     472             :     real(wp),intent(in)                    :: tauLimit
     473             :     ! OUTPUTS
     474             :     real(wp)                               :: weight_by_extinction
     475             :     ! LOCAL VARIABLES
     476             :     real(wp)                               :: deltaX, totalTau, totalProduct
     477             :     integer                                :: i 
     478             :     
     479             :     ! Find the extinction-weighted value of f(tau), assuming constant f within each layer
     480      386384 :     totalTau = 0._wp; totalProduct = 0._wp
     481    26348087 :     do i = 1, size(tauIncrement)
     482    26298181 :       if(totalTau + tauIncrement(i) > tauLimit) then 
     483      336478 :         deltaX       = tauLimit - totalTau
     484      336478 :         totalTau     = totalTau     + deltaX
     485      336478 :         totalProduct = totalProduct + deltaX * f(i) 
     486             :       else
     487    25961703 :         totalTau     = totalTau     + tauIncrement(i) 
     488    25961703 :         totalProduct = totalProduct + tauIncrement(i) * f(i) 
     489             :       end if 
     490    26348087 :       if(totalTau >= tauLimit) exit
     491             :     end do 
     492             : 
     493      386384 :     if (totalTau > 0._wp) then
     494      386384 :        weight_by_extinction = totalProduct/totalTau
     495             :     else
     496             :        weight_by_extinction = 0._wp
     497             :     endif
     498             :     
     499      386384 :   end function weight_by_extinction
     500             : 
     501             :   ! ########################################################################################
     502      386384 :   pure function interpolate_to_min(x, y, yobs)
     503             :     ! INPUTS
     504             :     real(wp),intent(in),dimension(num_trial_res) :: x, y 
     505             :     real(wp),intent(in)                          :: yobs
     506             :     ! OUTPUTS
     507             :     real(wp)                                     :: interpolate_to_min
     508             :     ! LOCAL VARIABLES
     509             :     real(wp), dimension(num_trial_res)           :: diff
     510             :     integer                                      :: nPoints, minDiffLoc, lowerBound, upperBound
     511             :     
     512             :     ! Given a set of values of y as y(x), find the value of x that minimizes abs(y - yobs)
     513             :     !   y must be monotonic in x
     514             :  
     515      386384 :     nPoints = size(y)
     516     6182144 :     diff(1:num_trial_res) = y(1:num_trial_res) - yobs
     517     6568528 :     minDiffLoc = minloc(abs(diff), dim = 1) 
     518             :     
     519      386384 :     if(minDiffLoc == 1) then 
     520         523 :       lowerBound = minDiffLoc
     521         523 :       upperBound = minDiffLoc + 1
     522      385861 :     else if(minDiffLoc == nPoints) then
     523      309449 :       lowerBound = minDiffLoc - 1
     524      309449 :       upperBound = minDiffLoc
     525             :     else
     526       76412 :       if(diff(minDiffLoc-1) * diff(minDiffLoc) < 0) then
     527             :         lowerBound = minDiffLoc-1
     528             :         upperBound = minDiffLoc
     529             :       else 
     530       37468 :         lowerBound = minDiffLoc
     531       37468 :         upperBound = minDiffLoc + 1
     532             :       end if 
     533             :     end if 
     534             :     
     535      386384 :     if(diff(lowerBound) * diff(upperBound) < 0) then     
     536             :       !
     537             :       ! Interpolate the root position linearly if we bracket the root
     538             :       !
     539             :       interpolate_to_min = x(upperBound) - & 
     540      103412 :                            diff(upperBound) * (x(upperBound) - x(lowerBound)) / (diff(upperBound) - diff(lowerBound))
     541             :     else 
     542      282972 :       interpolate_to_min = re_fill
     543             :     end if 
     544             :     
     545             : 
     546      386384 :   end function interpolate_to_min
     547             : 
     548             :   ! ########################################################################################
     549             :   ! Optical properties
     550             :   ! ########################################################################################
     551           0 :   elemental function get_g_nir_old (phase, re)
     552             :     ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
     553             :     !   of size for ice and water
     554             :     ! Fits from Steve Platnick
     555             : 
     556             :     ! INPUTS
     557             :     integer, intent(in) :: phase
     558             :     real(wp),intent(in) :: re
     559             :     ! OUTPUTS
     560             :     real(wp)            :: get_g_nir_old 
     561             :     ! LOCAL VARIABLES(parameters)
     562             :     real(wp), dimension(3), parameter :: &
     563             :          ice_coefficients         = (/ 0.7432,  4.5563e-3, -2.8697e-5 /), & 
     564             :          small_water_coefficients = (/ 0.8027, -1.0496e-2,  1.7071e-3 /), & 
     565             :          big_water_coefficients   = (/ 0.7931,  5.3087e-3, -7.4995e-5 /) 
     566             :    
     567             :     ! approx. fits from MODIS Collection 5 LUT scattering calculations
     568           0 :     if(phase == phaseIsLiquid) then
     569           0 :       if(re < 8.) then 
     570           0 :         get_g_nir_old = fit_to_quadratic(re, small_water_coefficients)
     571           0 :         if(re < re_water_min) get_g_nir_old = fit_to_quadratic(re_water_min, small_water_coefficients)
     572             :       else
     573           0 :         get_g_nir_old = fit_to_quadratic(re,   big_water_coefficients)
     574           0 :         if(re > re_water_max) get_g_nir_old = fit_to_quadratic(re_water_max, big_water_coefficients)
     575             :       end if 
     576             :     else
     577           0 :       get_g_nir_old = fit_to_quadratic(re, ice_coefficients)
     578           0 :       if(re < re_ice_min) get_g_nir_old = fit_to_quadratic(re_ice_min, ice_coefficients)
     579           0 :       if(re > re_ice_max) get_g_nir_old = fit_to_quadratic(re_ice_max, ice_coefficients)
     580             :     end if 
     581             :     
     582           0 :   end function get_g_nir_old
     583             : 
     584             :   ! ########################################################################################
     585           0 :   elemental function get_ssa_nir_old (phase, re)
     586             :     ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
     587             :     !   of size for ice and water
     588             :     ! Fits from Steve Platnick
     589             :     
     590             :     ! INPUTS
     591             :     integer, intent(in) :: phase
     592             :     real(wp),intent(in) :: re
     593             :     ! OUTPUTS
     594             :     real(wp)            :: get_ssa_nir_old
     595             :     ! LOCAL VARIABLES (parameters)
     596             :     real(wp), dimension(4), parameter :: ice_coefficients   = (/ 0.9994, -4.5199e-3, 3.9370e-5, -1.5235e-7 /)
     597             :     real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0008, -2.5626e-3, 1.6024e-5 /) 
     598             :     
     599             :     ! approx. fits from MODIS Collection 5 LUT scattering calculations
     600           0 :     if(phase == phaseIsLiquid) then
     601           0 :        get_ssa_nir_old = fit_to_quadratic(re, water_coefficients)
     602           0 :        if(re < re_water_min) get_ssa_nir_old = fit_to_quadratic(re_water_min, water_coefficients)
     603           0 :        if(re > re_water_max) get_ssa_nir_old = fit_to_quadratic(re_water_max, water_coefficients)
     604             :     else
     605           0 :        get_ssa_nir_old = fit_to_cubic(re, ice_coefficients)
     606           0 :        if(re < re_ice_min) get_ssa_nir_old = fit_to_cubic(re_ice_min, ice_coefficients)
     607           0 :        if(re > re_ice_max) get_ssa_nir_old = fit_to_cubic(re_ice_max, ice_coefficients)
     608             :     end if
     609             :     
     610           0 :   end function get_ssa_nir_old
     611             :   
     612   367462080 :   elemental function get_g_nir (phase, re)
     613             :     !
     614             :     ! Polynomial fit for asummetry parameter g in MODIS band 7 (near IR) as a function 
     615             :     !   of size for ice and water
     616             :     ! Fits from Steve Platnick
     617             :     !
     618             : 
     619             :     integer, intent(in) :: phase
     620             :     real(wp),    intent(in) :: re
     621             :     real(wp) :: get_g_nir 
     622             : 
     623             :     real(wp), dimension(3), parameter :: ice_coefficients         = (/ 0.7490, 6.5153e-3, -5.4136e-5 /), &
     624             :                                          small_water_coefficients = (/ 1.0364, -8.8800e-2, 7.0000e-3 /)
     625             :     real(wp), dimension(4), parameter :: big_water_coefficients   = (/ 0.6035, 2.8993e-2, -1.1051e-3, 1.5134e-5 /)
     626             : 
     627             :     ! approx. fits from MODIS Collection 6 LUT scattering calculations for 3.7 µm channel size retrievals
     628   367462080 :     if(phase == phaseIsLiquid) then 
     629   122495040 :        if(re < 7.) then
     630   112988137 :           get_g_nir = fit_to_quadratic(re, small_water_coefficients)
     631   112988137 :           if(re < re_water_min) get_g_nir = fit_to_quadratic(re_water_min, small_water_coefficients)
     632             :        else
     633     9506903 :           get_g_nir = fit_to_cubic(re, big_water_coefficients)
     634     9506903 :           if(re > re_water_max) get_g_nir = fit_to_cubic(re_water_max, big_water_coefficients)
     635             :        end if
     636             :     else
     637   244967040 :        get_g_nir = fit_to_quadratic(re, ice_coefficients)
     638   244967040 :       if(re < re_ice_min) get_g_nir = fit_to_quadratic(re_ice_min, ice_coefficients)
     639   244967040 :       if(re > re_ice_max) get_g_nir = fit_to_quadratic(re_ice_max, ice_coefficients)
     640             :     end if 
     641             :     
     642   367462080 :   end function get_g_nir
     643             : 
     644             :   ! --------------------------------------------
     645   367462080 :     elemental function get_ssa_nir (phase, re)
     646             :         integer, intent(in) :: phase
     647             :         real(wp),    intent(in) :: re
     648             :         real(wp)                :: get_ssa_nir
     649             :         !
     650             :         ! Polynomial fit for single scattering albedo in MODIS band 7 (near IR) as a function 
     651             :         !   of size for ice and water
     652             :         ! Fits from Steve Platnick
     653             :         !
     654             :         real(wp), dimension(4), parameter :: ice_coefficients   = (/ 0.9625, -1.8069e-2, 3.3281e-4,-2.2865e-6/)
     655             :         real(wp), dimension(3), parameter :: water_coefficients = (/ 1.0044, -1.1397e-2, 1.3300e-4 /)
     656             :         
     657             :         ! approx. fits from MODIS Collection 6 LUT scattering calculations
     658   367462080 :         if(phase == phaseIsLiquid) then
     659   122495040 :           get_ssa_nir = fit_to_quadratic(re, water_coefficients)
     660   122495040 :           if(re < re_water_min) get_ssa_nir = fit_to_quadratic(re_water_min, water_coefficients)
     661   122495040 :           if(re > re_water_max) get_ssa_nir = fit_to_quadratic(re_water_max, water_coefficients)
     662             :         else
     663   244967040 :           get_ssa_nir = fit_to_cubic(re, ice_coefficients)
     664   244967040 :           if(re < re_ice_min) get_ssa_nir = fit_to_cubic(re_ice_min, ice_coefficients)
     665   244967040 :           if(re > re_ice_max) get_ssa_nir = fit_to_cubic(re_ice_max, ice_coefficients)
     666             :         end if 
     667             : 
     668   367462080 :     end function get_ssa_nir
     669             : 
     670             :   
     671             : 
     672             :   ! ########################################################################################
     673   493721544 :   pure function fit_to_cubic(x, coefficients) 
     674             :     ! INPUTS
     675             :     real(wp),               intent(in) :: x
     676             :     real(wp), dimension(4), intent(in) :: coefficients
     677             :     ! OUTPUTS
     678             :     real(wp)                           :: fit_to_cubic  
     679             :     
     680   493721544 :     fit_to_cubic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3) + x * coefficients(4)))
     681   493721544 :   end function fit_to_cubic
     682             :     
     683             :   ! ########################################################################################
     684   944733302 :   pure function fit_to_quadratic(x, coefficients) 
     685             :     ! INPUTS
     686             :     real(wp),               intent(in) :: x
     687             :     real(wp), dimension(3), intent(in) :: coefficients
     688             :     ! OUTPUTS
     689             :     real(wp)                           :: fit_to_quadratic
     690             :     
     691   944733302 :     fit_to_quadratic = coefficients(1) + x * (coefficients(2) + x * (coefficients(3)))
     692   944733302 :   end function fit_to_quadratic
     693             : 
     694             :   ! ########################################################################################
     695             :   ! Radiative transfer
     696             :   ! ########################################################################################
     697      386384 :   pure function compute_toa_reflectace(nLevels,tau, g, w0)
     698             :     ! This wrapper reports reflectance only and strips out non-cloudy elements from the 
     699             :     ! calculation
     700             :     
     701             :     ! INPUTS
     702             :     integer,intent(in)                     :: nLevels
     703             :     real(wp),intent(in),dimension(nLevels) :: tau, g, w0
     704             :     ! OUTPUTS
     705             :     real(wp)                               :: compute_toa_reflectace
     706             :     ! LOCAL VARIABLES
     707      772768 :     logical, dimension(nLevels)                   :: cloudMask
     708    32842640 :     integer, dimension(count(tau(1:nLevels) > 0)) :: cloudIndicies
     709    65298896 :     real(wp),dimension(count(tau(1:nLevels) > 0)) :: Refl,Trans
     710             :     real(wp)                                      :: Refl_tot, Trans_tot
     711             :     integer                                       :: i
     712             : 
     713    32842640 :     cloudMask(1:nLevels) = tau(1:nLevels) > 0. 
     714    65298896 :     cloudIndicies = pack((/ (i, i = 1, nLevels) /), mask = cloudMask) 
     715     6653628 :     do i = 1, size(cloudIndicies)
     716     6653628 :        call two_stream(tau(cloudIndicies(i)), g(cloudIndicies(i)), w0(cloudIndicies(i)), Refl(i), Trans(i))
     717             :     end do
     718             :     
     719    32842640 :     call adding_doubling(count(tau(1:nLevels) > 0),Refl(:), Trans(:), Refl_tot, Trans_tot)  
     720             :     
     721      386384 :     compute_toa_reflectace = Refl_tot
     722             :     
     723      386384 :   end function compute_toa_reflectace
     724             :  
     725             :   ! ########################################################################################
     726     6267244 :   pure subroutine two_stream(tauint, gint, w0int, ref, tra) 
     727             :     ! Compute reflectance in a single layer using the two stream approximation 
     728             :     !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
     729             :     ! INPUTS
     730             :     real(wp), intent(in)  :: tauint, gint, w0int
     731             :     ! OUTPUTS
     732             :     real(wp), intent(out) :: ref, tra
     733             :     ! LOCAL VARIABLES
     734             :     !   for delta Eddington code
     735             :     !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
     736             :     integer, parameter :: beam = 2
     737             :     real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
     738             :     real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
     739             :          rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den, th
     740             :     
     741             :     ! Compute reflectance and transmittance in a single layer using the two stream approximation 
     742             :     !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
     743     6267244 :     f   = gint**2
     744     6267244 :     tau = (1._wp - w0int * f) * tauint
     745     6267244 :     w0  = (1._wp - f) * w0int / (1._wp - w0int * f)
     746     6267244 :     g   = (gint - f) / (1._wp - f)
     747             : 
     748             :     ! delta-Eddington (Joseph et al. 1976)
     749     6267244 :     gamma1 =  (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp
     750     6267244 :     gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp
     751     6267244 :     gamma3 =  (2._wp - 3._wp*g*xmu) / 4._wp
     752     6267244 :     gamma4 =   1._wp - gamma3
     753             : 
     754     6267244 :     if (w0int > minConservativeW0) then
     755             :       ! Conservative scattering
     756             :       if (beam == 1) then
     757             :           rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
     758             :   
     759             :           ref = rh / (1._wp + gamma1 * tau)
     760             :           tra = 1._wp - ref       
     761             :       else if(beam == 2) then
     762           0 :           ref = gamma1*tau/(1._wp + gamma1*tau)
     763           0 :           tra = 1._wp - ref
     764             :       endif
     765             :     else
     766             :       ! Non-conservative scattering
     767     6267244 :       a1 = gamma1 * gamma4 + gamma2 * gamma3
     768     6267244 :       a2 = gamma1 * gamma3 + gamma2 * gamma4
     769             : 
     770     6267244 :       rk = sqrt(gamma1**2 - gamma2**2)
     771             :       
     772     6267244 :       r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3)
     773     6267244 :       r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3)
     774     6267244 :       r3 = 2._wp * rk *(gamma3 - a2 * xmu)
     775     6267244 :       r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1)
     776     6267244 :       r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1)
     777             :       
     778     6267244 :       t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4)
     779     6267244 :       t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4)
     780     6267244 :       t3 = 2._wp * rk * (gamma4 + a1 * xmu)
     781     6267244 :       t4 = r4
     782     6267244 :       t5 = r5
     783             : 
     784     6267244 :       beta = -r5 / r4         
     785             :   
     786     6267244 :       e1 = min(rk * tau, 500._wp) 
     787     6267244 :       e2 = min(tau / xmu, 500._wp) 
     788             :       
     789             :       if (beam == 1) then
     790             :          den = r4 * exp(e1) + r5 * exp(-e1)
     791             :          ref  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
     792             :          den = t4 * exp(e1) + t5 * exp(-e1)
     793             :          th  = exp(-e2)
     794             :          tra = th-th*w0*(t1*exp(e1)-t2*exp(-e1)-t3*exp(e2))/den
     795             :       elseif (beam == 2) then
     796     6267244 :          ef1 = exp(-e1)
     797     6267244 :          ef2 = exp(-2*e1)
     798     6267244 :          ref = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2))
     799     6267244 :          tra = (2._wp*rk*ef1)/((rk+gamma1)*(1._wp-beta*ef2))
     800             :       endif
     801             :     end if
     802     6267244 :   end subroutine two_stream
     803             : 
     804             :   ! ########################################################################################
     805     5795760 :   elemental function two_stream_reflectance(tauint, gint, w0int)
     806             :     ! Compute reflectance in a single layer using the two stream approximation 
     807             :     !   The code itself is from Lazaros Oreopoulos via Steve Platnick 
     808             :     
     809             :     ! INPUTS
     810             :     real(wp), intent(in) :: tauint, gint, w0int
     811             :     ! OUTPUTS
     812             :     real(wp)             :: two_stream_reflectance
     813             :     ! LOCAL VARIABLES
     814             :     !   for delta Eddington code
     815             :     !   xmu, gamma3, and gamma4 only used for collimated beam approximation (i.e., beam=1)
     816             :     integer, parameter :: beam = 2
     817             :     real(wp),parameter :: xmu = 0.866, minConservativeW0 = 0.9999999
     818             :     real(wp) :: tau, w0, g, f, gamma1, gamma2, gamma3, gamma4, &
     819             :          rh, a1, a2, rk, r1, r2, r3, r4, r5, t1, t2, t3, t4, t5, beta, e1, e2, ef1, ef2, den
     820             : 
     821     5795760 :     f   = gint**2
     822     5795760 :     tau = (1._wp - w0int * f) * tauint
     823     5795760 :     w0  = (1._wp - f) * w0int / (1._wp - w0int * f)
     824     5795760 :     g   = (gint - f) / (1._wp - f)
     825             : 
     826             :     ! delta-Eddington (Joseph et al. 1976)
     827     5795760 :     gamma1 =  (7._wp - w0* (4._wp + 3._wp * g)) / 4._wp
     828     5795760 :     gamma2 = -(1._wp - w0* (4._wp - 3._wp * g)) / 4._wp
     829     5795760 :     gamma3 =  (2._wp - 3._wp*g*xmu) / 4._wp
     830     5795760 :     gamma4 =   1._wp - gamma3
     831             : 
     832     5795760 :     if (w0int > minConservativeW0) then
     833             :       ! Conservative scattering
     834           0 :       if (beam == 1) then
     835             :           rh = (gamma1*tau+(gamma3-gamma1*xmu)*(1-exp(-tau/xmu)))
     836             :           two_stream_reflectance = rh / (1._wp + gamma1 * tau)
     837             :       elseif (beam == 2) then
     838           0 :           two_stream_reflectance = gamma1*tau/(1._wp + gamma1*tau)
     839             :       endif
     840             :         
     841             :     else    !
     842             : 
     843             :         ! Non-conservative scattering
     844     5795760 :          a1 = gamma1 * gamma4 + gamma2 * gamma3
     845     5795760 :          a2 = gamma1 * gamma3 + gamma2 * gamma4
     846             : 
     847     5795760 :          rk = sqrt(gamma1**2 - gamma2**2)
     848             :          
     849     5795760 :          r1 = (1._wp - rk * xmu) * (a2 + rk * gamma3)
     850     5795760 :          r2 = (1._wp + rk * xmu) * (a2 - rk * gamma3)
     851     5795760 :          r3 = 2._wp * rk *(gamma3 - a2 * xmu)
     852     5795760 :          r4 = (1._wp - (rk * xmu)**2) * (rk + gamma1)
     853     5795760 :          r5 = (1._wp - (rk * xmu)**2) * (rk - gamma1)
     854             :          
     855     5795760 :          t1 = (1._wp + rk * xmu) * (a1 + rk * gamma4)
     856     5795760 :          t2 = (1._wp - rk * xmu) * (a1 - rk * gamma4)
     857     5795760 :          t3 = 2._wp * rk * (gamma4 + a1 * xmu)
     858     5795760 :          t4 = r4
     859     5795760 :          t5 = r5
     860             : 
     861     5795760 :          beta = -r5 / r4         
     862             :          
     863     5795760 :          e1 = min(rk * tau, 500._wp) 
     864     5795760 :          e2 = min(tau / xmu, 500._wp) 
     865             :          
     866             :          if (beam == 1) then
     867             :            den = r4 * exp(e1) + r5 * exp(-e1)
     868             :            two_stream_reflectance  = w0*(r1*exp(e1)-r2*exp(-e1)-r3*exp(-e2))/den
     869             :          elseif (beam == 2) then
     870             :            ef1 = exp(-e1)
     871     5795760 :            ef2 = exp(-2*e1)
     872     5795760 :            two_stream_reflectance = (gamma2*(1._wp-ef2))/((rk+gamma1)*(1._wp-beta*ef2))
     873             :          endif
     874             :            
     875             :       end if
     876     5795760 :   end function two_stream_reflectance 
     877             : 
     878             :   ! ########################################################################################
     879      386384 :   pure subroutine adding_doubling (npts,Refl, Tran, Refl_tot, Tran_tot)      
     880             :     ! Use adding/doubling formulas to compute total reflectance and transmittance from 
     881             :     ! layer values
     882             :     
     883             :     ! INPUTS
     884             :     integer,intent(in)                  :: npts
     885             :     real(wp),intent(in),dimension(npts) :: Refl,Tran
     886             :     ! OUTPUTS
     887             :     real(wp),intent(out)                :: Refl_tot, Tran_tot
     888             :     ! LOCAL VARIABLES
     889             :     integer :: i
     890      772768 :     real(wp), dimension(npts) :: Refl_cumulative, Tran_cumulative
     891             :     
     892      386384 :     Refl_cumulative(1) = Refl(1)
     893      386384 :     Tran_cumulative(1) = Tran(1)    
     894             :     
     895     6267244 :     do i=2, npts
     896             :        ! place (add) previous combined layer(s) reflectance on top of layer i, w/black surface (or ignoring surface):
     897     5880860 :        Refl_cumulative(i) = Refl_cumulative(i-1) + Refl(i)*(Tran_cumulative(i-1)**2)/(1._wp - Refl_cumulative(i-1) * Refl(i))
     898     6267244 :        Tran_cumulative(i) = (Tran_cumulative(i-1)*Tran(i)) / (1._wp - Refl_cumulative(i-1) * Refl(i))
     899             :     end do
     900             :     
     901      386384 :     Refl_tot = Refl_cumulative(size(Refl))
     902      386384 :     Tran_tot = Tran_cumulative(size(Refl))
     903             :     
     904      386384 :   end subroutine adding_doubling
     905             : 
     906             : end module mod_modis_sim

Generated by: LCOV version 1.14