!
!	linear_solver.f90
!	kernel_test
!
!	Created by keno on 11/12/05.
!	Copyright 2011 __iis__. All rights reserved.
!

!> ********************************************************************
!! @brief point SOR法
!! @param [in,out] p    圧力
!! @param [in]     sz   配列長
!! @param [in]     g    ガイドセル長
!! @param [in]     omg  加速係数
!! @param [in]     b    RHS vector
!! @param [in]     bp   BCindex P
!! @param [out]    res  residual
!! @param [out]    flop flop count
!! @note Activeマスクの位置は，固体中のラプラス式を解くように，更新式にはかけず残差のみにする
!<
subroutine psor (p, sz, g, psz3d, psz4dex, omg, b, bp, res, flop, vec_cnt)
implicit none
include 'cbc_f_params.h'
integer                                                      ::  i, j, k, ix, jx, kx, l, lx, g, vec_cnt, idx
integer, dimension(4)                                        ::  sz, psz4dex
integer, dimension(3)                                        ::  psz3d
double precision,dimension(sz(4))                            ::  res
double precision                                             ::  flop, de
real                                                         ::  ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b
real                                                         ::  dd, pp, bb, ss, dp, pn, ac, omg, dx, d0, d1, d2
real,    dimension(vec_cnt+psz4dex(1),1-g:sz(1)+g+psz4dex(2), 1-g:sz(2)+g+psz4dex(3), 1-g:sz(3)+g+psz4dex(4)) :: p, b
integer, dimension(          1-g:sz(1)+g+psz3d(1), 1-g:sz(2)+g+psz3d(2), 1-g:sz(3)+g+psz3d(3)) :: bp

ix = sz(1)
jx = sz(2)
kx = sz(3)
lx = vec_cnt

res = 0.0
flop = flop + dble(ix)*dble(jx)*dble(kx)*(12.0 + dble(lx)*23.0)

!$OMP PARALLEL &
!$OMP REDUCTION(+:res) &
!$OMP PRIVATE(ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b) &
!$OMP PRIVATE(dd, pp, bb, ss, dp, de, pn, ac, dx, d0, d1, d2, idx) &
!$OMP FIRSTPRIVATE(kx,jx,ix,lx,omg)

!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
   do j=1,jx
      do i=1,ix
         idx = bp(i,j,k)
         ndag_e = real(ibits(idx, bc_ndag_E, 1))  ! e
         ndag_w = real(ibits(idx, bc_ndag_W, 1))  ! w
         ndag_n = real(ibits(idx, bc_ndag_N, 1))  ! n
         ndag_s = real(ibits(idx, bc_ndag_S, 1))  ! s
         ndag_t = real(ibits(idx, bc_ndag_T, 1))  ! t
         ndag_b = real(ibits(idx, bc_ndag_B, 1))  ! b

         d0 = real(ibits(idx, bc_diag + 0, 1))
         d1 = real(ibits(idx, bc_diag + 1, 1))
         d2 = real(ibits(idx, bc_diag + 2, 1))
         dd = d2*4.0 + d1*2.0 + d0  ! diagonal

         ac = real(ibits(idx, Active, 1))

         dx = 1.0 / dd

         do l=1,lx
            pp = p(l,i,j,k)
            bb = b(l,i,j,k)

            ss = ndag_e * p(l,i+1,j  ,k  ) &
                 + ndag_w * p(l,i-1,j  ,k  ) &
                 + ndag_n * p(l,i  ,j+1,k  ) &
                 + ndag_s * p(l,i  ,j-1,k  ) &
                 + ndag_t * p(l,i  ,j  ,k+1) &
                 + ndag_b * p(l,i  ,j  ,k-1)
            dp = ( (ss - bb)*dx - pp ) * omg
            pn = pp + dp*ac
            p(l,i,j,k) = pn

            de  = dble( bb - (ss - pn * dd) )
            res(l) = res(l) + de*de * ac
         end do

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

return
end subroutine psor

!  **********************************************************************
!> @subroutine jacobi (p, sz, g, omg, b, bp, res, wk2, flop)
!! @brief 緩和Jacobi法
!! @param [in,out] p    圧力
!! @param [in]     sz   配列長
!! @param [in]     g    ガイドセル長
!! @param [in]     omg  加速係数
!! @param [in]     b    RHS vector
!! @param [in]     bp   BCindex P
!! @param [out]    res  residual
!! @param wk2 ワーク用配列
!! @param bp BCindex P
!! @param[out] flop flop count
!<
subroutine jacobi (p, sz, g, psz3d, psz4dex, omg, b, bp, res, wk2, flop, vec_cnt)
implicit none
include 'cbc_f_params.h'
integer                                                       ::  i, j, k, l, ix, jx, kx, lx, g, vec_cnt, idx
integer, dimension(4)                                         ::  sz, psz4dex
integer, dimension(3)                                         ::  psz3d
double precision                                              ::  flop, de
double precision, dimension(sz(4))                            ::  res
real                                                          ::  ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b
real                                                          ::  omg, dd, ss, dp, pp, bb, pn, ac, dx, d0, d1, d2
real, dimension(sz(4)+psz4dex(1),1-g:sz(1)+g+psz4dex(2), 1-g:sz(2)+g+psz4dex(3), 1-g:sz(3)+g+psz4dex(4)) :: p, b, wk2
integer, dimension(   1-g:sz(1)+g+psz3d(1), 1-g:sz(2)+g+psz3d(2), 1-g:sz(3)+g+psz3d(3)) :: bp

ix = sz(1)
jx = sz(2)
kx = sz(3)
lx = vec_cnt

res = 0.0 ! absolute
flop = flop + dble(ix*jx*kx*(8.0 + lx*23.0))

!$OMP PARALLEL &
!$OMP REDUCTION(+:res) &
!$OMP PRIVATE(ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b) &
!$OMP PRIVATE(dd, ss, dp, pp, bb, pn, ac, dx, de, idx, d0, d1, d2) &
!$OMP FIRSTPRIVATE(omg,kx,jx,ix,lx)

!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
   do j=1,jx
      do i=1,ix
         idx = bp(i,j,k)
         ndag_e = real(ibits(idx, bc_ndag_E, 1))  ! e
         ndag_w = real(ibits(idx, bc_ndag_W, 1))  ! w
         ndag_n = real(ibits(idx, bc_ndag_N, 1))  ! n
         ndag_s = real(ibits(idx, bc_ndag_S, 1))  ! s
         ndag_t = real(ibits(idx, bc_ndag_T, 1))  ! t
         ndag_b = real(ibits(idx, bc_ndag_B, 1))  ! b

         d0 = real(ibits(idx, bc_diag + 0, 1))
         d1 = real(ibits(idx, bc_diag + 1, 1))
         d2 = real(ibits(idx, bc_diag + 2, 1))
         dd = d2*4.0 + d1*2.0 + d0  ! diagonal

         ac = real(ibits(idx, Active, 1))

         dx = 1.0 / dd

         do l=1,lx
            pp = p(l,i,j,k)
            bb = b(l,i,j,k)

            ss = ndag_e * p(l,i+1,j  ,k  ) &
                 + ndag_w * p(l,i-1,j  ,k  ) &
                 + ndag_n * p(l,i  ,j+1,k  ) &
                 + ndag_s * p(l,i  ,j-1,k  ) &
                 + ndag_t * p(l,i  ,j  ,k+1) &
                 + ndag_b * p(l,i  ,j  ,k-1)
            dp = ( (ss - bb)*dx - pp ) * omg
            pn = pp + dp*ac
            wk2(l,i,j,k) = pn

            de  = dble( bb - (ss - pn * dd) )
            res(l) = res(l) + de*de *  ac
         end do
      end do
   end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
   do j=1,jx
      do i=1,ix
         do l=1,lx
            p(l,i,j,k)=wk2(l,i,j,k)
         end do
      end do
   end do
end do
!$OMP END DO
!$OMP END PARALLEL

return
end subroutine jacobi

!> ********************************************************************
!! @brief 2-colored SOR法 stride memory access
!! @param [in,out] p     圧力
!! @param [in]     sz    配列長
!! @param [in]     g     ガイドセル長
!! @param [in]     ip    開始点インデクス
!! @param [in]     color グループ番号
!! @param [in]     omg   加速係数
!! @param [in]     b     RHS vector
!! @param [in]     bp    BCindex P
!! @param [out]    res  residual
!! @param [out]    flop  浮動小数演算数
!! @note resは積算
!<
subroutine psor2sma_core (p, sz, g, psz3d, psz4dex, ip, color, omg, b, bp, res, flop, vec_cnt)
implicit none
include 'cbc_f_params.h'
integer                                                      ::  i, j, k, l, ix, jx, kx, lx, g, vec_cnt, idx
integer, dimension(4)                                        ::  sz, psz4dex
integer, dimension(3)                                        ::  psz3d
double precision                                             ::  flop, de
double precision, dimension(sz(4))                           ::  res
real                                                         ::  ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b
real                                                         ::  omg, dd, ss, dp, pp, bb, pn, ac, dx, d0, d1, d2
real, dimension(sz(4)+psz4dex(1),1-g:sz(1)+g+psz4dex(2), 1-g:sz(2)+g+psz4dex(3), 1-g:sz(3)+g+psz4dex(4)) :: p, b
integer, dimension(      1-g:sz(1)+g+psz3d(1), 1-g:sz(2)+g+psz3d(2), 1-g:sz(3)+g+psz3d(3)) :: bp
integer                                                      ::  ip, color

ix = sz(1)
jx = sz(2)
kx = sz(3)
lx = vec_cnt

