scale_atmos_diagnostic.F90

Go to the documentation of this file.

!-------------------------------------------------------------------------------
!-------------------------------------------------------------------------------
#include "scalelib.h"
module scale_atmos_diagnostic
  !-----------------------------------------------------------------------------
  !
  !++ used modules
  !
  use scale_precision
  use scale_io
  use scale_prof
  !-----------------------------------------------------------------------------
  implicit none
  private
  !-----------------------------------------------------------------------------
  !
  !++ Public procedure
  !
  public :: atmos_diagnostic_get_therm_rhot
  public :: atmos_diagnostic_get_therm_rhoe
  public :: atmos_diagnostic_get_phyd
  public :: atmos_diagnostic_get_potv
  public :: atmos_diagnostic_get_teml
  public :: atmos_diagnostic_get_n2
 
  !-----------------------------------------------------------------------------
  !
  !++ Public parameters & variables
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private procedure
  !
  !-----------------------------------------------------------------------------
  !
  !++ Private parameters & variables
  !
  !-----------------------------------------------------------------------------
contains
  !-----------------------------------------------------------------------------
  subroutine atmos_diagnostic_get_therm_rhot( &
       KA, KS, KE, &
       IA, IS, IE, &
       JA, JS, JE, &
       DENS, RHOT,             &
       Rtot, CVtot, CPtot,     &
       POTT, TEMP, PRES, EXNER )
    use scale_atmos_thermodyn, only: &
       thermodyn_rhot2temp_pres => atmos_thermodyn_rhot2temp_pres
    integer,  intent(in)  :: ka, ks, ke
    integer,  intent(in)  :: ia, is, ie
    integer,  intent(in)  :: ja, js, je
 
    real(rp), intent(in)  :: dens (ka,ia,ja)
    real(rp), intent(in)  :: rhot (ka,ia,ja)
    real(rp), intent(in)  :: rtot (ka,ia,ja)
    real(rp), intent(in)  :: cvtot(ka,ia,ja)
    real(rp), intent(in)  :: cptot(ka,ia,ja)
 
    real(rp), intent(out) :: pott (ka,ia,ja)
    real(rp), intent(out) :: temp (ka,ia,ja)
    real(rp), intent(out) :: pres (ka,ia,ja)
    real(rp), intent(out) :: exner(ka,ia,ja)
 
    integer :: k, i, j
    !---------------------------------------------------------------------------
 
    !$acc data copyin(DENS, RHOT, Rtot, CVtot, CPtot) copyout(POTT, TEMP, PRES, EXNER)
 
    call thermodyn_rhot2temp_pres( ka, ks, ke, ia, is, ie, ja, js, je, &
                                   dens(:,:,:), rhot(:,:,:),                & ! (in)
                                   rtot(:,:,:), cvtot(:,:,:), cptot(:,:,:), & ! (in)
                                   temp(:,:,:), pres(:,:,:)                 ) ! (out)
 
 
