c     ==========================================================================

	double precision function SphericalDistance(RA_SUN,DEC_SUN,RA,DEC)
c 	Compute the distance on the great circle.
c 	Computations are based upon
c	http://en.wikipedia.org/wiki/Great-circle_distance#Formulas
c	This is the *Angular* spherical distance in radians

	implicit none
	double precision RA_SUN, DEC_SUN, RA, DEC
	double precision ls, lf, ps, pf, dl, dp, num1, num2, den1, den2
	double precision num, den, angular_distance

	ls = RA_SUN
	lf = RA

	ps = DEC_SUN
	pf = DEC

	dl = lf-ls
	dp = pf-ps

	num1 = dcos(pf) * dsin(dl)
	num2 = dcos(ps) * dsin(pf) - dsin(ps)*dcos(pf)*dcos(dl)

	den1 = dsin(ps) * dsin(pf)
	den2 = dcos(ps) * dcos(pf) * dcos(dl)

	num = dsqrt(num1 * num1 + num2 * num2)
	den = den1 + den2

	SphericalDistance = datan2(num,den)

	return

	end

c     ==========================================================================
      subroutine ILLUMINATED_EARTH(RA_SUN, DEC_SUN, !Input
     &                             day_night)       !Output
c     Calculate the equatorial coordinates of the illuminated Earth
c	Compute which part of the Earth is illuminated and with what intensity
c	(in arbitrary unit between 0 (total night) and 1 (zenith)) and outputs
c	the results in a table of the size of Earth's grid (n_alpha x n_delta).

      implicit none
      include 'constants'
      include 'parameters'

	double precision RA_SUN, DEC_SUN
	double precision day_night(1:n_alpha, 1:n_delta)
	double precision SphericalDistance
	double precision alpha_grid, delta_grid, dist
      integer k, j

	do k = 1, n_alpha
	  alpha_grid = 2.d0*pi*dble(k-1)/dble(n_alpha-1)
	  do j = 1, n_delta
	    delta_grid = -pi/2.d0+dble(j-1)*pi/dble(n_delta-1)

c	    This is the *Angular* spherical distance
	    dist = SphericalDistance(RA_SUN,DEC_SUN,alpha_grid,delta_grid)

	    if (dist <= pi/2.) then
c		Compute correct illumination of a given cell on the Earth's surface
		if (gradient) then
		  day_night(k,j) = day * dcos(dist)
		else
		  day_night(k,j) = day
		endif
	    else
c		Initialise the rest of the table.
		day_night(k,j) = night
	    endif

	  enddo
	enddo

	if (log_all_data) then
	  call write_illuminated_earth(day_night)
	endif

      return
      end

c     ==========================================================================
      subroutine EARTH_SEEN_FROM_SAT (SAT, RA_SAT, DEC_SAT, day_night,	!Input
     &                                coord_illum)
c	Returns the coordinates of the cells of the Earths that are 1) in daylight
c	and 2) visible the the satellite.               	!Output

      implicit none
      include 'constants'
      include 'parameters'

      double precision SAT(1:3), RA_SAT, DEC_SAT, R_SAT
	double precision alpha_grid, delta_grid
      double precision alpha, SphericalDistance, dist
      double precision RA_LIMIT(1:n_alpha), DEC_LIMIT(1:n_alpha)
      double precision coord_illum(1:n_alpha, 1:n_delta)
      double precision day_night(1:n_alpha, 1:n_delta)
	integer j, k

c	Get the norm of the vector SAT to get its distance to Earth's center.
      call R_3D(SAT, R_SAT)

c     We look for the limit coordinates of the Earth seen by the satellite
c	alpha is the half-angle cone centred on the satellite containing the Earth
c	which is the horizon as seen by the satellite.

c	alpha is computed from the centre of the Earth !!
      alpha = acos(R_Earth/R_SAT)

c     We look for the coordinates of the Earth seen by the satellite

	do k = 1, n_alpha
	  alpha_grid = 2.d0*pi*dble(k-1)/dble(n_alpha-1)
	  do j = 1, n_delta
	    delta_grid = -pi/2.d0+dble(j-1)*pi/dble(n_delta-1)

	    dist = SphericalDistance(RA_SAT,DEC_SAT,alpha_grid,delta_grid)

	    if (dist <= alpha .and. day_night(k,j).ne.night) then
		coord_illum(k,j) = seen
	    else
c		Initialise the rest of the table.
		coord_illum(k,j) = night
	    endif
	  enddo
	enddo

	if (log_all_data) then
	  call write_seen(coord_illum)
	endif

      return
      end

c     ==========================================================================
      subroutine PHOTONS_AT_TELESCOPE(coord_illum, 				!Input
     &     RA_STAR, DEC_STAR, SAT,
     &     coord_photons, photons_hit, angle_photons, pst_photons,error)!Output

      implicit none
      include 'constants'
      include 'parameters'

      double precision coord_photons(1:n_alpha,1:n_delta)
      double precision coord_illum(1:n_alpha,1:n_delta)
      double precision angle_photons(1:n_alpha,1:n_delta)
      double precision pst_photons(1:n_alpha,1:n_delta)
      double precision prod, d, alpha_grid, delta_grid,d_cross
      double precision V(1:3), SAT(1:3), CELL(1:3)
      double precision angle_dat, pst_result
	double precision RA_STAR, DEC_STAR, R_STAR, STAR(1:3), vprod(1:3)
      double precision angle(n_ang), pst(n_ang)
      double precision min_angle_pst
	double precision a,b

      integer i, j, k
      logical photons_hit, error

      common /PST/ angle, pst, min_angle_pst

      error = .false.

      photons_hit = .false.

      R_STAR = 1.d0

	call CARTESIAN_COORDINATES(RA_STAR, DEC_STAR, R_STAR, !Input
     &     star) !Output

      do i = 1, n_alpha

         do j = 1, n_delta

            if(coord_illum(i,j).eq.illum) then
               alpha_grid= 2.d0*pi*dble(i-1)/dble(n_alpha-1)
               delta_grid= -pi/2.d0 + dble(j-1)*pi/dble(n_delta-1)

               call CARTESIAN_COORDINATES(alpha_grid, delta_grid,
     &              R_Earth ,   !Input
     &              CELL)	  !Output

c		   Get the normalised vector pointing to the cell from the sat.
               call VEC_SUBSTRACTION(SAT, CELL, V)
               call R_3D(V, d)
		   V = V / d

               call scalar_product(V, STAR, prod)
		   call vect_product(STAR, V, vprod)
               call R_3D(vprod, d_cross)

               if(datan(d_cross/prod).gt.0) then
                  coord_photons(i,j) = night !no photons hit the telescope
               else
                 photons_hit = .true.
                 coord_photons(i,j) = hit !photons hit the telescope

                 a = datan(d_cross/prod)*RAD
		     b = datan2(d_cross,prod)*RAD

                 a = pi/2.+datan(d_cross/prod)
		     b = pi/2.-(datan2(d_cross,prod)-pi/2.)

		     angle_photons(i,j) = b

		     if(include_pst) then
			 angle_dat = angle_photons(i,j)

c			 Check that the point given can actually be observed according
c			 to a simple rule: the angle between the line of sight and the
c			 Earth cannot be less than the stray light exclusion angle.
                   if(angle_dat*RAD.lt. SL_exclusion_angle .or.
     & angle_dat*RAD .gt. 90d0) then
			   error = .true.
                   endif

			 if(angle_dat.lt.min_angle_pst) then
			   write(*,*)'Angle photons< min angle pst',
     &                 angle_dat*RAD, min_angle_pst*RAD
                     error = .true.
                   endif

c			 Get the value of the PST for that particular LOS angle
			 call calcul_pst(angle_dat, pst_result)

                   if(pst_result.lt.pst_limit) then
                     write(*,*) 'PST < pst_limit=', pst_limit
                     write(*,*) 'angle_photons', angle_dat*RAD
                     write(*,*) 'pst_result',pst_result
                     error = .true.
                   endif

                   pst_photons(i,j) = pst_result
                 endif
               endif

            endif

         enddo
      enddo

	if (log_all_data .and. error) then
	  call write_contamination(coord_photons)
	  call write_angles(angle_photons)
	  call write_star(RA_STAR, DEC_STAR)
	endif

	if (log_non_nominal .and. error) then
	  call write_error_targets(RA_STAR, DEC_STAR)
	endif

      return
      end

c     ==========================================================================
      subroutine TOTAL_PHOTONS_AT_TELESCOPE(coord_photons,angle_photons,
     &     pst_photons, SAT,RA_SAT,DEC_SAT, day_night, !Input
     &     straylight_flux)                            !Output

      implicit none

      include 'constants'
      include 'parameters'

      double precision coord_photons(1:n_alpha,1:n_delta),
     &      angle_photons(1:n_alpha,1:n_delta),
     &      pst_photons(1:n_alpha,1:n_delta),
     &      day_night(1:n_alpha,1:n_delta)
      double precision dist(1:n_alpha,1:n_delta),
     &     EARTH(1:3), V(1:3)
      double precision d, SAT(1:3), R_SAT
      double precision energy, straylight_flux
      double precision solar_ref, solar_constant_cm
      double precision alpha_grid, delta_grid
      double precision Delta_alpha, Delta_delta
      double precision surf
      double precision RA_SAT, DEC_SAT
	double precision SphericalDistance
	double precision angle
	double precision proj_surf
      integer i,j

	double precision prod

	Delta_alpha = 2.d0*pi/dble(n_alpha-1)
	Delta_delta = pi/dble(n_delta-1)
	surf = R_Earth**2.d0 * Delta_alpha * Delta_delta

	energy = 0.d0
	straylight_flux = 0.d0

      call R_3D(SAT, R_SAT)

      solar_constant_cm = solar_constant/M2 !maximum energy that hit Earth per cm2
      solar_ref = solar_constant_cm * albedo/pi !reflected energy per cm2

      do i = 1, n_alpha
         do j = 1, n_delta

            if(coord_photons(i,j).eq.hit) then

               alpha_grid = 2.d0*pi*dble(i-1)/dble(n_alpha-1)
               delta_grid = -pi/2.d0 + dble(j-1)*pi/dble(n_delta-1)

               call CARTESIAN_COORDINATES(alpha_grid, delta_grid,
     &              R_Earth ,   ! Input
     &              EARTH)      ! Output

               call VEC_SUBSTRACTION(SAT, EARTH, V)

               call R_3D(V, d)

               call scalar_product(V, EARTH, prod)

c		   Get the surface area of the projected surface
		   angle = SphericalDistance(RA_SAT, DEC_SAT,
     &		 alpha_grid, delta_grid)

c	The first angle is angle between cell and the satellite
c	The second angle is the angle between the LOS and the cell
c	The 3rd is for the fact towards high delta we have smaller surface
		   proj_surf = surf*dcos(angle)*abs(prod/(R_Earth*d))
     &		 *dcos(delta_grid)

               if(include_pst) then
                 energy = energy +
     &                 solar_ref*proj_surf*pst_photons(i,j)*
     &                 day_night(i,j)/d**2.d0
               else
                  energy = energy +
     &                 solar_ref*proj_surf*angle_photons(i,j)*
     &                 day_night(i,j)/d**2.d0
               endif

            endif
         enddo
      enddo

      straylight_flux = energy * pixel !photons se px-1

      return
      end

c     =========================================================================
      subroutine vect_product(X, Y, Z)

      implicit none
      double precision X(1:3), Y(1:3), Z(1:3)

      Z(1) = X(2)*Y(3) - X(3)*Y(2)
      Z(2) = X(3)*Y(1) - X(1)*Y(3)
      Z(3) = X(1)*Y(2) - X(2)*Y(1)

      return
      end
c     ==========================================================================
      subroutine scalar_product(X, Y, z)

      implicit none
      double precision X(1:3), Y(1:3), z

      z = X(1)*Y(1) + X(2)*Y(2) + X(3)*Y(3)

      return
      end

c     ==========================================================================
      function REV(x)

      implicit none
      double precision REV, x

      REV = x - idint(x/360.d0)*360.d0
      if(REV.lt.0.d0) REV = REV + 360.d0

      return
      end

c     ==========================================================================
      function REV_RAD(x)

      implicit none
      double precision REV_RAD, x, twopi
      include 'constants'

      twopi = 2.d0*pi
      REV_RAD = x - idint(x/twopi)*twopi
      if(REV_RAD.lt.0.d0) REV_RAD = REV_RAD + twopi

      return
      end

c     =========================================================================
      subroutine RIGHT_ASCENSION(x, y, RA)

c     Given the cartesian coordinates it calculates the right ascention

      implicit none
      double precision x, y, RA

      RA = datan2(y,x)

      return
      end

c     =========================================================================
      subroutine DECLINATION(x, y, z, DEC)

c     Given the cartesian coordinates it calculates the declination

      implicit none
      double precision x, y, z, DEC

      DEC = datan2(z, sqrt(x**2+y**2))

      return
      end
c     =========================================================================
      subroutine R_3D(X, R)

c     Given the cartesian coordinates it calculates the distance

      implicit none
      double precision X(1:3), R

      R = sqrt(X(1)**2+X(2)**2+X(3)**2)

      return
      end

c     =========================================================================
      subroutine CARTESIAN_COORDINATES(alpha, delta, r, !I
     &     V)                                           !O

      implicit none
      double precision alpha, delta, r
      double precision V(1:3)

      V(1) = r*dcos(alpha)*dcos(delta)
      V(2) = r*dsin(alpha)*dcos(delta)
      V(3) = r*dsin(delta)

      return
      end