flop = flop + dble(ix)*dble(jx)*dble(kx)*(12.0 + dble(lx)*23.0) * 0.5d0
!$OMP PARALLEL &
!$OMP REDUCTION(+:res) &
!$OMP PRIVATE(ndag_e, ndag_w, ndag_n, ndag_s, ndag_t, ndag_b) &
!$OMP PRIVATE(dd, ss, dp, pp, bb, pn, ac, dx, de, idx, d0, d1, d2) &
!$OMP FIRSTPRIVATE(color, ip, omg,kx,jx,ix,lx)

!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do j=1,jx
do i=1+mod(k+j+color+ip,2), ix, 2
   idx = bp(i,j,k)
   ndag_e = real(ibits(idx, bc_ndag_E, 1))  ! e
   ndag_w = real(ibits(idx, bc_ndag_W, 1))  ! w
   ndag_n = real(ibits(idx, bc_ndag_N, 1))  ! n
   ndag_s = real(ibits(idx, bc_ndag_S, 1))  ! s
   ndag_t = real(ibits(idx, bc_ndag_T, 1))  ! t
   ndag_b = real(ibits(idx, bc_ndag_B, 1))  ! b

   d0 = real(ibits(idx, bc_diag + 0, 1))
   d1 = real(ibits(idx, bc_diag + 1, 1))
   d2 = real(ibits(idx, bc_diag + 2, 1))
   dd = d2*4.0 + d1*2.0 + d0  ! diagonal

   ac = real(ibits(idx, Active, 1))

   dx = 1.0 / dd

   do l=1,lx
      pp = p(l,i,j,k)
      bb = b(l,i,j,k)

      ss = ndag_e * p(l,i+1,j  ,k  ) &
           + ndag_w * p(l,i-1,j  ,k  ) &
           + ndag_n * p(l,i  ,j+1,k  ) &
           + ndag_s * p(l,i  ,j-1,k  ) &
           + ndag_t * p(l,i  ,j  ,k+1) &
           + ndag_b * p(l,i  ,j  ,k-1)
      dp = ( (ss - bb)*dx - pp ) * omg
      pn = pp + dp*ac
      p(l,i,j,k) = pn

      de  = dble( bb - (ss - pn * dd) )
      res(l) = res(l) + de*de * ac
   end do

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

return
end subroutine psor2sma_core

!> ********************************************************************
!! @brief Dirichlet source
!! @param [in]     b     RHS vector
!! @param [in]     sz    配列長
!! @param [in]     g     ガイドセル長
!! @param [in]     bp    BCindex P
!! @param [out]    dh    gird width
!! @note resは積算
!<
subroutine src_dirichlet (b, sz, g, psz3d, psz4dex, bp, dh)
implicit none
include 'cbc_f_params.h'
integer                                                      ::  i, j, k, ix, jx, kx, g, l, lx
integer, dimension(4)                                        ::  sz, psz4dex
integer, dimension(3)                                        ::  psz3d
real                                                         ::  dh
real                                                         ::  x, y, pi, z, x2, y2, z2,dh2
real, dimension(sz(4)+psz4dex(1),1-g:sz(1)+g+psz4dex(2), 1-g:sz(2)+g+psz4dex(3), 1-g:sz(3)+g+psz4dex(4)) :: b
integer, dimension(1-g:sz(1)+g+psz3d(1), 1-g:sz(2)+g+psz3d(2), 1-g:sz(3)+g+psz3d(3)) :: bp

ix = sz(1)
jx = sz(2)
kx = sz(3)
lx = sz(4)
pi = 2.0*asin(1.0)
dh2 = dh*dh

do l=1,lx
if(mod(l,64)==1) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==2) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==3) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==4) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*sin(0.5*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==5) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==6) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==7) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==8) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==9) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==10) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==11) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*2.0*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*2.0*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==12) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==13) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*(x+y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==14) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.2*(x+y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.2*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==15) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*abs(sin(4.0*pi*x))
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*abs(sin(4.0*pi*x))
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==16) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(pi*x)*sin(pi*x)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*x)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==17) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==18) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==19) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==20) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==21) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==22) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==23) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==24) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==25) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==26) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==27) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*2.0*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==28) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==29) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*(x+y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==30) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.2*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==31) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*abs(sin(4.0*pi*x))
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==32) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*x)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==33) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*sin(pi*x)*sin(pi*y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==34) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.1*sin(pi*x)*sin(pi*y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==35) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.5*sin(pi*x)*sin(pi*y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==36) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*sin(0.5*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*sin(0.5*pi*x)*sin(pi*y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==37) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1)  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==38) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==39) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*x*y
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==40) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.1*x*y
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==41) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.5*x*y
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==42) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*x*x*y*y
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==43) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*2.0*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*2.0*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*2.0*x*x*y*y
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*2.0*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==44) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.5*x*x*y*y
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==45) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*(x+y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.1*(x+y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==46) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.2*(x+y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.2*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.2*(x+y)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.2*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==47) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*abs(sin(4.0*pi*x))
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*abs(sin(4.0*pi*x))
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.5*abs(sin(4.0*pi*x))
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*abs(sin(4.0*pi*x))
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==48) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(pi*x)*sin(pi*x)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*x)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*sin(pi*x)*sin(pi*x)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==49) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==50) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==51) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*sin(pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==52) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*sin(0.5*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==53) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1)  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*sin(0.1*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==54) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*sin(0.5*pi*x)*sin(pi*y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==55) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==56) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==57) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*x*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*x*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==58) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==59) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*2.0*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*2.0*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*2.0*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==60) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*x*x*y*y
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*x*x*y*y
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==61) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.1*(x+y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.1*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.1*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==62) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.2*(x+y)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.2*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.2*(x+y)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==63) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*abs(sin(4.0*pi*x))
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*abs(sin(4.0*pi*x))
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*abs(sin(4.0*pi*x))
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(mod(l,64)==0) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)

b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*0.5*sin(pi*x)*sin(pi*x)
b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*0.5*sin(pi*x)*sin(pi*x)
end do
end do
!$OMP END DO
!$OMP END PARALLEL

!$OMP PARALLEL &
!$OMP PRIVATE(x, y) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(k)
b(l,i,1 ,k)  = - (1.0-real(ibits(bp(i,1,k ), bc_d_S, 1)))*0.5*sin(pi*x)*sin(pi*x)
b(l,i,jx,k) = - (1.0-real(ibits(bp(i,jx,k), bc_d_N, 1)))*0.5*sin(pi*x)*sin(pi*x)
end do
end do
!$OMP END DO
!$OMP END PARALLEL
end if

if(l<0) then
!$OMP PARALLEL &
!$OMP PRIVATE(x, y, z) &
!$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)
!$OMP DO SCHEDULE(static) COLLAPSE(2)
do k=1,kx
do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)
z = dh*real(k)
x2=x*x
y2=y*y
z2=z*z
b(l,i,j,k) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z)
end do
end do
end do
!$OMP END DO
!$OMP END PARALLEL

do j=1,jx
do i=1,ix
x = dh*real(i)
y = dh*real(j)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,i,j,kx) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(x*y)
end do
end do

do k=1,kx
do i=1,ix
x = dh*real(i)
y = dh*real(jx)
z = dh*real(k)
x2=x*x
y2=y*y
z2=z*z
b(l,i,jx,k) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) - (1.0-real(ibits(bp(i ,jx ,k), bc_d_N, 1)))*sin(x*z)
end do
end do

do k=1,kx
do j=1,jx
x = dh*real(ix)
y = dh*real(j)
z = dh*real(k)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,j,k) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) - (1.0-real(ibits(bp(ix,j,k), bc_d_E, 1)))*sin(y*z)
end do
end do

do j=1,jx
x = dh*real(1)
y = dh*real(j)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,1,j,kx ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
              -(1.0-real(ibits(bp(1 ,j,kx), bc_d_T, 1)))*sin(x*y)
x = dh*real(ix)
y = dh*real(j)
z = dh*real(1)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,j,1 ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(ix ,j,1), bc_d_E, 1)))*sin(y*z)
x = dh*real(ix)
y = dh*real(j)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,j,kx ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
              -(1.0-real(ibits(bp(ix ,j,kx), bc_d_T, 1)))*sin(x*y)&
              -(1.0-real(ibits(bp(ix ,j,kx), bc_d_E, 1)))*sin(y*z)
end do

do i=1,ix
x = dh*real(i)
y = dh*real(1)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,i,1,kx ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
              -(1.0-real(ibits(bp(i ,1,kx), bc_d_T, 1)))*sin(x*y)
x = dh*real(i)
y = dh*real(jx)
z = dh*real(1)
x2=x*x
y2=y*y
z2=z*z
b(l,i,jx,1 ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
              -(1.0-real(ibits(bp(i ,jx,1), bc_d_N, 1)))*sin(x*z)
x = dh*real(i)
y = dh*real(jx)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,i,jx,kx ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(i ,jx,kx), bc_d_T, 1)))*sin(x*y)&
     -(1.0-real(ibits(bp(i ,jx,kx), bc_d_N, 1)))*sin(x*z)
end do

do k=1,kx
x = dh*real(1)
y = dh*real(jx)
z = dh*real(k)
x2=x*x
y2=y*y
z2=z*z
b(l,1,jx,k ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
              -(1.0-real(ibits(bp(1 ,jx,k), bc_d_N, 1)))*sin(x*z)
x = dh*real(ix)
y = dh*real(1)
z = dh*real(k)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,1,k ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
              -(1.0-real(ibits(bp(ix ,1,k), bc_d_E, 1)))*sin(y*z)
x = dh*real(ix)
y = dh*real(jx)
z = dh*real(k)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,jx,k ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(ix ,jx,k), bc_d_N, 1)))*sin(x*z)&
     -(1.0-real(ibits(bp(ix ,jx,k), bc_d_E, 1)))*sin(y*z)
