cosp_isccp_simulator.F90

Go to the documentation of this file.

! (c) British Crown Copyright 2008, the Met Office.
! All rights reserved.
! 
! Redistribution and use in source and binary forms, with or without modification, are permitted 
! provided that the following conditions are met:
! 
!     * Redistributions of source code must retain the above copyright notice, this list 
!       of conditions and the following disclaimer.
!     * Redistributions in binary form must reproduce the above copyright notice, this list
!       of conditions and the following disclaimer in the documentation and/or other materials 
!       provided with the distribution.
!     * Neither the name of the Met Office nor the names of its contributors may be used 
!       to endorse or promote products derived from this software without specific prior written 
!       permission.
! 
! THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR 
! IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND 
! FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR 
! CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL 
! DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 
! DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER 
! IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT 
! OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.

MODULE mod_cosp_isccp_simulator
  USE mod_cosp_constants
  USE mod_cosp_types
  IMPLICIT NONE

CONTAINS


!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
!-------------- SUBROUTINE COSP_ISCCP_SIMULATOR -----------------
!%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%
SUBROUTINE cosp_isccp_simulator(gbx,sgx,y)
  
  ! Arguments
  type(cosp_gridbox),intent(in) :: gbx  ! Gridbox info
  type(cosp_subgrid),intent(in) :: sgx  ! Subgridbox info
  type(cosp_isccp),intent(inout) :: y   ! ISCCP simulator output
  
  ! Local variables 
  integer :: i,Nlevels,Npoints
  real :: pfull(gbx%npoints, gbx%nlevels)
  real :: phalf(gbx%npoints, gbx%nlevels + 1)
  real :: qv(gbx%npoints, gbx%nlevels)
  real :: cc(gbx%npoints, gbx%nlevels)
  real :: conv(gbx%npoints, gbx%nlevels)
  real :: dtau_s(gbx%npoints, gbx%nlevels)
  real :: dtau_c(gbx%npoints, gbx%nlevels)
  real :: at(gbx%npoints, gbx%nlevels)
  real :: dem_s(gbx%npoints, gbx%nlevels)
  real :: dem_c(gbx%npoints, gbx%nlevels)
  real :: frac_out(gbx%npoints, gbx%ncolumns, gbx%nlevels)
  integer :: sunlit(gbx%npoints)
  
  nlevels = gbx%Nlevels
  npoints = gbx%Npoints
  ! Flip inputs. Levels from TOA to surface
  pfull  = gbx%p(:,nlevels:1:-1) 
  phalf(:,1)         = 0.0 ! Top level
  phalf(:,2:nlevels+1) = gbx%ph(:,nlevels:1:-1)
  qv     = gbx%sh(:,nlevels:1:-1) 
  cc     = 0.999999*gbx%tca(:,nlevels:1:-1) 
  conv   = 0.999999*gbx%cca(:,nlevels:1:-1) 
  dtau_s = gbx%dtau_s(:,nlevels:1:-1) 
  dtau_c = gbx%dtau_c(:,nlevels:1:-1) 
  at     = gbx%T(:,nlevels:1:-1) 
  dem_s  = gbx%dem_s(:,nlevels:1:-1) 
  dem_c  = gbx%dem_c(:,nlevels:1:-1) 
  frac_out(1:npoints,:,1:nlevels) = sgx%frac_out(1:npoints,:,nlevels:1:-1)
  sunlit = int(gbx%sunlit)
  call icarus(0,0,gbx%npoints,sunlit,gbx%nlevels,gbx%ncolumns, &
            pfull,phalf,qv,cc,conv,dtau_s,dtau_c, &
            gbx%isccp_top_height,gbx%isccp_top_height_direction, &
            gbx%isccp_overlap,frac_out, &
            gbx%skt,gbx%isccp_emsfc_lw,at,dem_s,dem_c,y%fq_isccp,y%totalcldarea, &
            y%meanptop,y%meantaucld,y%meanalbedocld, &
            y%meantb,y%meantbclr,y%boxtau,y%boxptop)

  ! Flip outputs. Levels from surface to TOA
  ! --- (npoints,tau=7,pressure=7)
  y%fq_isccp(:,:,:) = y%fq_isccp(:,:,7:1:-1)
     
  ! Change boxptop from hPa to Pa. This avoids using UDUNITS in CMOR
!  y%boxptop = y%boxptop*100.0
  
  ! Check if there is any value slightly greater than 1
  where ((y%totalcldarea > 1.0-1.e-5) .and. (y%totalcldarea < 1.0+1.e-5))
    y%totalcldarea = 1.0
  endwhere
              
END SUBROUTINE cosp_isccp_simulator

END MODULE mod_cosp_isccp_simulator