c     =========================================================================
      subroutine VEC_SUBSTRACTION(V, W, Z)

      implicit none
      double precision V(1:3), W(1:3), Z(1:3)

      Z(1) = V(1) - W(1)
      Z(2) = V(2) - W(2)
      Z(3) = V(3) - W(3)

      return
      end

c     =========================================================================
      subroutine distance(R1, R2, D)

      implicit none
      double precision R1, R2, D

      D = sqrt(R1**2.d0 - R2**2.d0)

      return
      end

c     =========================================================================
      subroutine calcul_pst(angle_dat, pst_result)

      implicit none
      include 'parameters'
      double precision angle_dat, pst_result

      call interp_lineal(angle_dat, pst_result)

      return
      end
c     =========================================================================

      subroutine interp_lineal(angle_dat, pst_result)

      implicit none
      include 'parameters'
      double precision angle_dat, pst_result
      double precision angle(n_ang), pst(n_ang)
      double precision min_angle_pst
      common /PST/ angle, pst, min_angle_pst

      integer i

      do i= 1, n_ang-1
         if(angle_dat.ge.angle(i).and.angle_dat.lt.angle(i+1)) then
            pst_result = pst(i) +
     &     (angle_dat-angle(i))*(pst(i+1)-pst(i))/(angle(i+1)-angle(i))
         endif
      enddo

      return
      end


      double complex function qlLi2omrat(x,y)
      implicit none
      include 'qlconstants.f'
c     expression for dilog(1-(x-i*ep)/(y-i*ep)) for real x and y
c     Hence arguments are typically negative invariants
      double precision x,y,omarg,arg,ddilog
      double complex qllnrat,wlog
      omarg=x/y
      arg=1d0-omarg
      if (arg .gt. 1d0) then
      wlog=qllnrat(x,y)
      qlLi2omrat=dcmplx(pisqo6-ddilog(omarg))-log(arg)*wlog
      else
      qlLi2omrat=dcmplx(ddilog(arg))
      endif

      return
      end


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

!> ********************************************************************
!! @brief 2x2の行列反転
!! @param [in,out] d    RHS vector(d) -> 解ベクトル(x) (in-place)
!! @param [in]     a    係数
!! @param [in]     c    係数
!! @note Ax = d    9 fp
!!       A=|1  c1|   x={x1, x2}, d={d1, d2}
!!         |a2  1|
!<
subroutine matx2(d, a, c)
implicit none
double precision, dimension(3)       ::  d, a, c
double precision                     ::  a2, c1, j, d1, d2
  a2 = a(2)
  c1 = c(1)
  j = 1.0 / (1.0 - a2 * c1)
  d1 = d(1)
  d2 = d(2)
  d(1) = (d1 - c1 * d2) * j
  d(2) = (d2 - a2 * d1) * j

return
end subroutine matx2

!> ********************************************************************
!! @brief 3x3の行列反転
!! @param [in,out] d    RHS vector(d) -> 解ベクトル(x) (in-place)
!! @param [in]     a    係数
!! @param [in]     c    係数
!! @note Ax = d    25 fp
!!       A=|  1 c1  0 |
!!         | a2  1 c2 |
!!         |  0 a3  1 |
!<
subroutine matx3(d, a, c)
implicit none
double precision, dimension(3)       ::  d, a, c
double precision                     ::  j, d1, d2, d3, a2, a3, c1, c2

  a2 = a(2)
  a3 = a(3)
  c1 = c(1)
  c2 = c(2)
  d1 = d(1)
  d2 = d(2)
  d3 = d(3)
  j = 1.0 / (1.0 - c2 * a3 - c1 * a2)
  d(1) = ( d1 * (3.0-c2*a3) - c1*d2 ) * j
  d(2) = (1.0 - d1*a2 + 2.0*d2 - c2*d3) * j
  d(3) = (1.0 + 2.0*d3 - a3*d2 - a2*c1) * j

return
end subroutine matx3

!> ********************************************************************
!! @brief PCR
!! @param [in]     nx   配列長
!! @param [in]     g    ガイドセル長
!! @param [in,out] d    RHS vector -> 解ベクトル (in-place)
!! @param [in]     cf   係数
!! @param [in]     w    U_1 vector
!! @param [in,out] flop flop count
!<
subroutine lsor_pcr_kij (sz, idx, g, pn, x, a, c, d, a1, c1, d1, msk, rhs, omg, res, flop)
implicit none
integer                                                ::  i, j, k, g, kl, kr, s, p, pn
integer                                                ::  ist, ied, jst, jed, kst, ked
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
double precision                                       ::  flop, res
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  a, c, d, a1, c1, d1
real                                                   ::  r, ap, cp, e, omg, pp, dp
!dir$ assume_aligned x:64, msk:64, rhs:64, a:64, c:64, d:64, a1:64, c1:64, d1:64

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

r = 1.0/6.0

flop = flop + dble(  &
(jed-jst+1)*(ied-ist+1)* ( &
(ked-kst+1)*( 6.0       &  ! Source
+ pn * 14.0 &  ! PCR
+ 6.0 )     &  ! Relaxation
+ 6.0                   &  ! BC
) )

!$OMP PARALLEL