end do

x = dh*real(1)
y = dh*real(1)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,1,1,kx ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(1 ,1,kx), bc_d_T, 1)))*sin(x*y)

x = dh*real(1)
y = dh*real(jx)
z = dh*real(1)
x2=x*x
y2=y*y
z2=z*z
b(l,1,jx,1 ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(1 ,jx,1), bc_d_N, 1)))*sin(x*z)

x = dh*real(1)
y = dh*real(jx)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,1,jx,kx ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(1 ,jx,kx), bc_d_N, 1)))*sin(x*z)&
     -(1.0-real(ibits(bp(1 ,jx,kx), bc_d_T, 1)))*sin(x*y)

x = dh*real(ix)
y = dh*real(1)
z = dh*real(1)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,1,1 ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(ix ,1,1), bc_d_E, 1)))*sin(y*z)

x = dh*real(ix)
y = dh*real(1)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,1,kx ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(ix ,1,kx), bc_d_E, 1)))*sin(y*z)&
     -(1.0-real(ibits(bp(ix ,1,kx), bc_d_T, 1)))*sin(x*y)

x = dh*real(ix)
y = dh*real(jx)
z = dh*real(1)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,jx,1 ) = -dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(ix ,jx,1), bc_d_E, 1)))*sin(y*z)&
     -(1.0-real(ibits(bp(ix ,jx,1), bc_d_N, 1)))*sin(x*z)

x = dh*real(ix)
y = dh*real(jx)
z = dh*real(kx)
x2=x*x
y2=y*y
z2=z*z
b(l,ix,jx,kx ) = (-dh2*(x2*y2+y2*z2+z2*x2)*sin(x*y*z) &
     -(1.0-real(ibits(bp(ix ,jx,kx), bc_d_E, 1)))*sin(y*z)&
     -(1.0-real(ibits(bp(ix ,jx,kx), bc_d_N, 1)))*sin(x*z)&
     -(1.0-real(ibits(bp(ix ,jx,kx), bc_d_T, 1)))*sin(x*y))

! !$OMP PARALLEL &
! ! !$OMP REDUCTION(+:res) &
! ! !$OMP PRIVATE(ndag_w, ndag_e, ndag_s, ndag_n, ndag_b, ndag_t) &
! !$OMP PRIVATE(x, y) &
! !$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)

! !$OMP DO SCHEDULE(static) COLLAPSE(2)

! do j=1,jx
! do i=1,ix
! x = dh*real(i)
! y = dh*real(j)
! end do
! end do
! !$OMP END DO
! !$OMP END PARALLEL
end if

! if(lx>2) then
! l=3
! !$OMP PARALLEL &
! ! !$OMP REDUCTION(+:res) &
! ! !$OMP PRIVATE(ndag_w, ndag_e, ndag_s, ndag_n, ndag_b, ndag_t) &
! !$OMP PRIVATE(x, y) &
! !$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)

! !$OMP DO SCHEDULE(static) COLLAPSE(2)
! do j=1,jx
! do i=1,ix
! x = dh*real(i)
! y = dh*real(j)

! b(l,i,j,1 )  = - (1.0-real(ibits(bp(i,j,1 ), bc_d_B, 1)))*sin(pi*x)*sin(pi*y)
! b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*sin(pi*x)*sin(pi*y)
! end do
! end do
! !$OMP END DO
! !$OMP END PARALLEL
! ! !$OMP PARALLEL &
! ! !$OMP REDUCTION(+:res) &
! ! !$OMP PRIVATE(ndag_w, ndag_e, ndag_s, ndag_n, ndag_b, ndag_t) &
! ! !$OMP PRIVATE(x, y) &
! ! !$OMP FIRSTPRIVATE(ix, jx, kx, lx, dh, pi)

! ! !$OMP DO SCHEDULE(static) COLLAPSE(2)

! ! do j=1,jx
! ! do i=1,ix
! ! x = dh*real(i)
! ! y = dh*real(j)
! ! b(l,i,j,kx) = - (1.0-real(ibits(bp(i,j,kx), bc_d_T, 1)))*(x+y)
! ! end do
! ! end do
! ! !$OMP END DO
! ! !$OMP END PARALLEL
! !
! end if
end do

return
end subroutine src_dirichlet


      SUBROUTINE STGSNA( JOB, HOWMNY, SELECT, N, A, LDA, B, LDB, VL,
     $                   LDVL, VR, LDVR, S, DIF, MM, M, WORK, LWORK,
     $                   IWORK, INFO )
*
*  -- LAPACK routine (version 3.1) --
*     Univ. of Tennessee, Univ. of California Berkeley and NAG Ltd..
*     November 2006
*
*     .. Scalar Arguments ..
      CHARACTER          HOWMNY, JOB
      INTEGER            INFO, LDA, LDB, LDVL, LDVR, LWORK, M, MM, N
*     ..
*     .. Array Arguments ..
      LOGICAL            SELECT( * )
      INTEGER            IWORK( * )
      REAL               A( LDA, * ), B( LDB, * ), DIF( * ), S( * ),
     $                   VL( LDVL, * ), VR( LDVR, * ), WORK( * )
