!###################################################################################
!#
!# CubeZ
!#
!# Copyright (C) 2018-2020 Research Institute for Information Technology(RIIT), Kyushu University.
!# All rights reserved.
!#
!###################################################################################

!> ********************************************************************
!! @brief point SOR法
!! @param [in,out] p    圧力
!! @param [in]     sz   配列長
!! @param [in]     idx  インデクス範囲
!! @param [in]     g    ガイドセル長
!! @param [in]     X,Y,Z  座標
!! @param [in]     omg  加速係数
!! @param [in]     b    RHS vector
!! @param [out]    res  residual
!! @param [in,out] flop flop count
!<
subroutine psor_maf (p, sz, idx, g, X, Y, Z, omg, b, res, flop)
implicit none
integer                                                ::  i, j, k, g
integer                                                ::  ist, jst, kst
integer                                                ::  ied, jed, ked
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
double precision                                       ::  res
double precision                                       ::  flop
real                                                   ::  omg, dd, dp, pp, bb, pn, rp
real                                                   ::  GX, EY, TZ, YJA, YJAI
real                                                   ::  XG, YE, ZT, XGG, YEE, ZTT
real                                                   ::  C1, C2, C3, C7, C8, C9, res1
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  p, b
real, dimension(-1:sz(1)+2)                            ::  X
real, dimension(-1:sz(2)+2)                            ::  Y
real, dimension(-1:sz(3)+2)                            ::  Z

res1 = 0.0

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

flop = flop + 66.0d0      &
* dble(ied-ist+1) &
* dble(jed-jst+1) &
* dble(ked-kst+1)

!$OMP PARALLEL DO Collapse(2) &
!$OMP REDUCTION(+:res1) &
!$OMP PRIVATE(rp, pp, bb, dd, dp, pn) &
!$OMP PRIVATE(XG, YE, ZT, XGG, YEE, ZTT) &
!$OMP PRIVATE(GX, EY, TZ, YJA, YJAI) &
!$OMP PRIVATE(C1, C2, C3, C7, C8, C9)
do j = jst, jed
do i = ist, ied
do k = kst, ked
bb = b(k,i,j)
pp = p(k,i,j)

XG = 0.5 * (X(i+1) - X(i-1))
YE = 0.5 * (Y(j+1) - Y(j-1))
ZT = 0.5 * (Z(k+1) - Z(k-1)) ! 6

XGG= X(i+1) - 2.0*X(i) + X(i-1)
YEE= Y(j+1) - 2.0*Y(j) + Y(j-1)
ZTT= Z(k+1) - 2.0*Z(k) + Z(k-1) ! 9

! Jacobian
YJA  = XG * YE * ZT
YJAI = 1.0 / YJA    ! 3

! 1st order
GX =  YE * ZT * YJAI
EY =  XG * ZT * YJAI
TZ =  XG * YE * YJAI ! 6

! Laplacian
C1 =  GX * GX
C2 =  EY * EY
C3 =  TZ * TZ
C7 = -XGG * C1 * GX
C8 = -YEE * C2 * EY
C9 = -ZTT * C3 * TZ ! 9

dd = 2.0 * (C1 + C2 + C3)
rp = (C1 + 0.5 * C7) * P(k  , i+1, j  ) &
   + (C1 - 0.5 * C7) * P(k  , i-1, j  ) &
   + (C2 + 0.5 * C8) * P(k  , i  , j+1) &
   + (C2 - 0.5 * C8) * P(k  , i  , j-1) &
   + (C3 + 0.5 * C9) * P(k+1, i  , j  ) &
   + (C3 - 0.5 * C9) * P(k-1, i  , j  ) &
   + bb
dp = ( rp / dd - pp ) * omg
pn = pp + dp
P(k,i,j) = pn
res1 = res1 + dp * dp ! 30
enddo
enddo
enddo
!$OMP END PARALLEL DO

res = res + real(res1, kind=8)

return
end subroutine psor_maf

!> **********************************************************************
!! @brief 緩和Jacobi法
!! @param [in,out] p    圧力
!! @param [in]     sz   配列長
!! @param [in]     idx         インデクス範囲
!! @param [in]     g    ガイドセル長
!! @param [in]     X,Y,Z  座標
!! @param [in]     omg  加速係数
!! @param [in]     b    RHS vector
!! @param [in,out] res  residual
!! @param [out]    wk2  ワーク用配列
!! @param [in]     tmp  ワーク
!! @param [in,out] flop flop count
!<
subroutine jacobi_maf (p, sz, idx, g, X, Y, Z, omg, b, res, wk2, tmp, flop)
implicit none
integer                                                ::  i, j, k, g
integer                                                ::  ist, jst, kst
integer                                                ::  ied, jed, ked
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
double precision                                       ::  res
double precision                                       ::  flop
real                                                   ::  omg, dd, dp, pp, bb, pn, rp
real                                                   ::  GX, EY, TZ, YJA, YJAI
real                                                   ::  XG, YE, ZT, XGG, YEE, ZTT
real                                                   ::  C1, C2, C3, C7, C8, C9, res1
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  p, b, wk2
real, dimension(-1:sz(1)+2)                            ::  X
real, dimension(-1:sz(2)+2)                            ::  Y
real, dimension(-1:sz(3)+2)                            ::  Z, tmp

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

res1 = 0.0

#ifdef _SVR
tmp = 0.0
#endif

flop = flop + 66.0d0  &
* dble(ied-ist+1) &
* dble(jed-jst+1) &
* dble(ked-kst+1)

#ifdef _OPENACC
!$acc kernels
!$acc loop collapse(3) reduction(+:res1)
#else
!$OMP PARALLEL &
#ifdef _SVR
!$OMP REDUCTION(+:tmp) &
#else
!$OMP REDUCTION(+:res1) &
#endif
!$OMP PRIVATE(rp, pp, bb, dd, dp, pn) &
!$OMP PRIVATE(XG, YE, ZT, XGG, YEE, ZTT) &
!$OMP PRIVATE(GX, EY, TZ, YJA, YJAI) &
!$OMP PRIVATE(C1, C2, C3, C7, C8, C9)
#ifdef __NEC__
!$OMP DO SCHEDULE(static)
#else
!$OMP DO SCHEDULE(static) COLLAPSE(2)
#endif
#endif
do j = jst, jed
do i = ist, ied
do k = kst, ked
bb = b(k,i,j)
pp = p(k,i,j)

XG = 0.5 * (X(i+1) - X(i-1))
YE = 0.5 * (Y(j+1) - Y(j-1))
ZT = 0.5 * (Z(k+1) - Z(k-1)) ! 6

XGG= X(i+1) - 2.0*X(i) + X(i-1)
YEE= Y(j+1) - 2.0*Y(j) + Y(j-1)
ZTT= Z(k+1) - 2.0*Z(k) + Z(k-1) ! 9

! Jacobian
YJA  = XG * YE * ZT
YJAI = 1.0 / YJA    ! 3

! 1st order
GX =  YE * ZT * YJAI
EY =  XG * ZT * YJAI
TZ =  XG * YE * YJAI ! 6

! Laplacian
C1 =  GX * GX
C2 =  EY * EY
C3 =  TZ * TZ
C7 = -XGG * C1 * GX
C8 = -YEE * C2 * EY
C9 = -ZTT * C3 * TZ ! 9

dd = 2.0 * (C1 + C2 + C3)
rp = (C1 + 0.5 * C7) * P(k  , i+1, j  ) &
   + (C1 - 0.5 * C7) * P(k  , i-1, j  ) &
   + (C2 + 0.5 * C8) * P(k  , i  , j+1) &
   + (C2 - 0.5 * C8) * P(k  , i  , j-1) &
   + (C3 + 0.5 * C9) * P(k+1, i  , j  ) &
   + (C3 - 0.5 * C9) * P(k-1, i  , j  ) &
   + bb
dp = ( rp / dd - pp ) * omg
pn = pp + dp
wk2(k,i,j) = pn

#ifdef _SVR
tmp(k) = tmp(k) + dp * dp ! 30
#else
res1 = res1 + dp * dp ! 30
#endif

enddo
enddo
enddo
#ifdef _OPENACC
!$acc end kernels
#else
!$OMP END DO NOWAIT
#endif

#ifdef _OPENACC
!$acc kernels
!$acc loop collapse(3)
#else
#ifdef __NEC__
!$OMP DO SCHEDULE(static)
#else
!$OMP DO SCHEDULE(static) COLLAPSE(2)
#endif
#endif
do j = jst, jed
do i = ist, ied
do k = kst, ked
p(k,i,j)=wk2(k,i,j)
end do
end do
end do
#ifdef _OPENACC
!$acc end kernels
#else
!$OMP END DO
!$OMP END PARALLEL
#endif

#ifdef _SVR
do k = kst, ked
  res1 = res1 + tmp(k)
end do
#endif

res = res + real(res1, kind=8)

return
end subroutine jacobi_maf

!> ********************************************************************
!! @brief 2-colored SOR法 stride memory access
!! @param [in,out] p     圧力
!! @param [in]     sz    配列長
!! @param [in]     idx   インデクス範囲
!! @param [in]     g     ガイドセル長
!! @param [in]     X,Y,Z  座標
!! @param [in]     ofst  開始点オフセット
!! @param [in]     color グループ番号
!! @param [in]     omg   加速係数
!! @param [in]     b     RHS vector
!! @param [out]    res  residual
!! @param [in]     tmp  ワーク
!! @param [in,out] flop  浮動小数演算数
!! @note resは積算
!<
subroutine psor2sma_core_maf (p, sz, idx, g, X, Y, Z, ofst, color, omg, b, res, tmp, flop)
implicit none
integer                                                ::  i, j, k, g
integer                                                ::  ist, jst, kst
integer                                                ::  ied, jed, ked
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
double precision                                       ::  flop
double precision                                       ::  res
real                                                   ::  omg, dd, dp, pp, bb, pn, rp
real                                                   ::  GX, EY, TZ, YJA, YJAI
real                                                   ::  XG, YE, ZT, XGG, YEE, ZTT
real                                                   ::  C1, C2, C3, C7, C8, C9, res1
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  p, b
integer                                                ::  kp, color, ofst
real, dimension(-1:sz(1)+2)                            ::  X
real, dimension(-1:sz(2)+2)                            ::  Y
real, dimension(-1:sz(3)+2)                            ::  Z, tmp

kp = ofst+color
res1 = 0.0

#ifdef _SVR
tmp = 0.0
#endif

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

flop = flop + 66.0d0*0.5d0  &
* dble(ied-ist+1) &
* dble(jed-jst+1) &
* dble(ked-kst+1)

#ifdef _OPENACC
!$acc kernels
!$acc loop independent gang reduction(+:res1)
do j=jst,jed
!$acc loop independent gang reduction(+:res1)
do i=ist,ied
!$acc loop independent vector(128) reduction(+:res1)
do k=kst+mod(i+j+kp,2), ked, 2
#else
#ifdef __NEC__
!$OMP PARALLEL DO SCHEDULE(static) COLLAPSE(2) & ! ここはcollapseを入れた方がよい
#else
!$OMP PARALLEL DO SCHEDULE(static) COLLAPSE(2) &
#endif
#ifdef _SVR
!$OMP REDUCTION(+:tmp) &
#else
!$OMP REDUCTION(+:res1) &
#endif
!$OMP PRIVATE(rp, pp, bb, dd, dp, pn) &
!$OMP PRIVATE(XG, YE, ZT, XGG, YEE, ZTT) &
!$OMP PRIVATE(GX, EY, TZ, YJA, YJAI) &
!$OMP PRIVATE(C1, C2, C3, C7, C8, C9)
do j=jst,jed
!pgi$ novector
do i=ist,ied
!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
!pgi$ vector
do k=kst+mod(i+j+kp,2), ked, 2
#endif

pp = p(k,i,j)
bb = b(k,i,j)

XG = 0.5 * (X(i+1) - X(i-1))
YE = 0.5 * (Y(j+1) - Y(j-1))
ZT = 0.5 * (Z(k+1) - Z(k-1)) ! 6