! Reflesh coef. due to override

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst+1, ked
a(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst, ked-1
c(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
a(kst,i,j) = 0.0
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
c(ked,i,j) = 0.0
end do
end do
!$OMP END DO

res = 0.0

!$OMP DO SCHEDULE(static) collapse(2) &
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$OMP reduction(+:res)
do j=jst, jed
do i=ist, ied

! Source
!dir$ vector aligned
!dir$ simd
do k = kst, ked
d(k, i, j) = ( ( x(k, i  , j-1)        &
+     x(k, i  , j+1)        &
+     x(k, i-1, j  )        &
+     x(k, i+1, j  ) ) * r + rhs(k, i, j) ) &
*   msk(k, i, j)
end do

! BC
d(kst, i, j) = ( d(kst, i, j) + rhs(kst-1, i, j) * r ) * msk(kst, i, j)
d(ked, i, j) = ( d(ked, i, j) + rhs(ked+1, i, j) * r ) * msk(ked, i, j)

! PCR
do p=1, pn
s = 2**(p-1)

!dir$ vector aligned
!dir$ simd
do k = kst, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
ap = a(k,i,j)
cp = c(k,i,j)
e = 1.0 / ( 1.0 - ap * c(kl,i,j) - cp * a(kr,i,j) )
a1(k,i,j) =  -e * ap * a(kl,i,j)
c1(k,i,j) =  -e * cp * c(kr,i,j)
d1(k,i,j) =   e * ( d(k,i,j) - ap * d(kl,i,j) - cp * d(kr,i,j) )
end do

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k,i,j) = a1(k,i,j)
c(k,i,j) = c1(k,i,j)
d(k,i,j) = d1(k,i,j)
end do

end do

! Relaxation
!dir$ vector aligned
!dir$ simd
do k = kst, ked
pp =   x(k, i, j)
dp = ( d(k, i, j) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp
res = res + real(dp*dp, kind=8)
end do

end do
end do
!$OMP END DO

!$OMP END PARALLEL

return
end subroutine lsor_pcr_kij

!> ********************************************************************
!! @brief PCR
!! @param [in]     nx   配列長
!! @param [in]     g    ガイドセル長
!! @param [in,out] d    RHS vector -> 解ベクトル (in-place)
!! @param [in]     cf   係数
!! @param [in]     w    U_1 vector
!! @param [in,out] flop flop count
!! @note lsor_pcr_kij()からの変更 最終段を直接反転
!<
subroutine lsor_pcr_kij2 (sz, idx, g, pn, x, a, c, d, a1, c1, d1, msk, rhs, omg, res, flop)
implicit none
integer                                                ::  i, j, k, g, kl, kr, s, p, pn
integer                                                ::  ist, ied, jst, jed, kst, ked
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
double precision                                       ::  flop, res
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  a, c, d, a1, c1, d1
real                                                   ::  r, ap, cp, e, omg, pp, dp
double precision, dimension(3)                         ::  aa, cc, dd
!dir$ assume_aligned x:64, msk:64, rhs:64, a:64, c:64, d:64, a1:64, c1:64, d1:64
!DIR$ ATTRIBUTES FORCEINLINE::matx2, matx3

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

r = 1.0/6.0
s = 2**(pn-1)

flop = flop + dble(          &
(jed-jst+1)*(ied-ist+1)* ( &
(ked-kst+1)* 6.0        &  ! Source
+ (ked-kst+1)*(pn-1)*14.0 &  ! PCR
+ 2*s*9.0                 &
+ (ked-kst-2*s+1)*25.0    &
+ (ked-kst+1)*6.0         &  ! Relaxation
+ 6.0 )                 &  ! BC
)

!$OMP PARALLEL

! Reflesh coef. due to override

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst+1, ked
a(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst, ked-1
c(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
a(kst,i,j) = 0.0
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
c(ked,i,j) = 0.0
end do
end do
!$OMP END DO

res = 0.0

!$OMP DO SCHEDULE(static) collapse(2) &
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp, aa, cc, dd) &
!$OMP reduction(+:res)
do j=jst, jed
do i=ist, ied

! Source
!dir$ vector aligned
!dir$ simd
do k = kst, ked
d(k, i, j) = ( ( x(k, i  , j-1)        &
+     x(k, i  , j+1)        &
+     x(k, i-1, j  )        &
+     x(k, i+1, j  ) ) * r + rhs(k, i, j) ) &
*   msk(k, i, j)
end do

! BC
d(kst, i, j) = ( d(kst, i, j) + rhs(kst-1, i, j) * r ) * msk(kst, i, j)
d(ked, i, j) = ( d(ked, i, j) + rhs(ked+1, i, j) * r ) * msk(ked, i, j)

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

!dir$ vector aligned
!dir$ simd
do k = kst, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
ap = a(k,i,j)
cp = c(k,i,j)
e = 1.0 / ( 1.0 - ap * c(kl,i,j) - cp * a(kr,i,j) )
a1(k,i,j) =  -e * ap * a(kl,i,j)
c1(k,i,j) =  -e * cp * c(kr,i,j)
d1(k,i,j) =   e * ( d(k,i,j) - ap * d(kl,i,j) - cp * d(kr,i,j) )
end do

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k,i,j) = a1(k,i,j)
c(k,i,j) = c1(k,i,j)
d(k,i,j) = d1(k,i,j)
end do

end do ! p反復

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

!dir$ vector aligned
!dir$ simd
do k = kst, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)

if (k<kst+s) then ! 2 eqations
cc(1) = real( c(k ,i,j), kind=8)
aa(2) = real( a(kr,i,j), kind=8)
dd(1) = real( d(k ,i,j), kind=8)
dd(2) = real( d(kr,i,j), kind=8)
call matx2(dd, aa, cc)
d1(k ,i,j) = real( dd(1), kind=4)
d1(kr,i,j) = real( dd(2), kind=4)
else if (k<=ked-s) then ! 3 equations
cc(1) = real( c(kr,i,j), kind=8)
aa(2) = real( a(k ,i,j), kind=8)
cc(2) = real( c(k ,i,j), kind=8)
aa(3) = real( a(kl,i,j), kind=8)
dd(1) = real( d(kr,i,j), kind=8)
dd(2) = real( d(k ,i,j), kind=8)
dd(3) = real( d(kl,i,j), kind=8)
call matx3(dd, aa, cc)
d1(kr,i,j) = real( dd(1), kind=4)
d1(k ,i,j) = real( dd(2), kind=4)
d1(kl,i,j) = real( dd(3), kind=4)
else ! 2 equations
cc(1) = real( c(kl,i,j), kind=8)
aa(2) = real( a(k ,i,j), kind=8)
dd(1) = real( d(kl,i,j), kind=8)
dd(2) = real( d(k ,i,j), kind=8)
call matx2(dd, aa, cc)
d1(kl,i,j) = real( dd(1), kind=4)
d1(k ,i,j) = real( dd(2), kind=4)
endif
end do

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

! Relaxation
!dir$ vector aligned
!dir$ simd
do k = kst, ked
pp =   x(k, i, j)
dp = ( d1(k, i, j) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp
res = res + real(dp*dp, kind=8)
end do

end do
end do
!$OMP END DO

!$OMP END PARALLEL

return
end subroutine lsor_pcr_kij2

!> ********************************************************************
!! @brief PCR
!! @param [in]     nx   配列長
!! @param [in]     g    ガイドセル長
!! @param [in,out] d    RHS vector -> 解ベクトル (in-place)
!! @param [in]     cf   係数
!! @param [in]     w    U_1 vector
!! @param [in,out] flop flop count
!! @note lsor_pcr_kij2()からの変更 分割
!<
subroutine lsor_pcr_kij3 (sz, idx, g, pn, x, a, c, d, a1, c1, d1, msk, rhs, omg, res, flop)
implicit none
integer                                                ::  i, j, k, g, kl, kr, s, p, pn, t
integer                                                ::  ist, ied, jst, jed, kst, ked
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
double precision                                       ::  flop, res
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  a, c, d, a1, c1, d1
real                                                   ::  r, ap, cp, e, omg, pp, dp
double precision, dimension(3)                         ::  aa, cc, dd
!dir$ assume_aligned x:64, msk:64, rhs:64, a:64, c:64, d:64, a1:64, c1:64, d1:64
!DIR$ ATTRIBUTES FORCEINLINE::matx2, matx3

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

r = 1.0/6.0
t = 2**(pn-1)

flop = flop + dble(  &
(jed-jst+1)*(ied-ist+1)* ( &
(ked-kst+1)* 6.0        &  ! Source
+ (ked-kst+1)*(pn-1)*14.0 &  ! PCR
+ 2*t*9.0                 &
+ (ked-kst-2*t+1)*25.0    &
+ (ked-kst+1)*6.0         &  ! Relaxation
+ 6.0 )                 &  ! BC
)

!$OMP PARALLEL

! Refresh coef. due to override

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst+1, ked
a(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst, ked-1
c(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
a(kst,i,j) = 0.0
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
c(ked,i,j) = 0.0
end do
end do
!$OMP END DO

res = 0.0

!$OMP DO SCHEDULE(static) collapse(2) &
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp, aa, cc, dd) &
!$OMP reduction(+:res)
do j=jst, jed
do i=ist, ied

! Source
!dir$ vector aligned
!dir$ simd
do k = kst, ked ! 6 fp
d(k, i, j) = ( ( x(k, i  , j-1)        &
+     x(k, i  , j+1)        &
+     x(k, i-1, j  )        &
+     x(k, i+1, j  ) ) * r + rhs(k, i, j) ) &
*   msk(k, i, j)
end do

! BC
d(kst, i, j) = ( d(kst, i, j) + rhs(kst-1, i, j) * r ) * msk(kst, i, j)
d(ked, i, j) = ( d(ked, i, j) + rhs(ked+1, i, j) * r ) * msk(ked, i, j)

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

!dir$ vector aligned
!dir$ simd
do k = kst, ked ! 14 fp
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
ap = a(k,i,j)
cp = c(k,i,j)
e = 1.0 / ( 1.0 - ap * c(kl,i,j) - cp * a(kr,i,j) )
a1(k,i,j) =  -e * ap * a(kl,i,j)
c1(k,i,j) =  -e * cp * c(kr,i,j)
d1(k,i,j) =   e * ( d(k,i,j) - ap * d(kl,i,j) - cp * d(kr,i,j) )
end do

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k,i,j) = a1(k,i,j)
c(k,i,j) = c1(k,i,j)
d(k,i,j) = d1(k,i,j)
end do

end do ! p反復

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

!dir$ vector aligned
!dir$ simd
do k = kst, kst+s-1
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc(1) = real( c(k ,i,j), kind=8)
aa(2) = real( a(kr,i,j), kind=8)
dd(1) = real( d(k ,i,j), kind=8)
dd(2) = real( d(kr,i,j), kind=8)
call matx2(dd, aa, cc) ! 9 fp
d1(k ,i,j) = real( dd(1), kind=4)
d1(kr,i,j) = real( dd(2), kind=4)
end do

!dir$ vector aligned
!dir$ simd
do k = kst+s, ked-s
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc(1) = real( c(kr,i,j), kind=8)
aa(2) = real( a(k ,i,j), kind=8)
cc(2) = real( c(k ,i,j), kind=8)
aa(3) = real( a(kl,i,j), kind=8)
dd(1) = real( d(kr,i,j), kind=8)
dd(2) = real( d(k ,i,j), kind=8)
dd(3) = real( d(kl,i,j), kind=8)
call matx3(dd, aa, cc) ! 25 fp
d1(kr,i,j) = real( dd(1), kind=4)
d1(k ,i,j) = real( dd(2), kind=4)
d1(kl,i,j) = real( dd(3), kind=4)
end do

!dir$ vector aligned
!dir$ simd
do k = ked-s+1, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc(1) = real( c(kl,i,j), kind=8)
aa(2) = real( a(k ,i,j), kind=8)
dd(1) = real( d(kl,i,j), kind=8)
dd(2) = real( d(k ,i,j), kind=8)
call matx2(dd, aa, cc) ! 9 fp
d1(kl,i,j) = real( dd(1), kind=4)
d1(k ,i,j) = real( dd(2), kind=4)
end do

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

! Relaxation
!dir$ vector aligned
!dir$ simd
do k = kst, ked ! 6 fp
pp =   x(k, i, j)
dp = ( d1(k, i, j) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp
res = res + real(dp*dp, kind=8)
end do

end do
end do
!$OMP END DO

!$OMP END PARALLEL

return
end subroutine lsor_pcr_kij3

!> ********************************************************************
!! @brief PCR
!! @param [in]     nx   配列長
!! @param [in]     g    ガイドセル長
!! @param [in,out] d    RHS vector -> 解ベクトル (in-place)
!! @param [in]     cf   係数
!! @param [in]     w    U_1 vector
!! @param [in,out] flop flop count
!! @note lsor_pcr_kij4()からの変更 matx2, matx3を手動展開
!<
subroutine lsor_pcr_kij4 (sz, idx, g, pn, x, a, c, d, a1, c1, d1, msk, rhs, omg, res, flop)
implicit none
integer                                                ::  i, j, k, g, kl, kr, s, p, pn
integer                                                ::  ist, ied, jst, jed, kst, ked
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
double precision                                       ::  flop, res
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  a, c, d, a1, c1, d1
real                                                   ::  r, ap, cp, e, omg, pp, dp
double precision                                       ::  jj, dd1, dd2, dd3, aa2, aa3, cc1, cc2, f1, f2, f3
!dir$ assume_aligned x:64, msk:64, rhs:64, a:64, c:64, d:64, a1:64, c1:64, d1:64

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

r = 1.0/6.0
s = 2**(pn-1)

flop = flop + dble(          &
  (jed-jst+1)*(ied-ist+1)* ( &
     (ked-kst+1)* 6.0        &  ! Source
   + (ked-kst+1)*(pn-1)*14.0 &  ! PCR
   + 2*s*9.0                 &
   + (ked-kst-2*s+1)*25.0    &
   + (ked-kst+1)*6.0         &  ! Relaxation
     + 6.0 )                 &  ! BC
   )

!$OMP PARALLEL

! Reflesh coef. due to override

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst+1, ked
a(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
do k=kst, ked-1
c(k,i,j) = -r
end do
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
a(kst,i,j) = 0.0
end do
end do
!$OMP END DO

!$OMP DO SCHEDULE(static) collapse(2)
do j=jst, jed
do i=ist, ied
c(ked,i,j) = 0.0
end do
end do
!$OMP END DO

res = 0.0

!$OMP DO SCHEDULE(static) collapse(2) &
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, dd3, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP reduction(+:res)
do j=jst, jed
do i=ist, ied

! Source
!dir$ vector aligned
!dir$ simd
do k = kst, ked
d(k, i, j) = ( ( x(k, i  , j-1)        &
+     x(k, i  , j+1)        &
+     x(k, i-1, j  )        &
+     x(k, i+1, j  ) ) * r + rhs(k, i, j) ) &
*   msk(k, i, j)
end do

! BC
d(kst, i, j) = ( d(kst, i, j) + rhs(kst-1, i, j) * r ) * msk(kst, i, j)
d(ked, i, j) = ( d(ked, i, j) + rhs(ked+1, i, j) * r ) * msk(ked, i, j)

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

!dir$ vector aligned
!dir$ simd
do k = kst, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
ap = a(k,i,j)
cp = c(k,i,j)
e = 1.0 / ( 1.0 - ap * c(kl,i,j) - cp * a(kr,i,j) )
a1(k,i,j) =  -e * ap * a(kl,i,j)
c1(k,i,j) =  -e * cp * c(kr,i,j)
d1(k,i,j) =   e * ( d(k,i,j) - ap * d(kl,i,j) - cp * d(kr,i,j) )
end do

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k,i,j) = a1(k,i,j)
c(k,i,j) = c1(k,i,j)
d(k,i,j) = d1(k,i,j)
end do

end do ! p反復

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

!dir$ vector aligned
!dir$ simd
do k = kst, kst+s-1
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = real( c(k ,i,j), kind=8)
aa2 = real( a(kr,i,j), kind=8)
f1  = real( d(k ,i,j), kind=8)
f2  = real( d(kr,i,j), kind=8)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
d1(k ,i,j) = real( dd1, kind=4)
d1(kr,i,j) = real( dd2, kind=4)
end do

!dir$ vector aligned
!dir$ simd
do k = kst+s, ked-s
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = real( c(kr,i,j), kind=8)
aa2 = real( a(k ,i,j), kind=8)
cc2 = real( c(k ,i,j), kind=8)
aa3 = real( a(kl,i,j), kind=8)
f1  = real( d(kr,i,j), kind=8)
f2  = real( d(k ,i,j), kind=8)
f3  = real( d(kl,i,j), kind=8)
jj = 1.0 / (1.0 - cc2 * aa3 - cc1 * aa2)
dd1 = ( f1 * (3.0-cc2*aa3) - cc1*f2 ) * jj
dd2 = (1.0 - f1*aa2 + 2.0*f2 - cc2*f3) * jj
dd3 = (1.0 + 2.0*f3 - aa3*f2 - aa2*cc1) * jj
d1(kr,i,j) = real( dd1, kind=4)
d1(k ,i,j) = real( dd2, kind=4)
d1(kl,i,j) = real( dd3, kind=4)
end do

!dir$ vector aligned
!dir$ simd
do k = ked-s+1, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = real( c(kl,i,j), kind=8)
aa2 = real( a(k ,i,j), kind=8)
f1  = real( d(kl,i,j), kind=8)
f2  = real( d(k ,i,j), kind=8)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
d1(kl,i,j) = real( dd1, kind=4)
d1(k ,i,j) = real( dd2, kind=4)
end do

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

! Relaxation
!dir$ vector aligned
!dir$ simd
do k = kst, ked
pp =   x(k, i, j)
dp = ( d1(k, i, j) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp
res = res + real(dp*dp, kind=8)
end do

end do
end do
!$OMP END DO

!$OMP END PARALLEL

return
end subroutine lsor_pcr_kij4

!********************************************************************************
subroutine lsor_pcr_kij5 (sz, idx, g, pn, x, msk, rhs, omg, res, flop)
implicit none
! arguments
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
integer                                                ::  g, pn
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real                                                   ::  omg
double precision                                       ::  res, flop
! work
integer                      ::  i, j, k, kl, kr, s, p
integer                      ::  ist, ied, jst, jed, kst, ked
real, dimension(1-g:sz(3)+g) ::  a, c, d, a1, c1, d1
real                         ::  r, ap, cp, e, pp, dp
double precision             ::  jj, dd1, dd2, dd3, aa2, aa3, cc1, cc2, f1, f2, f3
!dir$ assume_aligned x:64, msk:64, rhs:64, a:64, c:64, d:64, a1:64, c1:64, d1:64

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

r = 1.0/6.0
s = 2**(pn-1)

flop = flop + dble(          &
(jed-jst+1)*(ied-ist+1)* ( &
(ked-kst+1)* 6.0        &  ! Source
+ (ked-kst+1)*(pn-1)*14.0 &  ! PCR
+ 2*s*9.0                 &
+ (ked-kst-2*s+1)*25.0    &
+ (ked-kst+1)*6.0         &  ! Relaxation
+ 6.0 )                 &  ! BC
)

!$OMP PARALLEL

res = 0.0

!$OMP DO SCHEDULE(static) collapse(2) &
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, dd3, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP private(a, c, d, a1, c1, d1) &
!$OMP reduction(+:res)
do j=jst, jed
do i=ist, ied

! Reflesh coef. due to override
a(kst) = 0.0
do k=kst+1, ked
a(k) = -r
end do

do k=kst, ked-1
c(k) = -r
end do
c(ked) = 0.0

! Source
!dir$ vector aligned
!dir$ simd
do k = kst, ked
d(k) = (   ( x(k, i  , j-1)        &
+     x(k, i  , j+1)        &
+     x(k, i-1, j  )        &
+     x(k, i+1, j  ) ) * r + rhs(k, i, j) ) &
*   msk(k, i, j)
end do

! BC
d(kst) = ( d(kst) + rhs(kst-1, i, j) * r ) * msk(kst, i, j)
d(ked) = ( d(ked) + rhs(ked+1, i, j) * r ) * msk(ked, i, j)

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

!dir$ vector aligned
!dir$ simd
do k = kst, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
ap = a(k)
cp = c(k)
e = 1.0 / ( 1.0 - ap * c(kl) - cp * a(kr) )
a1(k) =  -e * ap * a(kl)
c1(k) =  -e * cp * c(kr)
d1(k) =   e * ( d(k) - ap * d(kl) - cp * d(kr) )
end do

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k) = a1(k)
c(k) = c1(k)
d(k) = d1(k)
end do

end do ! p反復

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

!dir$ vector aligned
!dir$ simd
do k = kst, kst+s-1
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = real( c(k ), kind=8)
aa2 = real( a(kr), kind=8)
f1  = real( d(k ), kind=8)
f2  = real( d(kr), kind=8)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
d1(k ) = real( dd1, kind=4)
d1(kr) = real( dd2, kind=4)
end do

!dir$ vector aligned
!dir$ simd
do k = kst+s, ked-s
kl  = max(k-s, kst-1)
kr  = min(k+s, ked+1)
cc1 = real( c(kr), kind=8)
aa2 = real( a(k ), kind=8)
cc2 = real( c(k ), kind=8)
aa3 = real( a(kl), kind=8)
f1  = real( d(kr), kind=8)
f2  = real( d(k ), kind=8)
f3  = real( d(kl), kind=8)
jj = 1.0 / (1.0 - cc2 * aa3 - cc1 * aa2)
dd1 = ( f1 * (3.0-cc2*aa3) - cc1*f2 ) * jj
dd2 = (1.0 - f1*aa2 + 2.0*f2 - cc2*f3) * jj
dd3 = (1.0 + 2.0*f3 - aa3*f2 - aa2*cc1) * jj
d1(kr) = real( dd1, kind=4)
d1(k ) = real( dd2, kind=4)
d1(kl) = real( dd3, kind=4)
end do

!dir$ vector aligned
!dir$ simd
do k = ked-s+1, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = real( c(kl), kind=8)
aa2 = real( a(k ), kind=8)
f1  = real( d(kl), kind=8)
f2  = real( d(k ), kind=8)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
d1(kl) = real( dd1, kind=4)
d1(k ) = real( dd2, kind=4)
end do

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

! Relaxation
!dir$ vector aligned
!dir$ simd
do k = kst, ked
pp =   x(k, i, j)
dp = ( d1(k) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp
res = res + real(dp*dp, kind=8)
end do

end do
end do
!$OMP END DO

!$OMP END PARALLEL

return
end subroutine lsor_pcr_kij5

!********************************************************************************
subroutine lsor_pcr_kij6 (sz, idx, g, pn, x, msk, rhs, omg, res, flop)
implicit none
!args
integer, dimension(3)                                  ::  sz
integer, dimension(0:5)                                ::  idx
integer                                                ::  g, pn
real, dimension(1-g:sz(3)+g, 1-g:sz(1)+g, 1-g:sz(2)+g) ::  x, msk, rhs
real                                                   ::  omg
double precision                                       ::  res, flop
! work
integer                                  ::  i, j, k, kl, kr, s, p
integer                                  ::  ist, ied, jst, jed, kst, ked
real, dimension(1-g:sz(3)+g)             ::  a, c, d, a1, c1, d1
real                                     ::  r, ap, cp, e, pp, dp
real                                     ::  jj, dd1, dd2, dd3, aa2, aa3, cc1, cc2, f1, f2, f3
!dir$ assume_aligned x:64, msk:64, rhs:64, a:64, c:64, d:64, a1:64, c1:64, d1:64

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

r = 1.0/6.0
s = 2**(pn-1)

flop = flop + dble(          &
(jed-jst+1)*(ied-ist+1)* ( &
(ked-kst+1)* 6.0        &  ! Source
+ (ked-kst+1)*(pn-1)*14.0 &  ! PCR
+ 2*s*9.0                 &
+ (ked-kst-2*s+1)*25.0    &
+ (ked-kst+1)*6.0         &  ! Relaxation
+ 6.0 )                 &  ! BC
)

!$OMP PARALLEL

res = 0.0

!$OMP DO SCHEDULE(static) collapse(2) &
!$OMP private(kl, kr, ap, cp, e, s, p, k, pp, dp) &
!$OMP private(jj, dd1, dd2, dd3, aa2, aa3, cc1, cc2, f1, f2, f3) &
!$OMP private(a, c, d, a1, c1, d1) &
!$OMP reduction(+:res)
do j=jst, jed
do i=ist, ied

! Reflesh coef. due to override
a(kst) = 0.0
do k=kst+1, ked
a(k) = -r
end do

do k=kst, ked-1
c(k) = -r
end do
c(ked) = 0.0

! Source
!dir$ vector aligned
!dir$ simd
do k = kst, ked
d(k) = (   ( x(k, i  , j-1)        &
+     x(k, i  , j+1)        &
+     x(k, i-1, j  )        &
+     x(k, i+1, j  ) ) * r + rhs(k, i, j) ) &
*   msk(k, i, j)
end do

! BC
d(kst) = ( d(kst) + rhs(kst-1, i, j) * r ) * msk(kst, i, j)
d(ked) = ( d(ked) + rhs(ked+1, i, j) * r ) * msk(ked, i, j)

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

!dir$ vector aligned
!dir$ simd
do k = kst, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
ap = a(k)
cp = c(k)
e = 1.0 / ( 1.0 - ap * c(kl) - cp * a(kr) )
a1(k) =  -e * ap * a(kl)
c1(k) =  -e * cp * c(kr)
d1(k) =   e * ( d(k) - ap * d(kl) - cp * d(kr) )
end do

!dir$ vector aligned
!dir$ simd
do k = kst, ked
a(k) = a1(k)
c(k) = c1(k)
d(k) = d1(k)
end do

end do ! p反復

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

!dir$ vector aligned
!dir$ simd
do k = kst, kst+s-1
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = c(k)
aa2 = a(kr)
f1  = d(k)
f2  = d(kr)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
d1(k ) = dd1
d1(kr) = dd2
end do

!dir$ vector aligned
!dir$ simd
do k = kst+s, ked-s
kl  = max(k-s, kst-1)
kr  = min(k+s, ked+1)
cc1 = c(kr)
aa2 = a(k)
cc2 = c(k)
aa3 = a(kl)
f1  = d(kr)
f2  = d(k)
f3  = d(kl)
jj = 1.0 / (1.0 - cc2 * aa3 - cc1 * aa2)
dd1 = ( f1 * (3.0-cc2*aa3) - cc1*f2 ) * jj
dd2 = (1.0 - f1*aa2 + 2.0*f2 - cc2*f3) * jj
dd3 = (1.0 + 2.0*f3 - aa3*f2 - aa2*cc1) * jj
d1(kr) = dd1
d1(k ) = dd2
d1(kl) = dd3
end do

!dir$ vector aligned
!dir$ simd
do k = ked-s+1, ked
kl = max(k-s, kst-1)
kr = min(k+s, ked+1)
cc1 = c(kl)
aa2 = a(k)
f1  = d(kl)
f2  = d(k)
jj  = 1.0 / (1.0 - aa2 * cc1)
dd1 = (f1 - cc1 * f2) * jj
dd2 = (f2 - aa2 * f1) * jj
d1(kl) = dd1
d1(k ) = dd2
end do

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

! Relaxation
!dir$ vector aligned
!dir$ simd
do k = kst, ked
pp =   x(k, i, j)
dp = ( d1(k) - pp ) * omg * msk(k, i, j)
x(k, i, j) = pp + dp
res = res + real(dp*dp, kind=8)
end do

end do
end do
!$OMP END DO

!$OMP END PARALLEL

return
end subroutine lsor_pcr_kij6


program hash_function_test

   ! This program performs speed tests and collision tests for the integer
   ! and string hash functions in hash_functions.f90 module

   !============================================================================
   use hash_functions

   integer, parameter :: slen = 10 ! number of string bytes
   real           :: t1, t2, tsum
   character(6)   :: name
   character(slen):: str
   integer        :: ierror, key
   integer        :: i, j, ncol, k, strn(slen), base, a, b
   integer        :: tbl_size, nhash

   integer, dimension(27) :: asciis
   integer, dimension(:), allocatable :: keys, hash
   character(slen), dimension(:), allocatable :: keys_s

   procedure(sdbm_64_int),    pointer :: fhash_i => null()
   procedure(sdbm_64_str),    pointer :: fhash_s => null()

   !============================================================================
   ! Hash speed test: Integers
   !============================================================================

   nhash    = 50000000
   tbl_size = int(nhash/0.7)+1

   allocate(keys(nhash),hash(nhash),STAT=ierror)
   if(ierror /= 0) write(*,"('Mem alloc error')")

   write(*,"('Hash speed test: ',i12,' integers')") nhash

   do k = 1,7
      select case(k)
      case(1); fhash_i => djb2_64_int;    name = 'djb2  '
      case(2); fhash_i => djb2a_64_int;   name = 'djb2a '
      case(3); fhash_i => sdbm_64_int;    name = 'sdbm  '
      case(4); fhash_i => fnv1_64_int;    name = 'fnv1  '
      case(5); fhash_i => fnv1a_64_int;   name = 'fnv1a '
      case(6); fhash_i => mmh2_64_int;    name = 'mmh2  '
      case(7); fhash_i => mmh3_64_int;    name = 'mmh3  '
      end select

      call cpu_time(t1)
      do i = 1,nhash
         key = fhash_i(i)
         hash(i) = modulo(key,tbl_size)+1
      end do
      call cpu_time(t2)
      tsum = t2-t1

      write(*,"(a6,'  kiloHashes per second: ',i8)") name,int(nhash/(1000*tsum))
   end do

   !============================================================================
   ! Hash collision test: Integers
   !============================================================================

   nhash = 50000
   tbl_size = int(nhash/0.7)+1

   write(*,"(/)")
   write(*,"('Hash collision test: ',i12,' integers modulo ',i12)") nhash, tbl_size
   do k = 1,7
      select case(k)
      case(1); fhash_i => djb2_64_int;    name = 'djb2  '
      case(2); fhash_i => djb2a_64_int;   name = 'djb2a '
      case(3); fhash_i => sdbm_64_int;    name = 'sdbm  '
      case(4); fhash_i => fnv1_64_int;    name = 'fnv1  '
      case(5); fhash_i => fnv1a_64_int;   name = 'fnv1a '
      case(6); fhash_i => mmh2_64_int;    name = 'mmh2  '
      case(7); fhash_i => mmh3_64_int;    name = 'mmh3  '
      end select

      do i = 1,nhash
         key = fhash_i(i)
         hash(i) = modulo(key,tbl_size)+1 ! Pretend as if it is fitting into a table
      end do

      ncol = 0
      do i = 1,nhash-1
         if(hash(i) == 0) cycle
         do j = i+1,nhash
            if(hash(j)==0) then
               cycle
            else if(hash(i)==hash(j)) then
               ncol = ncol + 1
               hash(j) = 0
            end if
         end do
      end do
      write(*,"(a6,'  Number of collisions: ',i8)") name,ncol
   end do

   !============================================================================
   ! Hash speed test: Strings
   !============================================================================

   nhash    = 50000000
   tbl_size = int(nhash/0.7)+1

   write(*,"(/)")
   write(*,"('Hash speed test: ',i12,' ',i2,'-byte strings')") nhash, slen

   deallocate(keys,hash)
   allocate(keys_s(nhash),hash(nhash),STAT=ierror)
   if(ierror /= 0) write(*,"('Mem alloc error')")

   ! Use base conversion to make nhash strings which utilize character indices
   ! 1 through 'base' from among ASCII 32 & 97-122 (space + lower case letters)
   ! e.g. base 5 would use space + a,b,c,d to make strings '   ' through 'ddd'
   asciis(1) = 32
   asciis(2:27) = [(i,i=97,122)]

   base = 7 ! number of ascii characters to use/base to convert to

   do i = 1,nhash
      b = i
      do j = 1,slen                ! Do j=1,slen Euclidean divisions
         a = b/base                ! integer division, get seed for next digit
         strn(j)  = b - a*base +1  ! Fortran is indexed to 1, modulo is indexed to 0
         b = a                     ! set b = a to start on next digit
      end do

      do j = 1,slen        ! Convert from index to ASCII code to character
         str(j:j) = achar(asciis(strn(j)))
      end do

      keys_s(i) = str

   end do

   do k = 1,7
      select case(k)
      case(1); fhash_s => djb2_64_str;    name = 'djb2  '
      case(2); fhash_s => djb2a_64_str;   name = 'djb2a '
      case(3); fhash_s => sdbm_64_str;    name = 'sdbm  '
      case(4); fhash_s => fnv1_64_str;    name = 'fnv1  '
      case(5); fhash_s => fnv1a_64_str;   name = 'fnv1a '
      case(6); fhash_s => mmh2_64_str;    name = 'mmh2  '
      case(7); fhash_s => mmh3_64_str;    name = 'mmh3  '
      end select

      call cpu_time(t1)
      do i = 1,nhash
         key = fhash_s(keys_s(i))
         hash(i) = modulo(key,tbl_size)+1
      end do
      call cpu_time(t2)
      tsum = t2-t1

      write(*,"(a6,'  kiloHashes per second: ',i8)") name,int(nhash/(1000*tsum))
   end do

   !============================================================================
   ! Hash collision test: Strings
   !============================================================================

   nhash = 50000
   tbl_size = int(nhash/0.7)+1

   write(*,"(/)")
   write(*,"('Hash collision test: ',i12,' ',i2,'-byte strings modulo ',i12)") nhash, slen, tbl_size
   do k = 1,7
      select case(k)
      case(1); fhash_s => djb2_64_str;    name = 'djb2  '
      case(2); fhash_s => djb2a_64_str;   name = 'djb2a '
      case(3); fhash_s => sdbm_64_str;    name = 'sdbm  '
      case(4); fhash_s => fnv1_64_str;    name = 'fnv1  '
      case(5); fhash_s => fnv1a_64_str;   name = 'fnv1a '
      case(6); fhash_s => mmh2_64_str;    name = 'mmh2  '
      case(7); fhash_s => mmh3_64_str;    name = 'mmh3  '
      end select

      do i = 1,nhash
         key = fhash_s(keys_s(i))
         hash(i) = modulo(key,tbl_size)+1
      end do

      ncol = 0
      do i = 1,nhash-1
         if(hash(i) == 0) cycle
         do j = i+1,nhash
            if(hash(j)==0) then
               cycle
            else if(hash(i)==hash(j)) then
               ncol = ncol + 1
               hash(j) = 0
            end if
         end do
      end do
      write(*,"(a6,'  Number of collisions: ',i8)") name,ncol
   end do

   write(*,"(//,'Done...')")
   read(*,"(a)") str

end program


!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
! Information about last revision of $RCSfile: m_constants.f90,v $:
! $Revision: 1.3 $
! $Author: jorissen $
! $Date: 2010/12/16 18:30:30 $
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!*************************************************************************
module constants

  implicit none

  ! Symbolic names for kind types of 4-, 2-, and 1-byte integers:
  integer, parameter :: I4 = selected_int_kind(9)
  integer, parameter :: I2 = selected_int_kind(4)
  integer, parameter :: I1 = selected_int_kind(2)
  ! Symbolic names for kind types of single- and double-precision reals:
  integer, parameter :: SP  = kind(1.0)
  integer, parameter :: DP  = kind(1.0D0)
  ! Symbolic names for kind types of single- and double-precision complex:
  integer, parameter :: SZ  = kind((1.0,1.0))
  integer, parameter :: DZ  = kind((1.0D0,1.0D0))
  ! Symbolic name for kind type of default logical:
  integer, parameter :: LGT = kind(.true.)
  private i1,i2,i4,sp,dp,sz,dz,lgt

  real(dp), parameter :: pi2 = 6.283185307179586476925286766559_dp
  real(dp), parameter :: pi  = 3.1415926535897932384626433832795_dp
  real(dp), parameter :: one = 1.0_dp
  real(dp), parameter :: zero  = 0.0_dp
  real(dp), parameter :: third = 1.0_dp/3.0_dp
  real(dp), parameter :: raddeg = 180.0_dp/pi
  !     kf = fa/rs with fa = (9*pi/4)**third, see Ash&Merm, pg 37
  real(dp), parameter :: fa = 1.919158292677512811_dp
  complex(dz), parameter :: coni = (0.0_dp,1.0_dp)
  real(dp), parameter :: bohr = 0.529177249_dp
  real(dp), parameter :: ryd  = 13.605698_dp
  real(dp), parameter :: hart = 2.0_dp*ryd
  real(dp), parameter :: alpinv = 137.03598956_dp
  real(dp), parameter :: alphfs = 1.0_dp/alpinv

  ! from moduleseels.f
  ! conversion from eV to Ry :
  real(dp), parameter :: ev2Ry = 1.0_dp/13.6058_dp
  !  h/2pi c in units eV a.u.
  real(dp), parameter :: hbarc_eV = 1973.2708_dp/0.529177_dp
  real(dp), parameter :: hbarc_atomic = 137.04188_dp  ! i.e. in Ha, hence 27.2 times smaller than above
  ! electron rest mass times c^2 in au (ie, 1 * alfa * alfa), times eV/Ha (27.2)
  real(dp), parameter :: MeC2 =  511004.0_dp
  REAL(dp), parameter :: HOnSqrtTwoMe = 23.1761_dp
  ! Me c / hbar = 2.5896 10^12 m^(-1) = 137.04188 a.u.^(-1)
  real(dp), parameter :: MeCOnHbar = 137.04188_dp

end module constants


c     program DRSSFIT
c>> 1996-07-03 DRSSFIT Krogh Special code for C conversion.
c>> 1996-06-19 DRSSFIT Krogh Changes in formats for C conversion.
c>> 1996-05-28 DRSSFIT Krogh Added external & removed Fortran 90 syntax
c>> 1994-10-19 DRSSFIT Krogh Changes to use M77CON
c>> 1992-11-18 DRSSFIT CLL   Changed order of arguments in SSFIT.
c>> 1992-10-29 C. L. Lawson, JPL
c    Demonstration driver for SSFIT, SSVAL, SSQUAD, SSTOP, SPVAL, SPQUAD
c     ------------------------------------------------------------------
c--S replaces "?": DR?SFIT, ?SFIT, ?SVAL, ?SQUAD, ?STOP, ?PVAL, ?PQUAD
c--&                 ?PRPL
c     ------------------------------------------------------------------
c++ Code for .C. is inactive
c%%   long int k;
c++ End
      integer I, IERR, NXY, KORDER, MPC, NCOEF, NDERIV, NPC, NT, LDW
      parameter(NXY = 12, NCOEF=8, KORDER=4, NT = NCOEF+KORDER,LDW = 10)
      parameter(MPC = NCOEF-KORDER+1)
      external SSVAL, SSQUAD, SPVAL, SPQUAD
      real             BDIF(NCOEF*KORDER), SSVAL, SSQUAD, SPVAL, SPQUAD
      real             BCOEF(NCOEF), PCOEF(MPC*KORDER)
      real             SD(1), SIGFAC, TKNOTS(NT), W(LDW,KORDER+1)
      real             X(NXY), XI(MPC+1), Y(NXY), YFIT, Z
      character IMAGE*31
      data X / 2.E0, 4.E0, 6.E0, 8.E0,10.E0,12.E0,
     *        14.E0,16.E0,18.E0,20.E0,22.E0,24.E0/
      data Y /2.2E0,4.0E0,5.0E0,4.6E0,2.8E0,2.7E0,
     *        3.8E0,5.1E0,6.1E0,6.3E0,5.0E0,2.0E0/
      data TKNOTS / 4*2.0E0, 6.4E0, 10.8E0, 15.2E0, 19.6E0, 4*24.0E0 /
      data NDERIV / 0 /
      data SD(1) / -1.0E0 /
c     ------------------------------------------------------------------
      print'('' DRSSFIT''/ '' Demo driver for SSFIT, SSVAL, SSQUAD,'',
     *  '' SSTOP, SPVAL, SPQUAD'')'
      print'(/''   KORDER ='',i3,'',  NCOEF ='',i3)', KORDER, NCOEF
c++ Code for ~.C. is active
      print'(''   TKNOTS() = '',4f10.5/(14x,4f10.5))',
     *   (TKNOTS(I), I = 1, NT)
c++ Code for .C. is inactive
c%%     printf( "\n   TKNOTS() = ");
c%%     for (i = 1; i <= NT+3; i+=4){
c%%        for (k = i; k <= min( i+3, NT ); k++)
c%%           printf( "%10.5f", Tknots[k] );
c%%        if (i + 3 < NT) printf( "\n              ");}
c++ End
      call SSFIT(X, Y, SD, NXY, KORDER, NCOEF, TKNOTS, BCOEF,
     *           SIGFAC,IERR, LDW, W)
c++ Code for ~.C. is active
      print'(/'' After call to SSFIT:''/''   IERR ='',i5,
     *  '',  SIGFAC ='', f10.5 //''   BCOEF() = '',
     *  4f10.5/(13x,4f10.5))', IERR, SIGFAC, (BCOEF(I),I=1,NCOEF)
c++ Code for .C. is inactive
c%%     printf( "\n After call to SSFIT:\n   IERR =%5ld,  SIGFAC ="
c%%        "%10.5f\n\n   BCOEF() = ", ierr, sigfac);
c%%     for (i = 1; i <= NCOEF+3; i+=4){
c%%        for (k = i; k <= min( i+3, NCOEF ); k++)
c%%           printf( "%10.5f", Bcoef[k] );
c%%        if (i + 3 < NCOEF) printf( "\n             ");}
c++ End
      print'(/'' Evaluating fitted spline function using SSVAL:'')'
      print'(/
     * ''    I    X       Y       YFIT  R=Y-YFIT               YFIT''/)'

      do 20 I=1,NXY
       YFIT=  SSVAL(KORDER, NCOEF, TKNOTS, BCOEF, X(I), NDERIV)
       call SPRPL(YFIT, '*', IMAGE, 31, 1.9e0, 6.3e0, .true.)
       print'(3x,i2,f6.0,2f9.3,f10.3,3x,a31)',
     *    I, X(I), Y(I), YFIT, Y(I)-YFIT, IMAGE
   20 continue

      Z = SSQUAD(KORDER, NCOEF, TKNOTS, BCOEF, 5.0e0, 20.0e0)
      print'(/'' Integral from 5.0  to 20.0 using SSQUAD:'',f12.5)',Z

      call SSTOP(KORDER, NCOEF, TKNOTS, BCOEF, BDIF, NPC, XI, PCOEF)
      print'(/
     * '' Using SSTOP to convert from B-spline basis to power basis.'')'
      print'(''        NPC ='',i3)',NPC