*     ..
*
*  Purpose
*  =======
*
*  STGSNA estimates reciprocal condition numbers for specified
*  eigenvalues and/or eigenvectors of a matrix pair (A, B) in
*  generalized real Schur canonical form (or of any matrix pair
*  (Q*A*Z', Q*B*Z') with orthogonal matrices Q and Z, where
*  Z' denotes the transpose of Z.
*
*  (A, B) must be in generalized real Schur form (as returned by SGGES),
*  i.e. A is block upper triangular with 1-by-1 and 2-by-2 diagonal
*  blocks. B is upper triangular.
*
*
*  Arguments
*  =========
*
*  JOB     (input) CHARACTER*1
*          Specifies whether condition numbers are required for
*          eigenvalues (S) or eigenvectors (DIF):
*          = 'E': for eigenvalues only (S);
*          = 'V': for eigenvectors only (DIF);
*          = 'B': for both eigenvalues and eigenvectors (S and DIF).
*
*  HOWMNY  (input) CHARACTER*1
*          = 'A': compute condition numbers for all eigenpairs;
*          = 'S': compute condition numbers for selected eigenpairs
*                 specified by the array SELECT.
*
*  SELECT  (input) LOGICAL array, dimension (N)
*          If HOWMNY = 'S', SELECT specifies the eigenpairs for which
*          condition numbers are required. To select condition numbers
*          for the eigenpair corresponding to a real eigenvalue w(j),
*          SELECT(j) must be set to .TRUE.. To select condition numbers
*          corresponding to a complex conjugate pair of eigenvalues w(j)
*          and w(j+1), either SELECT(j) or SELECT(j+1) or both, must be
*          set to .TRUE..
*          If HOWMNY = 'A', SELECT is not referenced.
*
*  N       (input) INTEGER
*          The order of the square matrix pair (A, B). N >= 0.
*
*  A       (input) REAL array, dimension (LDA,N)
*          The upper quasi-triangular matrix A in the pair (A,B).
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A. LDA >= max(1,N).
*
*  B       (input) REAL array, dimension (LDB,N)
*          The upper triangular matrix B in the pair (A,B).
*
*  LDB     (input) INTEGER
*          The leading dimension of the array B. LDB >= max(1,N).
*
*  VL      (input) REAL array, dimension (LDVL,M)
*          If JOB = 'E' or 'B', VL must contain left eigenvectors of
*          (A, B), corresponding to the eigenpairs specified by HOWMNY
*          and SELECT. The eigenvectors must be stored in consecutive
*          columns of VL, as returned by STGEVC.
*          If JOB = 'V', VL is not referenced.
*
*  LDVL    (input) INTEGER
*          The leading dimension of the array VL. LDVL >= 1.
*          If JOB = 'E' or 'B', LDVL >= N.
*
*  VR      (input) REAL array, dimension (LDVR,M)
*          If JOB = 'E' or 'B', VR must contain right eigenvectors of
*          (A, B), corresponding to the eigenpairs specified by HOWMNY
*          and SELECT. The eigenvectors must be stored in consecutive
*          columns ov VR, as returned by STGEVC.
*          If JOB = 'V', VR is not referenced.
*
*  LDVR    (input) INTEGER
*          The leading dimension of the array VR. LDVR >= 1.
*          If JOB = 'E' or 'B', LDVR >= N.
*
*  S       (output) REAL array, dimension (MM)
*          If JOB = 'E' or 'B', the reciprocal condition numbers of the
*          selected eigenvalues, stored in consecutive elements of the
*          array. For a complex conjugate pair of eigenvalues two
*          consecutive elements of S are set to the same value. Thus
*          S(j), DIF(j), and the j-th columns of VL and VR all
*          correspond to the same eigenpair (but not in general the
*          j-th eigenpair, unless all eigenpairs are selected).
*          If JOB = 'V', S is not referenced.
*
*  DIF     (output) REAL array, dimension (MM)
*          If JOB = 'V' or 'B', the estimated reciprocal condition
*          numbers of the selected eigenvectors, stored in consecutive
*          elements of the array. For a complex eigenvector two
*          consecutive elements of DIF are set to the same value. If
*          the eigenvalues cannot be reordered to compute DIF(j), DIF(j)
*          is set to 0; this can only occur when the true value would be
*          very small anyway.
*          If JOB = 'E', DIF is not referenced.
*
*  MM      (input) INTEGER
*          The number of elements in the arrays S and DIF. MM >= M.
*
*  M       (output) INTEGER
*          The number of elements of the arrays S and DIF used to store
*          the specified condition numbers; for each selected real
*          eigenvalue one element is used, and for each selected complex
*          conjugate pair of eigenvalues, two elements are used.
*          If HOWMNY = 'A', M is set to N.
*
*  WORK    (workspace/output) REAL array, dimension (MAX(1,LWORK))
*          On exit, if INFO = 0, WORK(1) returns the optimal LWORK.
*
*  LWORK   (input) INTEGER
*          The dimension of the array WORK. LWORK >= max(1,N).
*          If JOB = 'V' or 'B' LWORK >= 2*N*(N+2)+16.
*
*          If LWORK = -1, then a workspace query is assumed; the routine
*          only calculates the optimal size of the WORK array, returns
*          this value as the first entry of the WORK array, and no error
*          message related to LWORK is issued by XERBLA.
*
*  IWORK   (workspace) INTEGER array, dimension (N + 6)
*          If JOB = 'E', IWORK is not referenced.
*
*  INFO    (output) INTEGER
*          =0: Successful exit
*          <0: If INFO = -i, the i-th argument had an illegal value
*
*
*  Further Details
*  ===============
*
*  The reciprocal of the condition number of a generalized eigenvalue
*  w = (a, b) is defined as
*
*       S(w) = (|u'Av|**2 + |u'Bv|**2)**(1/2) / (norm(u)*norm(v))
*
*  where u and v are the left and right eigenvectors of (A, B)
*  corresponding to w; |z| denotes the absolute value of the complex
*  number, and norm(u) denotes the 2-norm of the vector u.
*  The pair (a, b) corresponds to an eigenvalue w = a/b (= u'Av/u'Bv)
*  of the matrix pair (A, B). If both a and b equal zero, then (A B) is
*  singular and S(I) = -1 is returned.
*
*  An approximate error bound on the chordal distance between the i-th
*  computed generalized eigenvalue w and the corresponding exact
*  eigenvalue lambda is
*
*       chord(w, lambda) <= EPS * norm(A, B) / S(I)
*
*  where EPS is the machine precision.
*
*  The reciprocal of the condition number DIF(i) of right eigenvector u
*  and left eigenvector v corresponding to the generalized eigenvalue w
*  is defined as follows:
*
*  a) If the i-th eigenvalue w = (a,b) is real
*
*     Suppose U and V are orthogonal transformations such that
*
*                U'*(A, B)*V  = (S, T) = ( a   *  ) ( b  *  )  1
*                                        ( 0  S22 ),( 0 T22 )  n-1
*                                          1  n-1     1 n-1
*
*     Then the reciprocal condition number DIF(i) is
*
*                Difl((a, b), (S22, T22)) = sigma-min( Zl ),
*
*     where sigma-min(Zl) denotes the smallest singular value of the
*     2(n-1)-by-2(n-1) matrix
*
*         Zl = [ kron(a, In-1)  -kron(1, S22) ]
*              [ kron(b, In-1)  -kron(1, T22) ] .
*
*     Here In-1 is the identity matrix of size n-1. kron(X, Y) is the
*     Kronecker product between the matrices X and Y.
*
*     Note that if the default method for computing DIF(i) is wanted
*     (see SLATDF), then the parameter DIFDRI (see below) should be
*     changed from 3 to 4 (routine SLATDF(IJOB = 2 will be used)).
*     See STGSYL for more details.
*
*  b) If the i-th and (i+1)-th eigenvalues are complex conjugate pair,
*
*     Suppose U and V are orthogonal transformations such that
*
*                U'*(A, B)*V = (S, T) = ( S11  *   ) ( T11  *  )  2
*                                       ( 0    S22 ),( 0    T22) n-2
*                                         2    n-2     2    n-2
*
*     and (S11, T11) corresponds to the complex conjugate eigenvalue
*     pair (w, conjg(w)). There exist unitary matrices U1 and V1 such
*     that
*
*         U1'*S11*V1 = ( s11 s12 )   and U1'*T11*V1 = ( t11 t12 )
*                      (  0  s22 )                    (  0  t22 )
*
*     where the generalized eigenvalues w = s11/t11 and
*     conjg(w) = s22/t22.
*
*     Then the reciprocal condition number DIF(i) is bounded by
*
*         min( d1, max( 1, |real(s11)/real(s22)| )*d2 )
*
*     where, d1 = Difl((s11, t11), (s22, t22)) = sigma-min(Z1), where
*     Z1 is the complex 2-by-2 matrix
*
*              Z1 =  [ s11  -s22 ]
*                    [ t11  -t22 ],
*
*     This is done by computing (using real arithmetic) the
*     roots of the characteristical polynomial det(Z1' * Z1 - lambda I),
*     where Z1' denotes the conjugate transpose of Z1 and det(X) denotes
*     the determinant of X.
*
*     and d2 is an upper bound on Difl((S11, T11), (S22, T22)), i.e. an
*     upper bound on sigma-min(Z2), where Z2 is (2n-2)-by-(2n-2)
*
*              Z2 = [ kron(S11', In-2)  -kron(I2, S22) ]
*                   [ kron(T11', In-2)  -kron(I2, T22) ]
*
*     Note that if the default method for computing DIF is wanted (see
*     SLATDF), then the parameter DIFDRI (see below) should be changed
*     from 3 to 4 (routine SLATDF(IJOB = 2 will be used)). See STGSYL
*     for more details.
*
*  For each eigenvalue/vector specified by SELECT, DIF stores a
*  Frobenius norm-based estimate of Difl.
*
*  An approximate error bound for the i-th computed eigenvector VL(i) or
*  VR(i) is given by
*
*             EPS * norm(A, B) / DIF(i).
*
*  See ref. [2-3] for more details and further references.
*
*  Based on contributions by
*     Bo Kagstrom and Peter Poromaa, Department of Computing Science,
*     Umea University, S-901 87 Umea, Sweden.
*
*  References
*  ==========
*
*  [1] B. Kagstrom; A Direct Method for Reordering Eigenvalues in the
*      Generalized Real Schur Form of a Regular Matrix Pair (A, B), in
*      M.S. Moonen et al (eds), Linear Algebra for Large Scale and
*      Real-Time Applications, Kluwer Academic Publ. 1993, pp 195-218.
*
*  [2] B. Kagstrom and P. Poromaa; Computing Eigenspaces with Specified
*      Eigenvalues of a Regular Matrix Pair (A, B) and Condition
*      Estimation: Theory, Algorithms and Software,
*      Report UMINF - 94.04, Department of Computing Science, Umea
*      University, S-901 87 Umea, Sweden, 1994. Also as LAPACK Working
*      Note 87. To appear in Numerical Algorithms, 1996.
*
*  [3] B. Kagstrom and P. Poromaa, LAPACK-Style Algorithms and Software
*      for Solving the Generalized Sylvester Equation and Estimating the
*      Separation between Regular Matrix Pairs, Report UMINF - 93.23,
*      Department of Computing Science, Umea University, S-901 87 Umea,
*      Sweden, December 1993, Revised April 1994, Also as LAPACK Working
*      Note 75.  To appear in ACM Trans. on Math. Software, Vol 22,
*      No 1, 1996.
*
*  =====================================================================
*
*     .. Parameters ..
      INTEGER            DIFDRI
      PARAMETER          ( DIFDRI = 3 )
      REAL               ZERO, ONE, TWO, FOUR
      PARAMETER          ( ZERO = 0.0E+0, ONE = 1.0E+0, TWO = 2.0E+0,
     $                   FOUR = 4.0E+0 )
*     ..
*     .. Local Scalars ..
      LOGICAL            LQUERY, PAIR, SOMCON, WANTBH, WANTDF, WANTS
      INTEGER            I, IERR, IFST, ILST, IZ, K, KS, LWMIN, N1, N2
      REAL               ALPHAI, ALPHAR, ALPRQT, BETA, C1, C2, COND,
     $                   EPS, LNRM, RNRM, ROOT1, ROOT2, SCALE, SMLNUM,
     $                   TMPII, TMPIR, TMPRI, TMPRR, UHAV, UHAVI, UHBV,
     $                   UHBVI
*     ..
*     .. Local Arrays ..
      REAL               DUMMY( 1 ), DUMMY1( 1 )
*     ..
*     .. External Functions ..
      LOGICAL            LSAME
      REAL               SDOT, SLAMCH, SLAPY2, SNRM2
      EXTERNAL           LSAME, SDOT, SLAMCH, SLAPY2, SNRM2
*     ..
*     .. External Subroutines ..
      EXTERNAL           SGEMV, SLACPY, SLAG2, STGEXC, STGSYL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, SQRT
*     ..
*     .. Executable Statements ..
*
*     Decode and test the input parameters
*
      WANTBH = LSAME( JOB, 'B' )
      WANTS = LSAME( JOB, 'E' ) .OR. WANTBH
      WANTDF = LSAME( JOB, 'V' ) .OR. WANTBH
*
      SOMCON = LSAME( HOWMNY, 'S' )
*
      INFO = 0
      LQUERY = ( LWORK.EQ.-1 )
*
      IF( .NOT.WANTS .AND. .NOT.WANTDF ) THEN
         INFO = -1
      ELSE IF( .NOT.LSAME( HOWMNY, 'A' ) .AND. .NOT.SOMCON ) THEN
         INFO = -2
      ELSE IF( N.LT.0 ) THEN
         INFO = -4
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -8
      ELSE IF( WANTS .AND. LDVL.LT.N ) THEN
         INFO = -10
      ELSE IF( WANTS .AND. LDVR.LT.N ) THEN
         INFO = -12
      ELSE
*
*        Set M to the number of eigenpairs for which condition numbers
*        are required, and test MM.
*
         IF( SOMCON ) THEN
            M = 0
            PAIR = .FALSE.
            DO 10 K = 1, N
               IF( PAIR ) THEN
                  PAIR = .FALSE.
               ELSE
                  IF( K.LT.N ) THEN
                     IF( A( K+1, K ).EQ.ZERO ) THEN
                        IF( SELECT( K ) )
     $                     M = M + 1
                     ELSE
                        PAIR = .TRUE.
                        IF( SELECT( K ) .OR. SELECT( K+1 ) )
     $                     M = M + 2
                     END IF
                  ELSE
                     IF( SELECT( N ) )
     $                  M = M + 1
                  END IF
               END IF
   10       CONTINUE
         ELSE
            M = N
         END IF
*
         IF( N.EQ.0 ) THEN
            LWMIN = 1
         ELSE IF( LSAME( JOB, 'V' ) .OR. LSAME( JOB, 'B' ) ) THEN
            LWMIN = 2*N*( N + 2 ) + 16
         ELSE
            LWMIN = N
         END IF
         WORK( 1 ) = LWMIN
*
         IF( MM.LT.M ) THEN
            INFO = -15
         ELSE IF( LWORK.LT.LWMIN .AND. .NOT.LQUERY ) THEN
            INFO = -18
         END IF
      END IF
*
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'STGSNA', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 )
     $   RETURN
*
*     Get machine constants
*
      EPS = SLAMCH( 'P' )
      SMLNUM = SLAMCH( 'S' ) / EPS
      KS = 0
      PAIR = .FALSE.
*
      DO 20 K = 1, N
*
*        Determine whether A(k,k) begins a 1-by-1 or 2-by-2 block.
*
         IF( PAIR ) THEN
            PAIR = .FALSE.
            GO TO 20
         ELSE
            IF( K.LT.N )
     $         PAIR = A( K+1, K ).NE.ZERO
         END IF
*
*        Determine whether condition numbers are required for the k-th
*        eigenpair.
*
         IF( SOMCON ) THEN
            IF( PAIR ) THEN
               IF( .NOT.SELECT( K ) .AND. .NOT.SELECT( K+1 ) )
     $            GO TO 20
            ELSE
               IF( .NOT.SELECT( K ) )
     $            GO TO 20
            END IF
         END IF
*
         KS = KS + 1
*
         IF( WANTS ) THEN
*
*           Compute the reciprocal condition number of the k-th
*           eigenvalue.
*
            IF( PAIR ) THEN
*
*              Complex eigenvalue pair.
*
               RNRM = SLAPY2( SNRM2( N, VR( 1, KS ), 1 ),
     $                SNRM2( N, VR( 1, KS+1 ), 1 ) )
               LNRM = SLAPY2( SNRM2( N, VL( 1, KS ), 1 ),
     $                SNRM2( N, VL( 1, KS+1 ), 1 ) )
               CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
     $                     WORK, 1 )
               TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
               TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS+1 ), 1,
     $                     ZERO, WORK, 1 )
               TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
               UHAV = TMPRR + TMPII
               UHAVI = TMPIR - TMPRI
               CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
     $                     WORK, 1 )
               TMPRR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
               TMPRI = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS+1 ), 1,
     $                     ZERO, WORK, 1 )
               TMPII = SDOT( N, WORK, 1, VL( 1, KS+1 ), 1 )
               TMPIR = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
               UHBV = TMPRR + TMPII
               UHBVI = TMPIR - TMPRI
               UHAV = SLAPY2( UHAV, UHAVI )
               UHBV = SLAPY2( UHBV, UHBVI )
               COND = SLAPY2( UHAV, UHBV )
               S( KS ) = COND / ( RNRM*LNRM )
               S( KS+1 ) = S( KS )
