!----------------------------------------------------------------------
! Copyright (c) 2016 SPMODEL Development Group. All rights reserved.
!----------------------------------------------------------------------
!表題  w_base_mpi_module_supack
!
!  spml/w_base_mpi_module_supack モジュールは球面上での 2 次元流体運動を
!  球面調和函数を用いたスペクトル法と MPI によって数値計算するための 
!  モジュール w_mpi_module_supack の下部モジュールであり, スペクトル計算の
!  基本的な Fortran90 関数を提供する. 
!
!  内部で ISPACK2 の SUPACK の Fortran77 サブルーチンを呼んでいる. 
!  スペクトルデータおよび格子点データの格納方法や変換の詳しい計算法に
!  ついては ISPACK2/SUPACK のマニュアルを参照されたい.
!
!
!履歴  2016/03/13  竹広真一  w_base_mpi_module_sjpack を supack 化
!      2017/06/01  竹広真一  作業配列大きさ修正
!
module w_base_mpi_module_supack
  !
  ! w_base_mpi_module_supack
  !
  !  spml/w_base_mpi_module_supack モジュールは球面上での 2 次元流体運動を
  !  球面調和函数を用いたスペクトル法と MPI によって数値計算するための 
  !  モジュール w_mpi_module_supack の下部モジュールであり, スペクトル法の
  !  基本的なな Fortran90 関数を提供する. 
  !
  !  内部で ISPACK2 の SUPACK の Fortran77 サブルーチンを呼んでいる. 
  !  スペクトルデータおよび格子点データの格納方法や変換の詳しい計算法に
  !  ついては ISPACK2/SUPACK のマニュアルを参照されたい.
  !
  use dc_message
  use iso_c_binding
  use mpi
  
  implicit none

  integer               :: im=64            ! 格子点の設定(東西)
  integer               :: jm=32            ! 格子点の設定(南北)
  integer               :: nm=21            ! 計算する最大の全波数の設定
  integer               :: nn=22            ! 切断波数(全波数)の設定
  integer               :: mm=21            ! 切断波数(東西波数)の設定

  integer, allocatable  :: it(:)            ! 変換用配列
  real(8), allocatable  :: t(:)             ! 変換用配列
  real(8), allocatable  :: p(:,:), r(:)     ! 変換用配列
  integer, allocatable  :: jc(:)            ! 作業配列
  real(8), allocatable  :: wp(:)            ! 変換用作業配列

  real(8), allocatable  :: c(:)             ! 作業配列

  integer               :: j1, j2           ! 分散配置用変数
  integer               :: jl               ! 分散格子データの大きさ
  integer               :: nc               ! 分散スペクトルデータの大きさ

  integer, parameter    :: jv=4             ! ベクトル長

  integer               :: np               ! MPI プロセス数
  integer               :: ip               ! MPI プロセス番号
  
  real(8), allocatable  :: x_Lon(:), x_Lon_Weight(:)     ! 経度
  real(8), allocatable  :: v_Lat(:), v_Lat_Weight(:)     ! 緯度
  real(8), allocatable  :: xv_Lon(:,:), xv_Lat(:,:)

  real(8), pointer:: w(:), xv_pdata(:,:)
  type(C_PTR)     :: pw, pg

  logical               :: w_base_initialize=.false.   ! 初期化フラッグ

  real(8), parameter    :: pi=3.1415926535897932385D0
  
  private

  public im, jm, nn, mm, nm                   ! 格子点数, 切断波数
  public it, t, p, r, jc                      ! 変換用作業配列
  public j1, j2                               ! 分散格子データの大きさ
  public jl                                   ! 分散スペクトルデータの大きさ
  public nc
  public np, ip
  
  public w_base_mpi_Initial                   ! 初期化サブルーチン
  public w_base_mpi_Finalize                  ! 終了サブルーチン

  public x_Lon                                ! 格子座標
  public x_Lon_Weight                         ! 格子座標重み
  public v_Lat                                ! 格子座標
  public v_Lat_Weight                         ! 格子座標重み
  public xv_Lon, xv_Lat                       ! 格子座標(im,jm)
  public l_nm, nm_l                           ! 波数格納位置
  public xv_w, w_xv                           ! 変換関数
  public w_StreamPotential2VectorMPI          ! 流線ポテンシャルから速度場計算
  public w_Vector2VorDivMPI                   ! 速度場から渦度発散を計算
  public w_VectorCosLat2VorDivMPI             ! 速度場から渦度発散を計算

  interface l_nm
     module procedure l_nm_array00
     module procedure l_nm_array01
     module procedure l_nm_array10
     module procedure l_nm_array11
  end interface

  interface nm_l
     module procedure nm_l_int
     module procedure nm_l_array
  end interface

  save im, jm, nm, mm, nn                     ! 格子点数, 切断波数を記憶
  save it, t, p, r, jc                        ! 変換用配列を記憶
  save j1, j2
  save jl, nc
  save np, ip
  save c                                      ! 変換用配列
  save w, xv_pdata, pw, pg
  save w_base_initialize                      ! 初期化フラグ

  contains
  !--------------- 初期化 -----------------
    subroutine w_base_mpi_Initial(n_in,i_in,j_in)
      !
      ! スペクトル変換の格子点数, 波数および OPENMP 使用時の
      ! 最大スレッド数を設定する.
      !
      ! 実際の使用には上位サブルーチン w_Initial を用いること.
      !
      integer,intent(in) :: i_in              !(in) 格子点数(東西), 2の巾乗(<=2048)
      integer,intent(in) :: j_in              !(in) 格子点数(南北), 4 の倍数
      integer,intent(in) :: n_in              !(in) 切断全波数

      integer :: i, j
      integer :: ierr

      im = i_in   ; jm = j_in
      nn = n_in   ; nm = n_in+1 ;  mm = n_in      ! default は三角波数切断

      CALL MPI_COMM_SIZE(MPI_COMM_WORLD,NP,IERR)
      CALL MPI_COMM_RANK(MPI_COMM_WORLD,IP,IERR)

      allocate(it(im/2))                                ! 変換用配列
      allocate(t(im))                                   ! 変換用配列
      allocate(p(jm/2,2*(mm/np+1)+5))                   ! 変換用配列
      allocate(r(5*(mm/np+1)*(2*nm-mm/np*np)/4))        ! 変換用配列
      allocate(jc(5*(mm/np+1)*(2*nm-mm/np*np+8)/8))     ! 変換用配列
      allocate(wp(jm/2*mm))                             ! 変換用作業配列

      allocate(c((mm/np+1)*(2*(mm+1)-mm/np*np)))        ! 変換用作業配列

      call suinit(mm,nm,im,jm,it,t,p,r,jc,wp)
      call suinic(mm,c)
      
      call suqrnj(jm,jv,j1,j2)

      jl = j2-j1+1                              ! 分散格子データの大きさ
      nc = (mm/np+1)*(2*(nn+1)-mm/np*np)        ! 分散スペクトルデータの大きさ

      allocate(x_Lon(0:im-1))                   ! 格子点座標格納配列(経度)
      allocate(x_Lon_Weight(0:im-1))
      allocate(v_Lat(jl),v_Lat_Weight(jl))            ! 格子点座標格納配列
      allocate(xv_Lon(0:im-1,jl),xv_Lat(0:im-1,jl))   ! 格子点座標格納配列

      do i=0,im-1
         x_Lon(i)  = 2*pi/im*i               ! 経度座標
         x_Lon_Weight(i) = 2*pi/im           ! 経度座標重み
      enddo

      do j=j1,j2
         if ( j .gt. jm/2 ) then
            v_Lat(j-j1+1)         =  asin(p(j-jm/2,1)) ! 緯度座標
            v_Lat_Weight(j-j1+1)  = 2*p(j-jm/2,2)      ! 緯度重み(Gauss grid)
         else
            v_Lat(j-j1+1)         =  -asin(p(jm/2-j+1,1)) ! 緯度座標
            v_Lat_Weight(j-j1+1)  = 2*p(jm/2-j+1,2)       ! 緯度重み(Gauss grid)
         endif
      enddo

      do j=1,jl
         xv_Lon(:,j) = x_Lon
      enddo

      do i=0,im-1
         xv_Lat(i,:) = v_Lat
      enddo

      call mlallc(pg,jl*im)
      call mlallc(pw,4*2*jv*((jm/jv-1)/np+1)*((im/2-1)/np+1)*np)
      call c_f_pointer(pg, xv_pdata, [im,jl])
      call c_f_pointer(pw, w, [4*2*jv*((jm/jv-1)/np+1)*((im/2-1)/np+1)*np])

      w_base_initialize = .true.

      call MessageNotify('M','w_base_mpi_initial',&
           'w_base_mpi_module_supack (2017/06/01) for AVX/FMA is initialized')

    end subroutine w_base_mpi_Initial

  !--------------- 基本関数 -----------------

    function l_nm_array00(n,m)
      !
      ! 全波数(n)と東西波数(m)からそのスペクトルデータの格納位置を返す.
      ! 
      ! 引数 n,m がともに整数値の場合, 整数値を返す.
      ! プロセスに n,m が存在しない場合 0 を返す
      !
      integer               :: l_nm_array00   
      !(out) スペクトルデータの格納位置 

      integer, intent(in)   :: n     !(in) 全波数
      integer, intent(in)   :: m     !(in) 帯状波数

      integer :: ip_w

      if ( .not. w_base_initialize ) then
         call MessageNotify('E','l_nm_array00',&
              'w_base_mpi_module_supack not initialize yet. Use sunm2l routine in ISPACK2 directly.')
      else
         call sunm2l(nn,n,m,ip_w,l_nm_array00)
         if ( ip_w /= ip ) l_nm_array00 = 0
      endif

    end function l_nm_array00

    function l_nm_array01(n,marray)           ! スペクトルデータの格納位置 
      !
      ! 全波数(n)と東西波数(m)からそのスペクトルデータの格納位置を返す.
      ! 
      ! 第 1 引数 n が整数, 第 2 引数 marray が整数 1 次元配列の場合, 
      ! marray と同じ大きさの 1 次元整数配列を返す. 
      !
      integer, intent(in)  :: n               !(in) 全波数
      integer, intent(in)  :: marray(:)       !(in) 帯状波数
      integer              :: l_nm_array01(size(marray))
      !(out) スペクトルデータ位置

      integer              :: i 

      do i=1, size(marray)
         l_nm_array01(i) = l_nm_array00(n,marray(i))
      enddo
    end function l_nm_array01

    function l_nm_array10(narray,m)
      !
      ! 全波数(n)と東西波数(m)からそのスペクトルデータの格納位置を返す.
      ! 
      ! 第 1 引数 narray が整数 1 次元配列, 第 2 引数  m が整数の場合, 
      ! narray と同じ大きさの 1 次元整数配列を返す. 
      !
      integer, intent(in)  :: narray(:)           !(in) 全波数  
      integer, intent(in)  :: m                   !(in) 帯状波数
      integer              :: l_nm_array10(size(narray))
      !(out) スペクトルデータ位置

      integer              :: i 

      do i=1, size(narray)
         l_nm_array10(i) = l_nm_array00(narray(i),m)
      enddo
    end function l_nm_array10

    function l_nm_array11(narray,marray)
      !
      ! 全波数(n)と東西波数(m)からそのスペクトルデータの格納位置を返す.
      ! 
      ! 第 1,2 引数 narray, marray がともに整数 1 次元配列の場合, 
      ! narray, marray と同じ大きさの 1 次元整数配列を返す. 
      ! narray, marray は同じ大きさでなければならない. 
      !
      integer, intent(in)  :: narray(:)          !(in) 全波数  
      integer, intent(in)  :: marray(:)          !(in) 帯状波数
      integer              :: l_nm_array11(size(narray))
      !(out) スペクトルデータ位置

      integer              :: i 

      if ( size(narray) .ne. size(marray) ) then
         call MessageNotify('E','l_nm_array11',&
              'dimensions of input arrays  n and m are different.')
      endif

      do i=1, size(narray)
         l_nm_array11(i) = l_nm_array00(narray(i),marray(i))
      enddo
    end function l_nm_array11

    function nm_l_int(l)
      ! 
      ! スペクトルデータの格納位置(l)から全波数(n)と東西波数(m)を返す.
      !
      ! 引数 l が整数値の場合, 対応する全波数と帯状波数を
      ! 長さ 2 の 1 次元整数値を返す. 
      ! nm_l(1) が全波数, nm_l(2) が帯状波数である. 
      !
      integer               :: nm_l_int(2)  !(out) 全波数, 帯状波数
      integer, intent(in)   :: l            !(in) スペクトルデータの格納位置
      
      if ( .not. w_base_initialize ) then
         call MessageNotify('E','nm_l_int',&
              'w_base_mpi_module_supack not initialize yet. Use sul2nm routine in ISPACK2 directly.')
      else
         call sul2nm(mm,nn,l,nm_l_int(1),nm_l_int(2))
      endif

    end function nm_l_int

    function nm_l_array(larray)
      ! 
      ! スペクトルデータの格納位置(l)から全波数(n)と東西波数(m)を返す.
      !
      ! 引数 larray が整数 1 次元配列の場合, 
      ! larray に対応する n, m を格納した 2 次元整数配列を返す. 
      ! nm_l_array(:,1) が全波数, nm_l_array(:,2) が帯状波数である. 
      !
      integer, intent(in)  :: larray(:)
      !(out) 全波数, 帯状波数

      integer              :: nm_l_array(size(larray),2)
      !(in) スペクトルデータの格納位置

      integer              :: i

      do i=1, size(larray)
         nm_l_array(i,:) = nm_l_int(larray(i))
      enddo
    end function nm_l_array

    !--------------- 基本変換(格子点分散配置) -----------------

    function xv_w(w_data,ipow,iflag)
      !
      ! スペクトルデータから格子データへ変換する(1 層用).
      !
      real(8)               :: xv_w(0:im-1,1:jl)
      !(out) 格子点データ

      real(8), intent(in)   :: w_data(nc)

      !(in) スペクトルデータ

      integer, intent(in), optional  :: ipow      
      !(in) 作用させる 1/cosφ の次数. 省略時は 0. 

      integer, intent(in), optional  :: iflag
      !(in) 変換の種類
      !    0 : 通常の正変換
      !   -1 : 経度微分を作用させた逆変換
      !    1 : 緯度微分 cosφ・∂/∂φ を作用させた逆変換
      !    2 : sinφを作用させた逆変換
      !    省略時は 0.
      !
      integer, parameter  :: ipow_default  = 0
      integer, parameter  :: iflag_default = 0

      integer ipval, ifval

      real(8)             :: w_Xdata((mm/np+1)*(2*(nn+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2X 出力用)
      real(8)             :: w_Ydata((mm/np+1)*(2*(nm+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2Y 出力用)

      real(8)  :: ws((nm+1)*2,mm/np+1)           ! 変換用作業配列

      if ( .not. w_base_initialize ) then
         call MessageNotify('E','xv_w',&
              'w_base_mpi_module_supack not initialize yet.')
      endif

      if (present(ipow)) then
         ipval = ipow
      else
         ipval = ipow_default
      endif

      if (present(iflag)) then
         ifval = iflag
      else
         ifval = iflag_default
      endif

      if ( ifval==0 ) then
         call suts2g(mm,nm,nn,im,jm,jv,w_data,xv_pdata,it,t,p,r,jc,ws,w,ipval)
         xv_w = xv_pdata
      else if( ifval==-1 ) then
         call sucs2x(mm,w_data,w_Xdata)
         call suts2g(mm,nm,nn,im,jm,jv,w_Xdata,xv_pdata,it,t,p,r,jc,ws,w,ipval)
         xv_w = xv_pdata
      else if( ifval==1 ) then
         call sucs2y(mm,w_data,w_Ydata,c)
         call suts2g(mm,nm,nm,im,jm,jv,w_Ydata,xv_pdata,it,t,p,r,jc,ws,w,ipval)
         xv_w = xv_pdata
      else if( ifval==2 ) then
         call suts2g(mm,nm,nn,im,jm,jv,w_data,xv_pdata,it,t,p,r,jc,ws,w,ipval)
         xv_w = xv_pdata * sin(xv_Lat)
      else
         call MessageNotify('E','xv_w','invalid value of iflag')
      endif

    end function xv_w

    function w_xv(xv_data,ipow,iflag)
      !
      ! 格子データからスペクトルデータへ(正)変換する(1 層用).
      !
      real(8)               :: w_xv(nc)
      !(out) スペクトルデータ

      real(8), intent(in)   :: xv_data(0:im-1,1:jl)
      !(in) 格子点データ

      integer, intent(in), optional  :: ipow
      !(in) 変換時に同時に作用させる 1/cosφ の次数. 省略時は 0.

      integer, intent(in), optional  :: iflag
      ! 変換の種類
      !    0 : 通常の正変換
      !   -1 : 経度微分を作用させた正変換 
      !    1 : 緯度微分 1/cosφ・∂(f cos^2φ)/∂φ を作用させた正変換
      !    2 : sinφを作用させた正変換
      !  省略時は 0.


      integer, parameter  :: ipow_default  = 0    ! スイッチデフォルト値
      integer, parameter  :: iflag_default = 0    ! スイッチデフォルト値

      integer ipval, ifval

      real(8)             :: w_Xdata((mm/np+1)*(2*(nn+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2X 出力用)
      real(8)             :: w_Ydata((mm/np+1)*(2*(nm+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2Y 出力用)

      real(8)  :: ws((nm+1)*2,mm/np+1)            ! 変換用作業配列
      
      if ( .not. w_base_initialize ) then
         call MessageNotify('E','xv_w',&
              'w_base_mpi_module_supack not initialize yet.')
      endif

      if (present(ipow)) then
         ipval = ipow
      else
         ipval = ipow_default
      endif

      if (present(iflag)) then
         ifval = iflag
      else
         ifval = iflag_default
      endif
      
      if ( ifval == 0 ) then
         xv_pdata = xv_data
         call sutg2s(mm,nm,nn,im,jm,jv,w_xv,xv_pdata,it,t,p,r,jc,ws,w,ipval)
      else if ( ifval == -1 ) then
         xv_pdata = xv_data
         call sutg2s(mm,nm,nn,im,jm,jv,w_Xdata,xv_pdata,it,t,p,r,jc,ws,w,ipval)
         call sucs2x(mm,w_Xdata,w_xv)
      else if ( ifval == 1 ) then
         xv_pdata = xv_data
         call sutg2s(mm,nm,nm,im,jm,jv,w_Ydata,xv_pdata,it,t,p,r,jc,ws,w,ipval)
         call sucy2s(mm,w_Ydata,w_xv,c)
      else if ( ifval == 2 ) then
         xv_pdata = xv_data*sin(xv_Lat)
         call sutg2s(mm,nm,nn,im,jm,jv,w_xv,xv_pdata,it,t,p,r,jc,ws,w,ipval)
      end if

    end function w_xv

  !----------- 速度, 渦度・発散, 流線・ポテンシャル計算 -------------

    subroutine w_StreamPotential2VectorMPI(w_Psi, w_Chi, xv_U, xv_V)
      !
      ! 流線・ポテンシャル(スペクトルデータ)から速度場(格子データ)に
      ! (逆)変換する(1 層用, MPI)
      !
      ! スペクトル変換を用いず微分を計算するために, 変換回数が 2 回ですむ. 
      !
      !   u cosφ =      ∂χ/∂λ - cosφ∂ψ/∂φ, 
      !   v cosφ = cosφ∂χ/∂φ +      ∂ψ/∂λ 
      !
      real(8), intent(in)   :: w_Psi(nc)
      !(in) 流線関数
      real(8), intent(in)   :: w_Chi(nc)
      !(in) 速度ポテンシャル

      real(8), intent(out)   :: xv_U(0:im-1,1:jl)
      !(out) 速度経度成分
      real(8), intent(out)   :: xv_V(0:im-1,1:jl)
      !(out) 速度緯度成分

      real(8)  :: ws((nm+1)*2,mm/np+1)            ! 変換用作業配列

      real(8)             :: w_Rdata((mm/np+1)*(2*(nm+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUTS2G 出力用)
      real(8)             :: w_Xdata((mm/np+1)*(2*(nn+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2X 出力用)
      real(8)             :: w_Ydata((mm/np+1)*(2*(nm+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2Y 出力用)

      
      if ( .not. w_base_initialize ) then
         call MessageNotify('E','w_StreamPotential2VectorMPI',&
              'w_base_module not initialize yet.')
      endif
      !
      !   u cosφ = ∂χ/∂λ - cosφ∂ψ/∂φ の計算
      !
      call sucs2x(mm,w_Chi,w_Xdata)
      call sucs2y(mm,w_Psi,w_Ydata,c)
      call sucrup(mm,nm,w_Xdata,w_Rdata)
      w_Rdata = w_Rdata - w_Ydata
      !
      !   u の計算
      !
      call suts2g(mm,nm,nm,im,jm,jv,w_Rdata,xv_pdata,it,t,p,r,jc,ws,w,1)
      xv_U = xv_pdata
      !
      !   v cosφ = cosφ∂χ/∂φ + ∂ψ/∂λ の計算
      !
      call sucs2y(mm,w_Chi,w_Ydata,c)
      call sucs2x(mm,w_Psi,w_Xdata)
      call sucrup(mm,nm,w_Xdata,w_Rdata)
      w_Rdata= w_Rdata + w_Ydata
      !
      !   v の計算
      !
      call suts2g(mm,nm,nm,im,jm,jv,w_Rdata,xv_pdata,it,t,p,r,jc,ws,w,1)
      xv_V = xv_pdata

    end subroutine w_StreamPotential2VectorMPI

    subroutine w_Vector2VorDivMPI(xv_U, xv_V, w_Vor, w_Div)
      !
      ! 速度場(格子データ)から渦度・発散(スペクトルデータ)に
      ! (正)変換する(1 層用, MPI)
      ! 
      ! スペクトル変換を用いず微分を計算するために, 変換回数が 2 回ですむ. 
      !
      !   ζ = 1/cosφ∂v/∂λ - 1/cosφ ∂(u cosφ)/∂φ 
      !    D = 1/cosφ∂u/∂λ + 1/cosφ ∂(v cosφ)/∂φ
      !
      real(8), intent(in)   :: xv_U(0:im-1,1:jl)
      !(in) 速度経度成分
      real(8), intent(in)   :: xv_V(0:im-1,1:jl)
      !(in) 速度緯度成分

      real(8), intent(out)   :: w_Vor(nc)
      !(out) 流線関数
      real(8), intent(out)   :: w_Div(nc)
      !(out) 速度ポテンシャル

      real(8)  :: ws((nm+1)*2,mm/np+1)            ! 変換用作業配列

      real(8)             :: w_Xdata((mm/np+1)*(2*(nn+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2X 出力用)
      real(8)             :: w_Ydata((mm/np+1)*(2*(nm+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2Y 出力用)

      real(8)  :: w_Data1((mm/np+1)*(2*(nn+1)-mm/np*np))
      real(8)  :: w_Data2((mm/np+1)*(2*(nn+1)-mm/np*np))

      if ( .not. w_base_initialize ) then
         call MessageNotify('E','w_Vector2VorDivMPI',&
              'w_base_module not initialize yet.')
      endif
      !
      ! 1/cosφ∂u/∂λ, 1/cosφ ∂(u cosφ)/∂φ の計算
      !
      xv_pdata = xv_U
      call sutg2s(mm,nm,nm,im,jm,jv,w_Ydata,xv_pdata,it,t,p,r,jc,ws,w,1)
      call sucrdn(mm,nm,w_Ydata,w_Xdata)
      call sucs2x(mm,w_Xdata,w_Div)
      call sucy2s(mm,w_Ydata,w_Data1,c)
      !
      ! 1/cosφ∂v/∂λ, 1/cosφ ∂(v cosφ)/∂φ の計算
      !
      xv_pdata = xv_V
      call sutg2s(mm,nm,nm,im,jm,jv,w_Ydata,xv_pdata,it,t,p,r,jc,ws,w,1)
      call sucrdn(mm,nm,w_Ydata,w_Xdata)
      call sucs2x(mm,w_Xdata,w_Vor)
      call sucy2s(mm,w_Ydata,w_Data2,c)
      !
      !  渦度・発散の計算
      !
      !   ζ = 1/cosφ∂v/∂λ - 1/cosφ ∂(u cosφ)/∂φ 
      !    D = 1/cosφ∂u/∂λ + 1/cosφ ∂(v cosφ)/∂φ
      !
      w_Vor = w_Vor - w_Data1
      w_Div = w_Div + w_Data2

    end subroutine w_Vector2VorDivMPI

    subroutine w_VectorCosLat2VorDivMPI(xv_UCosLat, xv_VCosLat, w_Vor, w_Div)
      !
      ! 速度場(格子データ)から渦度・発散(スペクトルデータ)に
      ! (正)変換する(1 層用, MPI)
      ! 
      ! スペクトル変換を用いず微分を計算するために, 変換回数が 2 回ですむ. 
      !
      !   ζ = 1/cosφ∂v/∂λ - 1/cosφ ∂(u cosφ)/∂φ 
      !    D = 1/cosφ∂u/∂λ + 1/cosφ ∂(v cosφ)/∂φ
      !
      real(8), intent(in)   :: xv_UCosLat(0:im-1,1:jl)
      !(in) 速度経度成分 * cos(lat)
      real(8), intent(in)   :: xv_VCosLat(0:im-1,1:jl)
      !(in) 速度緯度成分 * cos(lat)

      real(8), intent(out)   :: w_Vor(nc)
      !(out) 流線関数
      real(8), intent(out)   :: w_Div(nc)
      !(out) 速度ポテンシャル

      real(8)  :: ws((nm+1)*2,mm/np+1)            ! 変換用作業配列

      real(8)             :: w_Xdata((mm/np+1)*(2*(mm+1)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2X 出力用)
      real(8)             :: w_Ydata((mm/np+1)*(2*(mm+2)-mm/np*np))
      ! 作業用スペクトルデータ(SUCS2Y 出力用)

      real(8)  :: w_Data1((mm/np+1)*(2*(mm+1)-mm/np*np))
      real(8)  :: w_Data2((mm/np+1)*(2*(mm+1)-mm/np*np))

      if ( .not. w_base_initialize ) then
         call MessageNotify('E','w_VectorCosLat2VorDivMPI',&
              'w_base_module not initialize yet.')
      endif
      !
      ! 1/cosφ∂u/∂λ, 1/cosφ ∂(u cosφ)/∂φ の計算
      !
      xv_pdata = xv_UCosLat
      call sutg2s(mm,nm,nm,im,jm,jv,w_Ydata,xv_pdata,it,t,p,r,jc,ws,w,2)
      call sucrdn(mm,nm,w_Ydata,w_Xdata)
      call sucs2x(mm,w_Xdata,w_Div)
      call sucy2s(mm,w_Ydata,w_Data1,c)
      !
      ! 1/cosφ∂v/∂λ, 1/cosφ ∂(v cosφ)/∂φ の計算
      !
      xv_pdata = xv_VCosLat
      call sutg2s(mm,nm,nm,im,jm,jv,w_Ydata,xv_pdata,it,t,p,r,jc,ws,w,2)
      call sucrdn(mm,nm,w_Ydata,w_Xdata)
      call sucs2x(mm,w_Xdata,w_Vor)
      call sucy2s(mm,w_Ydata,w_Data2,c)
      !
      !  渦度・発散の計算
      !
      !   ζ = 1/cosφ∂v/∂λ - 1/cosφ ∂(u cosφ)/∂φ 
      !    D = 1/cosφ∂u/∂λ + 1/cosφ ∂(v cosφ)/∂φ
      !
      w_Vor = w_Vor - w_Data1
      w_Div = w_Div + w_Data2

    end subroutine w_VectorCosLat2VorDivMPI

  !--------------- 終了処理 -----------------
    subroutine w_base_mpi_Finalize
      !
      ! モジュールの終了処理(割り付け配列の解放)をおこなう. 
      !
      ! 実際の使用には上位サブルーチン w_Finalize を用いること.
      !
      if ( .not. w_base_initialize ) then
         call MessageNotify('W','w_base_mpi_Finalize',&
              'w_base_mpi_module_supack not initialized yet')
         return
      endif

      deallocate(it)                 ! 変換用配列
      deallocate(t)                  ! 変換用配列
      deallocate(p)                  ! 変換用配列
      deallocate(r)                  ! 変換用配列
      deallocate(jc)                 ! 変換用作業配列

      deallocate(wp)                 ! 変換用作業配列

      deallocate(c)                  ! 変換用作業配列

      nullify(w)                     ! 変換用作業配列
      nullify(xv_pdata)              ! 変換用作業配列
      call mlfree(pg)                ! 変換用作業配列
      call mlfree(pw)                ! 変換用作業配列

      deallocate(x_Lon)              ! 格子点座標格納配列(経度)
      deallocate(x_Lon_Weight)
      deallocate(xv_Lon)
      deallocate(v_Lat)
      deallocate(v_Lat_Weight)       ! 格子点座標格納配列
      deallocate(xv_Lat)             ! 格子点座標格納配列

      w_base_initialize = .false.

      call MessageNotify('M','w_base_mpi_Finalize',&
           'w_base_mpi_module_supack (2016/03/13) for AVX/FMA is finalized')

    end subroutine w_base_mpi_Finalize

end module w_base_mpi_module_supack
