subroutine Brunt_Freq( x, y, z, pt, BV, undeff )
! ブラントバイサラ振動数の 2 乗を計算する.
  use analy
  use Phys_Const
  implicit none
  real, intent(in) :: x(:)  ! x 方向の座標変数 [m]
  real, intent(in) :: y(:)  ! y 方向の座標変数 [m]
  real, intent(in) :: z(:)  ! z 方向の座標変数 [m]
  real, intent(in) :: pt(size(x),size(y),size(z))  ! 温位 [K]
  real, intent(inout) :: BV(size(x),size(y),size(z))  ! ブラントバイサラ振動数 [1/s]
  real, intent(in), optional :: undeff
  integer :: i, j, k
  integer :: nx  ! 第 1 要素数
  integer :: ny  ! 第 2 要素数
  integer :: nz  ! 第 3 要素数
  real :: dx  ! x 方向の格子間隔 [m]
  real :: dy  ! y 方向の格子間隔 [m]
  real :: dz  ! z 方向の格子間隔 [m]

  nx=size(x)
  ny=size(y)
  nz=size(z)
  dx=x(2)-x(1)
  dy=y(2)-y(1)
  dz=z(2)-z(1)

  if(present(undeff))then
!$omp parallel default(shared)
!$omp do private(i,j)
     do j=1,ny
        do i=1,nx
           call grad_1d( z, pt(i,j,:), BV(i,j,:), undeff )
        end do
     end do
!$omp end do
!$omp end parallel

  else

!$omp parallel default(shared)
!$omp do private(i,j)
     do j=1,ny
        do i=1,nx
           call grad_1d( z, pt(i,j,:), BV(i,j,:) )
        end do
     end do
!$omp end do
!$omp end parallel
  end if

  do k=1,nz
     do j=1,ny
        do i=1,nx
           if(present(undeff))then
              if(BV(i,j,k)==undeff)then
                 BV(i,j,k)=undeff
              else
                 BV(i,j,k)=(g/pt(i,j,k))*BV(i,j,k)
              end if
           else
              BV(i,j,k)=(g/pt(i,j,k))*BV(i,j,k)
           end if
        end do
     end do
  end do

end subroutine

subroutine EDC_TKE( x, y, z, pt, tke, nuth, nutv, nuhh, nuhv )
  use Phys_Const
  use Statistics
  use Analy
! 1.5 次の TKE を用いた渦粘性係数を計算する.
  real, intent(in) :: x(:)  ! x 方向の座標変数 [m]
  real, intent(in) :: y(:)  ! y 方向の座標変数 [m]
  real, intent(in) :: z(:)  ! z 方向の座標変数 [m]
  real, intent(in) :: pt(size(x),size(y),size(z))  ! 温位 [K]
  real, intent(in) :: tke(size(x),size(y),size(z))  ! tke [J/kg]
  real, intent(inout) :: nuth(size(x),size(y),size(z))  ! 水平渦粘性係数 [m^2/s]
  real, intent(inout) :: nutv(size(x),size(y),size(z))  ! 鉛直渦粘性係数 [m^2/s]
  real, intent(inout) :: nuhh(size(x),size(y),size(z))  ! 水平渦拡散係数 [m^2/s]
  real, intent(inout) :: nuhv(size(x),size(y),size(z))  ! 鉛直渦拡散係数 [m^2/s]
  real :: ptb(size(z)), BV(size(z))
  real, dimension(size(x),size(y),size(z)) :: lv, ls
  real :: lh, dsh, dsv
  real, parameter :: alpha=1.0e-6
  integer :: i, j, k
  integer :: nx  ! 第 1 要素数
  integer :: ny  ! 第 2 要素数
  integer :: nz  ! 第 3 要素数
  real :: dx  ! x 方向の格子間隔 [m]
  real :: dy  ! y 方向の格子間隔 [m]
  real :: dz  ! z 方向の格子間隔 [m]
  intrinsic :: min, max

  dx=x(2)-x(1)
  dy=y(2)-y(1)
  dz=z(2)-z(1)
  nx=size(x)
  ny=size(y)
  nz=size(z)

  dsh=sqrt(dx*dy)
  dsv=dz
  lh=dsh

! 温位の水平面平均
  do i=1,nz
     call Mean_2d( pt(:,:,i), ptb(i) )
  end do

! 鉛直方向に ptb のブラントバイサラ振動数を計算する.
  call Brunt_Freq( x(1:1), y(1:1), z, ptb(:), BV(:) )

