LCOV - code coverage report
Current view: top level - physics/cosp2/src/src/simulator/MISR_simulator - MISR_simulator.F90 (source / functions) Hit Total Coverage
Test: coverage.info Lines: 64 64 100.0 %
Date: 2025-03-13 19:12:29 Functions: 2 2 100.0 %

          Line data    Source code
       1             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
       2             : ! Copyright (c) 2009, Roger Marchand, version 1.2
       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 2015 - D. Swales - Modified for COSPv2.0
      31             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      32             : MODULE MOD_MISR_SIMULATOR
      33             :   use cosp_kinds,      only: wp
      34             :   use MOD_COSP_STATS,  ONLY: hist2D
      35             :   use mod_cosp_config, ONLY: R_UNDEF,numMISRHgtBins,numMISRTauBins,misr_histHgt,  &
      36             :                              misr_histTau
      37             :   implicit none 
      38             : 
      39             :   ! Parameters
      40             :   real(wp),parameter :: &
      41             :        misr_taumin = 0.3_wp,            & ! Minimum optical depth for joint-histogram
      42             :        tauchk      = -1.*log(0.9999999)   ! Lower limit on optical depth
      43             : 
      44             : contains
      45             : 
      46             :   ! ######################################################################################
      47             :   ! SUBROUTINE misr_subcolumn
      48             :   ! ######################################################################################
      49        9288 :   SUBROUTINE MISR_SUBCOLUMN(npoints,ncol,nlev,dtau,zfull,at,sunlit,tauOUT,               &
      50        9288 :                         dist_model_layertops,box_MISR_ztop)
      51             :     ! INPUTS
      52             :     INTEGER, intent(in) :: &
      53             :          npoints,    & ! Number of horizontal gridpoints
      54             :          ncol,       & ! Number of subcolumns
      55             :          nlev          ! Number of vertical layers
      56             :     INTEGER, intent(in),dimension(npoints) :: &
      57             :          sunlit        ! 1 for day points, 0 for night time
      58             :     REAL(WP),intent(in),dimension(npoints,ncol,nlev) :: &
      59             :          dtau          ! Optical thickness
      60             :     REAL(WP),intent(in),dimension(npoints,nlev) :: &
      61             :          zfull,      & ! Height of full model levels (i.e. midpoints), [nlev] is bottom
      62             :          at            ! Temperature (K)
      63             : 
      64             :     ! OUTPUTS
      65             :     REAL(WP),intent(out),dimension(npoints,ncol) :: &
      66             :          box_MISR_ztop,     & ! Cloud-top height in each column
      67             :          tauOUT               ! Optical depth in each column
      68             :     REAL(WP),intent(out),dimension(npoints,numMISRHgtBins) :: &
      69             :          dist_model_layertops ! 
      70             : 
      71             :     ! INTERNAL VARIABLES
      72             :     INTEGER :: ilev,j,loop,ibox,thres_crossed_MISR
      73             :     INTEGER :: iMISR_ztop
      74             :     REAL(WP) :: cloud_dtau,MISR_penetration_height,ztest
      75             : 
      76             :     ! ############################################################################
      77             :     ! Initialize
      78     1560168 :     box_MISR_ztop(1:npoints,1:ncol) = 0._wp  
      79             : 
      80      155088 :     do j=1,npoints
      81             : 
      82             :        ! Estimate distribution of Model layer tops
      83     2478600 :        dist_model_layertops(j,:)=0
      84    12393000 :        do ilev=1,nlev
      85             :           ! Define location of "layer top"
      86    12247200 :           if(ilev.eq.1 .or. ilev.eq.nlev) then
      87      291600 :              ztest=zfull(j,ilev)
      88             :           else
      89    11955600 :              ztest=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1))
      90             :           endif
      91             : 
      92             :           ! Find MISR layer that contains this level
      93             :           ! *NOTE* the first MISR level is "no height" level
      94    12247200 :           iMISR_ztop=2
      95   195955200 :           do loop=2,numMISRHgtBins
      96   195955200 :              if ( ztest .gt. 1000*misr_histHgt(loop+1) ) then
      97   122154101 :                 iMISR_ztop=loop+1
      98             :              endif
      99             :           enddo
     100             :           
     101    12393000 :           dist_model_layertops(j,iMISR_ztop) = dist_model_layertops(j,iMISR_ztop)+1
     102             :        enddo
     103             : 
     104             :        ! For each GCM cell or horizontal model grid point   
     105     1613088 :        do ibox=1,ncol
     106             :           ! Compute optical depth as a cummulative distribution in the vertical (nlev).
     107   123930000 :           tauOUT(j,ibox)=sum(dtau(j,ibox,1:nlev))
     108             : 
     109     1458000 :           thres_crossed_MISR=0
     110   123930000 :           do ilev=1,nlev
     111             :              ! If there a cloud, start the counter and store this height
     112   122472000 :              if(thres_crossed_MISR .eq. 0 .and. dtau(j,ibox,ilev) .gt. 0.) then
     113             :                 ! First encountered a "cloud"
     114     1072046 :                 thres_crossed_MISR = 1  
     115     1072046 :                 cloud_dtau         = 0            
     116             :              endif
     117             : 
     118   123930000 :              if( thres_crossed_MISR .lt. 99 .and. thres_crossed_MISR .gt. 0 ) then
     119    25305983 :                 if( dtau(j,ibox,ilev) .eq. 0.) then
     120             :                    ! We have come to the end of the current cloud layer without yet 
     121             :                    ! selecting a CTH boundary. Restart cloud tau counter 
     122             :                    cloud_dtau=0
     123             :                 else
     124             :                    ! Add current optical depth to count for the current cloud layer
     125    12596269 :                    cloud_dtau=cloud_dtau+dtau(j,ibox,ilev)
     126             :                 endif
     127             :                 
     128             :                 ! If the cloud is continuous but optically thin (< 1) from above the 
     129             :                 ! current layer cloud top to the current level then MISR will like 
     130             :                 ! see a top below the top of the current layer.
     131    25305983 :                 if( dtau(j,ibox,ilev).gt.0 .and. (cloud_dtau-dtau(j,ibox,ilev)) .lt. 1) then
     132    10117516 :                    if(dtau(j,ibox,ilev) .lt. 1 .or. ilev.eq.1 .or. ilev.eq.nlev) then
     133             :                       ! MISR will likely penetrate to some point within this layer ... the middle
     134     9639068 :                       MISR_penetration_height=zfull(j,ilev)
     135             :                    else
     136             :                       ! Take the OD = 1.0 level into this layer
     137      478448 :                       MISR_penetration_height=0.5_wp*(zfull(j,ilev)+zfull(j,ilev-1)) - &
     138      956896 :                            0.5_wp*(zfull(j,ilev-1)-zfull(j,ilev+1))/dtau(j,ibox,ilev) 
     139             :                    endif
     140    10117516 :                    box_MISR_ztop(j,ibox)=MISR_penetration_height
     141             :                 endif
     142             :                 
     143             :                 ! Check for a distinctive water layer
     144    25305983 :                 if(dtau(j,ibox,ilev) .gt. 1 .and. at(j,ilev) .gt. 273 ) then
     145             :                    ! Must be a water cloud, take this as CTH level
     146      279622 :                    thres_crossed_MISR=99
     147             :                 endif
     148             :                 
     149             :                 ! If the total column optical depth is "large" than MISR can't see
     150             :                 ! anything else. Set current point as CTH level
     151  1656275189 :                 if(sum(dtau(j,ibox,1:ilev)) .gt. 5) then
     152      365130 :                    thres_crossed_MISR=99           
     153             :                 endif
     154             :              endif
     155             :           enddo  
     156             :           
     157             :           ! Check to see if there was a cloud for which we didn't 
     158             :           ! set a MISR cloud top boundary
     159     1603800 :           if( thres_crossed_MISR .eq. 1) then
     160             :              ! If the cloud has a total optical depth of greater
     161             :              ! than ~ 0.5 MISR will still likely pick up this cloud
     162             :              ! with a height near the true cloud top
     163             :              ! otherwise there should be no CTH
     164    44174840 :              if(sum(dtau(j,ibox,1:nlev)) .gt. 0.5) then
     165             :                 ! keep MISR detected CTH
     166    27909325 :              elseif(sum(dtau(j,ibox,1:nlev)) .gt. 0.2) then
     167             :                 ! MISR may detect but wont likley have a good height
     168       76794 :                 box_MISR_ztop(j,ibox)=-1
     169             :              else
     170             :                 ! MISR not likely to even detect.
     171             :                 ! so set as not cloudy
     172      251551 :                 box_MISR_ztop(j,ibox)=0
     173             :              endif
     174             :           endif
     175             :        enddo  ! loop of subcolumns
     176             :        
     177             :     enddo    ! loop of gridpoints
     178             :     
     179             :     ! Modify MISR CTH for satellite spatial / pattern matcher effects
     180             :     ! Code in this region added by roj 5/2006 to account
     181             :     ! for spatial effect of the MISR pattern matcher.
     182             :     ! Basically, if a column is found between two neighbors
     183             :     ! at the same CTH, and that column has no hieght or
     184             :     ! a lower CTH, THEN misr will tend to but place the
     185             :     ! odd column at the same height as it neighbors.
     186             :     
     187             :     ! This setup assumes the columns represent a about a 1 to 4 km scale
     188             :     ! it will need to be modified significantly, otherwise
     189             : !       ! DS2015: Add loop over gridpoints and index accordingly.
     190             : !    if(ncol.eq.1) then
     191             : !       ! Adjust based on neightboring points.
     192             : !       do j=2,npoints-1   
     193             : !          if(box_MISR_ztop(j-1,1) .gt. 0                             .and. &
     194             : !             box_MISR_ztop(j+1,1) .gt. 0                             .and. &
     195             : !             abs(box_MISR_ztop(j-1,1)-box_MISR_ztop(j+1,1)) .lt. 500 .and. &
     196             : !             box_MISR_ztop(j,1) .lt. box_MISR_ztop(j+1,1)) then
     197             : !             box_MISR_ztop(j,1) = box_MISR_ztop(j+1,1)    
     198             : !          endif
     199             : !       enddo
     200             : !    else
     201             : !       ! Adjust based on neighboring subcolumns.
     202             : !       do j=1,npoints
     203             : !          do ibox=2,ncol-1  
     204             : !                 if(box_MISR_ztop(j,ibox-1) .gt. 0                                .and. &
     205             : !                 box_MISR_ztop(j,ibox+1) .gt. 0                                .and. &
     206             : !                 abs(box_MISR_ztop(j,ibox-1)-box_MISR_ztop(j,ibox+1)) .lt. 500 .and. &
     207             : !                 box_MISR_ztop(j,ibox) .lt. box_MISR_ztop(j,ibox+1)) then
     208             : !                 box_MISR_ztop(j,ibox) = box_MISR_ztop(j,ibox+1)    
     209             : !               endif
     210             : !          enddo
     211             : !       enddo
     212             : !    endif
     213             : !    ! DS2015 END
     214             :      
     215             :     ! Fill dark scenes 
     216      157896 :     do j=1,numMISRHgtBins
     217     2490696 :        where(sunlit .ne. 1) dist_model_layertops(1:npoints,j) = R_UNDEF
     218             :     enddo
     219             : 
     220        9288 :   end SUBROUTINE MISR_SUBCOLUMN
     221             : 
     222             :   ! ######################################################################################
     223             :   ! SUBROUTINE misr_column
     224             :   ! ######################################################################################
     225        9288 :   SUBROUTINE MISR_COLUMN(npoints,ncol,box_MISR_ztop,sunlit,tau,MISR_cldarea,MISR_mean_ztop,fq_MISR_TAU_v_CTH)
     226             : 
     227             :     ! INPUTS
     228             :     INTEGER, intent(in) :: &
     229             :          npoints,        & ! Number of horizontal gridpoints
     230             :          ncol              ! Number of subcolumns
     231             :     INTEGER, intent(in),dimension(npoints) :: &
     232             :          sunlit            ! 1 for day points, 0 for night time
     233             :     REAL(WP),intent(in),dimension(npoints,ncol) :: &
     234             :          box_MISR_ztop,  & ! Cloud-top height in each column
     235             :          tau               ! Column optical thickness
     236             : 
     237             :     ! OUTPUTS
     238             :     REAL(WP),intent(inout),dimension(npoints) :: &
     239             :          MISR_cldarea,   & ! Fraction area covered by clouds
     240             :          MISR_mean_ztop    ! Mean cloud top height MISR would observe
     241             :     REAL(WP),intent(inout),dimension(npoints,7,numMISRHgtBins) :: &
     242             :          fq_MISR_TAU_v_CTH ! Joint histogram of cloud-cover and tau
     243             : 
     244             :     ! INTERNAL VARIABLES
     245             :     INTEGER :: j
     246       18576 :     LOGICAL,dimension(ncol) :: box_cloudy 
     247        9288 :     real(wp),dimension(npoints,ncol) :: tauWRK,box_MISR_ztopWRK
     248             :     ! ############################################################################
     249             : 
     250             :     ! Compute column quantities and joint-histogram
     251      155088 :     MISR_cldarea(1:npoints)                       = 0._wp
     252      155088 :     MISR_mean_ztop(1:npoints)                     = 0._wp
     253    17527752 :     fq_MISR_TAU_v_CTH(1:npoints,1:7,1:numMISRHgtBins) = 0._wp
     254     1560168 :     tauWRK(1:npoints,1:ncol)                      = tau(1:npoints,1:ncol)
     255     1560168 :     box_MISR_ztopWRK(1:npoints,1:ncol)            = box_MISR_ztop(1:npoints,1:ncol)
     256      155088 :     do j=1,npoints
     257             : 
     258             :        ! Subcolumns that are cloudy(true) and not(false)
     259     1603800 :        box_cloudy(1:ncol) = merge(.true.,.false.,tau(j,1:ncol) .gt. tauchk)
     260             : 
     261             :        ! Fill optically thin clouds with fill value
     262     1603800 :        where(.not. box_cloudy(1:ncol)) tauWRK(j,1:ncol)  = -999._wp
     263     1603800 :        where(box_MISR_ztopWRK(j,1:ncol) .eq. 0) box_MISR_ztopWRK(j,1:ncol)=-999._wp
     264             : 
     265             :        ! Compute joint histogram and column quantities for points that are sunlit and cloudy
     266      155088 :        if (sunlit(j) .eq. 1) then 
     267             :           ! Joint histogram
     268             :           call hist2D(tauWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol),ncol,misr_histTau,numMISRTauBins,&
     269    10862100 :                1000*misr_histHgt,numMISRHgtBins,fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins))
     270             :           fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins) =                       &
     271     9404100 :              100._wp*fq_MISR_TAU_v_CTH(j,1:numMISRTauBins,1:numMISRHgtBins)/ncol
     272             : 
     273             :           ! Column cloud area
     274      801900 :           MISR_cldarea(j)=real(count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.))/ncol
     275             : 
     276             :           ! Column cloud-top height
     277      801900 :           if ( count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.) .ne. 0 ) then
     278             :              MISR_mean_ztop(j) = sum(box_MISR_ztopWRK(j,1:ncol),box_MISR_ztopWRK(j,1:ncol) .ne. -999.)/ &
     279     1088362 :                   count(box_MISR_ztopWRK(j,1:ncol) .ne. -999.)
     280             :           else
     281       23429 :              MISR_mean_ztop(j) = R_UNDEF
     282             :           endif
     283             : 
     284             :        else
     285       72900 :           MISR_cldarea(j)         = R_UNDEF
     286       72900 :           MISR_mean_ztop(npoints) = R_UNDEF
     287             :        endif
     288             :     enddo
     289             : 
     290        9288 :   end SUBROUTINE MISR_COLUMN
     291             : 
     292             : end MODULE MOD_MISR_SIMULATOR

Generated by: LCOV version 1.14