*
            ELSE
*
*              Real eigenvalue.
*
               RNRM = SNRM2( N, VR( 1, KS ), 1 )
               LNRM = SNRM2( N, VL( 1, KS ), 1 )
               CALL SGEMV( 'N', N, N, ONE, A, LDA, VR( 1, KS ), 1, ZERO,
     $                     WORK, 1 )
               UHAV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
               CALL SGEMV( 'N', N, N, ONE, B, LDB, VR( 1, KS ), 1, ZERO,
     $                     WORK, 1 )
               UHBV = SDOT( N, WORK, 1, VL( 1, KS ), 1 )
               COND = SLAPY2( UHAV, UHBV )
               IF( COND.EQ.ZERO ) THEN
                  S( KS ) = -ONE
               ELSE
                  S( KS ) = COND / ( RNRM*LNRM )
               END IF
            END IF
         END IF
*
         IF( WANTDF ) THEN
            IF( N.EQ.1 ) THEN
               DIF( KS ) = SLAPY2( A( 1, 1 ), B( 1, 1 ) )
               GO TO 20
            END IF
*
*           Estimate the reciprocal condition number of the k-th
*           eigenvectors.
            IF( PAIR ) THEN
*
*              Copy the  2-by 2 pencil beginning at (A(k,k), B(k, k)).
*              Compute the eigenvalue(s) at position K.
*
               WORK( 1 ) = A( K, K )
               WORK( 2 ) = A( K+1, K )
               WORK( 3 ) = A( K, K+1 )
               WORK( 4 ) = A( K+1, K+1 )
               WORK( 5 ) = B( K, K )
               WORK( 6 ) = B( K+1, K )
               WORK( 7 ) = B( K, K+1 )
               WORK( 8 ) = B( K+1, K+1 )
               CALL SLAG2( WORK, 2, WORK( 5 ), 2, SMLNUM*EPS, BETA,
     $                     DUMMY1( 1 ), ALPHAR, DUMMY( 1 ), ALPHAI )
               ALPRQT = ONE
               C1 = TWO*( ALPHAR*ALPHAR+ALPHAI*ALPHAI+BETA*BETA )
               C2 = FOUR*BETA*BETA*ALPHAI*ALPHAI
               ROOT1 = C1 + SQRT( C1*C1-4.0*C2 )
               ROOT2 = C2 / ROOT1
               ROOT1 = ROOT1 / TWO
               COND = MIN( SQRT( ROOT1 ), SQRT( ROOT2 ) )
            END IF
*
*           Copy the matrix (A, B) to the array WORK and swap the
*           diagonal block beginning at A(k,k) to the (1,1) position.
*
            CALL SLACPY( 'Full', N, N, A, LDA, WORK, N )
            CALL SLACPY( 'Full', N, N, B, LDB, WORK( N*N+1 ), N )
            IFST = K
            ILST = 1
*
            CALL STGEXC( .FALSE., .FALSE., N, WORK, N, WORK( N*N+1 ), N,
     $                   DUMMY, 1, DUMMY1, 1, IFST, ILST,
     $                   WORK( N*N*2+1 ), LWORK-2*N*N, IERR )
*
            IF( IERR.GT.0 ) THEN
*
*              Ill-conditioned problem - swap rejected.
*
               DIF( KS ) = ZERO
            ELSE
*
*              Reordering successful, solve generalized Sylvester
*              equation for R and L,
*                         A22 * R - L * A11 = A12
*                         B22 * R - L * B11 = B12,
*              and compute estimate of Difl((A11,B11), (A22, B22)).
*
               N1 = 1
               IF( WORK( 2 ).NE.ZERO )
     $            N1 = 2
               N2 = N - N1
               IF( N2.EQ.0 ) THEN
                  DIF( KS ) = COND
               ELSE
                  I = N*N + 1
                  IZ = 2*N*N + 1
                  CALL STGSYL( 'N', DIFDRI, N2, N1, WORK( N*N1+N1+1 ),
     $                         N, WORK, N, WORK( N1+1 ), N,
     $                         WORK( N*N1+N1+I ), N, WORK( I ), N,
     $                         WORK( N1+I ), N, SCALE, DIF( KS ),
     $                         WORK( IZ+1 ), LWORK-2*N*N, IWORK, IERR )
*
                  IF( PAIR )
     $               DIF( KS ) = MIN( MAX( ONE, ALPRQT )*DIF( KS ),
     $                           COND )
               END IF
            END IF
            IF( PAIR )
     $         DIF( KS+1 ) = DIF( KS )
         END IF
         IF( PAIR )
     $      KS = KS + 1
*
   20 CONTINUE
      WORK( 1 ) = LWMIN
      RETURN
*
*     End of STGSNA
*
      END


program test_it_min_vw2
! Test free energy minimization with the von Weizsäcker term handled by first
! adding it in a split-operator method (handled by fft in reciprocal space) and
! then subtracting it in the real space potential. For a given time step dt,
! the imaginary time (IT) iterations will converge towards a value. This value
! is only O(dt^4) accurate with respect to the truly converged answer with
! conjugate gradients (CG). We test a larger dt, which gives low accuracy. For
! more accurate answer, lower the dt variable, and increase the number of IT
! steps. Converged (1e-12) value seems to be achieved with dt=1e-5 and about
! 400,000 time steps. That takes a long time, so the default parameters in this
! test are for a low accuracy case, in order for it to run fast.
use types, only: dp
use constants, only: Ha2eV, i_
use fourier, only: dft, idft, fft, fft_vectorized, fft_pass, fft_pass_inplace, &
        fft_vectorized_inplace, calculate_factors, ifft_pass, fft2_inplace, &
        fft3_inplace, ifft3_inplace
use utils, only: assert, init_random, stop_error, get_int_arg, get_float_arg, &
    allocate_mold, clock
use ffte, only: factor
use ofdft, only: read_pseudo
use pofdft_fft, only: pfft3_init, preal2fourier, pfourier2real, &
    real_space_vectors, reciprocal_space_vectors, calculate_myxyz, &
    pintegral, pintegralG, free_energy, free_energy_min, &
    radial_potential_fourier, psum, pmaxval