c++ Code for ~.C. is active
      print'(''       XI() = '',4f10.5/(14x,4f10.5))',(XI(I),I=1,NPC+1)
      print'(''    PCOEF() = '',4f10.5/(14x,4f10.5))',
     *   (PCOEF(I),I=1,NPC*KORDER)
c++ Code for .C. is inactive
c%%   printf( "       XI() = ");
c%%   for (i = 1; i <= (npc + 1); i+=4){
c%%      for (k = i; k <= min( i+3, npc+1 ); k++)
c%%           printf( "%10.5f", Xi[k] );
c%%      if (i <= npc) printf( "\n              ");}
c%%   printf( "\n    PCOEF() = ");
c%%   for (i = 1; i <= (npc*KORDER); i+=4){
c%%      for (k = i; k <= min( i+3, npc*KORDER ); k++)
c%%           printf( "%10.5f", Pcoef[k] );
c%%      if (i < npc*KORDER) printf( "\n              ");}
c++ End
      print'(/'' Evaluating fitted spline function using SPVAL:'')'
      print'(/
     * ''    I    X       Y       YFIT  R=Y-YFIT               YFIT''/)'

      do 40 I=1,NXY
       YFIT=  SPVAL(KORDER, NPC, XI, PCOEF, X(I), NDERIV)
       call SPRPL(YFIT, '*', IMAGE, 31, 1.9e0, 6.3e0, .true.)
       print'(3x,i2,f6.0,2f9.3,f10.3,3x,a31)',
     *    I, X(I), Y(I), YFIT, Y(I)-YFIT, IMAGE
   40 continue

      Z = SPQUAD(KORDER, NPC, XI, PCOEF, 5.0e0, 20.0e0)
      print'(/'' Integral from 5.0  to 20.0 using SPQUAD:'',f12.5)',Z
      end