XGG= X(i+1) - 2.0*X(i) + X(i-1)
YEE= Y(j+1) - 2.0*Y(j) + Y(j-1)
ZTT= Z(k+1) - 2.0*Z(k) + Z(k-1) ! 9

! Jacobian
YJA  = XG * YE * ZT
YJAI = 1.0 / YJA    ! 3

! 1st order
GX =  YE * ZT * YJAI
EY =  XG * ZT * YJAI
TZ =  XG * YE * YJAI ! 6

! Laplacian
C1 =  GX * GX
C2 =  EY * EY
C3 =  TZ * TZ
C7 = -XGG * C1 * GX
C8 = -YEE * C2 * EY
C9 = -ZTT * C3 * TZ ! 9

dd = 2.0 * (C1 + C2 + C3)
rp = (C1 + 0.5 * C7) * P(k  , i+1, j  ) &
   + (C1 - 0.5 * C7) * P(k  , i-1, j  ) &
   + (C2 + 0.5 * C8) * P(k  , i  , j+1) &
   + (C2 - 0.5 * C8) * P(k  , i  , j-1) &
   + (C3 + 0.5 * C9) * P(k+1, i  , j  ) &
   + (C3 - 0.5 * C9) * P(k-1, i  , j  ) &
   + bb

dp = ( rp / dd - pp ) * omg
pn = pp + dp
P(k,i,j) = pn

#ifdef _SVR
tmp(k) = tmp(k) + dp * dp ! 30
#else
res1 = res1 + dp * dp ! 30
#endif

end do
end do
end do
#ifdef _OPENACC
!$acc end kernels
#endif
!$OMP END PARALLEL DO

#ifdef _SVR
do k = kst, ked
res1 = res1 + tmp(k)
end do
#endif

res = res + real(res1, kind=8)

return
end subroutine psor2sma_core_maf

!********************************************************************************
subroutine pcr_rb_maf (sz, idx, g, pn, ofst, color, x, msk, rhs, XX, YY, ZZ, &
                       a, c, d, aw, cw, dw, omg, res, tmp, flop)
implicit none
!args
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
integer                                                ::  g, pn
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real                                                   ::  omg
double precision                                       ::  res, flop
! work
integer                                  ::  i, j, k, kl, kr, s, p, color, ip, ofst
integer                                  ::  ist, ied, jst, jed, kst, ked
real, dimension(-1:sz(3)+2)              ::  a, c, d, aw, cw, dw
real                                     ::  ap, cp, e, pp, dp, res1
real                                     ::  jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3
real                                                   ::  C1, C2, C7, C8, GX, EY, TZ, ZTT
real, dimension(-1:sz(1)+2)                            ::  XX
real, dimension(-1:sz(2)+2)                            ::  YY
real, dimension(-1:sz(3)+2)                            ::  ZZ, tmp

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

flop = flop + dble(           &
  (jed-jst+1)*(ied-ist+1)* (  &
    ( 24.0d0                  & ! metrics
     + 3.0 * 2.0 + 12.0       & ! coef BC
    )                         &
   + (ked-kst+1)* (11.0+10.0) & ! coef + Source
   + (ked-kst-1)* 6.0d0       & ! coef
   + (ked-kst+1)*(pn-1)*16.0  & ! PCR
   + 2**(pn-1) * 11.0           & ! 2x2
   + (ked-kst+1)*6.0          & ! Relaxation
   )                          &
 ) * 0.5

ip = ofst + color
res1 = 0.0

#ifdef _SVR
tmp = 0.0
#endif

#ifdef _OPENACC
!$acc kernels
!$acc loop independent collapse(2) gang reduction(+:res1) &
!$acc& private(a, c, d, aw, cw, dw) &
!$acc& private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$acc& private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$acc& private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
#else
!$OMP PARALLEL &
#ifdef _SVR
!$OMP REDUCTION(+:tmp) &
#else
!$OMP REDUCTION(+:res1) &
#endif
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP private(a, c, d, aw, cw, dw) &
!$OMP private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
!$OMP DO SCHEDULE(static) collapse(2)
#endif
do j=jst, jed
do i=ist, ied
if(mod(i+j,2) /= color) cycle

! do i=ist+mod(j+ip,2), ied, 2

GX =  2.0 / (XX(i+1) - XX(i-1))
EY =  2.0 / (YY(j+1) - YY(j-1))
C1 =  GX * GX
C2 =  EY * EY
C7 = -(XX(i+1) - 2.0*XX(i) + XX(i-1)) * C1 * GX
C8 = -(YY(j+1) - 2.0*YY(j) + YY(j-1)) * C2 * EY
dd1= C1 + 0.5 * C7 ! R1
dd2= C1 - 0.5 * C7 ! R2
cc1= C2 + 0.5 * C8 ! R3
cc2= C2 - 0.5 * C8 ! R4      >>  24 flops

! Reflesh coef. due to override
do k=kst, ked
  f1 = ZZ(k+1)
  f2 = ZZ(k-1)
  TZ = 2.0 / (f1 - f2)
  ZTT= f1 - 2.0*ZZ(k) + f2
  f3 = TZ * TZ
  aw(k) = f3              ! C3
  cw(k) = -ZTT * f3 * TZ  ! C9
  dw(k) = 0.5 / (C1 + C2 + f3) ! 1/R7
end do   ! >>  11 flops

a(kst) = 0.0
c(kst) = -(aw(kst) + 0.5 * cw(kst)) * dw(kst) ! -R5/R7 = -(C3+0.5*C9) / R7      >> 3 flops

do k=kst+1, ked-1
  f1 = aw(k)  ! C3
  f2 = cw(k)  ! C9
  aa3 = dw(k)
  a(k) = -(f1 - 0.5 * f2) * aa3
  c(k) = -(f1 + 0.5 * f2) * aa3
end do    !  >> 6 flops

a(ked) = -(aw(ked) - 0.5 * cw(ked)) * dw(ked) ! -R6/R7 = -(C3-0.5*C9) / R7     >> 3 flops
c(ked) = 0.0

! Source
do k = kst, ked
  d(k) = (                         &
            dd1 * x(k, i+1, j  )   &
          + dd2 * x(k, i-1, j  )   &
          + cc1 * x(k, i  , j+1)   &
          + cc2 * x(k, i  , j-1)   &
          - rhs(k, i, j)           &
        ) * dw(k) * msk(k, i, j)
end do   !  >>  10 flops
! ここまで、dd1, dd2, cc1, cc2は再利用しない
! a, c, dを計算したので、aw, cw, dwは再利用可能

! BC   >>  12 flops
d(kst) = ( d(kst) + (aw(kst) - 0.5 * cw(kst)) * dw(kst) * x(kst-1, i, j) ) * msk(kst, i, j)
d(ked) = ( d(ked) + (aw(ked) + 0.5 * cw(ked)) * dw(ked) * x(ked+1, i, j) ) * msk(ked, i, j)

! PCR  最終段の一つ手前で停止
!$acc loop seq
do p=1, pn-1
s = 2**(p-1)

!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
do k = kst, ked
  kl = max(k-s, kst-1)
  kr = min(k+s, ked+1)
  ap = a(k)
  cp = c(k)
  e = 1.0 / ( 1.0 - ap * c(kl) - cp * a(kr) )
  aw(k) =  -e * ap * a(kl)
  cw(k) =  -e * cp * c(kr)
  dw(k) =   e * ( d(k) - ap * d(kl) - cp * d(kr) )
end do   !  >> 16 flops

!dir$ vector aligned
!dir$ simd
do k = kst, ked
  a(k) = aw(k)
  c(k) = cw(k)
  d(k) = dw(k)
end do

end do ! p反復

! 最終段の反転
s = 2**(pn-1)

!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
!$acc loop independent
do k = kst, kst+s-1
  kl = max(k-s, kst-1)
  kr = min(k+s, ked+1)
  cc1 = c(k)
  aa2 = a(kr)
  f1  = d(k)
  f2  = d(kr)
  jj  = 1.0 / (1.0 - aa2 * cc1)
  dd1 = (f1 - cc1 * f2) * jj
  dd2 = (f2 - aa2 * f1) * jj
  dw(k ) = dd1
  dw(kr) = dd2
end do  ! >>  11 flops

! a_{i-1} x_{i-2} + x_{i-1} + c_{i-1} x_i     = d_{i-1}
! a_{i}   x_{i-1} + x_{i}   + c_{i}   x_{i+1} = d_{i}
! a_{i+1} x_{i}   + x_{i+1} + c_{i+1} x_{i+2} = d_{i+1}

! Relaxation
!dir$ vector aligned
!dir$ simd
!$acc loop reduction(+:res1)
do k = kst, ked
  pp =   x(k, i, j)
  dp = ( dw(k) - pp ) * omg * msk(k, i, j)
  x(k, i, j) = pp + dp

#ifdef _SVR
tmp(k) = tmp(k) + dp * dp ! 30
#else
res1 = res1 + dp * dp ! 30
#endif

end do  !  >> 6 flops

end do
end do
#ifdef _OPENACC
!$acc end kernels
#else
!$OMP END DO
!$OMP END PARALLEL
#endif

#ifdef _SVR
do k = kst, ked
res1 = res1 + tmp(k)
end do
#endif

res = res + real(res1, kind=8)

return
end subroutine pcr_rb_maf

!********************************************************************************
subroutine pcr_maf (sz, idx, g, pn, x, msk, rhs, XX, YY, ZZ, &
                    a, c, d, aw, cw, dw, omg, res, tmp, flop)
implicit none
!args
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
integer                                                ::  g, pn
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real                                                   ::  omg
double precision                                       ::  res, flop
! work
integer                                  ::  i, j, k, kl, kr, s, p
integer                                  ::  ist, ied, jst, jed, kst, ked
real, dimension(-1:sz(3)+2)              ::  a, c, d, aw, cw, dw
real                                     ::  ap, cp, e, pp, dp, res1
real                                     ::  jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3
real                                                   ::  C1, C2, C7, C8, GX, EY, TZ, ZTT
real, dimension(-1:sz(1)+2)                            ::  XX
real, dimension(-1:sz(2)+2)                            ::  YY
real, dimension(-1:sz(3)+2)                            ::  ZZ, tmp

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

res1 = 0.0

s = 2**(pn-1)

flop = flop + dble(           &
(jed-jst+1)*(ied-ist+1)* (  &
( 24.0d0                  & ! metrics
 + 3.0 * 2.0 + 12.0       & ! coef BC
)                         &
+ (ked-kst+1)* (11.0+10.0) & ! coef + Source
+ (ked-kst-1)* 6.0d0       & ! coef
+ (ked-kst+1)*(pn-1)*16.0  & ! PCR
+ s * 11.0           & ! 2x2
+ (ked-kst+1)*6.0          & ! Relaxation
)                          &
)

#ifdef _SVR
tmp = 0.0
#endif

#ifdef _OPENACC
!$acc kernels
!$acc loop independent collapse(2) reduction(+:res1) &
!$acc& private(a, c, d, aw, cw, dw) &
!$acc& private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$acc& private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$acc& private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
#else
!$OMP PARALLEL &
#ifdef _SVR
!$OMP REDUCTION(+:tmp) &
#else
!$OMP REDUCTION(+:res1) &
#endif
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP private(a, c, d, aw, cw, dw) &
!$OMP private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
!$OMP DO SCHEDULE(static) collapse(2)
#endif
do j=jst, jed
do i=ist, ied

GX =  2.0 / (XX(i+1) - XX(i-1))
EY =  2.0 / (YY(j+1) - YY(j-1))
C1 =  GX * GX
C2 =  EY * EY
C7 = -(XX(i+1) - 2.0*XX(i) + XX(i-1)) * C1 * GX
C8 = -(YY(j+1) - 2.0*YY(j) + YY(j-1)) * C2 * EY
dd1= C1 + 0.5 * C7 ! R1
dd2= C1 - 0.5 * C7 ! R2
cc1= C2 + 0.5 * C8 ! R3
cc2= C2 - 0.5 * C8 ! R4      >>  24 flops