use openmp, only: omp_get_wtime
use mpi2, only: mpi_finalize, MPI_COMM_WORLD, mpi_comm_rank, &
    mpi_comm_size, mpi_init, mpi_comm_split, MPI_INTEGER, &
    mpi_barrier, MPI_DOUBLE_PRECISION, mpi_bcast
use md, only: positions_bcc
implicit none

complex(dp), dimension(:,:,:), allocatable :: neG, VenG, psiG
real(dp), dimension(:,:,:), allocatable :: G2, Hn, Ven0G, ne, Ven, psi
real(dp), allocatable :: G(:,:,:,:), X(:,:,:,:), Xion(:,:), R(:), Ven_rad(:)
real(dp) :: L(3), Z, Eee_conv
integer :: i, j, k
integer :: Ng(3)
real(dp) :: t1, t2, t3
integer :: LNPU(3)
integer :: cg_iter, natom, u
real(dp) :: T_eV, T_au, Eee, Een, Ts, Exc, Etot, Ediff, V0, mu, Etot_conv32, &
    mu_conv32, mu_Hn, dt, psi_norm, t, Hn_mu_diff, Etot_it, EvW, &
    lambda

!  parallel variables
integer :: comm_all, commy, commz, nproc, ierr, nsub(3), Ng_local(3)
integer :: myid ! my ID (MPI rank), starts from 0
integer :: myxyz(3) ! myid, converted to the (x, y, z) box, starts from 0

T_eV = 34.5_dp
T_au = T_ev / Ha2eV
natom = 128
L = 8.1049178668765851_dp
lambda = 1._dp/9

call mpi_init(ierr)
comm_all  = MPI_COMM_WORLD
call mpi_comm_rank(comm_all, myid, ierr)
call mpi_comm_size(comm_all, nproc, ierr)
if (myid == 0) then
    if (command_argument_count() == 0) then
        call factor(nproc, LNPU)
        nsub(3) = (2**(LNPU(1)/2))*(3**(LNPU(2)/2))*(5**(LNPU(3)/2))
        nsub(2) = nproc / nsub(3)
        nsub(1) = 1
        Ng = 32
    else
        if (command_argument_count() /= 6) then
            print *, "Usage:"
            print *
            print *, "test_ffte_par Ng(3) nsub(3)"
            call stop_error("Incorrect number of arguments.")
        end if
        Ng(1) = get_int_arg(1)
        Ng(2) = get_int_arg(2)
        Ng(3) = get_int_arg(3)
        nsub(1) = get_int_arg(4)
        nsub(2) = get_int_arg(5)
        nsub(3) = get_int_arg(6)
    end if
    Ng_local = Ng / nsub

    print *, "L:       ", L
    print *, "nproc:   ", nproc
    print *, "nsub:    ", nsub
    print *, "Ng:      ", Ng
    print *, "Ng_local:", Ng_local

    if (product(nsub) /= nproc) then
        call stop_error("nproc must be equal to the number of subdomains")
    end if
end if
call mpi_bcast(nsub, size(nsub), MPI_INTEGER, 0, comm_all, ierr)
call mpi_bcast(Ng, size(Ng), MPI_INTEGER, 0, comm_all, ierr)
call mpi_bcast(Ng_local, size(Ng_local), MPI_INTEGER, 0, comm_all, ierr)
call pfft3_init(myid, comm_all, Ng, nsub)

myxyz = calculate_myxyz(myid, nsub)

! Note that myxyz(3) corresponds to commy, and myxyz(2) to commz
call mpi_comm_split(comm_all, myxyz(3), 0, commy, ierr)
call mpi_comm_split(comm_all, myxyz(2), 0, commz, ierr)

allocate(ne(Ng_local(1), Ng_local(2), Ng_local(3)))
allocate(neG(Ng_local(1), Ng_local(2), Ng_local(3)))
call allocate_mold(G2, ne)
call allocate_mold(Hn, ne)
call allocate_mold(Ven, ne)
call allocate_mold(Ven0G, ne)
call allocate_mold(VenG, neG)
call allocate_mold(psiG, neG)
call allocate_mold(psi, ne)
allocate(X(Ng_local(1), Ng_local(2), Ng_local(3), 3))
allocate(G(Ng_local(1), Ng_local(2), Ng_local(3), 3))
if (myid == 0) print *, "Load initial position"
allocate(Xion(3, natom))
! For now assume a box, until positions_bcc can accept a vector L(:)
! And radial_potential_fourier
call assert(abs(L(2)-L(1)) < 1e-15_dp)
call assert(abs(L(3)-L(1)) < 1e-15_dp)
call positions_bcc(Xion, L(1))
call real_space_vectors(L, X, Ng, myxyz)
call reciprocal_space_vectors(L, G, G2, Ng, myxyz)
if (myid == 0) print *, "Radial nuclear potential FFT"
call read_pseudo("../fem/D.pseudo", R, Ven_rad, Z, Ediff)
call radial_potential_fourier(R, Ven_rad, L, Z, G2, Ven0G, V0)
if (myid == 0) print *, "    Done."

VenG = 0
do i = 1, natom
    VenG = VenG - Ven0G * exp(-i_ * &
        (G(:,:,:,1)*Xion(1,i) + G(:,:,:,2)*Xion(2,i) + G(:,:,:,3)*Xion(3,i)))
end do

! Minimization

ne = natom / product(L)

call free_energy(myid, comm_all, commy, commz, Ng, nsub, &
        L, G2, T_au, VenG, ne, Eee, Een, Ts, Exc, Etot, Hn, &
        .true., .true., .true., lambda, lambda-1, EvW)

mu = psum(comm_all, Hn)/product(Ng)
Hn_mu_diff = pmaxval(comm_all, abs(Hn - mu))
if (myid == 0) then
    print *, "Etot =", Etot
    print *, "mu = ", mu
    print *, "max(abs(H-mu)) = ", Hn_mu_diff
end if
call assert(all(ne > 0))

if (myid == 0) then
    print *
    print *, "------------------------------------------------------------------"
    print *, "Propagation"
end if

! Propagate

if (myid == 0) then
    print *, "E_max =", maxval(abs(Hn)), "; dt <", 1/maxval(abs(Hn))
end if
dt = 5e-3_dp
if (myid == 0) then
    print *, "dt =", dt
end if

! Do first step by hand:
if (myid == 0) print *, "First step"
psi = sqrt(ne)

t = 0

psi = psi * exp(-Hn*dt/2)
call preal2fourier(psi, psiG, commy, commz, Ng, nsub)
psiG = psiG * exp(-G2*dt/2)
call pfourier2real(psiG, psi, commy, commz, Ng, nsub)
psi = psi * exp(-Hn*dt/2)

ne = psi**2
psi_norm = pintegral(comm_all, L, ne, Ng)
if (myid == 0) print *, "Initial norm of psi:", psi_norm
psi = sqrt(natom / psi_norm) * psi
ne = psi**2
psi_norm = pintegral(comm_all, L, ne, Ng)
if (myid == 0) print *, "norm of psi:", psi_norm

do i = 1, 300
    t = t + dt
    if (myid == 0) print *, "iter =", i, "time =", t
    psi = psi * exp(-Hn*dt/2)
    call preal2fourier(psi, psiG, commy, commz, Ng, nsub)
    psiG = psiG * exp(-G2*dt/2)
    call pfourier2real(psiG, psi, commy, commz, Ng, nsub)
    psi = psi * exp(-Hn*dt/2)
    ne = psi**2
    psi_norm = pintegral(comm_all, L, ne, Ng)
    if (myid == 0) print *, "Initial norm of psi:", psi_norm
    psi = sqrt(natom / psi_norm) * psi
    ne = psi**2
    psi_norm = pintegral(comm_all, L, ne, Ng)
    if (myid == 0) print *, "norm of psi:", psi_norm
    call assert(all(ne > 0))

    call free_energy(myid, comm_all, commy, commz, Ng, nsub, &
            L, G2, T_au, VenG, ne, Eee, Een, Ts, Exc, Etot, Hn, &
            .true., .true., .true., lambda, lambda-1, EvW)

    mu = 1._dp / natom * pintegral(comm_all, L, ne * Hn, Ng)
    mu_Hn = psum(comm_all, Hn)/product(Ng)
    if (myid == 0) then
        print *, mu, mu_Hn
        print *, "Summary of energies [a.u.]:"
        print "('    EvW  = ', f14.8)", EvW
        print "('    Ts   = ', f14.8)", Ts
        print "('    Een  = ', f14.8)", Een
        print "('    Eee  = ', f14.8)", Eee
        print "('    Exc  = ', f14.8)", Exc
        print *, "   ---------------------"
        print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV
    end if
end do
if (myid == 0) print *, "Done"

! Converged values for 32^3 PW
Etot_conv32 = -162.58659306421535_dp
mu_conv32 = 96.415580964855209_dp / product(L)

Etot_it = Etot

if (myid == 0) then
    print *, "Etot: ", Etot_it
    print *, "mu:", mu
    print *, "mu_Hn:", mu_Hn
    print *, "abs(mu-mu_Hn):", abs(mu - mu_Hn)
    if (all(Ng == [32, 32, 32])) then
        print *, "Ng=32^3, compare to gold result"
        print *, "abs(Etot - Etot_conv32) =", abs(Etot - Etot_conv32)
        print *, "abs(mu - mu_conv32) =", abs(mu - mu_conv32)
        print *, "abs(mu_Hn - mu_conv32) =", abs(mu_Hn - mu_conv32)