program test_utilities
      use utilities
      implicit none
      integer, parameter :: M = 3, N = 4
      real :: A(M,N)

      call random_number(A)
      A = A - 0.5
      print*, "A ="
      call print_matrix(A)
end program


program test_fftw3_wrapper
    use, intrinsic :: iso_c_binding
    use m_boundary_type
    use m_fft_wrapper
    use m_fftw3_wrapper_1d
    implicit none

    print *, "test_fftw31d periodic"
    call test_fftw31d(63, BoundaryType_Periodic)

    print *, "test_fftw31d dirichlet"
    call test_fftw31d(63, BoundaryType_Dirichlet)

    print *, "test_fftw31d neumman"
    call test_fftw31d(63, BoundaryType_Neumann)

    print *, "test_fftw31d dirichlet neumman"
    call test_fftw31d(63, BoundaryType_Dirichlet_Neumann)

    print *, "test_fftw31d neumman dirichlet"
    call test_fftw31d(63, BoundaryType_Neumann_Dirichlet)

contains

    subroutine test_fftw31d(n, boundary_type)
        integer, intent(in):: n
        integer, intent(in) :: boundary_type

        double precision, allocatable :: original(:), forwarded(:), backwarded(:)
        integer :: i

        type(t_FFTW3Executor1d) :: fft
        double precision :: diff

        allocate (original(n))
        allocate (forwarded(n))
        allocate (backwarded(n))

        do i = 1, n
            original(i) = sin(1.0d0*i/n*2*3.14)
        end do

        fft%boundary_type = boundary_type

        fft = new_FFTW3Executor1d(n, boundary_type)

        call fft%forward(original, forwarded)
        call fft%backward(forwarded, backwarded)

        diff = sum(abs(backwarded(:) - original(:))) / size(original)

        call fft%destroy

        print *, "Diff =", diff
    end subroutine

end program


       function norm_1(T)
        implicit none

        type(Tensor1) :: T
        real(kind=8) :: norm_1

        norm_1 = sqrt(sum((T%a)**2))

       end function norm_1

       function norm_2(T)
        implicit none

        type(Tensor2) :: T
        real(kind=8) :: norm_2

        norm_2 = sqrt(T**T)

       end function norm_2

       function norm_2s(T)
        implicit none

        type(Tensor2s) :: T
        real(kind=8) :: norm_2s

        norm_2s = sqrt(T**T)

       end function norm_2s


*..............................................................

!-------------------------------------------------------------------------
!         NASA/GSFC, Data Assimilation Office, Code 910.3, GEOS/DAS      !
!-------------------------------------------------------------------------
!BOP
!
! !ROUTINE: ODS_Julian() --- Returns the Julian day
!
! !DESCRIPTION:
!    \label{ODS:Julian}
!     The routine returns the Julian day number based on the
!     calendar date.  The algorithm was adopted from Press et al.
!     The Julian day number on May 23, 1968 is 2,440,000.  The
!     year zero is treated as the year 1 since the year 0 does
!     not exist.
!
!    \bigskip {\bf Reference:}
!    \begin{description}
!    \item Press, William H., Saul A. Teukolsky, William T.
!        Vetterling and Brian P. Flannery, 1992: {\em Numerical
!        Recipes in Fortran}, 2nd Ed. Cambridge University
!        Press, New York, NY, 963pp.
!    \end{description}
!
! !INTERFACE:
!
      integer function ODS_Julian ( CalDate )