! Reflesh coef. due to override
do k=kst, ked
f1 = ZZ(k+1)
f2 = ZZ(k-1)
TZ = 2.0 / (f1 - f2)
ZTT= f1 - 2.0*ZZ(k) + f2
f3 = TZ * TZ
aw(k) = f3              ! C3
cw(k) = -ZTT * f3 * TZ  ! C9
dw(k) = 0.5 / (C1 + C2 + f3) ! 1/R7
end do   ! >>  11 flops

a(kst) = 0.0
c(kst) = -(aw(kst) + 0.5 * cw(kst)) * dw(kst) ! -R5/R7 = -(C3+0.5*C9) / R7      >> 3 flops

do k=kst+1, ked-1
f1 = aw(k)  ! C3
f2 = cw(k)  ! C9
aa3 = dw(k)
a(k) = -(f1 - 0.5 * f2) * aa3
c(k) = -(f1 + 0.5 * f2) * aa3
end do    !  >> 6 flops

a(ked) = -(aw(ked) - 0.5 * cw(ked)) * dw(ked) ! -R6/R7 = -(C3-0.5*C9) / R7     >> 3 flops
c(ked) = 0.0

! Source
do k = kst, ked
d(k) = (                         &
dd1 * x(k, i+1, j  )   &
+ dd2 * x(k, i-1, j  )   &
+ cc1 * x(k, i  , j+1)   &
+ cc2 * x(k, i  , j-1)   &
- rhs(k, i, j)           &
) * dw(k) * msk(k, i, j)
end do   !  >>  10 flops
! ここまで、dd1, dd2, cc1, cc2は再利用しない
! a, c, dを計算したので、aw, cw, dwは再利用可能

! BC   >>  12 flops
d(kst) = ( d(kst) + (aw(kst) - 0.5 * cw(kst)) * dw(kst) * x(kst-1, i, j) ) * msk(kst, i, j)
d(ked) = ( d(ked) + (aw(ked) + 0.5 * cw(ked)) * dw(ked) * x(ked+1, i, j) ) * msk(ked, i, j)

! PCR  最終段の一つ手前で停止
!$acc loop seq
do p=1, pn-1
s = 2**(p-1)

!dir$ vector aligned
!dir$ simd
do k = kst, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
ap = a(k)
cp = c(k)
e = 1.0 / ( 1.0 - ap * c(kl) - cp * a(kr) )
aw(k) =  -e * ap * a(kl)
cw(k) =  -e * cp * c(kr)
dw(k) =   e * ( d(k) - ap * d(kl) - cp * d(kr) )
end do   !  >> 16 flops

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k) = aw(k)
c(k) = cw(k)
d(k) = dw(k)
end do

end do ! p反復

! 最終段の反転
s = 2**(pn-1)

!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
!$acc loop independent
do k = kst, kst+s-1
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = c(k)
aa2 = a(kr)
f1  = d(k)
f2  = d(kr)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
dw(k ) = dd1
dw(kr) = dd2
end do  ! >>  11 flops

! a_{i-1} x_{i-2} + x_{i-1} + c_{i-1} x_i     = d_{i-1}
! a_{i}   x_{i-1} + x_{i}   + c_{i}   x_{i+1} = d_{i}
! a_{i+1} x_{i}   + x_{i+1} + c_{i+1} x_{i+2} = d_{i+1}