!        call assert(abs(Etot - Etot_conv32) < 5e-11_dp)
!        call assert(abs(mu - mu_conv32) < 1e-12_dp)
    end if
!    call assert(abs(mu - mu_Hn) < 1e-12_dp)
end if

! Now compare against CG minimization
if (myid == 0) print *, "CG minimization:"
ne = natom / product(L)
call free_energy_min(myid, comm_all, commy, commz, Ng, nsub, &
        real(natom, dp), natom, L, G2, T_au, VenG, ne, 1e-12_dp, &
        Eee, Een, Ts, Exc, Etot, cg_iter, .true., lambda, EvW)
call free_energy(myid, comm_all, commy, commz, Ng, nsub, &
        L, G2, T_au, VenG, ne, Eee, Een, Ts, Exc, Etot, Hn, &
        .true., .true., .true., lambda, lambda, EvW)

mu = 1._dp / natom * pintegral(comm_all, L, ne * Hn, Ng)
mu_Hn = psum(comm_all, Hn)/product(Ng)
if (myid == 0) then
    print *, mu, mu_Hn
    print *, "Summary of energies [a.u.]:"
    print "('    EvW  = ', f14.8)", EvW
    print "('    Ts   = ', f14.8)", Ts
    print "('    Een  = ', f14.8)", Een
    print "('    Eee  = ', f14.8)", Eee
    print "('    Exc  = ', f14.8)", Exc
    print *, "   ---------------------"
    print "('    Etot = ', f14.8, ' a.u. = ', f14.8, ' eV')", Etot, Etot*Ha2eV

    print *, "abs(Etot-Etot_it):", abs(Etot-Etot_it)
    print *, "abs(mu-mu_Hn):", abs(mu - mu_Hn)
    if (all(Ng == [32, 32, 32])) then
        print *, "Ng=32^3, compare to gold result"
        print *, "Etot:", Etot, abs(Etot - Etot_conv32)
        print *, "mu:", mu, abs(mu - mu_conv32)
        print *, "mu_Hn:", mu_Hn, abs(mu_Hn - mu_conv32)
        call assert(abs(Etot - Etot_conv32) < 1e-11_dp)
!        call assert(abs(mu - mu_conv32) < 5e-8_dp)
    end if
    call assert(abs(Etot-Etot_it) < 1.3e-2_dp)
    call assert(abs(mu - mu_Hn) < 2e-8_dp)
end if

call mpi_finalize(ierr)
end program


*dk,taylor_error
      subroutine taylor_error(fieldname,badval,iparent)
C     #####################################################################
C
C     PURPOSE -
C
C     ERROR_EST generates an attribute with edges whose H1 seminorm
C     of the error
C     between a function with specified piecewise constant
C     Hessian and the piecewise linear approximation over the
C     tetrahedra is greater than badval.  The attribute contains
C     10* element number + edge number.  The name of the attribute
C     is quality_taylor.  The length of this array is stored in
C     the attribute quality_taylor_len.  The
C     seminorm functional is evaluated over the polyhedron
C     consisting of the union of tetrahedra sharing node NODE.
C     The functional being used
C     here is a generalization to 3D of the 2D analysis
C     of Bank and Smith.)
C
C     INPUT ARGUMENTS -
C
C     ITET  -  The itet array for the tetrahedral mesh considered.
C     X,Y,Z -  The xic, yic, zic arrays for the tet mesh.
C     NODE  -  The node over whose polyhedron we evaluate the
C        functional.
C     FVEC - Values at the nodes of the adaption function.
C
C     OUTPUT ARGUMENTS -
C
C     PF       The value of the smoothing functional.
C     PFX, ... First derivatives of the smoothing functional.
C     PFXX,... Second derivatives of the smoothing functional.
C
C     CHANGE HISTORY -
C$Log: taylor_error.f,v $
CRevision 2.00  2007/11/09 20:04:04  spchu
CImport to CVS
C
CPVCS
CPVCS       Rev 1.2   Fri Jan 22 16:51:28 1999   dcg
CPVCS    remove duplicate declaration
CPVCS
CPVCS       Rev 1.1   Wed Sep 03 11:32:26 1997   dcg
CPVCS    change output format for max error
CPVCS
CPVCS       Rev 1.0   Fri Aug 29 14:05:14 1997   dcg
CPVCS    Initial revision.
C
C     ######################################################################
      implicit none
      include 'consts.h'
      include 'local_element.h'

      integer lenptr
      parameter (lenptr=1000000)

      character*132 cbuff
      character* 132 logmess

      character*32 fieldname
      real*8 badval

      pointer (ipfvecx,fvecx),(ipfvecy,fvecy),(ipfvecz,fvecz)
      pointer (ipwt,wt),(ipldivide,ldivide)
      logical ldivide(lenptr)
      real*8 fvecx(lenptr),fvecy(lenptr),fvecz(lenptr)
      real*8 wt(lenptr)
      pointer (iphxx,hxx),(iphxy,hxy),(iphxz,hxz)
      pointer (iphyy,hyy),(iphyz,hyz)
      pointer (iphzz,hzz)
      real*8 hxx(lenptr),hxy(lenptr),hxz(lenptr),hyy(lenptr)
      real*8 hyz(lenptr),hzz(lenptr)
      real*8 crosx,crosy,crosz
      real*8 x1,y1,z1,x2,y2,z2,x3,y3,z3
      real*8 afac(3,4),vol6
      real*8 ssq
      real*8 ex,ey,ez
      real*8 edgerr,edgerrid
      pointer (ipxic,xic),(ipyic,yic),(ipzic,zic)
      real*8 xic(lenptr),yic(lenptr),zic(lenptr)
      pointer (ipreffield,reffield)
      real*8 reffield(lenptr)
      integer iparent(lenptr)

      integer i,i1,i2,i3,i4,k,k1
      integer it,ielmtyp,ipar
      integer loc2,loc3,loc4
      integer icscode
      integer nelements,nnodes
      real*8 volwt
      real*8 v1,v1id,h1,h1id

      real*8 xmin,xmax,ymin,ymax,zmin,zmax,epsilona,epsilonv
      pointer(ipitetoff,itetoff),(ipitettyp,itettyp),(ipitet,itet)
      integer itetoff(lenptr),itet(lenptr),itettyp(lenptr)

      integer badedges(lenptr), numbadedges, quality_taylor(lenptr)
      pointer (ipbadedges,badedges),(ipquality_taylor,quality_taylor)
      real*8 maxerror

      integer ier,ilen,ityp

      character*32 cmo,isubname

c...  Statement functions for the components of the cross product
c...  ((x2,y2,z2)-(x1,y1,z1)) X ((x3,y3,z3)-(x1,y1,z1)) .

      crosx(x1,y1,z1,x2,y2,z2,x3,y3,z3)=(y2-y1)*(z3-z1)-(z2-z1)*(y3-y1)
      crosy(x1,y1,z1,x2,y2,z2,x3,y3,z3)=(z2-z1)*(x3-x1)-(x2-x1)*(z3-z1)
      crosz(x1,y1,z1,x2,y2,z2,x3,y3,z3)=(x2-x1)*(y3-y1)-(y2-y1)*(x3-x1)

      isubname='error_est'
      maxerror = 0.

      call cmo_get_name(cmo,ier)
      if (ier .ne. 0) then
         write(logmess,"('No current mesh object')")
         call writloga('default',0,logmess,0,icscode)
         return
      endif
      call cmo_get_info('nnodes',cmo,nnodes,ilen,ityp,ier)
      call cmo_get_info('nelements',cmo,nelements,ilen,ityp,ier)
      call cmo_get_info('itettyp',cmo,ipitettyp,ilen,ityp,ier)
      call cmo_get_info('itetoff',cmo,ipitetoff,ilen,ityp,ier)
      call cmo_get_info('itet',cmo,ipitet,ilen,ityp,ier)
      call cmo_get_info('xic',cmo,ipxic,ilen,ityp,ier)
      call cmo_get_info('yic',cmo,ipyic,ilen,ityp,ier)
      call cmo_get_info('zic',cmo,ipzic,ilen,ityp,ier)

      call cmo_get_info(fieldname,cmo,ipreffield,ilen,ityp,ier)
      if (ier .ne. 0) then
         write (logmess,"('Couldnt get field')")
         call writloga('default',0,logmess,0,icscode)
      endif

      call mmgetblk('fvecx',isubname,ipfvecx,nnodes,2,ier)
      call mmgetblk('fvecy',isubname,ipfvecy,nnodes,2,ier)
      call mmgetblk('fvecz',isubname,ipfvecz,nnodes,2,ier)
      call mmgetblk('wt',isubname,ipwt,nnodes,2,ier)
      call mmgetblk('ldivide',isubname,ipldivide,nnodes,1,ier)
      call mmgetblk('hxx',isubname,iphxx,nelements,2,ier)
      call mmgetblk('hxy',isubname,iphxy,nelements,2,ier)
      call mmgetblk('hxz',isubname,iphxz,nelements,2,ier)
      call mmgetblk('hyy',isubname,iphyy,nelements,2,ier)
      call mmgetblk('hyz',isubname,iphyz,nelements,2,ier)
      call mmgetblk('hzz',isubname,iphzz,nelements,2,ier)

      call setsize()
      call getsize(xmin,xmax,ymin,ymax,zmin,zmax,epsilona,
     *             epsilonv)

      do i=1,nnodes
         fvecx(i)=0.
         fvecy(i)=0.
         fvecz(i)=0.
         wt(i)=0.
      enddo

      numbadedges = 0
      call mmgetblk('badedges',isubname,ipbadedges,
     *                        nelements*6,1,ier)