!OCL XFILL
    !$omp parallel do default(none) OMP_SCHEDULE_ collapse(2) &
    !$omp private(i,j,k) &
    !$omp shared(POTT,EXNER,RHOT,DENS,TEMP) &
    !$omp shared(KS,KE,IS,IE,JS,JE)
    !$acc kernels
    do j = js, je
    do i = is, ie
    do k = ks, ke
       pott(k,i,j) = rhot(k,i,j) / dens(k,i,j)
       exner(k,i,j) = temp(k,i,j) / pott(k,i,j)
    enddo
    enddo
    enddo
    !$acc end kernels
 
    !$acc end data
 
    return
  end subroutine atmos_diagnostic_get_therm_rhot
 
  !-----------------------------------------------------------------------------
  subroutine atmos_diagnostic_get_therm_rhoe( &
         KA, KS, KE, IA, IS, IE, JA, JS, JE, &
         DENS, RHOE, Rtot, CPtot, CVtot, & ! (in)
         temp, pott, pres, exner         ) ! (out)
    use scale_const, only: &
       pre00 => const_pre00
    implicit none
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in) :: dens (ka,ia,ja)
    real(rp), intent(in) :: rhoe (ka,ia,ja)
    real(rp), intent(in) :: rtot (ka,ia,ja)
    real(rp), intent(in) :: cptot(ka,ia,ja)
    real(rp), intent(in) :: cvtot(ka,ia,ja)
 
    real(rp), intent(out) :: pott (ka,ia,ja)
    real(rp), intent(out) :: temp (ka,ia,ja)
    real(rp), intent(out) :: pres (ka,ia,ja)
    real(rp), intent(out) :: exner(ka,ia,ja)
 
    integer :: i, j, k
 
    !$omp parallel do
    !$acc kernels
    do j = js, je
    do i = is, ie
    do k = ks, ke
       temp(k,i,j) = rhoe(k,i,j) / ( cvtot(k,i,j) * dens(k,i,j) )
       pres(k,i,j) = dens(k,i,j) * rtot(k,i,j) * temp(k,i,j)
       exner(k,i,j) = ( pres(k,i,j) / pre00 )**( rtot(k,i,j) / cptot(k,i,j) )
       pott(k,i,j) = temp(k,i,j) / exner(k,i,j)
    end do
    end do
    end do
    !$acc end kernels
 
    return
  end subroutine atmos_diagnostic_get_therm_rhoe
 
  !-----------------------------------------------------------------------------
  subroutine atmos_diagnostic_get_phyd( &
       KA, KS, KE, &
       IA, IS, IE, &
       JA, JS, JE, &
       DENS, PRES, &
       CZ, FZ,     &
       PHYD,       &
       PHYDH       )
    use scale_const, only: &
       eps  => const_eps, &
       grav => const_grav
    implicit none
 
    integer,  intent(in)  :: ka, ks, ke
    integer,  intent(in)  :: ia, is, ie
    integer,  intent(in)  :: ja, js, je
    real(rp), intent(in)  :: dens (  ka,ia,ja)
    real(rp), intent(in)  :: pres (  ka,ia,ja)
    real(rp), intent(in)  :: cz   (  ka,ia,ja)
    real(rp), intent(in)  :: fz   (0:ka,ia,ja)
    real(rp), intent(out) :: phyd (  ka,ia,ja)
    real(rp), intent(out) :: phydh(0:ka,ia,ja)
 
    real(rp) :: diff
 
    integer  :: k, i, j
    !---------------------------------------------------------------------------
 
    !$omp parallel do default(none) OMP_SCHEDULE_ &
    !$omp private(i,j,k) &
    !$omp private(diff) &
    !$omp shared(PHYD,PHYDH,DENS,PRES,CZ,FZ,GRAV,EPS) &
    !$omp shared(KS,KE,IS,IE,JS,JE)
    !$acc kernels copyin(DENS, CZ, FZ) copyout(PHYD, PHYDH)
    do j = js, je
    do i = is, ie
       phydh(ke,i,j) = pres(ke,i,j) - dens(ke,i,j) * grav * ( fz(ke,i,j) - cz(ke,i,j) )
       do k = ke-1, ks-1, -1
          phydh(k,i,j) = phydh(k+1,i,j) + dens(k+1,i,j) * grav * ( fz(k+1,i,j) - fz(k,i,j) )
       end do
       phyd(ke,i,j) = pres(ke,i,j)
       do k = ke-1, ks, -1
          phyd(k,i,j) = phyd(k+1,i,j) + ( dens(k+1,i,j) + dens(k,i,j) ) * grav * ( cz(k+1,i,j) - cz(k,i,j) ) * 0.5_rp
       end do
       diff = 0.0_rp
       do k = ks, ke-1
          diff = diff + ( pres(k,i,j) - phyd(k,i,j) ) * ( fz(k,i,j) - fz(k-1,i,j) )
       end do
       diff = diff / ( fz(ke,i,j) - fz(ks-1,i,j) )
       diff = max( diff, eps - phydh(ke,i,j) )
       do k = ks-1, ke
          phydh(k,i,j) = phydh(k,i,j) + diff
       end do
       do k = ks, ke
          phyd(k,i,j) = phyd(k,i,j) + diff
       end do
    enddo
    enddo
    !$acc end kernels
 
    return
  end subroutine atmos_diagnostic_get_phyd
 
  !-----------------------------------------------------------------------------
  subroutine atmos_diagnostic_get_n2( &
       KA, KS, KE, &
       IA, IS, IE, &
       JA, JS, JE, &
       POTT, Rtot,  &
       CZ, FZ, F2H, &
       N2           )
    use scale_const, only: &
       grav => const_grav
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in)  :: pott(ka,ia,ja)
    real(rp), intent(in)  :: rtot(ka,ia,ja)
 
    real(rp), intent(in)  :: cz (  ka,ia,ja)
    real(rp), intent(in)  :: fz (0:ka,ia,ja)
    real(rp), intent(in)  :: f2h(ka,2,ia,ja)
 
    real(rp), intent(out) :: n2  (ka,ia,ja)
 
    real(rp) :: rpt(ka)
    real(rp) :: rpt_h(ka)
 
    integer  :: k, i, j
    !---------------------------------------------------------------------------
 
    !$omp parallel do default(none) OMP_SCHEDULE_ collapse(2) &
    !$omp private(i,j,k) &
    !$omp private(RPT,RPT_h) &
    !$omp shared(N2,POTT,Rtot,CZ,FZ,F2H,GRAV) &
    !$omp shared(KS,KE,IS,IE,JS,JE)
    !$acc kernels
    !$acc loop private(RPT,RPT_h)
    do j = js, je
    !$acc loop private(RPT,RPT_h)
    do i = is, ie
       do k = ks, ke
          rpt(k) = rtot(k,i,j) * pott(k,i,j)
       end do
 
       do k = ks, ke-1
          rpt_h(k) = f2h(k,1,i,j) * rpt(k+1) + f2h(k,2,i,j) * rpt(k)
       end do
 
       n2(ks,i,j) = grav * ( rpt_h(ks) - rpt(ks) ) / ( ( fz(ks,i,j) - cz(ks,i,j) ) * rpt(ks) )
       do k = ks+1,ke-1
          n2(k,i,j) = grav * ( rpt_h(k) - rpt_h(k-1) ) / ( ( fz(k,i,j) - fz(k-1,i,j) ) * rpt(k) )
       end do
       n2(ke,i,j) = grav * ( rpt(ke) - rpt_h(ke-1) ) / ( ( cz(ke,i,j) - fz(ke-1,i,j) ) * rpt(ke) )
    end do
    end do
    !$acc end kernels
 
    return
  end subroutine atmos_diagnostic_get_n2
 
  !-----------------------------------------------------------------------------
  subroutine atmos_diagnostic_get_potv( &
       KA, KS, KE, &
       IA, IS, IE, &
       JA, JS, JE, &
       POTT, &
       Rtot, &
       POTV  )
    use scale_const, only: &
       rdry => const_rdry
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in)  :: pott(ka,ia,ja)
    real(rp), intent(in)  :: rtot(ka,ia,ja)
 
    real(rp), intent(out) :: potv(ka,ia,ja)
 
    integer  :: k, i, j
    !---------------------------------------------------------------------------
 