! Relaxation
!dir$ vector aligned
!dir$ simd
!$acc loop reduction(+:res1)
do k = kst, ked
pp =   x(k, i, j)
dp = ( dw(k) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp

#ifdef _SVR
tmp(k) = tmp(k) + dp * dp ! 30
#else
res1 = res1 + dp * dp ! 30
#endif

end do  !  >> 6 flops

end do
end do
#ifdef _OPENACC
!$acc end kernels
#else
!$OMP END DO
!$OMP END PARALLEL
#endif

#ifdef _SVR
do k = kst, ked
res1 = res1 + tmp(k)
end do
#endif

res = res + real(res1, kind=8)

return
end subroutine pcr_maf

!********************************************************************************
subroutine pcr_eda_maf (sz, idx, g, pn, x, msk, rhs, XX, YY, ZZ, &
aw, cw, dw, omg, res, tmp, flop)
implicit none
!args
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
integer                                                ::  g, pn
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real                                                   ::  omg
double precision                                       ::  res, flop
! work
integer                                  ::  i, j, k, kl, kr, s, p
integer                                  ::  ist, ied, jst, jed, kst, ked
real, dimension(-1:sz(3)+2)              ::  aw, cw, dw
real, dimension(:), allocatable          ::  a, c, d
real                                     ::  ap, cp, e, pp, dp, res1
real                                     ::  jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3
real                                                   ::  C1, C2, C7, C8, GX, EY, TZ, ZTT
real, dimension(-1:sz(1)+2)                            ::  XX
real, dimension(-1:sz(2)+2)                            ::  YY
real, dimension(-1:sz(3)+2)                            ::  ZZ, tmp

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

res1 = 0.0

#ifdef _SVR
tmp = 0.0
#endif

s = 2**(pn-1)

flop = flop + dble(           &
(jed-jst+1)*(ied-ist+1)* (  &
( 24.0d0                  & ! metrics
 + 3.0 * 2.0 + 12.0       & ! coef BC
)                         &
+ (ked-kst+1)* (11.0+10.0) & ! coef + Source
+ (ked-kst-1)* 6.0d0       & ! coef
+ (ked-kst+1)*(pn-1)*16.0  & ! PCR
+ s * 9.0           & ! 2x2
+ (ked-kst+1)*6.0          & ! Relaxation
)                          &
)

s = 2**(pn-2)
kl = kst-s
kr = ked+s
allocate(a(kl:kr))
allocate(c(kl:kr))
allocate(d(kl:kr))
do k=kl, kr
a(k) = 0.0
c(k) = 0.0
d(k) = 0.0
end do

!$OMP PARALLEL &
#ifdef _SVR
!$OMP REDUCTION(+:tmp) &
#else
!$OMP REDUCTION(+:res1) &
#endif
!$OMP private(ap, cp, e, s, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP private(aw, cw, dw) &
!$OMP firstprivate(a, c, d) &
!$OMP private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
!$OMP DO SCHEDULE(static) Collapse(2)
do j=jst, jed
do i=ist, ied

GX =  2.0 / (XX(i+1) - XX(i-1))
EY =  2.0 / (YY(j+1) - YY(j-1))
C1 =  GX * GX
C2 =  EY * EY
C7 = -(XX(i+1) - 2.0*XX(i) + XX(i-1)) * C1 * GX
C8 = -(YY(j+1) - 2.0*YY(j) + YY(j-1)) * C2 * EY
dd1= C1 + 0.5 * C7 ! R1
dd2= C1 - 0.5 * C7 ! R2
cc1= C2 + 0.5 * C8 ! R3
cc2= C2 - 0.5 * C8 ! R4      >>  24 flops

! Reflesh coef. due to override
do k=kst, ked
f1 = ZZ(k+1)
f2 = ZZ(k-1)
TZ = 2.0 / (f1 - f2)
ZTT= f1 - 2.0*ZZ(k) + f2
f3 = TZ * TZ
aw(k) = f3              ! C3
cw(k) = -ZTT * f3 * TZ  ! C9
dw(k) = 0.5 / (C1 + C2 + f3) ! 1/R7
end do   ! >>  11 flops

a(kst) = 0.0
c(kst) = -(aw(kst) + 0.5 * cw(kst)) * dw(kst) ! -R5/R7 = -(C3+0.5*C9) / R7      >> 3 flops

do k=kst+1, ked-1
f1 = aw(k)  ! C3
f2 = cw(k)  ! C9
aa3 = dw(k)
a(k) = -(f1 - 0.5 * f2) * aa3
c(k) = -(f1 + 0.5 * f2) * aa3
end do    !  >> 6 flops

a(ked) = -(aw(ked) - 0.5 * cw(ked)) * dw(ked) ! -R6/R7 = -(C3-0.5*C9) / R7     >> 3 flops
c(ked) = 0.0

! Source
do k = kst, ked
d(k) = (                         &
dd1 * x(k, i+1, j  )   &
+ dd2 * x(k, i-1, j  )   &
+ cc1 * x(k, i  , j+1)   &
+ cc2 * x(k, i  , j-1)   &
- rhs(k, i, j)           &
) * dw(k) * msk(k, i, j)
end do   !  >>  10 flops
! ここまで、dd1, dd2, cc1, cc2は再利用しない
! a, c, dを計算したので、aw, cw, dwは再利用可能

! BC   >>  12 flops
d(kst) = ( d(kst) + (aw(kst) - 0.5 * cw(kst)) * dw(kst) * x(kst-1, i, j) ) * msk(kst, i, j)
d(ked) = ( d(ked) + (aw(ked) + 0.5 * cw(ked)) * dw(ked) * x(ked+1, i, j) ) * msk(ked, i, j)

! PCR  最終段の一つ手前で停止
do p=1, pn-1
s = 2**(p-1)

!dir$ vector aligned
!dir$ simd
!pgi$ ivdep
do k = kst, ked
ap = a(k)
cp = c(k)
e = 1.0 / ( 1.0 - ap * c(k-s) - cp * a(k+s) )
aw(k) =  -e * ap * a(k-s)
cw(k) =  -e * cp * c(k+s)
dw(k) =   e * ( d(k) - ap * d(k-s) - cp * d(k+s) )
end do   !  >> 16 flops

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k) = aw(k)
c(k) = cw(k)
d(k) = dw(k)
end do

end do ! p反復

! 最終段の反転
s = 2**(pn-1)

!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
!pgi$ ivdep
do k = kst, kst+s-1
cc1 = c(k)
aa2 = a(k+s)
f1  = d(k)
f2  = d(k+s)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
dw(k ) = dd1
dw(k+s)= dd2
end do  ! >>  9 flops

! a_{i-1} x_{i-2} + x_{i-1} + c_{i-1} x_i     = d_{i-1}
! a_{i}   x_{i-1} + x_{i}   + c_{i}   x_{i+1} = d_{i}
! a_{i+1} x_{i}   + x_{i+1} + c_{i+1} x_{i+2} = d_{i+1}

! Relaxation
!dir$ vector aligned
!dir$ simd
do k = kst, ked
pp =   x(k, i, j)
dp = ( dw(k) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp

#ifdef _SVR
tmp(k) = tmp(k) + dp * dp ! 30
#else
res1 = res1 + dp * dp ! 30
#endif

end do  !  >> 6 flops

end do
end do
!$OMP END DO
!$OMP END PARALLEL

#ifdef _SVR
do k = kst, ked
res1 = res1 + tmp(k)
end do
#endif

res = res + real(res1, kind=8)

return
end subroutine pcr_eda_maf

!********************************************************************************
subroutine pcr_esa_maf (sz, idx, g, pn, s, x, msk, rhs, XX, YY, ZZ, &
a, c, d, aw, cw, dw, omg, res, tmp, flop)
implicit none
!args
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
integer                                                ::  g, pn
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real                                                   ::  omg
double precision                                       ::  res, flop
! work
integer                                  ::  i, j, k, p, sq, s
integer                                  ::  ist, ied, jst, jed, kst, ked
real, dimension(-1:sz(3)+2)              ::  aw, cw, dw
real, dimension(idx(4)-s:idx(5)+s)       ::  a, c, d
real                                     ::  ap, cp, e, pp, dp, res1
real                                     ::  jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3
real                                                   ::  C1, C2, C7, C8, GX, EY, TZ, ZTT
real, dimension(-1:sz(1)+2)                            ::  XX
real, dimension(-1:sz(2)+2)                            ::  YY
real, dimension(-1:sz(3)+2)                            ::  ZZ, tmp

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

res1 = 0.0

#ifdef _SVR
tmp = 0.0
#endif

flop = flop + dble(           &
(jed-jst+1)*(ied-ist+1)* (  &
( 24.0d0                  & ! metrics
 + 3.0 * 2.0 + 12.0       & ! coef BC
)                         &
+ (ked-kst+1)* (11.0+10.0) & ! coef + Source
+ (ked-kst-1)* 6.0d0       & ! coef
+ (ked-kst+1)*(pn-1)*16.0  & ! PCR
+ 2**(pn-1) * 9.0           & ! 2x2
+ (ked-kst+1)*6.0          & ! Relaxation
)                          &
)

#ifdef _OPENACC
!$acc kernels
!$acc loop independent collapse(2) reduction(+:res1) &
!$acc& private(a, c, d, aw, cw, dw) &
!$acc& private(ap, cp, e, sq, p, k, pp, dp) &
!$acc& private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$acc& private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
#else
!$OMP PARALLEL &
#ifdef _SVR
!$OMP REDUCTION(+:tmp) &
#else
!$OMP REDUCTION(+:res1) &
#endif
!$OMP private(ap, cp, e, sq, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP private(C1, C2, C7, C8, GX, EY, TZ, ZTT) &
!$OMP private(aw, cw, dw) &
!$OMP firstprivate(a, c, d)
!$OMP DO SCHEDULE(static) Collapse(2)
#endif
do j=jst, jed
do i=ist, ied

GX =  2.0 / (XX(i+1) - XX(i-1))
EY =  2.0 / (YY(j+1) - YY(j-1))
C1 =  GX * GX
C2 =  EY * EY
C7 = -(XX(i+1) - 2.0*XX(i) + XX(i-1)) * C1 * GX
C8 = -(YY(j+1) - 2.0*YY(j) + YY(j-1)) * C2 * EY
dd1= C1 + 0.5 * C7 ! R1
dd2= C1 - 0.5 * C7 ! R2
cc1= C2 + 0.5 * C8 ! R3
cc2= C2 - 0.5 * C8 ! R4      >>  24 flops

! Reflesh coef. due to override
do k=kst, ked
f1 = ZZ(k+1)
f2 = ZZ(k-1)
TZ = 2.0 / (f1 - f2)
ZTT= f1 - 2.0*ZZ(k) + f2
f3 = TZ * TZ
aw(k) = f3              ! C3
cw(k) = -ZTT * f3 * TZ  ! C9
dw(k) = 0.5 / (C1 + C2 + f3) ! 1/R7
end do   ! >>  11 flops

a(kst) = 0.0
c(kst) = -(aw(kst) + 0.5 * cw(kst)) * dw(kst) ! -R5/R7 = -(C3+0.5*C9) / R7      >> 3 flops

do k=kst+1, ked-1
f1 = aw(k)  ! C3
f2 = cw(k)  ! C9
aa3 = dw(k)
a(k) = -(f1 - 0.5 * f2) * aa3
c(k) = -(f1 + 0.5 * f2) * aa3
end do    !  >> 6 flops

a(ked) = -(aw(ked) - 0.5 * cw(ked)) * dw(ked) ! -R6/R7 = -(C3-0.5*C9) / R7     >> 3 flops
c(ked) = 0.0

! Source
do k = kst, ked
d(k) = (                         &
  dd1 * x(k, i+1, j  )   &
+ dd2 * x(k, i-1, j  )   &
+ cc1 * x(k, i  , j+1)   &
+ cc2 * x(k, i  , j-1)   &
- rhs(k, i, j)           &
) * dw(k) * msk(k, i, j)
end do   !  >>  10 flops
! ここまで、dd1, dd2, cc1, cc2は再利用しない
! a, c, dを計算したので、aw, cw, dwは再利用可能

! BC   >>  12 flops
d(kst) = ( d(kst) + (aw(kst) - 0.5 * cw(kst)) * dw(kst) * x(kst-1, i, j) ) * msk(kst, i, j)
d(ked) = ( d(ked) + (aw(ked) + 0.5 * cw(ked)) * dw(ked) * x(ked+1, i, j) ) * msk(ked, i, j)

! PCR  最終段の一つ手前で停止
!$acc loop seq
do p=1, pn-1
sq = 2**(p-1)

!dir$ vector aligned
!dir$ simd
!pgi$ ivdep
do k = kst, ked
ap = a(k)
cp = c(k)
e = 1.0 / ( 1.0 - ap * c(k-sq) - cp * a(k+sq) )
aw(k) =   -e * ap * a(k-sq)
cw(k) =   -e * cp * c(k+sq)
dw(k) =   e * ( d(k) - ap * d(k-sq) - cp * d(k+sq) )
end do   !  >> 16 flops

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k) = aw(k)
c(k) = cw(k)
d(k) = dw(k)
end do

end do ! p反復

! 最終段の反転
sq = 2**(pn-1)

!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
!pgi$ ivdep
!$acc loop independent
do k = kst, kst+sq-1
cc1 = c(k)
aa2 = a(k+sq)
f1  = d(k)
f2  = d(k+sq)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
dw(k   ) = dd1
dw(k+sq) = dd2
end do  ! >>  9 flops

! a_{i-1} x_{i-2} + x_{i-1} + c_{i-1} x_i     = d_{i-1}
! a_{i}   x_{i-1} + x_{i}   + c_{i}   x_{i+1} = d_{i}
! a_{i+1} x_{i}   + x_{i+1} + c_{i+1} x_{i+2} = d_{i+1}

! Relaxation
!dir$ vector aligned
!dir$ simd
!$acc loop reduction(+:res1)
do k = kst, ked
pp =   x(k, i, j)
dp = ( dw(k) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp

#ifdef _SVR
tmp(k) = tmp(k) + dp * dp ! 30
#else
res1 = res1 + dp * dp ! 30
#endif

end do  !  >> 6 flops

end do
end do
#ifdef _OPENACC
!$acc end kernels
#else
!$OMP END DO
!$OMP END PARALLEL
#endif

#ifdef _SVR
do k = kst, ked
res1 = res1 + tmp(k)
end do
#endif

res = res + real(res1, kind=8)

return
end subroutine pcr_esa_maf

!********************************************************************************
subroutine pcr_rb_esa_maf (sz, idx, g, pn, ofst, color, s, x, msk, rhs, XX, YY, ZZ, &
a, c, d, aw, cw, dw, omg, res, tmp, flop)
implicit none
!args
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
integer                                                ::  g, pn
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real                                                   ::  omg
double precision                                       ::  res, flop
! work
integer                                  ::  i, j, k, p, color, ip, ofst, sq, s
integer                                  ::  ist, ied, jst, jed, kst, ked
real, dimension(-1:sz(3)+2)              ::  aw, cw, dw
real, dimension(idx(4)-s:idx(5)+s)       ::  a, c, d
real                                     ::  ap, cp, e, pp, dp, res1
real                                     ::  jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3
real                                                   ::  C1, C2, C7, C8, GX, EY, TZ, ZTT
real, dimension(-1:sz(1)+2)                            ::  XX
real, dimension(-1:sz(2)+2)                            ::  YY
real, dimension(-1:sz(3)+2)                            ::  ZZ, tmp

ist = idx(0)
ied = idx(1)
jst = idx(2)
jed = idx(3)
kst = idx(4)
ked = idx(5)

flop = flop + dble(           &
(jed-jst+1)*(ied-ist+1)* (  &
( 24.0d0                  & ! metrics
 + 3.0 * 2.0 + 12.0       & ! coef BC
)                         &
+ (ked-kst+1)* (11.0+10.0) & ! coef + Source
+ (ked-kst-1)* 6.0d0       & ! coef
+ (ked-kst+1)*(pn-1)*16.0  & ! PCR
+ 2**(pn-1) * 11.0           & ! 2x2
+ (ked-kst+1)*6.0          & ! Relaxation
)                          &
) * 0.5

ip = ofst + color
res1 = 0.0

#ifdef _SVR
tmp = 0.0
#endif

#ifdef _OPENACC
!$acc kernels
!$acc loop independent collapse(2) reduction(+:res1) &
!$acc& private(a, c, d, aw, cw, dw) &
!$acc& private(ap, cp, e, sq, p, k, pp, dp) &
!$acc& private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$acc& private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
#else
!$OMP PARALLEL &
#ifdef _SVR
!$OMP REDUCTION(+:tmp) &
#else
!$OMP REDUCTION(+:res1) &
#endif
!$OMP private(ap, cp, e, sq, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP private(aw, cw, dw) &
!$OMP firstprivate(a, c, d) &
!$OMP private(C1, C2, C7, C8, GX, EY, TZ, ZTT)
!$OMP DO SCHEDULE(static) collapse(2)
#endif
do j=jst, jed
do i=ist, ied
if(mod(i+j,2) /= color) cycle

!do i=ist+mod(j+ip,2), ied, 2

GX =  2.0 / (XX(i+1) - XX(i-1))
EY =  2.0 / (YY(j+1) - YY(j-1))
C1 =  GX * GX
C2 =  EY * EY
C7 = -(XX(i+1) - 2.0*XX(i) + XX(i-1)) * C1 * GX
C8 = -(YY(j+1) - 2.0*YY(j) + YY(j-1)) * C2 * EY
dd1= C1 + 0.5 * C7 ! R1
dd2= C1 - 0.5 * C7 ! R2
cc1= C2 + 0.5 * C8 ! R3
cc2= C2 - 0.5 * C8 ! R4      >>  24 flops

! Reflesh coef. due to override
do k=kst, ked
f1 = ZZ(k+1)
f2 = ZZ(k-1)
TZ = 2.0 / (f1 - f2)
ZTT= f1 - 2.0*ZZ(k) + f2
f3 = TZ * TZ
aw(k) = f3              ! C3
cw(k) = -ZTT * f3 * TZ  ! C9
dw(k) = 0.5 / (C1 + C2 + f3) ! 1/R7
end do   ! >>  11 flops

a(kst) = 0.0
c(kst) = -(aw(kst) + 0.5 * cw(kst)) * dw(kst) ! -R5/R7 = -(C3+0.5*C9) / R7      >> 3 flops

do k=kst+1, ked-1
f1 = aw(k)  ! C3
f2 = cw(k)  ! C9
aa3 = dw(k)
a(k) = -(f1 - 0.5 * f2) * aa3
c(k) = -(f1 + 0.5 * f2) * aa3
end do    !  >> 6 flops

a(ked) = -(aw(ked) - 0.5 * cw(ked)) * dw(ked) ! -R6/R7 = -(C3-0.5*C9) / R7     >> 3 flops
c(ked) = 0.0

! Source
do k = kst, ked
d(k) = (                         &
dd1 * x(k, i+1, j  )   &
+ dd2 * x(k, i-1, j  )   &
+ cc1 * x(k, i  , j+1)   &
+ cc2 * x(k, i  , j-1)   &
- rhs(k, i, j)           &
) * dw(k) * msk(k, i, j)
end do   !  >>  10 flops
! ここまで、dd1, dd2, cc1, cc2は再利用しない
! a, c, dを計算したので、aw, cw, dwは再利用可能

! BC   >>  12 flops
d(kst) = ( d(kst) + (aw(kst) - 0.5 * cw(kst)) * dw(kst) * x(kst-1, i, j) ) * msk(kst, i, j)
d(ked) = ( d(ked) + (aw(ked) + 0.5 * cw(ked)) * dw(ked) * x(ked+1, i, j) ) * msk(ked, i, j)

! PCR  最終段の一つ手前で停止
!$acc loop seq
do p=1, pn-1
sq = 2**(p-1)

!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
do k = kst, ked
ap = a(k)
cp = c(k)
e = 1.0 / ( 1.0 - ap * c(k-sq) - cp * a(k+sq) )
aw(k) =   -e * ap * a(k-sq)
cw(k) =   -e * cp * c(k+sq)
dw(k) =   e * ( d(k) - ap * d(k-sq) - cp * d(k+sq) )
end do   !  >> 16 flops

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k) = aw(k)
c(k) = cw(k)
d(k) = dw(k)
end do

end do ! p反復

! 最終段の反転
sq = 2**(pn-1)

!dir$ vector aligned
!dir$ simd
!NEC$ IVDEP
!$acc loop independent
do k = kst, kst+sq-1
cc1 = c(k)
aa2 = a(k+sq)
f1  = d(k)
f2  = d(k+sq)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
dw(k   ) = dd1
dw(k+sq) = dd2
end do  ! >>  11 flops

! a_{i-1} x_{i-2} + x_{i-1} + c_{i-1} x_i     = d_{i-1}
! a_{i}   x_{i-1} + x_{i}   + c_{i}   x_{i+1} = d_{i}
! a_{i+1} x_{i}   + x_{i+1} + c_{i+1} x_{i+2} = d_{i+1}

! Relaxation
!dir$ vector aligned
!dir$ simd
!$acc loop reduction(+:res1)
do k = kst, ked
pp =   x(k, i, j)
dp = ( dw(k) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp

#ifdef _SVR
tmp(k) = tmp(k) + dp * dp ! 30
#else
res1 = res1 + dp * dp ! 30
#endif

end do  !  >> 6 flops

end do
end do
#ifdef _OPENACC
!$acc end kernels
#else
!$OMP END DO
!$OMP END PARALLEL
#endif

#ifdef _SVR
do k = kst, ked
res1 = res1 + tmp(k)
end do
#endif

res = res + real(res1, kind=8)

return
end subroutine pcr_rb_esa_maf


program Subspace_Real32
use,intrinsic:: iso_fortran_env, only: int64, stderr=>error_unit
use,intrinsic:: iso_c_binding, only: c_int,c_bool

use comm, only: sp, rand_init
use perf, only: sysclock2ms
use subspace, only: esprit_r
use signals, only: signoise
use filters, only: fircircfilter

implicit none (type, external)

integer(c_int) :: Ns = 1024, &
                  Ntone = 2
real(sp) :: fs=48000, &
            f0=12345.6, &
            snr=60  !dB
character(*), parameter :: bfn='../bfilt.txt'

integer(c_int) :: M,Nb
integer:: fstat
logical(c_bool) :: filtok

real(sp),allocatable :: x(:), b(:), y(:)
real(sp),allocatable :: tones(:),sigma(:)

integer(int64) :: tic,toc
integer :: narg,u
character(16) :: arg

call rand_init(.false., .false.)
!----------- parse command line ------------------
M = Ns / 2_c_int
narg = command_argument_count()

if (narg > 0) then
  call get_command_argument(1,arg); read(arg,*) Ns
endif
if (narg > 1) then
  call get_command_argument(2,arg); read(arg,*) fs
endif
if (narg > 2) then
  call get_command_argument(3,arg); read(arg,*) Ntone
endif
if (narg > 3) then
  call get_command_argument(4,arg); read(arg,*) M
endif
if (narg > 4) then
  call get_command_argument(5,arg); read(arg,*) snr !dB
endif

print *, "Fortran Esprit: Real Single Precision"
!---------- assign variable size arrays ---------------
allocate(x(Ns), y(Ns), tones(Ntone/2), sigma(Ntone/2))
!--- checking system numerics --------------
if (storage_size(fs) /= 32) then
  write(stderr,*) 'expected 32-bit real but you have : ', storage_size(fs)
  error stop
endif
!------ simulate noisy signal ------------
call signoise(fs, f0, snr, Ns, x)   ! output "X"
!------ filter noisy signal --------------
! read coefficients 'b'
filtok=.false.
open(newunit=u, file=bfn, status='old', action='read', iostat=fstat)

if (fstat == 0) then
  read(u,*) Nb !first line of file: number of coeff
  allocate(b(Nb))
  read(u,*) b ! second line all coeff
  close(u)
!    print *,'FIR Coefficients'
!    print '(EN10.1)', b

  call system_clock(tic)
  call fircircfilter(x, size(x,kind=c_int), b, size(b,kind=c_int), y, filtok)
  call system_clock(toc)
  print '(A,EN10.1)', 'seconds to FIR filter: ',sysclock2ms(toc-tic) / 1000
endif

if (fstat /= 0 .or. .not. filtok) then
  write(stderr,*) 'skipped FIR filter.'
  y=x
endif
!------ estimate frequency of sinusoid in noise --------
call system_clock(tic)
call esprit_r(y, size(y,kind=c_int), Ntone, M, fs, &
            tones,sigma)
call system_clock(toc)

! -- assert <0.1% error ---------
if (abs(tones(1)-f0) > 0.001*f0) error stop 'excessive frequency estimation error'

print '(A,100F10.2)', 'estimated tone freq [Hz]: ',tones
print '(A,100F5.1)', 'with sigma: ',sigma
print '(A,F10.3)', 'seconds to estimate frequencies: ',sysclock2ms(toc-tic) / 1000

print *,'OK'

end program


SUBROUTINE beamdis(loads,nf,ratmax,interp,nels,ell,argv,nlen,ips)
!
! This subroutine produces a PostScript output file "*.dis" displaying
! the deformed 1-D finite element mesh.
!
 IMPLICIT NONE
 INTEGER,PARAMETER::iwp=SELECTED_REAL_KIND(15)
 REAL(iwp),INTENT(IN)::loads(0:),ratmax,ell(:)
 INTEGER,INTENT(IN)::ips,nf(:,:),nels,interp,nlen
 REAL(iwp)::width,height,scale=72,sxy,xo,yo,x,y,dismag,vmax
 REAL(iwp)::xmin,xmax,ymin,ymax,xnow,dmax,zero=0.0_iwp,pt5=0.5_iwp,       &
   opt5=1.5_iwp,fpt5=5.5_iwp,d8=8.0_iwp,ept5=8.5_iwp,d11=11.0_iwp,        &
   one=1.0_iwp,two=2.0_iwp,thr=3.0_iwp,                                   &
   localx,globalx,na,nb,nc,nd,ll,wold,wnew
 INTEGER::i,j,nn
 CHARACTER(LEN=15)::argv
 REAL(iwp),ALLOCATABLE::xcoord(:)
 OPEN(ips,FILE=argv(1:nlen)//'.dis')
!
 nn=nels+1
 ALLOCATE(xcoord(nn))

 xmin=zero
 xmax=zero
 xnow=zero
 ymin=zero
 ymax=zero

 xcoord(1)=xnow

 DO i=2,nn
   xnow=xnow+ell(i-1)
   xcoord(i)=xnow
 END DO

 xmax=xcoord(nn)

 DO i=1,nn
    IF(loads(nf(1,i))<ymin)ymin=loads(nf(1,i))
    IF(loads(nf(1,i))>ymax)ymax=loads(nf(1,i))
 END DO

 width=xmax-xmin
 height=ymax-ymin
 dmax=ratmax*width
 IF(height>width)dmax=ratmax*height
!
 vmax=zero
 DO i=1,nn
     IF(ABS(loads(nf(1,i)))>vmax)vmax=ABS(loads(nf(1,i)))
 END DO
 dismag=dmax/vmax
!
 ymin=zero
 ymax=zero

 DO i=1,nn
   IF(dismag*loads(nf(1,i))<ymin)                            &
     ymin=dismag*loads(nf(1,i))
   IF(dismag*loads(nf(1,i))>ymax)                            &
     ymax=dismag*loads(nf(1,i))
!
   IF(loads(nf(1,i))<ymin)ymin=loads(nf(1,i))
   IF(loads(nf(1,i))>ymax)ymax=loads(nf(1,i))
 END DO
!
 width =xmax-xmin
 height=ymax-ymin
!
!                       allow 1.5" margin minimum on each side of figure
!
!                       portrait mode
!
 IF(height.GE.d11/ept5*width)THEN
!
!                       height governs the scale
!
   sxy=scale*d8/height
   xo=scale*pt5*(ept5-d8*width/height)
   yo=scale*opt5
 ELSE
!
!                       width governs the scale
!
   sxy=scale*fpt5/width
   xo=scale*opt5
   yo=scale*pt5*(d11-fpt5*height/width)
 END IF
!
!
!                       start PostScript output
!
 WRITE(ips,'(a)')'%!PS-Adobe-1.0'
 WRITE(ips,'(a)')'%%DocumentFonts: none'
 WRITE(ips,'(a)')'%%Pages: 1'
 WRITE(ips,'(a)')'%%EndComments'
 WRITE(ips,'(a)')'/m {moveto} def'
 WRITE(ips,'(a)')'/l {lineto} def'
 WRITE(ips,'(a)')'/s {stroke} def'
 WRITE(ips,'(a)')'/c {closepath} def'
 WRITE(ips,'(a)')'%%EndProlog'
 WRITE(ips,'(a)')'%%Page: 0 1'
 WRITE(ips,'(a)')'gsave'
!
!                       draw the deformed mesh
!
 WRITE(ips,'(2f9.2,a)') xo, yo, ' translate'
 WRITE(ips,'(f9.2,a)') 0.5, ' setlinewidth'

 wnew=loads(nf(1,1))

 DO i=1,nels
    DO j=1,interp

    wold=wnew
    localx=j*ell(i)/interp
    globalx=localx+xcoord(i)
    ll=ell(i)
    na=(one/(ll**3))*(ll**3-thr*ll*localx**2+two*localx**3)
    nb=(one/(ll**2))*(localx*ll**2-two*ll*localx**2+localx**3)
    nc=(one/(ll**3))*(thr*ll*localx**2-two*localx**3)
    nd=(one/(ll**2))*(localx**3-ll*localx**2)
    wnew=na*loads(nf(1,i))+nb*loads(nf(2,i))+nc*loads(nf(1,1+i))+nd*loads(nf(2,i+1))

    x=sxy*((globalx-ell(i)/interp)-xmin)
    y=sxy*(dismag*wold-ymin)
    WRITE(ips,'(2f9.2,a)') x, y,' m'
    x=sxy*(globalx-xmin)
    y=sxy*(dismag*wnew-ymin)
    WRITE(ips,'(2f9.2,a)') x, y,' l'
    WRITE(ips,'(a)')'c s'

    END DO

 END DO
!
 WRITE(ips,'(a)')'grestore'
 WRITE(ips,'(a)')'showpage'
 CLOSE(ips)
!
RETURN
END SUBROUTINE beamdis


!>A module to hold different routines which can be used to invert a matrix
module mat_inv

!>Really we should provide an interface to different versions of these routines for
!different data types, doing things in-place or not and with assumed arrays and not etc.

!>If our code were needs to do lots of inverts then it may make sense to create a small
!timing routine which can be used to select the most efficient method for a given size on
!the current machine etc. This could then be used with a generic invert routine, the basic
!idea being:
!subroutine invert(a)
!:
!!If this is the first call then do some timing to pick best method
!if(first) call pick_best_method
!!This will set a module level variable identifying the best routine
!select case(best_method)
!case(0)
! call invert_type_1(a)
!:
!end select
!:
!end subroutine
!Of course the best method may change with matrix size so we may need to calculate
!best_method for a number of sizes and then pick the one corresponding to the closest
!sized array to the one we have.

  implicit none

  private

  !/Serial
!  public :: inverse_lapack
  public :: inverse_gj
  !/OpenMP
  public :: inverse_gj_omp
  !/MPI

!NOTE: No attempt has been made to optimise any of these routines yet.
contains

  !>Serial
  ! !>A routine to invert a matrix using lapack routines
  ! !Will probably have to remove this before merging back as it introduces
  ! !new dependencies.
  ! subroutine inverse_lapack(a,n)
  !   integer,intent(in)::n
  !   complex,dimension(:,:),intent(inout)::a
  !   complex,dimension(:),allocatable::work
  !   integer :: lwork
  !   integer :: info
  !   integer,dimension(:),allocatable::ipiv

  !   !Setup
  !   lwork=n*n

  !   !Allocates
  !   allocate(work(lwork),ipiv(n))

  !   !LU decompose
  !   CALL ZGETRF( N, N, a, N, IPIV, INFO )
  !   if(info.ne.0)then
  !      write(6,'("Error during lapack LU factorization.")')
  !   endif

  !   !Invert
  !   CALL ZGETRI(N, a, N, IPIV, WORK, LWORK, INFO)
  !   if(info.ne.0)then
  !      write(6,'("Error during lapack invert")')
  !   endif

  !   !Cleanup
  !   deallocate(work,ipiv)
  ! end subroutine inverse_lapack

  !>Serial Gauss-Jordan elimination
  subroutine inverse_gj(a,n)
    implicit none
    integer,intent(in):: n
    !Should we make this assumed shape?
    !
Tagged
    complex,dimension(n,n),intent(inout) :: a

    !Is it better to make these allocatable?
    !
Tagged
    complex :: tmp,fac
    integer i, k

    do i=1,n
       fac=1/a(i,i) !This would become inverse if done on blocks
       a(i,i)=1
       a(:,i)=a(:,i)*fac
       !NOTE:These loops don't shrink as i increases so load should
       !be balanced?
       do k=1,i-1
          tmp=a(i,k)
          a(i,k)=0
          a(:,k)=a(:,k)-a(:,i)*tmp
       enddo
       do k=i+1,n
          tmp=a(i,k)
          a(i,k)=0
          a(:,k)=a(:,k)-a(:,i)*tmp
       enddo
    enddo
  end subroutine inverse_gj

  !>openmp Gauss-Jordan elimination
  subroutine inverse_gj_omp(a,n)
    implicit none
    integer,intent(in):: n
    !Should we make this assumed shape?
    !
Tagged
    complex,dimension(n,n),intent(inout) :: a

    !Is it better to make these allocatable?
    !
Tagged
    complex :: tmp,fac
    integer i, k

    !Can't omp at top level currently due to data dependencies
    do i=1,n
       fac=1/a(i,i) !This would become inverse if done on blocks
       a(i,i)=1
       a(:,i)=a(:,i)*fac
       !NOTE: Slight difference to serial version to avoid
       !having two separate parallel regions
       !$OMP PARALLEL DO DEFAULT(SHARED) PRIVATE(tmp)
       do k=1,n
          if(k.eq.i)cycle
          tmp=a(i,k)
          a(i,k)=0
          a(:,k)=a(:,k)-a(:,i)*tmp
       enddo
       !$OMP END PARALLEL DO
    enddo
  end subroutine inverse_gj_omp
end module mat_inv


PROGRAM bad_nested_loops_2
INTEGER :: i, j, product
outer: DO i = 1, 3
   inner: DO j = 1, 3
      product = i * j
      WRITE (*,*) i, ' * ', j, ' = ', product
END DO outer
END PROGRAM bad_nested_loops_2


c###fnorml.for
      FUNCTION FNORML(YPX)
C--------------------------------
C
C     THIS FUNCTION COMPUTES THE CUMULATIVE NORMAL DISTRIBUTION FUNCTION
C     FOR POSITIVE OR NEGATIVE VALUES OF X. SEE "THE HANDBOOK OF
C     MATHEMATICAL FUNCTIONS", AMS 55.  NOTE THAT THIS METHOD WILL WORK
C     ON 16 BIT MACHINES (32 BIT FLOATING POINT WORD)
C
      DIMENSION C(4)
      DATA C/.196854, .115194, .000344, .019527/
C
      YP = YPX
      IF(YPX) 105, 110, 110
  105 YP = - YPX
  110 YP = AMIN1(5.0, YP)
      QX = 1. + YP * (C(1) + YP * (C(2) + YP* (C(3) + YP * C(4))))
      QX = QX * QX * QX * QX
      QX = 1. / QX
      QX = .5 * QX
      IF(YPX) 115, 120, 120
  115 PX = QX
      QX = 1. - PX
      GO TO 125
  120 PX = 1. - QX
  125 CONTINUE
      FNORML = PX
      RETURN
      END
C--------------------------------
C--------------------------------


c
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c  .                                                             .
c  .                  copyright (c) 1998 by UCAR                 .
c  .                                                             .
c  .       University Corporation for Atmospheric Research       .
c  .                                                             .
c  .                      all rights reserved                    .
c  .                                                             .
c  .                                                             .
c  .                         SPHEREPACK                          .
c  .                                                             .
c  . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . . .
c
c
c
c ... file vhags.f
c
c     this file contains code and documentation for subroutines
c     vhags and vhagsi
c
c ... files which must be loaded with vhags.f
c
c     sphcom.f, hrfft.f, gaqd.f
c
c     subroutine vhags(nlat,nlon,ityp,nt,v,w,idvw,jdvw,br,bi,cr,ci,
c    +                 mdab,ndab,wvhags,lvhags,work,lwork,ierror)
c
c     subroutine vhags performs the vector spherical harmonic analysis
c     on the vector field (v,w) and stores the result in the arrays
c     br, bi, cr, and ci. v(i,j) and w(i,j) are the colatitudinal
c     (measured from the north pole) and east longitudinal components
c     respectively, located at the gaussian colatitude point theta(i)
c     and longitude phi(j) = (j-1)*2*pi/nlon. the spectral
c     representation of (v,w) is given at output parameters v,w in
c     subroutine vhses.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     ityp   = 0  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon.
c
c            = 1  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 2  no symmetries exist about the equator. the analysis
c                 is performed on the entire sphere.  i.e. on the
c                 arrays v(i,j),w(i,j) for i=1,...,nlat and
c                 j=1,...,nlon. the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 3  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 4  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 5  v is symmetric and w is antisymmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c            = 6  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c
c            = 7  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the curl of (v,w) is zero. that is,
c                 (d/dtheta (sin(theta) w) - dv/dphi)/sin(theta) = 0.
c                 the coefficients cr and ci are zero.
c
c            = 8  v is antisymmetric and w is symmetric about the
c                 equator. the analysis is performed on the northern
c                 hemisphere only.  i.e., if nlat is odd the analysis
c                 is performed on the arrays v(i,j),w(i,j) for
c                 i=1,...,(nlat+1)/2 and j=1,...,nlon. if nlat is
c                 even the analysis is performed on the the arrays
c                 v(i,j),w(i,j) for i=1,...,nlat/2 and j=1,...,nlon.
c                 the divergence of (v,w) is zero. i.e.,
c                 (d/dtheta (sin(theta) v) + dw/dphi)/sin(theta) = 0.
c                 the coefficients br and bi are zero.
c
c
c     nt     the number of analyses.  in the program that calls vhags,
c            the arrays v,w,br,bi,cr, and ci can be three dimensional
c            in which case multiple analyses will be performed.
c            the third index is the analysis index which assumes the
c            values k=1,...,nt.  for a single analysis set nt=1. the
c            discription of the remaining parameters is simplified
c            by assuming that nt=1 or that all the arrays are two
c            dimensional.
c
c     v,w    two or three dimensional arrays (see input parameter nt)
c            that contain the vector function to be analyzed.
c            v is the colatitudnal component and w is the east
c            longitudinal component. v(i,j),w(i,j) contain the
c            components at the gaussian colatitude point theta(i)
c            and longitude phi(j) = (j-1)*2*pi/nlon. the index ranges
c            are defined above at the input parameter ityp.
c
c     idvw   the first dimension of the arrays v,w as it appears in
c            the program that calls vhags. if ityp .le. 2 then idvw
c            must be at least nlat.  if ityp .gt. 2 and nlat is
c            even then idvw must be at least nlat/2. if ityp .gt. 2
c            and nlat is odd then idvw must be at least (nlat+1)/2.
c
c     jdvw   the second dimension of the arrays v,w as it appears in
c            the program that calls vhags. jdvw must be at least nlon.
c
c     mdab   the first dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhags. mdab must be at
c            least min0(nlat,nlon/2) if nlon is even or at least
c            min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ndab   the second dimension of the arrays br,bi,cr, and ci as it
c            appears in the program that calls vhags. ndab must be at
c            least nlat.
c
c     wvhags an array which must be initialized by subroutine vhgsi.
c            once initialized, wvhags can be used repeatedly by vhags
c            as long as nlon and nlat remain unchanged.  wvhags must
c            not be altered between calls of vhags.
c
c     lvhags the dimension of the array wvhags as it appears in the
c            program that calls vhags. define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhags must be at least
c
c            l1*l2(nlat+nlat-l1+1)+nlon+15
c
c        ??? (nlat+1)*(nlat+1)*nlat/2 + nlon + 15
c
c
c
c     work   a work array that does not have to be saved.
c
c     lwork  the dimension of the array work as it appears in the
c            program that calls vhags. define
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            if ityp .le. 2 then lwork must be at least
c            the larger of the two quantities
c
c               3*nlat*(nlat+1)+2  (required by vhagsi)
c
c            and
c
c               (2*nt+1)*nlat*nlon
c
c            if ityp .gt. 2 then lwork must be at least
c            the larger of the two quantities
c
c               3*nlat*(nlat+1)+2  (required by vhagsi)
c
c            and
c
c              (2*nt+1)*l2*nlon
c
c
c     **************************************************************
c
c     output parameters
c
c     br,bi  two or three dimensional arrays (see input parameter nt)
c     cr,ci  that contain the vector spherical harmonic coefficients
c            in the spectral representation of v(i,j) and w(i,j) given
c            in the discription of subroutine vhses. br(mp1,np1),
c            bi(mp1,np1),cr(mp1,np1), and ci(mp1,np1) are computed
c            for mp1=1,...,mmax and np1=mp1,...,nlat except for np1=nlat
c            and odd mp1. mmax=min0(nlat,nlon/2) if nlon is even or
c            mmax=min0(nlat,(nlon+1)/2) if nlon is odd.
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of ityp
c            = 4  error in the specification of nt
c            = 5  error in the specification of idvw
c            = 6  error in the specification of jdvw
c            = 7  error in the specification of mdab
c            = 8  error in the specification of ndab
c            = 9  error in the specification of lvhags
c            = 10 error in the specification of lwork
c
c
c     subroutine vhagsi(nlat,nlon,wvhags,lvhags,work,lwork,ierror)
c
c     subroutine vhagsi initializes the array wvhags which can then be
c     used repeatedly by subroutine vhags until nlat or nlon is changed.
c
c     input parameters
c
c     nlat   the number of points in the gaussian colatitude grid on the
C*PL*ERROR* Comment line too long
c            full sphere. these lie in the interval (0,pi) and are computed
C*PL*ERROR* Comment line too long
c            in radians in theta(1) <...< theta(nlat) by subroutine gaqd.
C*PL*ERROR* Comment line too long
c            if nlat is odd the equator will be included as the grid point
c            theta((nlat+1)/2).  if nlat is even the equator will be
c            excluded as a grid point and will lie half way between
c            theta(nlat/2) and theta(nlat/2+1). nlat must be at least 3.
c            note: on the half sphere, the number of grid points in the
c            colatitudinal direction is nlat/2 if nlat is even or
c            (nlat+1)/2 if nlat is odd.
c
c     nlon   the number of distinct londitude points.  nlon determines
c            the grid increment in longitude as 2*pi/nlon. for example
c            nlon = 72 for a five degree grid. nlon must be greater
c            than zero. the axisymmetric case corresponds to nlon=1.
c            the efficiency of the computation is improved when nlon
c            is a product of small prime numbers.
c
c     lvhags the dimension of the array wvhags as it appears in the
c            program that calls vhagsi.  define
c
c               l1 = min0(nlat,nlon/2) if nlon is even or
c               l1 = min0(nlat,(nlon+1)/2) if nlon is odd
c
c            and
c
c               l2 = nlat/2        if nlat is even or
c               l2 = (nlat+1)/2    if nlat is odd
c
c            then lvhags must be at least
c
c               3*nlat*(nlat+1)+2  (required by vhagsi)
c
C*PL*ERROR* Comment line too long
c     dwork  a double precision work space that does not need to be saved
c
c     ldwork the dimension of the array dwork as it appears in the
c            program that calls vhagsi. ldwork must be at least
c
c                   (3*nlat*(nlat+3)+2)/2
c
c     **************************************************************
c
c     output parameters
c
c     wvhags an array which is initialized for use by subroutine vhags.
c            once initialized, wvhags can be used repeatedly by vhags
c            as long as nlat and nlon remain unchanged.  wvhags must not
c            be altered between calls of vhags.
c
c
c     ierror = 0  no errors
c            = 1  error in the specification of nlat
c            = 2  error in the specification of nlon
c            = 3  error in the specification of lvhags
c            = 4  error in the specification of ldwork
c
      SUBROUTINE DVHAGS(NLAT,NLON,ITYP,NT,V,W,IDVW,JDVW,BR,BI,CR,CI,
     +                  MDAB,NDAB,WVHAGS,LVHAGS,WORK,LWORK,IERROR)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION WVHAGS
      DOUBLE PRECISION WORK
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),WORK(1),
     +          WVHAGS(1)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IF (ITYP.LT.0 .OR. ITYP.GT.8) RETURN
      IERROR = 4
      IF (NT.LT.0) RETURN
      IERROR = 5
      IMID = (NLAT+1)/2
      IF ((ITYP.LE.2.AND.IDVW.LT.NLAT) .OR.
     +    (ITYP.GT.2.AND.IDVW.LT.IMID)) RETURN
      IERROR = 6
      IF (JDVW.LT.NLON) RETURN
      IERROR = 7
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IF (MDAB.LT.MMAX) RETURN
      IERROR = 8
      IF (NDAB.LT.NLAT) RETURN
      IERROR = 9
      IDZ = (MMAX* (NLAT+NLAT-MMAX+1))/2
      LZIMN = IDZ*IMID
      IF (LVHAGS.LT.LZIMN+LZIMN+NLON+15) RETURN
      IERROR = 10
      IDV = NLAT
      IF (ITYP.GT.2) IDV = IMID
      LNL = NT*IDV*NLON
      IF (LWORK.LT.LNL+LNL+IDV*NLON) RETURN
      IERROR = 0
      IST = 0
      IF (ITYP.LE.2) IST = IMID
c
c     set wvhags pointers
c
      LMN = NLAT* (NLAT+1)/2
      JW1 = 1
      JW2 = JW1 + IMID*LMN
      JW3 = JW2 + IMID*LMN
c
c     set work pointers
c
      IW1 = IST + 1
      IW2 = LNL + 1
      IW3 = IW2 + IST
      IW4 = IW2 + LNL
      CALL DVHAGS1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,BR,
     +             BI,CR,CI,IDV,WORK,WORK(IW1),WORK(IW2),WORK(IW3),
     +             WORK(IW4),IDZ,WVHAGS(JW1),WVHAGS(JW2),WVHAGS(JW3))
      RETURN
      END

      SUBROUTINE DVHAGS1(NLAT,NLON,ITYP,NT,IMID,IDVW,JDVW,V,W,MDAB,NDAB,
     +                   BR,BI,CR,CI,IDV,VE,VO,WE,WO,WORK,IDZ,VB,WB,
     +                   WRFFT)
      DOUBLE PRECISION V
      DOUBLE PRECISION W
      DOUBLE PRECISION BR
      DOUBLE PRECISION BI
      DOUBLE PRECISION CR
      DOUBLE PRECISION CI
      DOUBLE PRECISION VE
      DOUBLE PRECISION VO
      DOUBLE PRECISION WE
      DOUBLE PRECISION WO
      DOUBLE PRECISION WORK
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DOUBLE PRECISION WRFFT
      DOUBLE PRECISION TSN
      DOUBLE PRECISION FSN
      DIMENSION V(IDVW,JDVW,1),W(IDVW,JDVW,1),BR(MDAB,NDAB,1),
     +          BI(MDAB,NDAB,1),CR(MDAB,NDAB,1),CI(MDAB,NDAB,1),
     +          VE(IDV,NLON,1),VO(IDV,NLON,1),WE(IDV,NLON,1),
     +          WO(IDV,NLON,1),WORK(1),VB(IMID,1),WB(IMID,1),WRFFT(1)

      NLP1 = NLAT + 1
      TSN = 2.D0/NLON
      FSN = 4.D0/NLON
      MLAT = MOD(NLAT,2)
      MLON = MOD(NLON,2)
      MMAX = MIN0(NLAT, (NLON+1)/2)
      IMM1 = IMID
      IF (MLAT.NE.0) IMM1 = IMID - 1
      IF (ITYP.GT.2) GO TO 3
      DO 5 K = 1,NT
          DO 5 I = 1,IMM1
              DO 5 J = 1,NLON
                  VE(I,J,K) = TSN* (V(I,J,K)+V(NLP1-I,J,K))
                  VO(I,J,K) = TSN* (V(I,J,K)-V(NLP1-I,J,K))
                  WE(I,J,K) = TSN* (W(I,J,K)+W(NLP1-I,J,K))
                  WO(I,J,K) = TSN* (W(I,J,K)-W(NLP1-I,J,K))
    5 CONTINUE
      GO TO 2
    3 DO 8 K = 1,NT
          DO 8 I = 1,IMM1
              DO 8 J = 1,NLON
                  VE(I,J,K) = FSN*V(I,J,K)
                  VO(I,J,K) = FSN*V(I,J,K)
                  WE(I,J,K) = FSN*W(I,J,K)
                  WO(I,J,K) = FSN*W(I,J,K)
    8 CONTINUE
    2 IF (MLAT.EQ.0) GO TO 7
      DO 6 K = 1,NT
          DO 6 J = 1,NLON
              VE(IMID,J,K) = TSN*V(IMID,J,K)
              WE(IMID,J,K) = TSN*W(IMID,J,K)
    6 CONTINUE
    7 DO 9 K = 1,NT
          CALL DHRFFTF(IDV,NLON,VE(1,1,K),IDV,WRFFT,WORK)
          CALL DHRFFTF(IDV,NLON,WE(1,1,K),IDV,WRFFT,WORK)
    9 CONTINUE
      NDO1 = NLAT
      NDO2 = NLAT
      IF (MLAT.NE.0) NDO1 = NLAT - 1
      IF (MLAT.EQ.0) NDO2 = NLAT - 1
      IF (ITYP.EQ.2 .OR. ITYP.EQ.5 .OR. ITYP.EQ.8) GO TO 11
      DO 10 K = 1,NT
          DO 10 MP1 = 1,MMAX
              DO 10 NP1 = MP1,NLAT
                  BR(MP1,NP1,K) = 0.D0
                  BI(MP1,NP1,K) = 0.D0
   10 CONTINUE
   11 IF (ITYP.EQ.1 .OR. ITYP.EQ.4 .OR. ITYP.EQ.7) GO TO 13
      DO 12 K = 1,NT
          DO 12 MP1 = 1,MMAX
              DO 12 NP1 = MP1,NLAT
                  CR(MP1,NP1,K) = 0.D0
                  CI(MP1,NP1,K) = 0.D0
   12 CONTINUE
   13 ITYPP = ITYP + 1
      GO TO (1,100,200,300,400,500,600,700,800) ITYPP
c
c     case ityp=0 ,  no symmetries
c
c     case m=0
c
    1 DO 15 K = 1,NT
          DO 15 I = 1,IMID
              DO 15 NP1 = 2,NDO2,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VE(I,1,K)
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WE(I,1,K)
   15 CONTINUE
      DO 16 K = 1,NT
          DO 16 I = 1,IMM1
              DO 16 NP1 = 3,NDO1,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VO(I,1,K)
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WO(I,1,K)
   16 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 20 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 17
          DO 23 K = 1,NT
              DO 23 I = 1,IMM1
                  DO 23 NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WE(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WE(I,2*MP1-2,K)
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VE(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VE(I,2*MP1-2,K)
   23     CONTINUE
          IF (MLAT.EQ.0) GO TO 17
          DO 24 K = 1,NT
              DO 24 NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
   24     CONTINUE
   17     IF (MP2.GT.NDO2) GO TO 20
          DO 21 K = 1,NT
              DO 21 I = 1,IMM1
                  DO 21 NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WO(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WO(I,2*MP1-2,K)
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VO(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VO(I,2*MP1-2,K)
   21     CONTINUE
          IF (MLAT.EQ.0) GO TO 20
          DO 22 K = 1,NT
              DO 22 NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
   22     CONTINUE
   20 CONTINUE
      RETURN
c
c     case ityp=1 ,  no symmetries but cr and ci equal zero
c
c     case m=0
c
  100 DO 115 K = 1,NT
          DO 115 I = 1,IMID
              DO 115 NP1 = 2,NDO2,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VE(I,1,K)
  115 CONTINUE
      DO 116 K = 1,NT
          DO 116 I = 1,IMM1
              DO 116 NP1 = 3,NDO1,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VO(I,1,K)
  116 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 120 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 117
          DO 123 K = 1,NT
              DO 123 I = 1,IMM1
                  DO 123 NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WE(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WE(I,2*MP1-2,K)
  123     CONTINUE
          IF (MLAT.EQ.0) GO TO 117
          DO 124 K = 1,NT
              DO 124 NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
  124     CONTINUE
  117     IF (MP2.GT.NDO2) GO TO 120
          DO 121 K = 1,NT
              DO 121 I = 1,IMM1
                  DO 121 NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WO(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WO(I,2*MP1-2,K)
  121     CONTINUE
          IF (MLAT.EQ.0) GO TO 120
          DO 122 K = 1,NT
              DO 122 NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
  122     CONTINUE
  120 CONTINUE
      RETURN
c
c     case ityp=2 ,  no symmetries but br and bi equal zero
c
c     case m=0
c
  200 DO 215 K = 1,NT
          DO 215 I = 1,IMID
              DO 215 NP1 = 2,NDO2,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WE(I,1,K)
  215 CONTINUE
      DO 216 K = 1,NT
          DO 216 I = 1,IMM1
              DO 216 NP1 = 3,NDO1,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WO(I,1,K)
  216 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 220 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 217
          DO 223 K = 1,NT
              DO 223 I = 1,IMM1
                  DO 223 NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VE(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VE(I,2*MP1-2,K)
  223     CONTINUE
          IF (MLAT.EQ.0) GO TO 217
          DO 224 K = 1,NT
              DO 224 NP1 = MP1,NDO1,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
  224     CONTINUE
  217     IF (MP2.GT.NDO2) GO TO 220
          DO 221 K = 1,NT
              DO 221 I = 1,IMM1
                  DO 221 NP1 = MP2,NDO2,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VO(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VO(I,2*MP1-2,K)
  221     CONTINUE
          IF (MLAT.EQ.0) GO TO 220
          DO 222 K = 1,NT
              DO 222 NP1 = MP2,NDO2,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
  222     CONTINUE
  220 CONTINUE
      RETURN
c
c     case ityp=3 ,  v even , w odd
c
c     case m=0
c
  300 DO 315 K = 1,NT
          DO 315 I = 1,IMID
              DO 315 NP1 = 2,NDO2,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VE(I,1,K)
  315 CONTINUE
      DO 316 K = 1,NT
          DO 316 I = 1,IMM1
              DO 316 NP1 = 3,NDO1,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WO(I,1,K)
  316 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 320 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 317
          DO 323 K = 1,NT
              DO 323 I = 1,IMM1
                  DO 323 NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VE(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VE(I,2*MP1-2,K)
  323     CONTINUE
          IF (MLAT.EQ.0) GO TO 317
          DO 324 K = 1,NT
              DO 324 NP1 = MP1,NDO1,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
  324     CONTINUE
  317     IF (MP2.GT.NDO2) GO TO 320
          DO 321 K = 1,NT
              DO 321 I = 1,IMM1
                  DO 321 NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WO(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WO(I,2*MP1-2,K)
  321     CONTINUE
          IF (MLAT.EQ.0) GO TO 320
          DO 322 K = 1,NT
              DO 322 NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
  322     CONTINUE
  320 CONTINUE
      RETURN
c
c     case ityp=4 ,  v even, w odd, and cr and ci equal 0.
c
c     case m=0
c
  400 DO 415 K = 1,NT
          DO 415 I = 1,IMID
              DO 415 NP1 = 2,NDO2,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VE(I,1,K)
  415 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 420 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 420
          DO 421 K = 1,NT
              DO 421 I = 1,IMM1
                  DO 421 NP1 = MP2,NDO2,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WO(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WO(I,2*MP1-2,K)
  421     CONTINUE
          IF (MLAT.EQ.0) GO TO 420
          DO 422 K = 1,NT
              DO 422 NP1 = MP2,NDO2,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                            VB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
  422     CONTINUE
  420 CONTINUE
      RETURN
c
c     case ityp=5   v even, w odd, and br and bi equal zero
c
c     case m=0
c
  500 DO 516 K = 1,NT
          DO 516 I = 1,IMM1
              DO 516 NP1 = 3,NDO1,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WO(I,1,K)
  516 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 520 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 520
          DO 523 K = 1,NT
              DO 523 I = 1,IMM1
                  DO 523 NP1 = MP1,NDO1,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VE(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VE(I,2*MP1-2,K)
  523     CONTINUE
          IF (MLAT.EQ.0) GO TO 520
          DO 524 K = 1,NT
              DO 524 NP1 = MP1,NDO1,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-1,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*VE(IMID,2*MP1-2,K)
  524     CONTINUE
  520 CONTINUE
      RETURN
c
c     case ityp=6 ,  v odd , w even
c
c     case m=0
c
  600 DO 615 K = 1,NT
          DO 615 I = 1,IMID
              DO 615 NP1 = 2,NDO2,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WE(I,1,K)
  615 CONTINUE
      DO 616 K = 1,NT
          DO 616 I = 1,IMM1
              DO 616 NP1 = 3,NDO1,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VO(I,1,K)
  616 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 620 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 617
          DO 623 K = 1,NT
              DO 623 I = 1,IMM1
                  DO 623 NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WE(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WE(I,2*MP1-2,K)
  623     CONTINUE
          IF (MLAT.EQ.0) GO TO 617
          DO 624 K = 1,NT
              DO 624 NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
  624     CONTINUE
  617     IF (MP2.GT.NDO2) GO TO 620
          DO 621 K = 1,NT
              DO 621 I = 1,IMM1
                  DO 621 NP1 = MP2,NDO2,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VO(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VO(I,2*MP1-2,K)
  621     CONTINUE
          IF (MLAT.EQ.0) GO TO 620
          DO 622 K = 1,NT
              DO 622 NP1 = MP2,NDO2,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
  622     CONTINUE
  620 CONTINUE
      RETURN
c
c     case ityp=7   v odd, w even, and cr and ci equal zero
c
c     case m=0
c
  700 DO 716 K = 1,NT
          DO 716 I = 1,IMM1
              DO 716 NP1 = 3,NDO1,2
                  BR(1,NP1,K) = BR(1,NP1,K) + VB(I,NP1)*VO(I,1,K)
  716 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 720 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP1.GT.NDO1) GO TO 720
          DO 723 K = 1,NT
              DO 723 I = 1,IMM1
                  DO 723 NP1 = MP1,NDO1,2
                      BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*WE(I,2*MP1-1,K)
                      BI(MP1,NP1,K) = BI(MP1,NP1,K) +
     +                                VB(I,NP1+MB)*VO(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*WE(I,2*MP1-2,K)
  723     CONTINUE
          IF (MLAT.EQ.0) GO TO 720
          DO 724 K = 1,NT
              DO 724 NP1 = MP1,NDO1,2
                  BR(MP1,NP1,K) = BR(MP1,NP1,K) +
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
                  BI(MP1,NP1,K) = BI(MP1,NP1,K) -
     +                            WB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
  724     CONTINUE
  720 CONTINUE
      RETURN
c
c     case ityp=8   v odd, w even, and both br and bi equal zero
c
c     case m=0
c
  800 DO 815 K = 1,NT
          DO 815 I = 1,IMID
              DO 815 NP1 = 2,NDO2,2
                  CR(1,NP1,K) = CR(1,NP1,K) - VB(I,NP1)*WE(I,1,K)
  815 CONTINUE
c
c     case m = 1 through nlat-1
c
      IF (MMAX.LT.2) RETURN
      DO 820 MP1 = 2,MMAX
          M = MP1 - 1
          MB = M*NLAT - (M* (M+1))/2
          MP2 = MP1 + 1
          IF (MP2.GT.NDO2) GO TO 820
          DO 821 K = 1,NT
              DO 821 I = 1,IMM1
                  DO 821 NP1 = MP2,NDO2,2
                      CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-2,K) +
     +                                WB(I,NP1+MB)*VO(I,2*MP1-1,K)
                      CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                                VB(I,NP1+MB)*WE(I,2*MP1-1,K) -
     +                                WB(I,NP1+MB)*VO(I,2*MP1-2,K)
  821     CONTINUE
          IF (MLAT.EQ.0) GO TO 820
          DO 822 K = 1,NT
              DO 822 NP1 = MP2,NDO2,2
                  CR(MP1,NP1,K) = CR(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-2,K)
                  CI(MP1,NP1,K) = CI(MP1,NP1,K) -
     +                            VB(IMID,NP1+MB)*WE(IMID,2*MP1-1,K)
  822     CONTINUE
  820 CONTINUE
      RETURN
      END
      SUBROUTINE DVHAGSI(NLAT,NLON,WVHAGS,LVHAGS,DWORK,LDWORK,IERROR)
      DOUBLE PRECISION WVHAGS
      DIMENSION WVHAGS(LVHAGS)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DWORK(LDWORK)

      IERROR = 1
      IF (NLAT.LT.3) RETURN
      IERROR = 2
      IF (NLON.LT.1) RETURN
      IERROR = 3
      IMID = (NLAT+1)/2
      LMN = (NLAT* (NLAT+1))/2
      IF (LVHAGS.LT.2* (IMID*LMN)+NLON+15) RETURN
      IERROR = 4
c     if (ldwork.lt.nlat*(3*nlat+9)+2) return
      IF (LDWORK.LT. (NLAT* (3*NLAT+9)+2)/2) RETURN
      IERROR = 0
      JW1 = 1
      JW2 = JW1 + IMID*LMN
      JW3 = JW2 + IMID*LMN
      IW1 = 1
      IW2 = IW1 + NLAT
      IW3 = IW2 + NLAT
      IW4 = IW3 + 3*IMID*NLAT
c     iw2 = iw1+nlat+nlat
c     iw3 = iw2+nlat+nlat
c     iw4 = iw3+6*imid*nlat
      CALL DVHGAI1(NLAT,IMID,WVHAGS(JW1),WVHAGS(JW2),DWORK(IW1),
     +             DWORK(IW2),DWORK(IW3),DWORK(IW4))
      CALL DHRFFTI(NLON,WVHAGS(JW3))
      RETURN
      END
      SUBROUTINE DVHGAI1(NLAT,IMID,VB,WB,DTHET,DWTS,DPBAR,WORK)
      DOUBLE PRECISION VB
      DOUBLE PRECISION WB
      DIMENSION VB(IMID,*),WB(IMID,*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION ABEL,BBEL,CBEL,SSQR2,DCF
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DPBAR(IMID,NLAT,3),DTHET(*),DWTS(*),WORK(*)
C*PT*WARNING* Already double-precision
      DOUBLE PRECISION DN,DM
c     lwk = 4*nlat*(nlat+2)
      LWK = NLAT* (NLAT+2)
      CALL DGAQD(NLAT,DTHET,DWTS,DPBAR,LWK,IERROR)
C*PT*WARNING* Constant already double-precision
c
c     compute associated legendre functions
c
c     compute m=n=0 legendre polynomials for all theta(i)
c
      SSQR2 = 1.D0/DSQRT(2.d0)
      DO 90 I = 1,IMID
          DPBAR(I,1,1) = SSQR2
          VB(I,1) = 0.D0
          WB(I,1) = 0.D0
   90 CONTINUE
c
c     main loop for remaining vb, and wb
c
      DO 100 N = 1,NLAT - 1
C*PT*WARNING* Already double-precision (DBLE)
          DN = DBLE(N)
          NM = MOD(N-2,3) + 1
          NZ = MOD(N-1,3) + 1
          NP = MOD(N,3) + 1
c
c     compute dpbar for m=0
c
          CALL DDNLFK(0,N,WORK)
          MN = INDX(0,N,NLAT)
          DO 105 I = 1,IMID
              CALL DDNLFT(0,N,DTHET(I),WORK,DPBAR(I,1,NP))
  105     CONTINUE
c
c     compute dpbar for m=1
c
          CALL DDNLFK(1,N,WORK)
          MN = INDX(1,N,NLAT)
          DO 106 I = 1,IMID
              CALL DDNLFT(1,N,DTHET(I),WORK,DPBAR(I,2,NP))
c      pbar(i,mn) = dpbar(i,2,np)
  106     CONTINUE
  104     CONTINUE
c
c     compute and store dpbar for m=2,n
c
          IF (N.LT.2) GO TO 108
          DO 107 M = 2,N
C*PT*WARNING* Already double-precision (DBLE)
              DM = DBLE(M)
              ABEL = DSQRT(((2*DN+1)* (DM+DN-2)* (DM+DN-3))/
     +               ((2*DN-3)* (DM+DN-1)* (DM+DN)))
              BBEL = DSQRT(((2*DN+1)* (DN-DM-1)* (DN-DM))/
     +               ((2*DN-3)* (DM+DN-1)* (DM+DN)))
              CBEL = DSQRT(((DN-DM+1)* (DN-DM+2))/ ((DM+DN-1)* (DM+DN)))
              ID = INDX(M,N,NLAT)
              IF (M.GE.N-1) GO TO 102
              DO 103 I = 1,IMID
                  DPBAR(I,M+1,NP) = ABEL*DPBAR(I,M-1,NM) +
     +                              BBEL*DPBAR(I,M+1,NM) -
     +                              CBEL*DPBAR(I,M-1,NP)
  103         CONTINUE
              GO TO 107
  102         DO 101 I = 1,IMID
                  DPBAR(I,M+1,NP) = ABEL*DPBAR(I,M-1,NM) -
     +                              CBEL*DPBAR(I,M-1,NP)
  101         CONTINUE
  107     CONTINUE
c
c     compute the derivative of the functions
c
  108     CONTINUE
          IX = INDX(0,N,NLAT)
          IY = INDX(N,N,NLAT)
          DO 125 I = 1,IMID
              VB(I,IX) = -DPBAR(I,2,NP)*DWTS(I)
              VB(I,IY) = DPBAR(I,N,NP)/DSQRT(2* (DN+1))*DWTS(I)
  125     CONTINUE
c
          IF (N.EQ.1) GO TO 131
          DCF = DSQRT(4*DN* (DN+1))
          DO 130 M = 1,N - 1
              DM = DBLE(M)
              IX = INDX(M,N,NLAT)
              ABEL = DSQRT((DN+DM)* (DN-DM+1))/DCF
              BBEL = DSQRT((DN-DM)* (DN+DM+1))/DCF
              DO 130 I = 1,IMID
                  VB(I,IX) = (ABEL*DPBAR(I,M,NP)-BBEL*DPBAR(I,M+2,NP))*
     +                       DWTS(I)
  130     CONTINUE
c
c     compute the vector harmonic w(theta) = m*pbar/cos(theta)
c
c     set wb=0 for m=0
c
  131     CONTINUE
          IX = INDX(0,N,NLAT)
          DO 220 I = 1,IMID
C*PT*WARNING* Constant already double-precision
              WB(I,IX) = 0.d0
  220     CONTINUE
c
c     compute wb for m=1,n
c
          DCF = DSQRT((DN+DN+1)/ (4*DN* (DN+1)* (DN+DN-1)))
          DO 230 M = 1,N
              DM = DBLE(M)
              IX = INDX(M,N,NLAT)
              ABEL = DCF*DSQRT((DN+DM)* (DN+DM-1))
              BBEL = DCF*DSQRT((DN-DM)* (DN-DM-1))
              IF (M.GE.N-1) GO TO 231
              DO 229 I = 1,IMID
                  WB(I,IX) = (ABEL*DPBAR(I,M,NZ)+BBEL*DPBAR(I,M+2,NZ))*
     +                       DWTS(I)
  229         CONTINUE
              GO TO 230
  231         DO 228 I = 1,IMID
                  WB(I,IX) = ABEL*DPBAR(I,M,NZ)*DWTS(I)
  228         CONTINUE
  230     CONTINUE
  100 CONTINUE
      RETURN
      END

      FUNCTION INDX(M,N,NLAT)
      INTEGER INDX

      INDX = M*NLAT - (M* (M+1))/2 + N + 1
      RETURN
      END