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

          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             : ! Jul 2007 - A. Bodas-Salcedo - Initial version
      31             : ! Jul 2008 - A. Bodas-Salcedo - Added capability of producing outputs in standard grid
      32             : ! Oct 2008 - J.-L. Dufresne   - Bug fixed. Assignment of Npoints,Nlevels,Nhydro,Ncolumns 
      33             : !                               in COSP_STATS
      34             : ! Oct 2008 - H. Chepfer       - Added PARASOL reflectance arguments
      35             : ! Jun 2010 - T. Yokohata, T. Nishimura and K. Ogochi - Added NEC SXs optimisations
      36             : ! Jan 2013 - G. Cesana        - Added betaperp and temperature arguments 
      37             : !                             - Added phase 3D/3Dtemperature/Map output variables in diag_lidar 
      38             : ! May 2015 - D. Swales        - Modified for cosp2.0 
      39             : ! %%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      40             : MODULE MOD_COSP_STATS
      41             :   USE COSP_KINDS, ONLY: wp
      42             :   USE MOD_COSP_CONFIG, ONLY: R_UNDEF,R_GROUND
      43             : 
      44             :   IMPLICIT NONE
      45             : CONTAINS
      46             : 
      47             :   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      48             :   !---------- SUBROUTINE COSP_CHANGE_VERTICAL_GRID ----------------
      49             :   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
      50      102168 : SUBROUTINE COSP_CHANGE_VERTICAL_GRID(Npoints,Ncolumns,Nlevels,zfull,zhalf,y,Nglevels,newgrid_bot,newgrid_top,r,log_units)
      51             :    implicit none
      52             :    ! Input arguments
      53             :    integer,intent(in) :: Npoints  !# of grid points
      54             :    integer,intent(in) :: Nlevels  !# of levels
      55             :    integer,intent(in) :: Ncolumns !# of columns
      56             :    real(wp),dimension(Npoints,Nlevels),intent(in) :: zfull ! Height at model levels [m] (Bottom of model layer)
      57             :    real(wp),dimension(Npoints,Nlevels),intent(in) :: zhalf ! Height at half model levels [m] (Bottom of model layer)
      58             :    real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: y     ! Variable to be changed to a different grid
      59             :    integer,intent(in) :: Nglevels  !# levels in the new grid
      60             :    real(wp),dimension(Nglevels),intent(in) :: newgrid_bot ! Lower boundary of new levels  [m]
      61             :    real(wp),dimension(Nglevels),intent(in) :: newgrid_top ! Upper boundary of new levels  [m]
      62             :    logical,optional,intent(in) :: log_units ! log units, need to convert to linear units
      63             :    ! Output
      64             :    real(wp),dimension(Npoints,Ncolumns,Nglevels),intent(out) :: r ! Variable on new grid
      65             : 
      66             :    ! Local variables
      67             :    integer :: i,j,k
      68             :    logical :: lunits
      69             :    integer :: l
      70             :    real(wp) :: w ! Weight
      71             :    real(wp) :: dbb, dtb, dbt, dtt ! Distances between edges of both grids
      72             :    integer :: Nw  ! Number of weights
      73             :    real(wp) :: wt  ! Sum of weights
      74      204336 :    real(wp),dimension(Nlevels) :: oldgrid_bot,oldgrid_top ! Lower and upper boundaries of model grid
      75             :    real(wp) :: yp ! Local copy of y at a particular point.
      76             :               ! This allows for change of units.
      77             : 
      78      102168 :    lunits=.false.
      79      102168 :    if (present(log_units)) lunits=log_units
      80             : 
      81   463249368 :    r = 0._wp
      82             : 
      83     1705968 :    do i=1,Npoints
      84             :      ! Calculate tops and bottoms of new and old grids
      85   136323000 :      oldgrid_bot = zhalf(i,:)
      86   134719200 :      oldgrid_top(1:Nlevels-1) = oldgrid_bot(2:Nlevels)
      87     1603800 :      oldgrid_top(Nlevels) = zfull(i,Nlevels) +  zfull(i,Nlevels) - zhalf(i,Nlevels) ! Top level symmetric
      88     1603800 :      l = 0 ! Index of level in the old grid
      89             :      ! Loop over levels in the new grid
      90    65857968 :      do k = 1,Nglevels
      91             :        Nw = 0 ! Number of weigths
      92             :        wt = 0._wp ! Sum of weights
      93             :        ! Loop over levels in the old grid and accumulate total for weighted average
      94             :        do
      95   211696969 :          l = l + 1
      96   211696969 :          w = 0.0 ! Initialise weight to 0
      97             :          ! Distances between edges of both grids
      98   211696969 :          dbb = oldgrid_bot(l) - newgrid_bot(k)
      99   211696969 :          dtb = oldgrid_top(l) - newgrid_bot(k)
     100   211696969 :          dbt = oldgrid_bot(l) - newgrid_top(k)
     101   211696969 :          dtt = oldgrid_top(l) - newgrid_top(k)
     102   211696969 :          if (dbt >= 0.0) exit ! Do next level in the new grid
     103   211696969 :          if (dtb > 0.0) then
     104   147544969 :            if (dbb <= 0.0) then
     105    61973989 :              if (dtt <= 0) then
     106             :                w = dtb
     107             :              else
     108     1246861 :                w = newgrid_top(k) - newgrid_bot(k)
     109             :              endif
     110             :            else
     111    85570980 :              if (dtt <= 0) then
     112    23240382 :                w = oldgrid_top(l) - oldgrid_bot(l)
     113             :              else
     114    62330598 :                w = -dbt
     115             :              endif
     116             :            endif
     117             :            ! If layers overlap (w/=0), then accumulate
     118   147544969 :            if (w /= 0.0) then
     119   147544969 :              Nw = Nw + 1
     120   147544969 :              wt = wt + w
     121  1140120215 :              do j=1,Ncolumns
     122   992575246 :                if (lunits) then
     123   402395370 :                  if (y(i,j,l) /= R_UNDEF) then
     124   198419355 :                    yp = 10._wp**(y(i,j,l)/10._wp)
     125             :                  else
     126             :                    yp = 0._wp
     127             :                  endif
     128             :                else
     129   590179876 :                  yp = y(i,j,l)
     130             :                endif
     131  1140120215 :                r(i,j,k) = r(i,j,k) + w*yp
     132             :              enddo
     133             :            endif
     134             :          endif
     135             :        enddo
     136    64152000 :        l = l - 2
     137    64152000 :        if (l < 1) l = 0
     138             :        ! Calculate average in new grid
     139    65755800 :        if (Nw > 0) then
     140   491280365 :          do j=1,Ncolumns
     141   491280365 :            r(i,j,k) = r(i,j,k)/wt
     142             :          enddo
     143             :        endif
     144             :      enddo
     145             :    enddo
     146             : 
     147             :    ! Set points under surface to R_UNDEF, and change to dBZ if necessary
     148     4188888 :    do k=1,Nglevels
     149    31681368 :      do j=1,Ncolumns
     150   463147200 :        do i=1,Npoints
     151   459060480 :          if (newgrid_top(k) > zhalf(i,1)) then ! Level above model bottom level
     152   427702906 :            if (lunits) then
     153   173393070 :              if (r(i,j,k) <= 0.0) then
     154    90849312 :                r(i,j,k) = R_UNDEF
     155             :              else
     156    82543758 :                r(i,j,k) = 10._wp*log10(r(i,j,k))
     157             :              endif
     158             :            endif
     159             :          else ! Level below surface
     160     3865094 :            r(i,j,k) = R_GROUND
     161             :          endif
     162             :        enddo
     163             :      enddo
     164             :    enddo
     165             : 
     166      102168 : END SUBROUTINE COSP_CHANGE_VERTICAL_GRID
     167             : 
     168             :   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     169             :   !------------- SUBROUTINE COSP_LIDAR_ONLY_CLOUD -----------------
     170             :   ! (c) 2008, Lawrence Livermore National Security Limited Liability Corporation.
     171             :   ! All rights reserved.
     172             :   !%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
     173        9288 :   SUBROUTINE COSP_LIDAR_ONLY_CLOUD(Npoints, Ncolumns, Nlevels, beta_tot, beta_mol,       &
     174        9288 :      Ze_tot, lidar_only_freq_cloud, tcc, radar_tcc, radar_tcc2)
     175             :     ! Inputs
     176             :     integer,intent(in) :: &
     177             :          Npoints,       & ! Number of horizontal gridpoints
     178             :          Ncolumns,      & ! Number of subcolumns
     179             :          Nlevels          ! Number of vertical layers
     180             :     real(wp),dimension(Npoints,Nlevels),intent(in) :: &
     181             :          beta_mol         ! Molecular backscatter
     182             :     real(wp),dimension(Npoints,Ncolumns,Nlevels),intent(in) :: &
     183             :          beta_tot,      & ! Total backscattered signal
     184             :          Ze_tot           ! Radar reflectivity
     185             :     ! Outputs
     186             :     real(wp),dimension(Npoints,Nlevels),intent(out) :: &
     187             :          lidar_only_freq_cloud
     188             :     real(wp),dimension(Npoints),intent(out) ::&
     189             :          tcc,       & !
     190             :          radar_tcc, & !
     191             :          radar_tcc2   !
     192             :     
     193             :     ! local variables
     194             :     real(wp) :: sc_ratio
     195             :     real(wp),parameter :: &
     196             :          s_cld=5.0, &
     197             :          s_att=0.01
     198             :     integer :: flag_sat,flag_cld,pr,i,j,flag_radarcld,flag_radarcld_no1km,j_1km
     199             :     
     200     6212808 :     lidar_only_freq_cloud = 0._wp
     201      155088 :     tcc = 0._wp
     202      155088 :     radar_tcc = 0._wp
     203      155088 :     radar_tcc2 = 0._wp
     204      155088 :     do pr=1,Npoints
     205     1613088 :        do i=1,Ncolumns
     206     1458000 :           flag_sat = 0
     207     1458000 :           flag_cld = 0
     208     1458000 :           flag_radarcld = 0 !+JEK
     209     1458000 :           flag_radarcld_no1km=0 !+JEK
     210             :           ! look for j_1km from bottom to top
     211             :           j = 1
     212     1458000 :           do while (Ze_tot(pr,i,j) .eq. R_GROUND)
     213           0 :              j = j+1
     214             :           enddo
     215     1458000 :           j_1km = j+1  !this is the vertical index of 1km above surface  
     216             :           
     217    59778000 :           do j=1,Nlevels
     218    58320000 :              sc_ratio = beta_tot(pr,i,j)/beta_mol(pr,j)
     219    58320000 :              if ((sc_ratio .le. s_att) .and. (flag_sat .eq. 0)) flag_sat = j
     220    59778000 :              if (Ze_tot(pr,i,j) .lt. -30.) then  !radar can't detect cloud
     221    53481144 :                 if ( (sc_ratio .gt. s_cld) .or. (flag_sat .eq. j) ) then  !lidar sense cloud
     222      445081 :                    lidar_only_freq_cloud(pr,j)=lidar_only_freq_cloud(pr,j)+1. !top->surf
     223      445081 :                    flag_cld=1
     224             :                 endif
     225             :              else  !radar sense cloud (z%Ze_tot(pr,i,j) .ge. -30.)
     226     4838856 :                 flag_cld=1
     227     4838856 :                 flag_radarcld=1
     228     4838856 :                 if (j .gt. j_1km) flag_radarcld_no1km=1              
     229             :              endif
     230             :           enddo !levels
     231     1458000 :           if (flag_cld .eq. 1) tcc(pr)=tcc(pr)+1._wp
     232     1458000 :           if (flag_radarcld .eq. 1) radar_tcc(pr)=radar_tcc(pr)+1.
     233     1603800 :           if (flag_radarcld_no1km .eq. 1) radar_tcc2(pr)=radar_tcc2(pr)+1.        
     234             :        enddo !columns
     235             :     enddo !points
     236     6212808 :     lidar_only_freq_cloud=lidar_only_freq_cloud/Ncolumns
     237      155088 :     tcc=tcc/Ncolumns
     238      155088 :     radar_tcc=radar_tcc/Ncolumns
     239      155088 :     radar_tcc2=radar_tcc2/Ncolumns
     240             :     
     241             :     ! Unit conversion
     242             :     where(lidar_only_freq_cloud /= R_UNDEF) &
     243     6212808 :             lidar_only_freq_cloud = lidar_only_freq_cloud*100._wp
     244      155088 :     where(tcc /= R_UNDEF) tcc = tcc*100._wp
     245      155088 :     where(radar_tcc /= R_UNDEF) radar_tcc = radar_tcc*100._wp
     246      155088 :     where(radar_tcc2 /= R_UNDEF) radar_tcc2 = radar_tcc2*100._wp
     247             :     
     248        9288 :   END SUBROUTINE COSP_LIDAR_ONLY_CLOUD
     249             :   
     250             :   ! ######################################################################################
     251             :   ! FUNCTION hist1D
     252             :   ! ######################################################################################
     253    11664000 :   function hist1d(Npoints,var,nbins,bins)
     254             :     ! Inputs
     255             :     integer,intent(in) :: &
     256             :          Npoints, & ! Number of points in input array
     257             :          Nbins      ! Number of bins for sorting
     258             :     real(wp),intent(in),dimension(Npoints) :: &
     259             :          var        ! Input variable to be sorted
     260             :     real(wp),intent(in),dimension(Nbins+1) :: &
     261             :          bins       ! Histogram bins [lowest,binTops]  
     262             :     ! Outputs
     263             :     real(wp),dimension(Nbins) :: &
     264             :          hist1d     ! Output histogram      
     265             :     ! Local variables
     266             :     integer :: ij
     267             :     
     268   186624000 :     do ij=2,Nbins+1  
     269  1924560000 :        hist1D(ij-1) = count(var .ge. bins(ij-1) .and. var .lt. bins(ij))
     270  1936224000 :        if (count(var .eq. R_GROUND) .ge. 1) hist1D(ij-1)=R_UNDEF
     271             :     enddo
     272             :     
     273             :   end function hist1D
     274             :   
     275             :   ! ######################################################################################
     276             :   ! SUBROUTINE hist2D
     277             :   ! ######################################################################################
     278      364500 :   subroutine hist2D(var1,var2,npts,bin1,nbin1,bin2,nbin2,jointHist)
     279             :     implicit none
     280             :     
     281             :     ! INPUTS
     282             :     integer, intent(in) :: &
     283             :          npts,  & ! Number of data points to be sorted
     284             :          nbin1, & ! Number of bins in histogram direction 1 
     285             :          nbin2    ! Number of bins in histogram direction 2
     286             :     real(wp),intent(in),dimension(npts) :: &
     287             :          var1,  & ! Variable 1 to be sorted into bins
     288             :          var2     ! variable 2 to be sorted into bins
     289             :     real(wp),intent(in),dimension(nbin1+1) :: &
     290             :          bin1     ! Histogram bin 1 boundaries
     291             :     real(wp),intent(in),dimension(nbin2+1) :: &
     292             :          bin2     ! Histogram bin 2 boundaries
     293             :     ! OUTPUTS
     294             :     real(wp),intent(out),dimension(nbin1,nbin2) :: &
     295             :          jointHist
     296             :     
     297             :     ! LOCAL VARIABLES
     298             :     integer :: ij,ik
     299             :     
     300     2916000 :     do ij=2,nbin1+1
     301    24348600 :        do ik=2,nbin2+1
     302    64297800 :           jointHist(ij-1,ik-1)=count(var1 .ge. bin1(ij-1) .and. var1 .lt. bin1(ij) .and. &
     303   302607900 :                var2 .ge. bin2(ik-1) .and. var2 .lt. bin2(ik))        
     304             :        enddo
     305             :     enddo
     306      364500 :   end subroutine hist2D
     307             : END MODULE MOD_COSP_STATS

Generated by: LCOV version 1.14