! 大気の安定度で場合分け
  do k=1,nz
     do j=1,ny
        do i=1,nx
           if(BV(k)>0.0)then
              ls(i,j,k)=0.76*sqrt(tke(i,j,k)/BV(k))
              lv(i,j,k)=min(dsv,ls(i,j,k))
           else
              lv(i,j,k)=dsv
           end if
           nuth(i,j,k)=max(0.1*sqrt(tke(i,j,k))*lh,alpha*(dsh**2))
           nutv(i,j,k)=max(0.1*sqrt(tke(i,j,k))*lv(i,j,k),alpha*(dsv**2))
           nuhh(i,j,k)=3.0*nuth(i,j,k)
           nuhv(i,j,k)=nutv(i,j,k)*(1.0+2.0*(lv(i,j,k)/dsv))
        end do
     end do
  end do

end subroutine

subroutine Ertel_PV( x, y, z, u, v, w, rho, pt, pv, undeff )
! エルテルのポテンシャル渦度を計算する
  use Thermo_Function
  use Thermo_Routine
  use analy 
  implicit none
  real, intent(in) :: x(:)  ! x 方向の座標変数 [m]
  real, intent(in) :: y(:)  ! y 方向の座標変数 [m]
  real, intent(in) :: z(:)  ! z 方向の座標変数 [m]
  real, intent(in) :: u(size(x),size(y),size(z))  ! 速度場の x 成分 [m/s]
  real, intent(in) :: v(size(x),size(y),size(z))  ! 速度場の y 成分 [m/s]
  real, intent(in) :: w(size(x),size(y),size(z))  ! 速度場の z 成分 [m/s]
  real, intent(in) :: rho(size(x),size(y),size(z))  ! 密度場 [kg/m^3]
  real, intent(in) :: pt(size(x),size(y),size(z))  ! 温位場 [K]
  real, intent(inout) :: pv(size(x),size(y),size(z))  ! PV [Km^2/kgs]
  real, intent(in), optional :: undeff
  real :: tmp1(size(x),size(y),size(z))
  real :: tmp2(size(x),size(y),size(z))
  real :: tmp3(size(x),size(y),size(z))
  real :: tmp4(size(x),size(y),size(z))
  real :: tmp5(size(x),size(y),size(z))
  real :: tmp6(size(x),size(y),size(z))
  real :: tmp7(size(x),size(y),size(z))
  integer :: i, j, k
  integer :: nx  ! 第 1 要素数
  integer :: ny  ! 第 2 要素数
  integer :: nz  ! 第 3 要素数
  real :: dx  ! x 方向の格子間隔 [m]
  real :: dy  ! y 方向の格子間隔 [m]
  real :: dz  ! z 方向の格子間隔 [m]

  nx=size(x)
  ny=size(y)
  nz=size(z)
  dx=x(2)-x(1)
  dy=y(2)-y(1)
  dz=z(2)-z(1)

  if(present(undeff))then
!  温位の空間勾配を計算.
     call grad_vec_3d( x, y, z, pt, tmp1, tmp2, tmp3, undeff )
!  3 次元 rotation を計算.
     call rotate( x, y, z, u, v, w, tmp4, tmp5, tmp6, undeff )
!  omega と grad pt の内積を計算
     call dot_prod( tmp4, tmp5, tmp6, tmp1, tmp2, tmp3, tmp7, undeff )
  else
!  温位の空間勾配を計算.
     call grad_vec_3d( x, y, z, pt, tmp1, tmp2, tmp3 )
!  3 次元 rotation を計算.
     call rotate( x, y, z, u, v, w, tmp4, tmp5, tmp6 )
!  omega と grad pt の内積を計算
     call dot_prod( tmp4, tmp5, tmp6, tmp1, tmp2, tmp3, tmp7 )
  end if

  if(present(undeff))then
!$omp parallel default(shared)
!$omp do private(i,j,k)

     do k=1,nz
        do j=1,ny
           do i=1,nx
              if(tmp7(i,j,k)==undeff.or.rho(i,j,k)==undeff)then
                 pv(i,j,k)=undeff
              else
                 pv(i,j,k)=tmp7(i,j,k)/rho(i,j,k)
              end if
           end do
        end do
     end do

!$omp end do
!$omp end parallel

  else

!$omp parallel default(shared)
!$omp do private(i,j,k)

     do k=1,nz
        do j=1,ny
           do i=1,nx
              pv(i,j,k)=tmp7(i,j,k)/rho(i,j,k)
           end do
        end do
     end do

!$omp end do
!$omp end parallel

  end if

end subroutine