!
! !INPUT PARAMETERS:
      implicit NONE
      integer  CalDate  ! Calendar date in the format YYYYMMDD
                        !   where YYYY is the year, MM is the
                        !   month and DD is the day.  A negative
                        !   number implies that the year is B.C.
!
! !OUTPUT PARAMETERS:
!     integer  JulDay     Julian day number
!
! !SEE ALSO:
!     ODS_Min2Cal()   - Convert minutes since a given reference to
!                       "calendar" date and time
!     ODS_Cal2Min()   - Convert "calendar" date and time to minutes
!                       since a given reference
!     ODS_Time2Cal()  - converts ODS "time" attribute to "calendar"
!                       date and time
!     ODS_Cal2Time()  - converts "calendar" date and time to ODS
!                       time attribute
!     ODS_CalDat()    - calculates the "calendar" date and time
!                       from the Julian day
!
! !REVISION HISTORY:
!     13Apr1998  C. Redder   Original code.  Routine was developed to
!                            create ODS version 2.00
!     19Nov1999  C. Redder   Added a latex label in and moved the
!                            subroutine statement into the prologue.
!     06Dec1999  C. Redder   Corrections to the documentation in the
!                            prologue.
!     10May2000  C. Redder   Updated prologue to include the routines
!                            ODS_Min2Cal and ODS_Cal2Min in the
!                            "See Also" list
!
!EOP
!-------------------------------------------------------------------------

*     Other variables
*     ---------------
      integer     Year
      integer     Month
      integer     Day
      integer     iGreg  ! Gregorian Calendar adopted Oct 12, 1582
      parameter ( iGreg = 15 + 31 * ( 10 + 12 * 1582 ) )
      integer     JulDay
      integer     jy, jm, ja

      Year   =       CalDate / 10000
      Month  = mod ( CalDate,  10000 ) / 100
      Day    = mod ( CalDate,    100 )

*     Change year 0 to year 1
*     -----------------------
      if ( Year  .eq. 0 ) Year = 1

*     Account for the nonexisting year 0
*     ----------------------------------
      if ( Year  .lt. 0 ) Year = Year + 1

      if ( Month .gt. 2 ) then
         jy = Year
         jm = Month + 1

      else
         jy = Year  - 1
         jm = Month + 13

      endif

      JulDay = int ( 365.25  * jy )
     .       + int ( 30.6001 * jm )
     .       + Day + 1720995

*     Test whether to change to Gregorian Celendar
*     --------------------------------------------
      if ( Day + 31 * ( Month + 12 * Year ) .ge. iGreg) then
        ja     = int ( 0.01 * jy )
        Julday = JulDay + 2 - ja + int ( 0.25 * ja )

      endif

      ODS_Julian = JulDay

      return
      end


*DECK CGEFA
      SUBROUTINE CGEFA (A, LDA, N, IPVT, INFO)
C***BEGIN PROLOGUE  CGEFA
C***PURPOSE  Factor a matrix using Gaussian elimination.
C***LIBRARY   SLATEC (LINPACK)
C***CATEGORY  D2C1
C***TYPE      COMPLEX (SGEFA-S, DGEFA-D, CGEFA-C)
C***KEYWORDS  GENERAL MATRIX, LINEAR ALGEBRA, LINPACK,
C             MATRIX FACTORIZATION
C***AUTHOR  Moler, C. B., (U. of New Mexico)
C***DESCRIPTION
C
C     CGEFA factors a complex matrix by Gaussian elimination.
C
C     CGEFA is usually called by CGECO, but it can be called
C     directly with a saving in time if  RCOND  is not needed.
C     (Time for CGECO) = (1 + 9/N)*(Time for CGEFA) .
C
C     On Entry
C
C        A       COMPLEX(LDA, N)
C                the matrix to be factored.
C
C        LDA     INTEGER
C                the leading dimension of the array  A .
C
C        N       INTEGER
C                the order of the matrix  A .
C
C     On Return
C
C        A       an upper triangular matrix and the multipliers
C                which were used to obtain it.
C                The factorization can be written  A = L*U  where
C                L  is a product of permutation and unit lower
C                triangular matrices and  U  is upper triangular.
C
C        IPVT    INTEGER(N)
C                an integer vector of pivot indices.
C
C        INFO    INTEGER
C                = 0  normal value.
C                = K  if  U(K,K) .EQ. 0.0 .  This is not an error
C                     condition for this subroutine, but it does
C                     indicate that CGESL or CGEDI will divide by zero
C                     if called.  Use  RCOND  in CGECO for a reliable
C                     indication of singularity.
C
C***REFERENCES  J. J. Dongarra, J. R. Bunch, C. B. Moler, and G. W.
C                 Stewart, LINPACK Users' Guide, SIAM, 1979.
C***ROUTINES CALLED  CAXPY, CSCAL, ICAMAX
C***REVISION HISTORY  (YYMMDD)
C   780814  DATE WRITTEN
C   890831  Modified array declarations.  (WRB)
C   890831  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C   900326  Removed duplicate information from DESCRIPTION section.
C           (WRB)
C   920501  Reformatted the REFERENCES section.  (WRB)
C***END PROLOGUE  CGEFA
      INTEGER LDA,N,IPVT(*),INFO
      COMPLEX A(LDA,*)
C
      COMPLEX T
      INTEGER ICAMAX,J,K,KP1,L,NM1
      COMPLEX ZDUM
      REAL CABS1
      CABS1(ZDUM) = ABS(REAL(ZDUM)) + ABS(AIMAG(ZDUM))
C
C     GAUSSIAN ELIMINATION WITH PARTIAL PIVOTING
C
C***FIRST EXECUTABLE STATEMENT  CGEFA
      INFO = 0
      NM1 = N - 1
      IF (NM1 .LT. 1) GO TO 70
      DO 60 K = 1, NM1
         KP1 = K + 1
C
C        FIND L = PIVOT INDEX
C
         L = ICAMAX(N-K+1,A(K,K),1) + K - 1
         IPVT(K) = L
C
C        ZERO PIVOT IMPLIES THIS COLUMN ALREADY TRIANGULARIZED
C
         IF (CABS1(A(L,K)) .EQ. 0.0E0) GO TO 40
C
C           INTERCHANGE IF NECESSARY
C
            IF (L .EQ. K) GO TO 10
               T = A(L,K)
               A(L,K) = A(K,K)
               A(K,K) = T
   10       CONTINUE
C
C           COMPUTE MULTIPLIERS
C
            T = -(1.0E0,0.0E0)/A(K,K)
            CALL CSCAL(N-K,T,A(K+1,K),1)
C
C           ROW ELIMINATION WITH COLUMN INDEXING
C
            DO 30 J = KP1, N
               T = A(L,J)
               IF (L .EQ. K) GO TO 20
                  A(L,J) = A(K,J)
                  A(K,J) = T
   20          CONTINUE
               CALL CAXPY(N-K,T,A(K+1,K),1,A(K+1,J),1)
   30       CONTINUE
         GO TO 50
   40    CONTINUE
            INFO = K
   50    CONTINUE
   60 CONTINUE
   70 CONTINUE
      IPVT(N) = N
      IF (CABS1(A(N,N)) .EQ. 0.0E0) INFO = N
      RETURN
      END


module nltransf

!$$$   module documentation block
! module:    nltransf
! program history log:
! 2018-01-18 yang/Guo ! Jim Purser's nonlinear transformation for vis and cldch.
!  will work on the document late
!$$$   end documentation block
!                .      .    .                                       .

  use kinds, only: r_kind, i_kind
  use constants, only: zero

  implicit none
  private

  public:: nltransf_forward
        interface nltransf_forward ; module procedure  forward; end interface
  public:: nltransf_inverse
        interface nltransf_inverse ; module procedure  inverse; end interface

!

CONTAINS

subroutine forward(zin,zout,powerp,scale_cv)

!--------------------------------------------------------------
! input argument:
!   zin - vis or cldch
!   powerp - parameter for nltr
! output argument:
!   zout - the vis or cldch after the nonlinear transformation
!--------------------------------------------------------------
  implicit none
  real(r_kind),intent(in):: zin
  real(r_kind),intent(in):: powerp
  real(r_kind),intent(in):: scale_cv
  real(r_kind)           :: zout

! local variable
  real(r_kind) :: temp                      ! after the nltransformation
! do not choose negative powerp
  if (abs(powerp) > zero) then
    !non-log conversion
     temp =(zin/scale_cv)**powerp
     zout =(temp-1.0_r_kind)/powerp
  else
    !log conversion
     zout=log(zin/scale_cv)
  endif
  return
end subroutine forward

subroutine inverse(zin,zout,powerp,scale_cv)
  implicit none
  real(r_kind),intent(in):: zin
  real(r_kind),intent(in):: powerp
  real(r_kind),intent(in):: scale_cv
  real(r_kind)           :: zout

! Local variable
  real(r_kind) :: powerpinv
  real(r_kind) :: z1

!change zin from nltr space back to physical space
  if (abs(powerp)> zero) then
    ! non-log conversion
     powerpinv=1.0_r_kind/powerp
     z1=(powerp*zin + 1.0_r_kind)
     z1=z1**powerpinv
     zout=z1*scale_cv
  else
    ! log conversion
    zout=exp(zin)*scale_cv
  endif
  return
end subroutine inverse

end module nltransf


C$Procedure      RADREC ( Range, RA and DEC to rectangular coordinates )

      SUBROUTINE RADREC ( RANGE, RA, DEC, RECTAN )

C$ Abstract
C
C     Convert from range, right ascension, and declination to
C     rectangular coordinates.
C
C$ Disclaimer
C
C     THIS SOFTWARE AND ANY RELATED MATERIALS WERE CREATED BY THE
C     CALIFORNIA INSTITUTE OF TECHNOLOGY (CALTECH) UNDER A U.S.
C     GOVERNMENT CONTRACT WITH THE NATIONAL AERONAUTICS AND SPACE
C     ADMINISTRATION (NASA). THE SOFTWARE IS TECHNOLOGY AND SOFTWARE
C     PUBLICLY AVAILABLE UNDER U.S. EXPORT LAWS AND IS PROVIDED "AS-IS"
C     TO THE RECIPIENT WITHOUT WARRANTY OF ANY KIND, INCLUDING ANY
C     WARRANTIES OF PERFORMANCE OR MERCHANTABILITY OR FITNESS FOR A
C     PARTICULAR USE OR PURPOSE (AS SET FORTH IN UNITED STATES UCC
C     SECTIONS 2312-2313) OR FOR ANY PURPOSE WHATSOEVER, FOR THE
C     SOFTWARE AND RELATED MATERIALS, HOWEVER USED.
C
C     IN NO EVENT SHALL CALTECH, ITS JET PROPULSION LABORATORY, OR NASA
C     BE LIABLE FOR ANY DAMAGES AND/OR COSTS, INCLUDING, BUT NOT
C     LIMITED TO, INCIDENTAL OR CONSEQUENTIAL DAMAGES OF ANY KIND,
C     INCLUDING ECONOMIC DAMAGE OR INJURY TO PROPERTY AND LOST PROFITS,
C     REGARDLESS OF WHETHER CALTECH, JPL, OR NASA BE ADVISED, HAVE
C     REASON TO KNOW, OR, IN FACT, SHALL KNOW OF THE POSSIBILITY.
C
C     RECIPIENT BEARS ALL RISK RELATING TO QUALITY AND PERFORMANCE OF
C     THE SOFTWARE AND ANY RELATED MATERIALS, AND AGREES TO INDEMNIFY
C     CALTECH AND NASA FOR ALL THIRD-PARTY CLAIMS RESULTING FROM THE
C     ACTIONS OF RECIPIENT IN THE USE OF THE SOFTWARE.
C
C$ Required_Reading
C
C     None.
C
C$ Keywords
C
C     CONVERSION,   COORDINATES
C
C$ Declarations

      DOUBLE PRECISION      RANGE
      DOUBLE PRECISION      RA
      DOUBLE PRECISION      DEC
      DOUBLE PRECISION      RECTAN ( 3 )