!OCL XFILL
    !$omp parallel do default(none) OMP_SCHEDULE_ collapse(2) &
    !$omp private(i,j,k) &
    !$omp shared(POTV,POTT,Rtot,Rdry) &
    !$omp shared(KS,KE,IS,IE,JS,JE)
    !$acc kernels
    do j = js, je
    do i = is, ie
    do k = ks, ke
       potv(k,i,j) = pott(k,i,j) * rtot(k,i,j) / rdry
    end do
    end do
    end do
    !$acc end kernels
 
    return
  end subroutine atmos_diagnostic_get_potv
 
  !-----------------------------------------------------------------------------
  subroutine atmos_diagnostic_get_teml( &
       KA, KS, KE, &
       IA, IS, IE, &
       JA, JS, JE, &
       TEMP,     &
       LHV, LHS, &
       QC, QI,   &
       CPtot,    &
       TEML      )
    integer, intent(in) :: ka, ks, ke
    integer, intent(in) :: ia, is, ie
    integer, intent(in) :: ja, js, je
 
    real(rp), intent(in)  :: temp (ka,ia,ja)
    real(rp), intent(in)  :: lhv  (ka,ia,ja)
    real(rp), intent(in)  :: lhs  (ka,ia,ja)
    real(rp), intent(in)  :: qc   (ka,ia,ja)
    real(rp), intent(in)  :: qi   (ka,ia,ja)
    real(rp), intent(in)  :: cptot(ka,ia,ja)
 
    real(rp), intent(out) :: teml(ka,ia,ja)
 
    integer  :: k, i, j
    !---------------------------------------------------------------------------
 
!OCL XFILL
    !$omp parallel do default(none) OMP_SCHEDULE_ collapse(2) &
    !$omp private(i,j,k) &
    !$omp shared(TEML,TEMP,LHV,LHS,QC,QI,CPtot) &
    !$omp shared(KS,KE,IS,IE,JS,JE)
    !$acc kernels
    do j = js, je
    do i = is, ie
    do k = ks, ke
       teml(k,i,j) = temp(k,i,j) &
                   - ( lhv(k,i,j) * qc(k,i,j) + lhs(k,i,j) * qi(k,i,j) ) / cptot(k,i,j)
    end do
    end do
    end do
    !$acc end kernels
 
    return
  end subroutine atmos_diagnostic_get_teml
 
end module scale_atmos_diagnostic