subroutine Louis_horizon( z, z0m, richard, Lo )
! Louis(1980) で提案されている大気の不安定度を考慮したバルク係数の補正係数を計算する関数
  use Thermo_Advanced_Function
  implicit none
  real, intent(in) :: z  ! cm を求める高度 [m]
  real, intent(in), dimension(:,:) :: z0m  ! モデルで計算される粗度高度 [m]
  real, intent(in), dimension(size(z0m,1),size(z0m,2)) :: richard  ! バルクリチャードソン数
  real, intent(inout), dimension(size(z0m,1),size(z0m,2)) :: Lo  ! 補正係数
  real, parameter :: b=5.0, c=5.0
  real :: cm_tmp, zratio
  integer :: i, j, nx, ny

  nx=size(z0m,1)
  ny=size(z0m,2)

!$omp parallel default(shared)
!$omp do private(i,j)
  do j=1,ny
     do i=1,nx
        Lo(i,j)=Louis( z, z0m(i,j), richard(i,j) )
     end do
  end do
!$omp end do
!$omp end parallel

end subroutine

subroutine Rich_horizon( za, pta, ptg, va, qva, qvs, Ri )
! バルクリチャードソン数を計算するルーチン
  use Thermo_Advanced_Function
  implicit none
  real, intent(in) :: za  ! リチャードソン数を計算する高度 [m]
  real, intent(in), dimension(:,:) :: pta  ! za での仮温位 [K]
  real, intent(in), dimension(size(pta,1),size(pta,2)) :: ptg  ! 地表面での温位 [K]
  real, intent(in), dimension(size(pta,1),size(pta,2)) :: va  ! 高度 za での水平風速の絶対値 [m/s]
  real, intent(in), dimension(size(pta,1),size(pta,2)) :: qva  ! za での混合比 [kg/kg]
  real, intent(in), dimension(size(pta,1),size(pta,2)) :: qvs  ! 地表面での飽和混合比 [kg/kg]
  real, intent(inout), dimension(size(pta,1),size(pta,2)) :: Ri  ! 求めるリチャードソン数
  real, dimension(size(pta,1),size(pta,2)) :: ptvg, ptva, dpt
  integer :: i, j, nx, ny

  nx=size(pta,1)
  ny=size(pta,2)

!$omp parallel default(shared)
!$omp do private(i,j)
  do j=1,ny
     do i=1,nx
        Ri(i,j)=Rich( za, pta(i,j), ptg(i,j), va(i,j), qva(i,j), qvs(i,j) )
     end do
  end do
!$omp end do
!$omp end parallel

end subroutine

subroutine cm_horizon( z, z0m, coem, richard )
! 運動量に関するバルク係数を計算するルーチン
  use Thermo_Advanced_Function
  implicit none
  real, intent(in) :: z  ! cm を求める高度 [m]
  real, intent(in), dimension(:,:) :: z0m  ! モデルで計算される粗度高度 [m]
  real, intent(inout), dimension(size(z0m,1),size(z0m,2)) :: coem  ! バルク係数
  real, intent(in), dimension(size(z0m,1),size(z0m,2)), optional :: richard  ! Louis (1980) のスキームで計算する場合のバルクリチャードソン数
  integer :: i, j, nx, ny

  nx=size(z0m,1)
  ny=size(z0m,2)

  if(present(richard))then
!$omp parallel default(shared)
!$omp do private(i,j)
     do j=1,ny
        do i=1,nx
           coem(i,j)=cm( z, z0m(i,j), richard(i,j) )
        end do
     end do
!$omp end do
!$omp end parallel
  else
!$omp parallel default(shared)
!$omp do private(i,j)
     do j=1,ny
        do i=1,nx
           coem(i,j)=cm( z, z0m(i,j), richard(i,j) )
        end do
     end do
!$omp end do
!$omp end parallel
  end if

end subroutine

subroutine ust_horizon( cmd, va, velst )
! 摩擦速度 u_* を計算するルーチン
  use Thermo_Advanced_Function
  implicit none
  real, intent(in), dimension(:,:) :: cmd  ! 高度 za でのバルク係数
  real, intent(in), dimension(size(cmd,1),size(cmd,2)) :: va  ! 高度 za での水平風の絶対値 [m/s]
  real, intent(inout), dimension(size(cmd,1),size(cmd,2)) :: velst  ! 摩擦速度 [m/s]
  integer :: i, j, nx, ny

!$omp parallel default(shared)
!$omp do private(i,j)
     do j=1,ny
        do i=1,nx
           velst(i,j)=ust( cmd(i,j), va(i,j) )
        end do
     end do
!$omp end do
!$omp end parallel

end subroutine