C$ Brief_I/O
C
C     VARIABLE  I/O  DESCRIPTION
C     --------  ---  ---------------------------------------------------
C     RANGE      I   Distance of a point from the origin.
C     RA         I   Right ascension in radians.
C     DEC        I   Declination in radians.
C     RECTAN     O   Rectangular coordinates of the point.
C
C$ Detailed_Input
C
C     RANGE      is the distance of the point from the origin. Input
C                should be in terms of the same units in which the
C                output is desired.
C
C
C     RA         is the right ascension of RECTAN.  This is the angular
C                distance measured toward the east from the prime
C                meridian to the meridian containing the input point.
C                The direction of increasing right ascension is from
C                the +X axis towards the +Y axis.
C
C                The range (i.e., the set of allowed values) of
C                RA is unrestricted.  Units are radians.
C
C
C     DEC        is the declination of RECTAN.  This is the angle from
C                the XY plane of the ray from the origin through the
C                point.
C
C                The range (i.e., the set of allowed values) of
C                DEC is unrestricted.  Units are radians.
C
C
C$ Detailed_Output
C
C     RECTAN     is the array containing the rectangular coordinates of
C                the point.
C
C                The units associated with RECTAN are those
C                associated with the input RANGE.
C
C$ Parameters
C
C     None.
C
C$ Exceptions
C
C     Error free.
C
C$ Files
C
C     None.
C
C$ Particulars
C
C     This routine converts the right ascension, declination, and range
C     of a point into the associated rectangular coordinates.
C
C     The input is defined by a distance from a central reference point,
C     an angle from a reference meridian, and an angle above the equator
C     of a sphere centered at the central reference point.
C
C$ Examples
C
C     The following code fragment converts right ascension and
C     declination from the B1950 reference frame to the J2000 frame.
C
C        C
C        C     Convert RA and DEC to a 3-vector expressed in
C        C     the B1950 frame.
C        C
C              CALL RADREC ( 1.D0, RA, DEC, V1950 )
C        C
C        C     We use the SPICELIB routine PXFORM to obtain the
C        C     transformation  matrix for converting vectors between
C        C     the B1950 and J2000 reference frames.  Since
C        C     both frames are inertial, the input time value we
C        C     supply to PXFORM is arbitrary.  We choose zero
C        C     seconds past the J2000 epoch.
C        C
C              CALL PXFORM ( 'B1950', 'J2000', 0.D0, MTRANS )
C        C
C        C     Transform the vector to the J2000 frame.
C        C
C              CALL MXV ( MTRANS, V1950, V2000 )
C        C
C        C     Find the RA and DEC of the J2000-relative vector.
C        C
C              CALL RECRAD ( V2000, R, RA, DEC )
C
C$ Restrictions
C
C     None.
C
C$ Author_and_Institution
C
C     C.H. Acton      (JPL)
C     N.J. Bachman    (JPL)
C     H.A. Neilan     (JPL)
C
C$ Literature_References
C
C     "Celestial Mechanics, A Computational Guide for the Practitioner"
C           by Laurence G. Taff
C
C$ Version
C
C-    SPICELIB Version 1.0.2, 30-JUL-2003 (NJB) (CHA)
C
C        Various header changes were made to improve clarity.  Some
C        minor header corrections were made.
C
C-     SPICELIB Version 1.0.1, 10-MAR-1992 (WLT)
C
C         Comment section for permuted index source lines was added
C         following the header.
C
C-     SPICELIB Version 1.0.0, 31-JAN-1990 (HAN)
C
C-&

C$ Index_Entries
C
C     range ra and dec to rectangular coordinates
C     right_ascension and declination to rectangular
C
C-&

C$ Revisions
C
C-     Beta Version 1.1.0, 19-MAY-1989 (HAN)
C
C         Removed calls to CHKIN and CHKOUT. This routine is
C         "error free" and should not have been participating
C         in error handling.
C
C-&

C
C     Convert from range, right ascension, and declination to
C     rectangular coordinates by calling the routine LATREC.
C

      CALL LATREC ( RANGE, RA, DEC, RECTAN )

      RETURN
      END


c
c    tests subroutines shpei and shpe in file shpe.f
c    also requires files  shaec.f shsec.f sphcom.f and hrfft.f
c
c    shpe is the n**2 filter with complement, odd/even
c    factorization and zero truncation on an equally spaced
c    grid. The projection is defined in the JCP paper "Generalized
c    discrete spherical harmonic transforms" by
c    Paul N. Swarztrauber and William F. Spotz
c    J. Comp. Phys., 159(2000) pp. 213-230.
c
c                     April 2002
c
      program tshpe
      parameter (idp=32)
      parameter (kdp=idp+idp-2)
      parameter (lwshp=2*(idp+1)**2+kdp+20,
     1    liwshp=4*(idp+1),lwrk=1.25*(idp+1)**2+7*idp+8)
      parameter (lwrk1=idp*kdp)
      parameter(lwork = 5*idp*(idp-1),
     1 lwsha=idp*(idp+1)+3*(idp-2)*(idp-1)/2+kdp+15)
      double precision work(lwrk)
      dimension sx(idp,kdp),sy(idp,kdp),
     1wshp(lwshp),iwshp(liwshp),wrk1(lwrk1)
      dimension g(idp,kdp,2),ga(idp,idp,2),gb(idp,idp,2),
     1          gh(idp,kdp,2),gw(idp,kdp,2),
     2          wrk2(lwork),wshaec(lwsha),wshsec(lwsha)
      dimension t1(2)
c
      iprint = 0
      nt = 1
c
      do 100 nlat=6,8
      do 100 mtr=1,3
      mtrunc = nlat-mtr
      idimg = idp
      jdimg = kdp
      nlon = 2*(nlat-1)
      mtrunc = min(mtrunc,nlat-1,nlon/2)
      call shaeci(nlat,nlon,wshaec,lwsha,work,lwrk,ierror)
      if(ierror .ne. 0) write(6,70) ierror
   70 format('   ierror0' ,i5)
c
      lwshs = lwsha
      call shseci(nlat,nlon,wshsec,lwshs,work,lwrk,ierror)
      if(ierror .ne. 0) write(6,71) ierror
   71 format('   ierror1' ,i5)
c
      mode = 0
      if(iprint .ne. 0) write (6,5) mode,nlat,nlon
    5 format(' mode =' ,i5,'  nlat =',i5,'  nlon =',i5)
c
      do 10 k=1,nt
      do 10 i=1,nlat
      do 10 j=1,nlon
      g(i,j,k) = cos(float(i*j))
      gh(i,j,k) = g(i,j,k)
   10 continue
c
      thold = etime(t1)
      thold = t1(1)
      call shaec(nlat,nlon,mode,nt,g,idimg,jdimg,ga,gb,idimg,idimg,
     1              wshaec,lwsha,wrk2,lwork,ierror)
      if(ierror .ne. 0) write(6,72) ierror
   72 format('   ierror2' ,i5)
c
      if(mtrunc.lt.nlat-1) then
      do np1=mtrunc+2,nlat
       do mp1=1,np1
        ga(mp1,np1,1) = 0.
        gb(mp1,np1,1) = 0.
       end do
      end do
      end if
      call shsec(nlat,nlon,mode,nt,gw,idimg,jdimg,ga,gb,idimg,idimg,
     1              wshsec,lwshs,wrk2,lwork,ierror)
      tusl = etime(t1)
      tusl = t1(1)-thold
      if(ierror .ne. 0) write(6,73) ierror
   73 format('   ierror3' ,i5)
c
c     faster filter
c
      isym = 0
c      mtrunc = nlat-1
      call shpei(nlat,nlon,isym,mtrunc,wshp,lwshp,iwshp,liwshp,
     1 work,lwrk,ierror)
c
      if(ierror.ne.0) write(*,429) ierror
 429  format(' ierror =',i5,' at 429')
      do j=1,nlon
      do i=1,nlat
      sx(i,j) = gh(i,j,1)
      end do
      end do
c
c      do i=1,nlat
c       write(*,427) i,(sx(i,j),j=1,nlon)
c 427   format(i5,1p4e15.6/(5x,1p4e15.6))
c      end do
      thold = etime(t1)
      toe = t1(1)
      call shpe(nlat,nlon,isym,mtrunc,sx,sy,idp,
     1  wshp,lwshp,iwshp,liwshp,wrk1,lwrk1,ierror)
      thold = etime(t1)
      toe = t1(1)-toe
      if(ierror.ne.0) write(*,428) ierror
 428  format(' ierror =',i5,' at 428')
      if(iprint.gt.0)write(*,431)
 431  format(/' approx and exact solution'/)
      do j=1,nlon
      if(iprint.gt.0)write(*,437) j,(sy(i,j),gw(i,j,1),i=1,nlat)
 437  format(' j=',i5,1p4e15.6/(8x,1p4e15.6))
      end do
      dmax1 = 0.
      do j=1,nlon
      do i=1,nlat
      dmax1 = max(dmax1,abs(sy(i,j)-gw(i,j,1)))
      end do
      end do
      write (6,134) nlat,mtrunc
 134  format(/'case nlat =',i5,' and mtrunc =',i5/)
      write(*,135) dmax1,tusl,toe
 135  format(/' error =',1pe15.6/
     1        ' tusl  =',1pe15.6/
     2        ' toe   =',1pe15.6)
  100 continue
      end


module three_dimensional_solvers

    use fishpack_precision, only: &
        wp, & ! Working precision
        ip, & ! Integer precision
        PI

    use type_FishpackWorkspace, only: &
        FishpackWorkspace

    use type_PeriodicFastFourierTransform, only: &
        PeriodicFastFourierTransform

    ! Explicit typing only
    implicit none

    ! Everything is private unless stated otherwise
    private
    public :: pois3d
    public :: hw3crt
    public :: SolverUtility3D

    ! Parameters confined to the module
    real(wp),    parameter :: ZERO = 0.0_wp
    real(wp),    parameter :: HALF = 0.5_wp
    real(wp),    parameter :: ONE = 1.0_wp
    real(wp),    parameter :: TWO = 2.0_wp
    real(wp),    parameter :: FOUR = 4.0_wp
    integer(ip), parameter :: SIZE_OF_WORKSPACE_INDICES = 6

    type, public :: SolverUtility3D
        ! Type components
        integer(ip) :: IIWK = SIZE_OF_WORKSPACE_INDICES
    contains
        ! Type-bound procedures
        procedure, nopass :: pois3dd
        procedure, nopass :: check_input_arguments
        procedure, nopass :: get_workspace_indices
    end type SolverUtility3D

    ! Declare interfaces for submodule implementation
    interface
        module subroutine pois3d(lperod, l, c1, mperod, m, c2, nperod, n, a, b, c, &
            ldimf, mdimf, f, ierror)

            ! Dummy arguments
            integer(ip), intent(in)    :: lperod
            integer(ip), intent(in)    :: l
            integer(ip), intent(in)    :: mperod
            integer(ip), intent(in)    :: m
            integer(ip), intent(in)    :: nperod
            integer(ip), intent(in)    :: n
            integer(ip), intent(in)    :: ldimf
            integer(ip), intent(in)    :: mdimf
            integer(ip), intent(out)   :: ierror
            real(wp),    intent(in)    :: c1
            real(wp),    intent(in)    :: c2
            real(wp),    intent(inout) :: a(:)
            real(wp),    intent(inout) :: b(:)
            real(wp),    intent(inout) :: c(:)
            real(wp),    intent(inout) :: f(:,:,:)
        end subroutine pois3d

        module subroutine hw3crt(xs, xf, l, lbdcnd, bdxs, bdxf, ys, yf, m, mbdcnd, &
            bdys, bdyf, zs, zf, n, nbdcnd, bdzs, bdzf, elmbda, ldimf, &
            mdimf, f, pertrb, ierror)

            ! Dummy arguments
            integer(ip), intent(in)     :: l
            integer(ip), intent(in)     :: lbdcnd
            integer(ip), intent(in)     :: m
            integer(ip), intent(in)     :: mbdcnd
            integer(ip), intent(in)     :: n
            integer(ip), intent(in)     :: nbdcnd
            integer(ip), intent(in)     :: ldimf
            integer(ip), intent(in)     :: mdimf
            integer(ip), intent(out)    :: ierror
            real(wp),    intent(in)     :: xs
            real(wp),    intent(in)     :: xf
            real(wp),    intent(in)     :: ys
            real(wp),    intent(in)     :: yf
            real(wp),    intent(in)     :: zs
            real(wp),    intent(in)     :: zf
            real(wp),    intent(in)     :: elmbda
            real(wp),    intent(out)    :: pertrb
            real(wp),    intent(in)     :: bdxs(:,:)
            real(wp),    intent(in)     :: bdxf(:,:)
            real(wp),    intent(in)     :: bdys(:,:)
            real(wp),    intent(in)     :: bdyf(:,:)
            real(wp),    intent(in)     :: bdzs(:,:)
            real(wp),    intent(in)     :: bdzf(:,:)
            real(wp),    intent(inout)  :: f(:,:,:)
        end subroutine hw3crt
    end interface