c.... Loop over all elements in mesh.  Distribute gradients to
c.... parent nodes weighted by element volumes.

      do i=1,nelements
         ielmtyp=itettyp(i)

c.... Loop over all four faces of tet and compute area vectors.

         do k=1,4
            loc2=ielmface1(1,k,ielmtyp)
            loc3=ielmface1(2,k,ielmtyp)
            loc4=ielmface1(3,k,ielmtyp)
            i2=itet(loc2+itetoff(i))
            i3=itet(loc3+itetoff(i))
            i4=itet(loc4+itetoff(i))
            afac(1,k)=crosx(xic(i2),yic(i2),zic(i2),xic(i3),
     &                yic(i3),zic(i3),xic(i4),yic(i4),zic(i4))
            afac(2,k)=crosy(xic(i2),yic(i2),zic(i2),xic(i3),
     &                yic(i3),zic(i3),xic(i4),yic(i4),zic(i4))
            afac(3,k)=crosz(xic(i2),yic(i2),zic(i2),xic(i3),
     &                yic(i3),zic(i3),xic(i4),yic(i4),zic(i4))
         enddo

c.... Compute the volume of the tet.

         i1=itet(1 + itetoff(i))
         i2=itet(2 + itetoff(i))
         vol6=afac(1,1)*(xic(i2)-xic(i1))+
     &        afac(2,1)*(yic(i2)-yic(i1))+afac(3,1)*(zic(i2)-zic(i1))

c.... If the volume is bigger than EPSILONV, we compute the gradient of
c.... this tet and distribute this value to the four nodes, weighted
c.... by the volume times the tet weight.

         if (vol6.gt.6.*epsilonv) then
            do k=1,4
               ipar=iparent(itet(k + itetoff(i)))
               do k1=1,4
                  i1=itet(k1 + itetoff(i))
                  fvecx(ipar)=fvecx(ipar) - reffield(i1)*afac(1,k1)
                  fvecy(ipar)=fvecy(ipar) - reffield(i1)*afac(2,k1)
                  fvecz(ipar)=fvecz(ipar) - reffield(i1)*afac(3,k1)
               enddo
               wt(ipar)=wt(ipar) + vol6
            enddo
         endif
      enddo

      do i=1,nnodes
         ldivide(i)=.false.
      enddo
      do i=1,nnodes
         ipar=iparent(i)
         if (wt(ipar).gt.zero) then
            ldivide(ipar)=.true.
         endif
      enddo
      do i=1,nnodes
         ipar=iparent(i)
         if (ldivide(ipar)) then
            ldivide(ipar)=.false.
            fvecx(ipar)=fvecx(ipar)/wt(ipar)
            fvecy(ipar)=fvecy(ipar)/wt(ipar)
            fvecz(ipar)=fvecz(ipar)/wt(ipar)
         endif
      enddo

c.... Loop over elements used in computation and compute Hessians
c.... and regularization strengths for each element.

      do it=1,nelements
         ielmtyp=itettyp(it)
         hxx(it)=0.
         hxy(it)=0.
         hxz(it)=0.
         hyy(it)=0.
         hyz(it)=0.
         hzz(it)=0.
         volwt=0.

c.... Loop over all four faces and compute the sum of squares
c.... of area vectors.

         ssq=0.
         do i=1,4
            loc2=ielmface1(1,i,ielmtyp)
            loc3=ielmface1(2,i,ielmtyp)
            loc4=ielmface1(3,i,ielmtyp)
            i2=itet(loc2 + itetoff(it))
            i3=itet(loc3 + itetoff(it))
            i4=itet(loc4 + itetoff(it))
            afac(1,i)=crosx(xic(i2),yic(i2),zic(i2),xic(i3),
     &           yic(i3),zic(i3),xic(i4),yic(i4),zic(i4))
            afac(2,i)=crosy(xic(i2),yic(i2),zic(i2),xic(i3),
     &           yic(i3),zic(i3),xic(i4),yic(i4),zic(i4))
            afac(3,i)=crosz(xic(i2),yic(i2),zic(i2),xic(i3),
     &           yic(i3),zic(i3),xic(i4),yic(i4),zic(i4))
            ssq=ssq+afac(1,i)**2+afac(2,i)**2+afac(3,i)**2
         enddo

c.... Compute the volume of the tet.

         i1=itet(1 + itetoff(it))
         i2=itet(2 + itetoff(it))
         vol6=afac(1,1)*(xic(i2)-xic(i1))+
     &        afac(2,1)*(yic(i2)-yic(i1))+afac(3,1)*(zic(i2)-zic(i1))

c.... If the volume is bigger than EPSILONV, we compute the Hessian of
c.... this tet.  The Hessian is computed by differencing the
c.... node values of the first derivatives in FVECX, FVECY, and FVECZ.
c.... Since we are computing a weighted sum of Hessians of tetrahedra, we
c.... then multiply by the weights.  The weight is equal to the
c.... volume of the tet.

         if (vol6.gt.6.*epsilonv) then
            do i=1,4
               ipar=iparent(itet(i + itetoff(it)))
               hxx(it)=hxx(it) - fvecx(ipar)*afac(1,i)
               hxy(it)=hxy(it) - fvecx(ipar)*afac(2,i)
               hxz(it)=hxz(it) - fvecx(ipar)*afac(3,i)
               hyy(it)=hyy(it) - fvecy(ipar)*afac(2,i)
               hyz(it)=hyz(it) - fvecy(ipar)*afac(3,i)
               hzz(it)=hzz(it) - fvecz(ipar)*afac(3,i)
            enddo

            volwt=volwt + vol6

         else

c.... If the volume of the tet is bad, we don't bother computing
c.... a Hessian for the tet, and we compute a 'geometry factor'
c.... equal to the sum of squares of the area vectors divided by
c.... the epsilon volume.  (If the tet was good, we would divide
c.... by the true volume.)  The idea is to compute a LARGE
c.... (but numerically stable) geometry factor which gives the
c.... algorithm a chance to fix the tet.

         endif

c.... Now divide through the sum of Hessians by the sum of weights
c.... to get an average Hessian for the element.

         hxx(it)=hxx(it)/volwt
         hxy(it)=hxy(it)/volwt
         hxz(it)=hxz(it)/volwt
         hyy(it)=hyy(it)/volwt
         hyz(it)=hyz(it)/volwt
         hzz(it)=hzz(it)/volwt

c.... We now compute for the current element the
c.... value of the functional using the true adaption function,
c.... and the value of the functional using the Identity matrix
c.... for a Hessian.  This will allow us to calculate a regularization
c.... strength for the element.  This reg. strength is the ratio between
c.... the two functional values.  The calculation of the functional
c.... over the element is performed by doing a weighted sum of
c.... functional values over the virtual tets in the element.

C         do loctet=1,itnumtetv(itettyp(it))

c...  Compute the edge errors over the edges {1,...,6}.

         edgerr = 0
         edgerrid = 0
         do i = 1,nelmnee(ielmtyp)
            i1 = itet(ielmedge1(1,i,ielmtyp) + itetoff(it))
            i2 = itet(ielmedge1(2,i,ielmtyp) + itetoff(it))

            ex=xic(i2)-xic(i1)
            ey=yic(i2)-yic(i1)
            ez=zic(i2)-zic(i1)
            v1=ex*(hxx(it)*ex+2.*hxy(it)*ey+2.*hxz(it)*ez)+
     &           ey*(hyy(it)*ey+2.*hyz(it)*ez)+ez*hzz(it)*ez
            v1id=ex*ex+ey*ey+ez*ez
            edgerr = edgerr + v1**2
            edgerrid = edgerrid + v1id**2
            if (abs(v1) .gt. badval) then
               numbadedges = numbadedges + 1
               badedges(numbadedges) = 10*it + i
            endif
            if (abs(v1) .gt. maxerror) then
               maxerror = abs(v1)
            endif
         enddo

C...  Compute the sum of squares of edge errors, and sum of squares of
c...  edge errors if we assume the Hessian is equal to the identity.

         h1=h1 + edgerr
         h1id=h1id + edgerrid
C     enddo

      enddo
C
C  Write error info
      write(logmess,"('Max abs Taylor error = ',e18.13)") maxerror
      call writloga('default',0,logmess,0,icscode)

      cbuff='cmo/addatt//quality_taylor_len/INT/' //
     *     'scalar/scalar/constant//x/0' //
     *     ' ; finish'
      call dotaskx3d(cbuff,ier)
      if (ier .ne. 0) then
         write (logmess,"('Couldnt create length attribute')")
         call writloga('default',0,logmess,0,icscode)
      endif
      call cmo_set_info('quality_taylor_len',cmo,
     *                    numbadedges,1,1,ier)
      if (ier .ne. 0) then
         write (logmess,"('Couldnt set length attribute')")
         call writloga('default',0,logmess,0,icscode)
      endif

      if (numbadedges .gt. 0) then
         cbuff='cmo/addatt//quality_taylor/VINT/' //
     *        'scalar/quality_taylor_len/constant//x/0' //
     *        ' ; finish'
         call dotaskx3d(cbuff,ier)
         if (ier .ne. 0) then
            write (logmess,"('Couldnt create attribute')")
            call writloga('default',0,logmess,0,icscode)
         endif
         call mmgetpr('quality_taylor',cmo,ipquality_taylor,ier)
         if (ier .ne. 0) then
            write (logmess,"('Couldnt access attribute')")
            call writloga('default',0,logmess,0,icscode)
         endif

         do i=1,numbadedges
            quality_taylor(i) = badedges(i)
         enddo
      endif

 9999 continue

      call mmrelprt(isubname,icscode)
      return
      end