contains

    subroutine pois3dd(lperod, l, c1, mperod, m, c2, nperod, n, a, b, &
        c, ldimf, mdimf, f, ierror, w, workspace_indices)

        ! Dummy arguments
        integer(ip), intent(in)    :: lperod
        integer(ip), intent(in)    :: l
        integer(ip), intent(in)    :: mperod
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: nperod
        integer(ip), intent(in)    :: n
        integer(ip), intent(in)    :: ldimf
        integer(ip), intent(in)    :: mdimf
        integer(ip), intent(out)   :: ierror
        integer(ip), intent(in)    :: workspace_indices(:)
        real(wp),    intent(in)    :: c1
        real(wp),    intent(in)    :: c2
        real(wp),    intent(inout) :: a(n)
        real(wp),    intent(inout) :: b(n)
        real(wp),    intent(inout) :: c(n)
        real(wp),    intent(inout) :: f(:,:,:)
        real(wp),    intent(inout) :: w(:)

        ! Local variables
        integer(ip) :: nh, nhm1, nodd, i, j, k
        real(wp)    :: temp_save(SIZE_OF_WORKSPACE_INDICES)

        ! Check input arguments
        call check_input_arguments(lperod, l, mperod, m, nperod, n, &
            a, b, c, ldimf, mdimf, ierror)

        ! Check error flag
        if (ierror /= 0) return

        associate( &
            lp => lperod + 1, &
            mp => mperod + 1, &
            np => nperod + 1, &
            iwyrt => workspace_indices(1), &
            iwt => workspace_indices(2), &
            iwd => workspace_indices(3), &
            iwbb => workspace_indices(4), &
            iwx => workspace_indices(5), &
            iwy => workspace_indices(6) &
            )

            if (np == 1) then
                ! Reorder unknowns when nperod = 0
                nh = (n + 1)/2
                nhm1 = nh - 1

                if (2*nh == n) then
                    nodd = 2
                else
                    nodd = 1
                end if

                do i = 1, l
                    do j = 1, m
                        do k = 1, nhm1
                            w(k) = f(i, j, nh-k) - f(i, j, k+nh)
                            w(k+nh) = f(i, j, nh-k) + f(i, j, k+nh)
                        end do

                        w(nh) = TWO*f(i, j, nh)

                        select case (nodd)
                            case (1)
                                f(i, j,:n) = w(:n)
                            case (2)
                                w(n) = TWO * f(i, j, n)
                                f(i, j,:n) = w(:n)
                        end select

                    end do
                end do

                temp_save(1) = c(nhm1)
                temp_save(2) = a(nh)
                temp_save(3) = c(nh)
                temp_save(4) = b(nhm1)
                temp_save(5) = b(n)
                temp_save(6) = a(n)

                c(nhm1) = ZERO
                a(nh) = ZERO
                c(nh) = TWO*c(nh)

                select case (nodd)
                    case (2)
                        a(n) = c(nh)
                    case default
                        b(nhm1) = b(nhm1) - a(nh-1)
                        b(n) = b(n) + a(n)
                end select
            end if

            call pois3dd_lower_routine(lp, l, mp, m, n, a, b, c, f, &
                w, w(iwyrt:), w(iwt:), w(iwd:), w(iwx:), w(iwy:), c1, c2, w(iwbb:))

            if (np == 1) then
                do i = 1, l
                    do j = 1, m
                        w(nh-1:nh-nhm1:(-1))= &
                            HALF *(f(i, j, nh+1:nhm1+nh)+f(i, j,:nhm1))
                        w(nh+1:nhm1+nh) = &
                            HALF *(f(i, j, nh+1:nhm1+nh)-f(i, j,:nhm1))
                        w(nh) = HALF *f(i, j, nh)
                        select case (nodd)
                            case (1)
                                f(i, j,:n) = w(:n)
                            case (2)
                                w(n) = HALF * f(i, j, n)
                                f(i, j,:n) = w(:n)
                        end select
                    end do
                end do

                c(nhm1) = temp_save(1)
                a(nh) = temp_save(2)
                c(nh) = temp_save(3)
                b(nhm1) = temp_save(4)
                b(n) = temp_save(5)
                a(n) = temp_save(6)
            end if
        end associate

    end subroutine pois3dd

    pure subroutine check_input_arguments(lperod, l, mperod, m, nperod, n, &
        a, b, c, ldimf, mdimf, ierror)

        ! Dummy arguments
        integer(ip), intent(in)   :: lperod
        integer(ip), intent(in)   :: l
        integer(ip), intent(in)   :: mperod
        integer(ip), intent(in)   :: m
        integer(ip), intent(in)   :: nperod
        integer(ip), intent(in)   :: n
        integer(ip), intent(in)   :: ldimf
        integer(ip), intent(in)   :: mdimf
        integer(ip), intent(out)  :: ierror
        real(wp),    intent(in)   :: a(n)
        real(wp),    intent(in)   :: b(n)
        real(wp),    intent(in)   :: c(n)

        associate( &
            lp => lperod + 1, &
            mp => mperod + 1, &
            np => nperod + 1 &
            )

            if (lp < 1 .or. lp > 5) then
                ierror = 1
            else if (l < 3) then
                ierror = 2
            else if (mp < 1 .or. mp > 5) then
                ierror = 3
            else if (m < 3) then
                ierror = 4
            else if (np < 1 .or. np > 2) then
                ierror = 5
            else if (n < 3) then
                ierror = 6
            else if (ldimf < l) then
                ierror = 7
            else if (mdimf < m) then
                ierror = 8
            else if (np == 1) then
                if (any(a /= c(1)) .or. any(c /= c(1)) .or. any(b /= b(1))) then
                    ierror = 9
                end if
            else if (nperod == 1 .and. (a(1) /= ZERO .or. c(n) /= ZERO)) then
                ierror = 10
            else
                ierror = 0
            end if
        end associate

    end subroutine check_input_arguments

    pure function get_workspace_indices(l, m, n) &
        result (return_value)

        ! Dummy arguments
        integer(ip), intent(in)     :: l
        integer(ip), intent(in)     :: m
        integer(ip), intent(in)     :: n
        integer(ip)                 :: return_value(SIZE_OF_WORKSPACE_INDICES)

        associate( indx => return_value )
            indx(1) = l + 1
            indx(2) = indx(1) + m
            indx(3) = indx(2) + max(l, m, n) + 1
            indx(4) = indx(3) + n
            indx(5) = indx(4) + n
            indx(6) = indx(5) + 7*((l + 1)/2) + 15
        end associate

    end function get_workspace_indices

    subroutine pois3dd_lower_routine(lp, l, mp, m, n, a, b, c, &
        f, xrt, yrt, t, d, wx, wy, c1, c2, bb)

        ! Dummy arguments
        integer(ip), intent(in)    :: lp
        integer(ip), intent(in)    :: l
        integer(ip), intent(in)    :: mp
        integer(ip), intent(in)    :: m
        integer(ip), intent(in)    :: n
        real(wp),    intent(in)    :: c1
        real(wp),    intent(in)    :: c2
        real(wp),    intent(inout) :: a(n)
        real(wp),    intent(in)    :: b(n)
        real(wp),    intent(inout) :: c(n)
        real(wp),    intent(inout) :: f(:,:,:)
        real(wp),    intent(inout) :: xrt(:)
        real(wp),    intent(inout) :: yrt(:)
        real(wp),    intent(inout) :: t(:)
        real(wp),    intent(inout) :: d(:)
        real(wp),    intent(inout) :: wx(:)
        real(wp),    intent(inout) :: wy(:)
        real(wp),    intent(inout) :: bb(:)

        ! Local variables
        integer(ip) :: lr, mr, nr, lrdel, i, mrdel, j, ifwrd, is, k
        real(wp)    :: scalx, dx, di, scaly, dy, dj
        type(PeriodicFastFourierTransform)  :: fft

        lr = l
        mr = m
        nr = n

        ! generate transform roots
        lrdel = ((lp - 1)*(lp - 3)*(lp - 5))/3
        scalx = lr + lrdel
        dx = PI/(TWO*scalx)

        select case (lp)
            case (1)
                xrt(1) = ZERO
                xrt(lr) = -FOUR*c1

                do i = 3, lr, 2
                    xrt(i-1) = -FOUR*c1*sin(real(i - 1, kind=wp)*dx)**2
                    xrt(i) = xrt(i-1)
                end do

                call fft%rffti(lr, wx)

            case default

                select case (lp)
                    case (2)
                        di = ZERO
                    case (3, 5)
                        di = HALF
                        scalx = TWO*scalx
                    case (4)
                        di = ONE
                end select

                do i = 1, lr
                    xrt(i) = -FOUR*c1*sin((real(i, kind=wp) - di)*dx)**2
                end do

                scalx = TWO*scalx

                if (lp /= 1) then
                    select case (lp)
                        case (2)
                            call fft%sinti(lr, wx)
                        case (3)
                            call fft%sinqi(lr, wx)
                        case (4)
                            call fft%costi(lr, wx)
                        case (5)
                            call fft%cosqi(lr, wx)
                        case default

                            xrt(1) = ZERO
                            xrt(lr) = -FOUR*c1

                            do i = 3, lr, 2
                                xrt(i-1) = -FOUR*c1*sin(real(i - 1)*dx)**2
                                xrt(i) = xrt(i-1)
                            end do

                            call fft%rffti(lr, wx)
                    end select
                end if
        end select

        mrdel = ((mp - 1)*(mp - 3)*(mp - 5))/3
        scaly = mr + mrdel
        dy = PI/(TWO*scaly)

        select case (mp)
            case (1)
                yrt(1) = ZERO
                yrt(mr) = -FOUR*c2

                do j = 3, mr, 2
                    yrt(j-1) = -FOUR*c2*sin(real(j - 1, kind=wp)*dy)**2
                    yrt(j) = yrt(j-1)
                end do

                call fft%rffti(mr, wy)

            case default

                select case (mp)
                    case (2)
                        dj = ZERO
                    case (3, 5)
                        dj = HALF
                        scaly = TWO*scaly
                    case (4)
                        dj = ONE
                end select

                do j = 1, mr
                    yrt(j) = -FOUR*c2*sin((real(j, kind=wp) - dj)*dy)**2
                end do

                scaly = TWO * scaly

                select case (mp)
                    case (1)
                        yrt(1) = ZERO
                        yrt(mr) = -FOUR*c2

                        do j = 3, mr, 2
                            yrt(j-1) = -FOUR*c2*sin(real(j - 1, kind=wp)*dy)**2
                            yrt(j) = yrt(j-1)
                        end do

                        call fft%rffti(mr, wy)

                    case default

                        select case (mp)
                            case (2)
                                call fft%sinti(mr, wy)
                            case (3)
                                call fft%sinqi(mr, wy)
                            case (4)
                                call fft%costi(mr, wy)
                            case (5)
                                call fft%cosqi(mr, wy)
                        end select

                end select
        end select

        ifwrd = 1
        is = 1

        x_transform: do
            do j=1, mr
                do k=1, nr
                    do i=1, lr
                        t(i) = f(i, j, k)
                    end do
                    select case (lp)
                        case (1)
                            select case (ifwrd)
                                case (1)
                                    call fft%rfftf(lr, t, wx)
                                case (2)
                                    call fft%rfftb(lr, t, wx)
                            end select
                        case (2)
                            call fft%sint(lr, t, wx)
                        case (3)
                            select case (ifwrd)
                                case (1)
                                    call fft%sinqf(lr, t, wx)
                                case (2)
                                    call fft%sinqb(lr, t, wx)
                            end select
                        case (4)
                            call fft%cost(lr, t, wx)
                        case (5)
                            select case (ifwrd)
                                case (1)
                                    call fft%cosqf(lr, t, wx)
                                case (2)
                                    call fft%cosqb(lr, t, wx)
                            end select
                    end select

                    do i=1, lr
                        f(i, j, k) = t(i)
                    end do
                end do
            end do

            if (ifwrd == 2) then
                f(:lr,:mr,:nr) = f(:lr,:mr,:nr)/(scalx*scaly)
                return
            end if

            y_transform: do
                do i=1, lr
                    do k=1, nr
                        t(1:mr) = f(i,1:mr, k)
                        select case (mp)
                            case (1)
                                select case (ifwrd)
                                    case (1)
                                        call fft%rfftf(mr, t, wy)
                                    case (2)
                                        call fft%rfftb(mr, t, wy)
                                end select
                            case (2)
                                call fft%sint(mr, t, wy)
                            case (3)
                                select case (ifwrd)
                                    case (1)
                                        call fft%sinqf(mr, t, wy)
                                    case (2)
                                        call fft%sinqb(mr, t, wy)
                                end select
                            case (4)
                                call fft%cost(mr, t, wy)
                            case (5)
                                select case (ifwrd)
                                    case (1)
                                        call fft%cosqf(mr, t, wy)
                                    case (2)
                                        call fft%cosqb(mr, t, wy)
                                end select
                        end select
                        f(i,1:mr, k) = t(1:mr)
                    end do
                end do

                select case (ifwrd)
                    case (1)
                        do i = 1, lr
                            do j = 1, mr
                                bb(:nr) = b(:nr) + xrt(i) + yrt(j)
                                t(:nr) = f(i, j,:nr)

                                call solve_tridiag(nr, a, bb, c, t, d)

                                f(i, j,:nr) = t(:nr)
                            end do
                        end do
                        ifwrd = 2
                        is = -1
                        cycle y_transform
                    case (2)
                        cycle x_transform
                end select

                exit y_transform
            end do y_transform

            exit x_transform
        end do x_transform

        f(:lr,:mr,:nr) = f(:lr,:mr,:nr)/(scalx*scaly)

    end subroutine pois3dd_lower_routine

    subroutine solve_tridiag(m, a, b, c, y, d)

        ! Dummy arguments
        integer(ip), intent(in)    :: m
        real(wp),    intent(in)    :: a(m) ! subdiagonal, i.e., the diagonal below the main diagonal
        real(wp),    intent(in)    :: b(m) ! the main diagonal
        real(wp),    intent(in)    :: c(m) ! supdiagonal, i.e, the diagonal above the main diagonal
        real(wp),    intent(inout) :: y(m) ! the answer
        real(wp),    intent(inout) :: d(m) ! right part

        ! Local variables
        integer(ip) :: i
        real(wp)    :: temp

        ! Initialize
        d(1) = c(1)/b(1)
        y(1) = y(1)/b(1)

        do i = 2, m - 1
            temp = b(i) - d(i - 1) * a(i)
            d(i) = c(i)/temp
            y(i) = (y(i) - a(i) * y(i - 1))/temp
        end do

        temp = b(m) - a(m) * d(m - 1)

        if (temp == ZERO) then
            y(m) = ZERO
        else
            y(m) = (y(m) - a(m) * y(m - 1))/temp
        end if

        do i = m - 1, 1, -1
            y(i) = y(i) - d(i) * y(i + 1)
        end do

    end subroutine solve_tridiag

end module three_dimensional_solvers


program i
  real ::b=(10.0 * 4)
  real  ::c=(4.0 ** 2)
  real :: a
  a = (b * c)
end program i