module geom
  !! Some operations on box tensors etc...
  implicit none

contains

  real(8) function inverse_box(a,ai)
    !! Computes the inverse of box `a` to `ai`. Returns the determinant of `a`.
    implicit none
    real(8) :: a(3,3),ai(3,3)

    real(8) :: det

    det = +a(1,1)*(a(2,2)*a(3,3)-a(2,3)*a(3,2))&
      -a(1,2)*(a(2,1)*a(3,3)-a(2,3)*a(3,1))&
      +a(1,3)*(a(2,1)*a(3,2)-a(2,2)*a(3,1))

    if(det>0.d0) then
      ai(1,1)=+(a(2,2)*a(3,3)-a(2,3)*a(3,2))
      ai(1,2)=-(a(1,2)*a(3,3)-a(1,3)*a(3,2))
      ai(1,3)=+(a(1,2)*a(2,3)-a(1,3)*a(2,2))
      ai(2,1)=-(a(2,1)*a(3,3)-a(2,3)*a(3,1))
      ai(2,2)=+(a(1,1)*a(3,3)-a(1,3)*a(3,1))
      ai(2,3)=-(a(1,1)*a(2,3)-a(1,3)*a(2,1))
      ai(3,1)=+(a(2,1)*a(3,2)-a(2,2)*a(3,1))
      ai(3,2)=-(a(1,1)*a(3,2)-a(1,2)*a(3,1))
      ai(3,3)=+(a(1,1)*a(2,2)-a(1,2)*a(2,1))

      ai = ai/det
    else
      ai = 0.d0
    end if

    inverse_box = det

  end function inverse_box

  subroutine print_box(unit, a)
    !! Pints a 3x3 array `a` to `unit` in a line1\nline2\n... fashion.
    implicit none
    integer :: unit
    real(8) :: a(3,3)
    integer :: i
    do i=1,3
      write(unit, '(3G16.7)') a(i,1:3)
    end do
  end subroutine print_box

  real(8) function volume_box(a)
    !! Compute the volume of box of tensor `a`.
    implicit none
    real(8) :: a(3,3)

    real(8) :: det

    det=a(1,1)*(a(2,2)*a(3,3)-a(3,2)*a(2,3)) - a(2,1)*(a(1,2)*a(3,3)-a(3,2)*a(1,3))&
      +a(3,1)*(a(1,2)*a(2,3)-a(2,2)*a(1,3))

    volume_box = det

  end function volume_box

  subroutine calc_metric(a, m)
    !! Compute the metric of a box of tensor `a` to `m`.
    real(8), intent(in) :: a(3,3)
    real(8), intent(out) :: m(3,3)

    integer :: i,j,k
    do i=1,3
      do j=1,3
        m(i,j) = 0.d0
        do k=1,3
          m(i,j) = m(i,j) + a(k,i)*a(k,j)
        end do
      end do
    end do

  end subroutine calc_metric

  function matvec3_prod(bt,p)
    !! Matrix product of `bt` with `p`.
    real(8) :: matvec3_prod(3)
    real(8), intent(in) :: bt(3,3), p(3)
    integer :: i
    do i=1,3
      matvec3_prod(i) = bt(i,1)*p(1) + bt(i,2)*p(2) + bt(i,3)*p(3)
    end do
  end function matvec3_prod

  subroutine create_box_from_3l3a(boxtens,La,Lb,Lc,alpha,beta,gamma)
    !! Computes a box tensor from box lengths and box angles.
    implicit none
    real(8),intent(in) :: La,Lb,Lc,alpha,beta,gamma
    real(8),intent(out) :: boxtens(3,3)

    real(8) :: a(3),b(3),c(3)

    a(1)=la ; a(2)=0.D0 ; a(3)=0.D0
    b(1)=lb*cos(gamma) ; b(2) = lb*sin(gamma) ; b(3)=0.D0
    c(1)=lc*cos(beta)
    c(2)=lc/(lb*sin(gamma))*(lb*cos(alpha)-la*cos(beta)*cos(gamma))
    c(3) = sqrt(lc**2-c(2)**2-c(1)**2)

    boxtens(1,:) = a
    boxtens(2,:) = b
    boxtens(3,:) = c

  end subroutine create_box_from_3l3a

end module geom


\ https://rosettacode.org/wiki/Sum_digits_of_an_integer#Forh

: SUM-INT 0 BEGIN OVER WHILE SWAP BASE @ /MOD SWAP ROT + REPEAT NIP ;

T{ 2 BASE ! 11110 SUM-INT -> #4  }T
T{ DECIMAL  12345 SUM-INT -> #15 }T
T{ HEX      F0E   SUM-INT -> #29 }T


MODULE externalModule

    IMPLICIT NONE

CONTAINS

    REAL FUNCTION rectagleArea( side_a_length , side_b_length )
        IMPLICIT NONE
        REAL, INTENT(IN) :: side_a_length
        REAL, INTENT(IN) :: side_b_length

        rectagleArea=side_a_length*side_b_length
    END FUNCTION

END MODULE externalModule


program xrandom_int
implicit none
integer, parameter :: n = 10**6 ! # of random integers
integer, parameter :: imax = 5 ! maximum random integer (min is 1)
real :: xran(n)
integer :: iran(n),i
call random_seed()
call random_number(xran) ! generate uniform deviates
iran = 1 + imax*xran     ! transform uniform deviates to random integers from 1 to imax
print*,"#samples =",n
print*,"min, max random integer",1,imax
print*,"# outside range =",count(iran < 1 .or. iran > imax) ! should be zero
print "(/,2a10)", "i","count"
do i=1,imax
   print "(2i10)", i,count(iran==i)
end do
end program xrandom_int


subroutine getplane(x1,y1,z1,x2,y2,z2,A,B,C)
  implicit none
  real:: x1,y1,z1,x2,y2,z2, A,B,C
  A=y1*z2-z1*y2
  B=z1*x2-x1*z2
  C=x1*y2-x2*y1
  !print*, A,B,C
end subroutine getplane

subroutine getAnglePlanes(A1,B1,C1,A2,B2,C2,angle)
  implicit none
  real:: A1,B1,C1,A2,B2,C2,angle
  real:: a11,a22
  a11=abs(A1*A2+B1*B2+C1*C2)
  a22=sqrt(A1**2+B1**2+C1**2)*sqrt(A2**2+B2**2+C2**2)
  if(a22>a11) then
     angle=acos(a11/a22)
  else
     angle=0.
  endif
end subroutine getAnglePlanes
!def hdist(lats,latf,lons,lonf):
!    dphi=abs(lats-latf)
!    dlam=abs(lons-lonf)
!    d=2*asin(sqrt(sin(dphi/2)**2+cos(lats)*cos(latf)*sin(dlam/2)**2))
!    return d
!def rotation(x,y,z,incangle):
!    x1=x
!    y1=y*cos(incangle)-z*sin(incangle)
!    z1=y*sin(incangle)+z*cos(incangle)
!    return x1,y1,z1

subroutine fromlatlon(lat,lon,x,y,z)
  implicit none
  real:: x,y,z,lat,lon
  x=cos(lon)*sin(lat)
  y=sin(lon)*sin(lat)
  z=cos(lat)
end subroutine fromlatlon

!def tolatlon(x,y,z):
!    lat=atan2(sqrt(x**2+y**2),z)
!    lon=atan2(y,x)
!    return lat,lon
!def dist(xn,yn,zn,xs,ys,zs):
!    return sqrt((xn-xs)**2+(yn-ys)**2+(zn-zs)**2)


C File: arrays-constr-04.f
C This program has a simple 1-D array with the default lower bound of 1.
C It shows the use of an array constructor to initialize the array.

      program main
      implicit none

C     arr is a 1-D array of integers with an implicit lower-bound = 1
C     and an upper bound of 10.
      integer, dimension(10) :: arr
      integer :: i

C     array constructor III -- implied do loop, in three segments
      arr = (/ (11*I, I = 1, 3), (10*I-1, I = 4, 7), (I*I, I = 8,10) /)

      do i = 1, 10
          write (*,10) arr(i)
      end do

 10   format(I5)

      stop
      end program main


!======================================================================!
  REAL FUNCTION TetVol(xA,yA,zA,xB,yB,zB,xC,yC,zC,xD,yD,zD)
!----------------------------------------------------------------------!
!   Returns the volume of tethraedra spanned with A, B, C and D.       !
!----------------------------------------------------------------------!
  IMPLICIT NONE
!-----------------------------[Parameters]-----------------------------!
  REAL :: xA,yA,zA,xB,yB,zB,xC,yC,zC,xD,yD,zD
!--------------------------------[CVS]---------------------------------!
!  $Id: TetVol.f90,v 1.4 2002/10/30 16:29:33 niceno Exp $
!  $Source: /home/muhamed/.CVSROOT/T-Rex/Library/TetVol.f90,v $
!======================================================================!
!                                                                      !
!   The order of nodes (A,B,C and D) DOES matters.                     !
!                                                                      !
!                D-----C                                               !
!               / \  . |                                               !
!              /   \   |                                               !
!             /  .  \  |    I am not 100% sure that the figure is OK   !
!            / .     \ |                                               !
!           /.        \|                                               !
!          A-----------B                                               !
!                                                                      !
!----------------------------------------------------------------------!

  TetVol=( ((yB-yA)*(zC-zA)-(yC-yA)*(zB-zA))*(xD-xA) +              &
	   ((xC-xA)*(zB-zA)-(xB-xA)*(zC-zA))*(yD-yA) +              &
	   ((xB-xA)*(yC-yA)-(xC-xA)*(yB-yA))*(zD-zA) )/6.0

  END FUNCTION TetVol


MODULE myMath_module
! basic matrix and vector functions, following MATLAB names
  USE nrtype;   USE nrutil, ONLY : assert
  IMPLICIT NONE

  INTERFACE Bspline_conv
    module procedure  Bspline1D_mirr_conv_S, Bspline1D_mirr_conv_D, &
            Bspline2D_mirr_conv_S,  Bspline3D_mirr_conv_S
  END INTERFACE ! Bspline1D_mirr_conv_S(A, W, tmp1, tmp2), ..._D(A, W, tmp),
           !Bspline2D_mirr_conv_S(A, W)

  INTERFACE percentile
    module procedure  percentile1D
    module procedure  percentile2D
  END INTERFACE

  INTERFACE diff     ! like the MATLAB diff.  diff(A,dim) has 1 fewer elements along dim,
  ! e.g., diff([1 2 5]) = [1 3].  only 1d implemented.
    module procedure diff_rv
  END INTERFACE diff

  INTERFACE diff0   ! diff0(A,dim) has same size as A, 'coz  diff wrt A(0)==0, thus
  ! retaining A(1), as A(1)-A(0) = A(1), e.g.,
  ! diff([3 5 9]) = [3 2 4]
    module procedure diff0_rv, diff0_rm
  END INTERFACE diff0

  INTERFACE ind2sub  ! index --> subscript:  sub = ind2sub(idx,siz)
    module procedure ind2sub_v, ind2sub_s
  END INTERFACE ind2sub

  ! All accumulative operations involving single precision should be
  ! accumulated on double precision.  Otherwise the error could be too big!
  ! 1d vectors may be fine, but when the size is large, need to use double!

  INTERFACE norm_1    ! norm_1:  \Sum_i |x_i|
    module procedure norm_1_rv, norm_1_dv,  &
                     norm_1_rm, norm_1_dm,  &
                     norm_1_r3d,norm_1_d3d
  END INTERFACE

  INTERFACE norm_inf  !   max_i |x_i|
    module procedure norm_inf_rv, norm_inf_dv,  &
                     norm_inf_rm, norm_inf_dm,  &
                     norm_inf_r3d,norm_inf_d3d
  END INTERFACE

  INTERFACE norm2    ! square of Euclidean norm
    module procedure norm2_rv, norm2_dv, norm2_cv, norm2_zv, &
                     norm2_rm, norm2_dm, norm2_cm, norm2_zm, &
                     norm2_r3d,norm2_d3d,norm2_c3d,norm2_z3d
  END INTERFACE

  INTERFACE norm    ! Euclidean norm
    module procedure norm_rv, norm_dv, norm_cv, norm_zv, &
                     norm_rm, norm_dm, norm_cm, norm_zm, &
                     norm_r3d,norm_d3d,norm_c3d,norm_z3d
  END INTERFACE

  INTERFACE dot_prod    ! dot product.  0,1,2,3 dimensions.
    module procedure dot_prod_rv, dot_prod_dv, dot_prod_cv, dot_prod_zv, &
                     dot_prod_rm, dot_prod_dm, dot_prod_cm, dot_prod_zm, &
                     dot_prod_r3d,dot_prod_d3d,dot_prod_c3d,dot_prod_z3d
  END INTERFACE

  INTERFACE swap_pointers   ! swap_pointers(pa, pb)  ! pntr always pass by reference
    module procedure swap_pointers_1d, swap_pointers_1r, swap_pointers_1i, &
                     swap_pointers_2r, swap_pointers_2i, &
                     swap_pointers_3r, swap_pointers_3i
  END INTERFACE

  INTERFACE swapDimInplace  ! swapDimInplace(A,dim1,dim2), swapDimInplace(A)
    module procedure swapDimInplace2r, swapDimInplace3r, &
                     swapDimInplace2c, swapDimInplace3c, &
                     swapDimInplace2i, &
                     swapDimInplace2d, swapDimInplace3d, &
                     swapDimInplace2z, swapDimInplace3z
  END INTERFACE swapDimInplace ! A's length along dim1 & dim2 must be equal
  ! otherwise inplace swapping can't work because of different shape

  INTERFACE permute  ! rearrange dimensions of N-D array
  ! e.g.,
  ! call permute(Y, X, (/2 3 1/) )
  ! Y <-- X(2nd dim, 3rd dim, 1st dim), where Y's type is array pointer:
  !    ..., POINTER :: Y(:,:,:)
    module procedure permute_r, permute_c, permute_d, permute_z
  ! only 3d array implemented, 'coz 2d matrix can transpose
  END INTERFACE permute

  INTERFACE cat1
    module procedure cat1_iv, cat1_rv, cat1_cv, cat1_dv, cat1_zv, &
                     cat1_im, cat1_rm, cat1_cm, cat1_dm, cat1_zm
  END INTERFACE cat1
  INTERFACE cat2
    module procedure cat2_iv, cat2_rv, cat2_cv, cat2_dv, cat2_zv, &
                     cat2_im, cat2_rm, cat2_cm, cat2_dm, cat2_zm
  END INTERFACE cat2
  INTERFACE catfun1
    module procedure &
      catfun1_iv, catfun1_rv, catfun1_cv, catfun1_dv, catfun1_zv, &
      catfun1_im, catfun1_rm, catfun1_cm, catfun1_dm, catfun1_zm
  END INTERFACE catfun1
  INTERFACE catfun2
    module procedure &
      catfun2_iv, catfun2_rv, catfun2_cv, catfun2_dv, catfun2_zv, &
      catfun2_im, catfun2_rm, catfun2_cm, catfun2_dm, catfun2_zm
  END INTERFACE catfun2

  INTEGER, PARAMETER :: Nprimes   = 1000
  INTEGER, DIMENSION(Nprimes) :: primes ! 1st 1000 prime numbers, in 100 lines X 10 numbers/line
  LOGICAL  :: primes_read_already = .false.
  PRIVATE  :: Nprimes, primes, primes_read_already
CONTAINS
!==================================

real function percentile2D(p, a) result(val)
! p-percentile of a(:,:)   0<=p<=100
real,     intent(in)   :: p, a(:,:)
integer   :: k, j, M, km,kn
real      :: ak
k   = max(1, floor(p/100*size(a) + 0.5))
if (p>=100) then
  val = maxval(a)
else if (k==1) then
  val = minval(a)
else
  M = size(a,1)
  kn= (k-1)/M    ! 0-based index
  km=  k - M *kn
  kn = kn + 1    ! 1-based
  ak=a(km,kn)

  j  = count(a < ak)  ! # how many a(:) < ak
  ! write(*,*) 'Q2D:   j, k, ak', j, k, ak
  if (j>=k) then
    val = selec_rank1D(k, pack(a, a < ak))
  else
    j   = k - (size(a) - count(a > ak))
    if(j>0) then
      val = selec_rank1D(j, pack(a, a > ak))
    else
      val = ak
    end if
  end if
end if
end function

real function percentile1D(p, a) result(val)
! p-percentile of a(:)   0<=p<=100
real,     intent(in)   :: p, a(:)
integer   :: k
k   = max(1, floor(p/100*size(a) + 0.5))
if (p>=100) then
  val = maxval(a)
else if (k==1) then
  val = minval(a)
else
  val = selec_rank1D(k, a)
end if
end function

recursive real function selec_rank1D(k, a) result(val)
! if in a sorted array, val = a(k)
integer,  intent(in)   :: k ! # position in array
real,     intent(in)   :: a(:)
integer   :: j
real      :: ak
ak = a(k)
j  = count(a < ak)  ! # how many a(:) < ak
! write(*,*) 'Q1D:   j, k, ak', j, k, ak
if (j>=k) then
  val = selec_rank1D(k, pack(a, a < ak))
else
  j   = k - (size(a) - count(a > ak))
  if(j>0) then
    val = selec_rank1D(j, pack(a, a > ak))
  else
    val = ak
  end if
end if
end function
!!!!!!!!!!!!

subroutine laplace2_ext(B, A)  ! perform laplacian, then the boundary values are extended out from the inner
real,      intent(out) :: B(:,:)
real,      intent(in)  :: A(:,:)  ! same size
integer    :: nx, nz, ix, iz
nx = size(A,1)
nz = size(A,2)
!$OMP parallel do PRIVATE(ix)
do iz = 2, nz-1
  do ix = 2, nx-1
    B(ix,iz) = A(ix-1,iz) + A(ix+1,iz) + A(ix,iz-1) + A(ix,iz+1) - 4.*A(ix,iz)
  end do
  B(1, iz) = B(2,   iz)
  B(nx,iz) = B(nx-1,iz)
end do
B(:,1) = B(:,   2)
B(:,nz)= B(:,nz-1)
end subroutine
! . . . . . . .

function diff_rv(x) result(d)
real, intent(in) :: x(:)
real  :: d(size(x)-1)
d = x(2:) - x(:size(x)-1)
end function

function diff0_rv(x) result(d)
real, intent(in) :: x(:)
real  :: d(size(x))
d(1)  = x(1)
d(2:) = x(2:) - x(:size(x)-1)
end function

function diff0_rm(x, wei) result(d)
real,    intent(in) :: x(:,:)
integer, intent(in) :: wei   ! dimension, weidu
real  :: d(size(x,1), size(x,2))
integer  :: k, M, N
M = size(x,1);    N = size(x,2)
if (wei==1) then
  do k = 1, N
    d(1,k)   = x(1,k)
    d(2:, k) = x(2:, k) - x(:M-1, k)
  end do
else
  d(:,1) = x(:,1)
  do k = 2, N
    d(:,k) = x(:,k) - x(:,k-1)
  end do
end if

end function

subroutine cumsum2d(B,A,kdim)
! B <--cumulative sum A, along dimension kdim
real, intent(out) :: B(:,:)  ! same size as A, space pre-assigned
real, intent(in)  :: A(:,:)
integer, optional, intent(in) :: kdim ! default 1
integer  :: d, j,k, shp(2)

d  = 1;  if(present(kdim))  d = kdim
shp= shape(A)

if (d==1) then
  do k = 1, shp(2)
    B(1,k) = A(1,k)
    do j=2, shp(1)
      B(j,k) = B(j-1,k) + A(j,k)
    end do
  end do
else
 B(:,1) = A(:,1)
 do k = 2, shp(2)
   B(:,k) = B(:,k-1) + A(:,k)
 end do
end if
end subroutine
! ******* ******* ******* SMOOTHING ******* ******* ******* *****
subroutine rect1D_mirror_conv_D(A, il, ir, B)  ! rect(x \in [-il,ir]) (*) A --> B.
!    Note: A is modified as cumsum(A)
real(8), intent(inout) :: A(:)   ! A is Double
real(8), intent(out)   :: B(:)   ! same size as A
integer, intent(in)    :: il, ir ! index displacement.  I.e, a rect of width 4, center is regarded as index 2.  Then il = -1, ir = 2
! if -il == ir, then rect width is odd; otherwise, even.
integer  :: i, na, sml, smr      ! sm = sum of algebraic index and mirror-reflected index
na   = size(A)

! handle the boundaries first:
! See the  MRI, MRH, ... in Bspline1Dconv()
! left  boundary MRH, if (rect is MRI) | (rect is MRH & -il > ir)
sml = 2    ! MRI,  by default
if (-il >= ir)  sml = 1  ! MRH
! right boundary MRH, if (rect is MRI) | (rect is MRH & -il < ir)
smr = 2*na ! MRI,  at the right boundary, by default
if (ir >= -il)  smr = smr + 1    ! MRH

do i = 1, -il
  B(i) = sum(A(sml:sml-(i+il))) + sum(A(1:i+ir))
end do
do i = na-ir+1, na
  B(i) = sum(A(smr-(i+ir):smr-(na+1))) + sum(A(i+il:na))
end do

! do the valid (inner) part
do i = 2, na      ! cumsum, in-place
  A(i) = A(i) + A(i-1)
end do
B(1-il)= A(1-il+ir)
do i   = 2-il, na-ir
  B(i) = A(i+ir) - A(i+il-1)
end do
end subroutine

subroutine Bspline1D_mirr_conv_S(A, W, tmp1, tmp2)
! A <-- A (*) rect's, of width W(1), W(2),...,W(n).  A  single precision.
! If conv w/ a single rect, then write W as (/ w /), in an array form.
! tmp1,2:   same length as A,  double precision, to avoid error accumulation
! bundary:  mirror reflection
! Lemma:    if A is mirror-symmetric (MR), then A (*) rect is also MR.
! Two cases of MR:
! 1)  MRH:  MR w.r.t. half integer
! 2)  MRI:  MR w.r.t. integer
! If W(i) is even, then the rect is MRH; otherwise, MRI
! Lemma:    MRH (*) MRI = MRH;   MRI (*) MRI = MRI;  MRH (*) MRH = MRI
! If  rect is MRI, then let A be MRH, so the output length stays the same
! If  rect is MRH, then let A be MRI, so the output length = length(A) - 1  [we can extend 1 pixel easily]
!             or set A's left- and right-boundary to be MRI & MRH.  See rect1D_mirror_conv_D().
real,    intent(inout) :: A(:)
integer, intent(in)    :: W(:)
real(8), intent(inout),target :: tmp1(:), tmp2(:)
real(8), pointer       :: p1(:), p2(:)
integer  :: wi, i, c, il, ir, cenR  ! when rect of even width, take center+0.5 as location 0
p1 => tmp1; p2 => tmp2
p1 = A   ! a copying
cenR = 0 ! init.  when wi is even, then flip-flop
do i = 1, size(W)
  wi = W(i)
  if (wi==1)   cycle !!!!!!!!! skip triviality
  c  = ceiling(wi/2.)
  if (c+c==wi) then  ! even
    if (cenR==1) c = c + 1
    cenR = 1 - cenR  ! flip-flop
  end if
  il = 1 - c;  ir = wi - c
  call rect1D_mirror_conv_D(p1, il, ir, p2)
  call swap_pointers(p1, p2)
end do
A = p1  ! copying back
end subroutine

subroutine Bspline1D_mirr_conv_D(A, W, tmp)  ! like Bspline1D_mirr_conv_S, except A is double
real(8), intent(inout),target :: A(:), tmp(:)
integer, intent(in)    :: W(:)
real(8), pointer       :: p1(:), p2(:)
integer  :: nw, wi, i, c, il, ir, cenR  ! when rect of even width, take center+0.5 as location 0
p1 => A; p2 => tmp
cenR = 0  ! init.  when wi is even, then flip-flop
nw   = size(W)
do i = 1, nw
  wi = W(i)
  c  = ceiling(wi/2.)
  if (c+c==wi) then  ! even
    if (cenR==1) c = c + 1
    cenR = 1 - cenR  ! flip-flop
  end if
  il = 1 - c;  ir = wi - c
  call rect1D_mirror_conv_D(p1, il, ir, p2)
  call swap_pointers(p1, p2)
end do
if ((nw/2)*2 /= nw) A = p1   ! need to copy back to A if nw is odd.
end subroutine

subroutine Bspline2D_mirr_conv_S(A, W)
! see the comment in Bspline1D_mirr_conv_S()
real,    intent(inout) :: A(:,:)
integer, intent(in)    :: W(:)
integer  :: shp(2), j
real(8), allocatable   :: tmp1(:), tmp2(:)
shp = shape(A)

!$omp parallel private(j, TMP1, TMP2)
allocate(tmp1(shp(1)), tmp2(shp(1)) )
!$omp do
do j = 1, shp(2)
  tmp1  = A(:,j)
  call Bspline1D_mirr_conv_D(tmp1, W, tmp2)
  A(:,j)= tmp1
end do
!$omp end do
deallocate(tmp1, tmp2)

allocate(tmp1(shp(2)), tmp2(shp(2)) )
!$omp do
do j= 1, shp(1)
  tmp1  = A(j,:)
  call Bspline1D_mirr_conv_D(tmp1, W, tmp2)
  A(j,:)= tmp1
end do
!$omp end do
deallocate(tmp1, tmp2)
!$omp end parallel
end subroutine

subroutine Bspline3D_mirr_conv_S(A, W)
real,    intent(inout) :: A(:,:,:)
integer, intent(in)    :: W(:)
integer  :: shp(3), j, k, M
real(8), allocatable   :: tmp1(:), tmp2(:)
shp = shape(A)
M   = maxval(shp)

!$omp parallel private(j, k, TMP1, TMP2)  !===
allocate(tmp1(M), tmp2(M))

!$omp do
do k= 1, shp(3)
  do j= 1, shp(2)
    tmp1(1:shp(1))  = A(:,j,k)
    call Bspline1D_mirr_conv_D( tmp1(1:shp(1)), W, tmp2(1:shp(1)) )
    A(:,j,k)  = tmp1(1:shp(1))
  enddo
  do j= 1, shp(1)
    tmp1(1:shp(2))  = A(j,:,k)
    call Bspline1D_mirr_conv_D(tmp1(1:shp(2)), W, tmp2(1:shp(2)) )
    A(j,:,k)  = tmp1(1:shp(2))
  end do
end do
!$omp end do

!$omp do
do k = 1, shp(2)
  do j= 1, shp(1)
    tmp1(1:shp(3))  = A(j,k,:)
    call Bspline1D_mirr_conv_D(tmp1(1:shp(3)), W, tmp2(1:shp(3)) )
    A(j,k,:)  = tmp1(1:shp(3))
  end do
end do
!$omp end do

deallocate(tmp1, tmp2)
!$omp end parallel      !===
end subroutine
!******************************** PRIME # ************************
subroutine read_prime_numbers
 integer :: i, beg
 open(10, file='prime_numbers_1000.txt', err=20, form='formatted', status='old')
 do i = 1, 100
   beg = (i-1)*10 + 1
   read(10, *) primes(beg:beg+9)
 enddo
 close(10)
 return
20 stop '  Read error: prime_numbers_1000.txt!'
end subroutine
!-------------
subroutine PRIMEFACTORS(num, factors, nf)
  INTEGER, INTENT(IN) ::num  ! input number
  INTEGER, INTENT(OUT)::nf,  factors(:) ! # of factors, array to store factors
  ! e.g., factors = {2,2,7,7}, nf = 4
  integer  :: ip, n, tmp     ! ip: index to prime #,  n: store 'num'
  if (.not. primes_read_already) then
    call read_prime_numbers
    primes_read_already = .true.
  endif
  ip = 1
  nf = 0
  n  = num
  do while(n > 1)
    if (ip > Nprimes)  stop 'needed prime factor > 7919, too large!'
    tmp = primes(ip)
    if ( (n/tmp)*tmp == n ) then ! a new factor
      nf = nf + 1;
      factors(nf) = tmp
      n  = n/tmp
    else
      ip = ip+1
    endif
  enddo
end subroutine
!-------------
function If_Has_Small_Prime_Factors(num, nf) result(whe)
  ! num:  input number in question
  ! nf:   the smallest nf prime factors
  ! whe:  whether num consists of only the nf smallest prime factors?
  integer, intent(in)  :: num, nf
  logical  :: whe
  integer  :: ip, n, tmp
  if (.not. primes_read_already) then
    call read_prime_numbers
    primes_read_already = .true.
  endif
  n = num
  do ip = 1, nf
    tmp = primes(ip)
    do while ((n/tmp)*tmp == n)
      n = n/tmp
    end do
  end do
  whe = n==1
end function
!---------------------------------
function findBoundingIntv(s, y) result(md)  !!!!!!!!!!!!!!!!!!!!!!!!!!
! s is a non-decreasing series
! find 'md' such that s(md) < y <= s(md+1), using 2-beta search
integer, intent(in)  :: s(:), y
integer  :: md, bg, en
bg  = 1;    en = size(s)
if (y <= s(1)) then
  md = 0     ! as out-of-bound signal
  return
else if (y > s(en)) then
  md = en    ! as out-of-bound signal
  return
endif
DO
  if (en == bg+1)  then
    md = bg
    return
  endif
  md = (bg + en)/2
  if (s(md+1) < y) then
    bg = md + 1   ! take right half
  else if (y <= s(md)) then
    en = md       ! take left  half
  else
    return
  endif
END DO
end function
!-------------
subroutine binnedIncrSeriesIdx(s, y1, y2, idx, num)
! s is a non-decreasing series
! find all the idx satisfying y1 <= s(idx) < y2,  num = length(idx)
!!! i.e., y2 is non-inclusive
integer, intent(in)  :: s(:), y1, y2
integer, intent(OUT) :: idx(:), num   ! make sure idx has enough space
integer  :: b, a, k
! 1.  find a, such that s(a)<y1 and s(a+1)>=y1
a   = findBoundingIntv(s, y1)
! 2.  find b, such that s(b)<y2 and s(b+1)>=y2
b   = findBoundingIntv(s, y2)
idx = (/ (k, k=a+1, b) /)
num = b-a   ! # elements inside [y1, y2)
end subroutine
!------
subroutine binnedSeriesNums(s, wintv, nss, cmsm0)
! s is a series
! intervals are [1, wintv] [1+wintv, 2*wintv] [1+2*wintv, 3*wintv], ...
! find how many series elements fall in each interval --> nss
! cumulative sum of 'nss' starting @ 0                --> cmsm0.
!   is the displacement of each interval's stored s's relative to the beginning
integer, intent(in)  :: s(:), wintv
integer, intent(OUT) :: nss(:)       ! make sure enough length
integer, intent(OUT),   optional ::  cmsm0(:)
integer  :: k, i, L
L    = size(s)
nss  = 0  ! init.
do k = 1, L
  i  = (s(k)-1)/wintv + 1  ! find interval index
  nss(i) = nss(i) + 1
enddo
if (present(cmsm0)) then
  L = size(nss)
  cmsm0(1) = 0
  if (L < 2) return
  cmsm0(2) = nss(1)
  do k = 3, L
    cmsm0(k) = cmsm0(k-1) + nss(k-1)
  enddo
endif
end subroutine
!---------------------
subroutine stripSmallPrimeFactors(A, C, B)
! A = C B, where C = 2^m 3^n 5^o 7^p, B is a prime number > 7
integer, intent(in)  :: A
integer, intent(out) :: C, B
integer  :: prm(4) = (/2,3,5,7/), i, p
C = 1;  B = A
outer: do i = 1, 4  ! go through the 4 smallest prime numbers
  p = prm(i)
  inner: do
    if ( (B/p)*p == B ) then
      B = B/p;  C = C*p
    else
      exit inner
    endif
  enddo inner
enddo outer
end subroutine

function roundUp2SmallPrimeProduct(A) result (C)
! round A up to a smallest integer C that is 2^m 3^n 5^o 7^p
integer, intent(in) :: A
integer  :: C
C = A
do while(.not.If_Has_Small_Prime_Factors(C, 4))
  C = C + 1
enddo
end function

!*****************************************
subroutine find_indices(ind, nfound, crit)
  integer, intent(out) :: ind(:),  nfound   ! nfound limited by size(ind)
  logical, intent(in)  :: crit(:)

  integer  :: nind, k
  nind = size(ind)
  nfound = 0
  do k = 1, size(crit)  ! prefer head
    if(.not. crit(k)) cycle
    nfound = nfound + 1
    ind(nfound) = k
    if (nfound==nind) exit
  end do
end subroutine

FUNCTION SUB2IND(siz, sub) result (ind)  !!!!!!!!!!!!!!!!!!!!!!!!!!
! siz    D x 1   array of the shape of multi-dim tensor
! sub    D x 1   subscript
! return scalar index
! ***using FORTRAN array convention***
integer, intent(in) :: siz(:), sub(:)
integer  :: ind, D, k
D   = size(siz)
ind = sub(D)-1
do k = D-1, 1 ,-1
  ind = ind*siz(k) + sub(k)-1
enddo
ind = ind + 1
END FUNCTION

!===========
function ind2sub_s(ndx, siz)
! scalar ndx
! siz    D x 1   array of the shape of multi-dim tensor
! ndx    1 x 1   index into the tensor, treated as 1d vector (1st dim is the fastest)
! return D x 1   subscript vector
! ***using FORTRAN array convention***
!    following MATLAB's naming.
integer, intent(in) :: siz(:), ndx
integer             :: ind2sub_s(size(siz))
integer             :: D, k, i, n
D    = size(siz)
ind2sub_s(1) = 1
ind2sub_s(2) = siz(1)
do k = 3, D
  ind2sub_s(k) = siz(k-1) * ind2sub_s(k-1)
enddo  ! [1, cumprod]
i    = ndx
do k = D, 2, -1
  n  = (i-1)/ind2sub_s(k)  ! C convention
  i  = i - n*ind2sub_s(k)
  ind2sub_s(k) = n + 1     ! to Fortran convention
enddo
ind2sub_s(1)   = i   ! @ k = 1
end function
!-----

function ind2sub_v(ndx, siz)
! vector ndx
! siz    D x 1   array of the shape of multi-dim tensor
! ndx    N x 1   N indices into the same sized tensor, treated as 1d vector (1st dim is the fastest)
! return D x N   subscript matrix.  Each column is a D-dimensional subscript vector, and
!        there're N of them.
! ***using FORTRAN array convention***
!    following MATLAB's naming.
integer, intent(in) :: siz(:), ndx(:)
integer             :: ind2sub_v(size(siz), size(ndx))
integer             :: D, N, kd, kn, i, x

D   = size(siz);    N = size(ndx)
ind2sub_v(1,1) = 1
ind2sub_v(2,1) = siz(1)
do kd = 3, D
  ind2sub_v(kd,1) = siz(kd-1) * ind2sub_v(kd-1,1)
enddo  ! [1; cumprod] saved @ the 1st column of ind2sub_v
do kn = N, 1, -1
  i   = ndx(kn)
  do kd = D, 2, -1
    x   = (i-1)/ind2sub_v(kd,1)  ! C convention
    i   = i - x*ind2sub_v(kd,1)
    ind2sub_v(kd,kn) = x + 1     ! to Fortran convention
  enddo
  ind2sub_v(1, kn)   = i   ! @ kd = 1
enddo
end function

! * * * * * * * * * * * * * * * * * *
!           1-Norm
! * * * * * * * * * * * * * * * * * *
function norm_1_rv(v)
REAL(SP) :: v(:), norm_1_rv
integer  :: i
norm_1_rv = 0.
do i = 1, size(v)
  if (v(i)>0.) then
    norm_1_rv = norm_1_rv + v(i)
  else
    norm_1_rv = norm_1_rv - v(i)
  endif
end do
end function

function norm_1_dv(v)  result(nrm)
REAL(DP) :: v(:), nrm
integer  :: i
nrm = 0.
do i = 1, size(v)
  if (v(i)>0.) then
    nrm = nrm + v(i)
  else
    nrm = nrm - v(i)
  endif
end do
end function

function norm_1_rm(v)  result(nrm)  ! matrix v
REAL(SP) :: v(:,:), nrm
REAL(DP) :: nrm_c   ! local accumulator, double prec.
integer  :: i, j
nrm_c = 0.
do i = 1, size(v,2)
  do j = 1, size(v,1)
  if (v(j,i)>0.) then
    nrm_c = nrm_c + v(j,i)
  else
    nrm_c = nrm_c - v(j,i)
  end if
  end do
end do
nrm = nrm_c
end function

function norm_1_dm(v)  result(nrm)  ! matrix v
REAL(DP) :: v(:,:), nrm
integer  :: i, j
nrm = 0.
do i = 1, size(v,2)
  do j = 1, size(v,1)
  if (v(j,i)>0.) then
    nrm = nrm + v(j,i)
  else
    nrm = nrm - v(j,i)
  endif
  end do
end do
end function

function norm_1_r3d(v)  result(nrm_o)  ! matrix v
REAL(SP) :: v(:,:,:), nrm_o
REAL(DP) :: nrm
integer  :: i, j, k
nrm = 0.
do k = 1, size(v,3)
  do i = 1, size(v,2)
    do j = 1, size(v,1)
    if (v(j,i,k)>0.) then
      nrm = nrm + v(j,i,k)
    else
      nrm = nrm - v(j,i,k)
    end if
    end do
  end do
end do
nrm_o = nrm
end function

function norm_1_d3d(v)  result(nrm)  ! matrix v
REAL(DP) :: v(:,:,:), nrm
integer  :: i, j, k
nrm = 0.
do k = 1, size(v,3)
  do i = 1, size(v,2)
    do j = 1, size(v,1)
      if (v(j,i,k)>0.) then
        nrm = nrm + v(j,i,k)
      else
        nrm = nrm - v(j,i,k)
      end if
    end do
  end do
end do
end function

! * * * * * * * * * * * * *
!       inf-Norm
! * * * * * * * * * * * * *
function norm_inf_rv(v) result(nrm)
REAL(SP) :: v(:), nrm
integer  :: i
nrm = 0.
do i = 1, size(v)
  if (v(i)> nrm) then
    nrm  = v(i)
  else if (-v(i)> nrm) then
    nrm  = -v(i)
  end if
end do
end function

function norm_inf_dv(v) result(nrm)
REAL(DP) :: v(:), nrm
integer  :: i
nrm = 0.
do i = 1, size(v)
  if (v(i)> nrm) then
    nrm  = v(i)
  else if (-v(i)> nrm) then
    nrm  = -v(i)
  end if
end do
end function

function norm_inf_rm(v) result(nrm)
REAL(SP) :: v(:,:), nrm
integer  :: i, j
nrm = 0.
do j = 1, size(v,2)
  do i = 1, size(v,1)
    if (v(i,j)> nrm) then
      nrm  = v(i,j)
    else if (-v(i,j)> nrm) then
      nrm  = -v(i,j)
    end if
  end do
end do
end function

function norm_inf_dm(v) result(nrm)
REAL(DP) :: v(:,:), nrm
integer  :: i, j
nrm = 0.
do j = 1, size(v,2)
  do i = 1, size(v,1)
    if (v(i,j)> nrm) then
      nrm  = v(i,j)
    else if (-v(i,j)> nrm) then
      nrm  = -v(i,j)
    end if
  end do
end do
end function

function norm_inf_r3d(v) result(nrm)
REAL(SP) :: v(:,:,:), nrm
integer  :: i, j, k
nrm = 0.
do k = 1, size(v,3)
  do j = 1, size(v,2)
    do i = 1, size(v,1)
     if (v(i,j,k)> nrm) then
      nrm  = v(i,j,k)
     else if (-v(i,j,k)> nrm) then
      nrm  = -v(i,j,k)
     end if
    end do
  end do
end do
end function

function norm_inf_d3d(v) result(nrm)
REAL(DP) :: v(:,:,:), nrm
integer  :: i, j, k
nrm = 0.
do k = 1, size(v,3)
  do j = 1, size(v,2)
    do i = 1, size(v,1)
     if (v(i,j,k)> nrm) then
      nrm  = v(i,j,k)
     else if (-v(i,j,k)> nrm) then
      nrm  = -v(i,j,k)
     end if
    end do
  end do
end do
end function

! * * * * * * * * * * * * *
! square of Euclidean norm
FUNCTION norm2_rv(v)  ! real
REAL(SP)     :: v(:)
REAL(SP)     :: norm2_rv
norm2_rv = dot_product(v,v)
END FUNCTION

FUNCTION norm2_dv(v)  ! double
REAL(DP)     :: v(:)
REAL(DP)     :: norm2_dv
norm2_dv = dot_product(v,v)
END FUNCTION

FUNCTION norm2_cv(v)  ! complex
COMPLEX(SPC) :: v(:)
REAL(SP)     :: norm2_cv
norm2_cv = dot_product(v,v)
END FUNCTION

FUNCTION norm2_zv(v)  ! complex double
COMPLEX(DPC) :: v(:)
REAL(DP)     :: norm2_zv
norm2_zv = dot_product(v,v)
END FUNCTION
!-------------------
FUNCTION norm2_rm(m)  result(norm2_o)  !! matrix
REAL(SP)     :: m(:,:), norm2_o
REAL(DP)     :: norm2 !!! double
integer      :: i,j, shp(2)
shp   = shape(m)
norm2 = 0.
do j  = 1, shp(2)
  do i = 1, shp(1)
    norm2 = norm2 + DBLE(m(i,j))**2
  end do
end do
norm2_o = norm2
END FUNCTION

FUNCTION norm2_dm(m)  result(norm2)
REAL(DP)     :: m(:,:)
REAL(DP)     :: norm2
integer      :: i, j, shp(2)
shp   = shape(m)
norm2 = 0.
do j  = 1, shp(2)
  do i = 1, shp(1)
    norm2 = norm2 + m(i,j)**2
  enddo
enddo
END FUNCTION

FUNCTION norm2_cm(m)  result(norm2_o)
COMPLEX(SPC) :: m(:,:)
REAL(SP)     :: norm2_o
REAL(DP)     :: norm2  !!! double
integer      :: i, j, shp(2)
shp   = shape(m)
norm2 = 0.
do j  = 1, shp(2)
  do i = 1, shp(1)
    norm2 = norm2 + DBLE(m(i,j))*DBLE(conjg(m(i,j)))
  enddo
enddo
norm2_o = norm2
END FUNCTION

FUNCTION norm2_zm(m)  result(norm2)
COMPLEX(DPC) :: m(:,:)
REAL(DP)     :: norm2
integer      :: i, j, shp(2)
shp   = shape(m)
norm2 = 0
do j  = 1, shp(2)
  do i = 1, shp(1)
    norm2 = norm2 + m(i,j)*conjg(m(i,j))
  enddo
enddo
END FUNCTION
!-------------------
FUNCTION norm2_r3d(t)    result(norm2_o)  !!! 3d tensor
REAL(SP)     :: t(:,:,:), norm2_o
REAL(DP)     :: norm2    !!! double
integer      :: i, j, k, shp(3)
shp   = shape(t)
norm2 = 0.
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      norm2 = norm2 + DBLE(t(i,j,k))**2
    enddo
  enddo
enddo
norm2_o = norm2
END FUNCTION

FUNCTION norm2_d3d(t)   result(norm2)
REAL(DP)     :: t(:,:,:)
REAL(DP)     :: norm2
integer      :: i, j, k, shp(3)
shp   = shape(t)
norm2 = 0
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      norm2 = norm2 + t(i,j,k)**2
    enddo
  enddo
enddo
END FUNCTION

FUNCTION norm2_c3d(t)   result(norm2_o)
COMPLEX(SPC) :: t(:,:,:)
REAL(SP)     :: norm2_o
REAL(DP)     :: norm2   !!! double
integer      :: i, j, k, shp(3)
shp   = shape(t)
norm2 = 0.
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      norm2 = norm2 + DBLE(t(i,j,k))*DBLE(conjg(t(i,j,k)))
    enddo
  enddo
enddo
norm2_o = norm2
END FUNCTION

FUNCTION norm2_z3d(t)  result(norm2)
COMPLEX(DPC) :: t(:,:,:)
REAL(DP)     :: norm2
integer      :: i, j, k, shp(3)
shp   = shape(t)
norm2 = 0
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      norm2 = norm2 + t(i,j,k)*conjg(t(i,j,k))
    enddo
  enddo
enddo
END FUNCTION

! * * * * * *  Euclidean norm * * * * *
FUNCTION norm_rv(v)  result(norm) ! real
REAL(SP)     :: v(:)
REAL(SP)     :: norm
norm = sqrt(norm2(v))
END FUNCTION

FUNCTION norm_dv(v)  result(norm) ! double
REAL(DP)     :: v(:)
REAL(DP)     :: norm
norm = sqrt(norm2(v))
END FUNCTION

FUNCTION norm_cv(v)  result(norm)  ! complex
COMPLEX(SPC) :: v(:)
REAL(SP)     :: norm
norm = sqrt(norm2(v))
END FUNCTION

FUNCTION norm_zv(v)  result(norm)  ! complex double
COMPLEX(DPC) :: v(:)
REAL(DP)     :: norm
norm = sqrt(norm2(v))
END FUNCTION
!-------------------
FUNCTION norm_rm(m)  result(norm)  !! matrix
REAL(SP)     :: m(:,:)
REAL(SP)     :: norm
norm = sqrt(norm2(m))
END FUNCTION

FUNCTION norm_dm(m)  result(norm)
REAL(DP)     :: m(:,:)
REAL(DP)     :: norm
norm = sqrt(norm2(m))
END FUNCTION

FUNCTION norm_cm(m)  result(norm)
COMPLEX(SPC) :: m(:,:)
REAL(SP)     :: norm
norm = sqrt(norm2(m))
END FUNCTION

FUNCTION norm_zm(m)  result(norm)
COMPLEX(DPC) :: m(:,:)
REAL(DP)     :: norm
norm = sqrt(norm2(m))
END FUNCTION
!-------------------
FUNCTION norm_r3d(t)    result(norm)  !!! 3d tensor
REAL(SP)     :: t(:,:,:)
REAL(SP)     :: norm
norm = sqrt(norm2(t))
END FUNCTION

FUNCTION norm_d3d(t)   result(norm)
REAL(DP)     :: t(:,:,:)
REAL(DP)     :: norm
norm = sqrt(norm2(t))
END FUNCTION

FUNCTION norm_c3d(t)   result(norm)
COMPLEX(SPC) :: t(:,:,:)
REAL(SP)     :: norm
norm = sqrt(norm2(t))
END FUNCTION

FUNCTION norm_z3d(t)  result(norm)
COMPLEX(DPC) :: t(:,:,:)
REAL(DP)     :: norm
norm = sqrt(norm2(t))
END FUNCTION

! * * * * * * * * * * * * *
! * * *  dot product  * * *

FUNCTION dot_prod_rv(u,v) result(dtp) ! real
REAL(SP)     :: u(:), v(:)
REAL(SP)     :: dtp
dtp = dot_product(u,v)
END FUNCTION

FUNCTION dot_prod_dv(u,v) result(dtp)  ! double
REAL(DP)     :: u(:), v(:)
REAL(DP)     :: dtp
dtp = dot_product(u,v)
END FUNCTION

FUNCTION dot_prod_cv(u,v) result(dtp)  ! complex
COMPLEX(SPC) :: u(:), v(:)
REAL(SP)     :: dtp
dtp = dot_product(u,v)
END FUNCTION

FUNCTION dot_prod_zv(u,v) result(dtp)  ! complex double
COMPLEX(DPC) :: u(:), v(:)
REAL(DP)     :: dtp
dtp = dot_product(u,v)
END FUNCTION
!-------------------
FUNCTION dot_prod_rm(m,n)  result(dtp_o)  !! matrix
REAL(SP)     :: m(:,:), n(:,:), dtp_o
REAL(DP)     :: dtp   !!! double
integer      :: i, j, shp(2)
shp   = shape(m)
dtp   = 0.
do j  = 1, shp(2)
  do i = 1, shp(1)
    dtp = dtp + DBLE(m(i,j)) * DBLE(n(i,j))
  enddo
enddo
dtp_o = dtp
END FUNCTION

FUNCTION dot_prod_dm(m,n)  result(dtp)
REAL(DP)     :: m(:,:), n(:,:), dtp
integer      :: i, j, shp(2)
shp   = shape(m)
dtp   = 0.
do j  = 1, shp(2)
  do i = 1, shp(1)
    dtp = dtp + m(i,j) * n(i,j)
  enddo
enddo
END FUNCTION

FUNCTION dot_prod_cm(m,n)  result(dtp_o)
COMPLEX(SPC) :: m(:,:), n(:,:), dtp_o
COMPLEX(DPC) :: dtp  !!! double
integer      :: i, j, shp(2)
shp   = shape(m)
dtp   = 0.
do j  = 1, shp(2)
  do i = 1, shp(1)
    dtp = dtp + n(i,j)*conjg(m(i,j))
  enddo
enddo
dtp_o = dtp
END FUNCTION

FUNCTION dot_prod_zm(m,n)  result(dtp)
COMPLEX(DPC) :: m(:,:),n(:,:), dtp
integer      :: i, j, shp(2)
shp   = shape(m)
dtp   = 0.
do j  = 1, shp(2)
  do i = 1, shp(1)
    dtp = dtp + n(i,j)*conjg(m(i,j))
  enddo
enddo
END FUNCTION
!-------------------
FUNCTION dot_prod_r3d(s,t)    result(dtp_o)  !!! 3d tensor
REAL(SP)     :: s(:,:,:), t(:,:,:), dtp_o
REAL(DP)     :: dtp      !!! double
integer      :: i, j, k, shp(3)
shp  = shape(t)
dtp  = 0.
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      dtp = dtp + DBLE(t(i,j,k)) * DBLE(s(i,j,k))
    enddo
  enddo
enddo
dtp_o = dtp
END FUNCTION

FUNCTION dot_prod_d3d(s,t)   result(dtp)
REAL(DP)     :: s(:,:,:), t(:,:,:), dtp
integer      :: i, j, k, shp(3)
shp  = shape(t)
dtp   = 0
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      dtp = dtp + t(i,j,k) * s(i,j,k)
    enddo
  enddo
enddo
END FUNCTION

FUNCTION dot_prod_c3d(s,t)   result(dtp_o)
COMPLEX(SPC) :: s(:,:,:), t(:,:,:), dtp_o
COMPLEX(DPC) :: dtp      !!! double
integer      :: i, j, k, shp(3)
shp  = shape(t)
dtp  = 0.
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      dtp = dtp + t(i,j,k)*conjg(s(i,j,k))
    enddo
  enddo
enddo
dtp_o = dtp
END FUNCTION

FUNCTION dot_prod_z3d(s,t)  result(dtp)
COMPLEX(DPC) :: s(:,:,:), t(:,:,:), dtp
integer      :: i, j, k, shp(3)
shp  = shape(t)
dtp   = 0
do k = 1, shp(3)
  do j = 1, shp(2)
    do i = 1, shp(1)
      dtp = dtp + t(i,j,k)*conjg(s(i,j,k))
    enddo
  enddo
enddo
END FUNCTION

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
SUBROUTINE swap_pointers_1d(pa, pb)
REAL(DP), pointer  :: pa(:), pb(:), tmp(:)
tmp => pa;  pa => pb;  pb => tmp
END SUBROUTINE

SUBROUTINE swap_pointers_1r(pa, pb)
REAL(SP), pointer  :: pa(:), pb(:), tmp(:)
tmp => pa;  pa => pb;  pb => tmp
END SUBROUTINE

SUBROUTINE swap_pointers_1i(pa, pb)
integer,  pointer  :: pa(:), pb(:), tmp(:)
tmp => pa;  pa => pb;  pb => tmp
END SUBROUTINE

SUBROUTINE swap_pointers_2r(pa, pb)
REAL(SP), pointer  :: pa(:,:), pb(:,:), tmp(:,:)
tmp => pa;  pa => pb;  pb => tmp
END SUBROUTINE

SUBROUTINE swap_pointers_2i(pa, pb)
integer,  pointer  :: pa(:,:), pb(:,:), tmp(:,:)
tmp => pa;  pa => pb;  pb => tmp
END SUBROUTINE

SUBROUTINE swap_pointers_3r(pa, pb)
REAL(SP), pointer  :: pa(:,:,:), pb(:,:,:), tmp(:,:,:)
tmp => pa;  pa => pb;  pb => tmp
END SUBROUTINE

SUBROUTINE swap_pointers_3i(pa, pb)
integer,  pointer  :: pa(:,:,:), pb(:,:,:), tmp(:,:,:)
tmp => pa;  pa => pb;  pb => tmp
END SUBROUTINE
!~~~~~~~~~~~~~~~~~~ swapDimInplace ~~~~~~~~~~~~~~~~~~
SUBROUTINE swapDimInplace2r(A)
REAL(SP), intent(inout)  :: A(:,:)
REAL(SP)                 :: T
INTEGER(I4B) :: I,J, S
S = SIZE(A,1)
CALL ASSERT(S==SIZE(A,2), 'INPUT MUST BE SQUARE MATRIX TO ALLOW INPLACE TRANSPOSE')
DO I = 1,S-1
  DO J = I+1,S
    T = A(J,I);  A(J,I) = A(I,J);  A(I,J) = T;
  ENDDO
ENDDO
END SUBROUTINE
SUBROUTINE swapDimInplace2c(A)
COMPLEX(SPC), intent(inout)  :: A(:,:)
COMPLEX(SPC)                 :: T
INTEGER(I4B) :: I,J, S
S = SIZE(A,1)
CALL ASSERT(S==SIZE(A,2), 'INPUT MUST BE SQUARE MATRIX TO ALLOW INPLACE TRANSPOSE')
DO I = 1,S-1
  DO J = I+1,S
    T = A(J,I);  A(J,I) = A(I,J);  A(I,J) = T;
  ENDDO
ENDDO
END SUBROUTINE
SUBROUTINE swapDimInplace2i(A)
INTEGER(I4B), intent(inout)   :: A(:,:)
INTEGER(I4B)  :: T, I,J, S
S = SIZE(A,1)
CALL ASSERT(S==SIZE(A,2), 'INPUT MUST BE SQUARE MATRIX TO ALLOW INPLACE TRANSPOSE')
DO I = 1,S-1
  DO J = I+1,S
    T = A(J,I);  A(J,I) = A(I,J);  A(I,J) = T;
  ENDDO
ENDDO
END SUBROUTINE
SUBROUTINE swapDimInplace2d(A)
REAL(DP), intent(inout)  :: A(:,:)
REAL(DP)  :: T
INTEGER(I4B) :: I,J, S
S = SIZE(A,1)
CALL ASSERT(S==SIZE(A,2), 'INPUT MUST BE SQUARE MATRIX TO ALLOW INPLACE TRANSPOSE')
DO I = 1,S-1
  DO J = I+1,S
    T = A(J,I);  A(J,I) = A(I,J);  A(I,J) = T;
  ENDDO
ENDDO
END SUBROUTINE
SUBROUTINE swapDimInplace2z(A)
COMPLEX(DPC), intent(inout) :: A(:,:)
COMPLEX(DPC) :: T
INTEGER(I4B) :: I,J, S
S = SIZE(A,1)
CALL ASSERT(S==SIZE(A,2), 'INPUT MUST BE SQUARE MATRIX TO ALLOW INPLACE TRANSPOSE')
DO I = 1,S-1
  DO J = I+1,S
    T = A(J,I);  A(J,I) = A(I,J);  A(I,J) = T;
  ENDDO
ENDDO
END SUBROUTINE

SUBROUTINE swapDimInplace3r(A, d1, d2)  ! A: 3D array, swap it's d1 & d2 diemsions in-place
REAL(SP), intent(inout)   :: A(:,:,:)
REAL(SP)  :: T
INTEGER(I4B) :: d1,d2, I,J,K, S(3)
CALL ASSERT(d1/=d2, d1<4, d2<4, 'Dimension indices to swap must be valid (unequal, 1-->3)')
S = SHAPE(A)
IF (d1/=3 .AND. d2/=3) THEN  ! swap 1 <--> 2
  CALL ASSERT(S(1)==S(2), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)
   DO I = 1,S(2)-1
    DO J = I+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(I,J,K);  A(I,J,K) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE IF(d1/=2 .AND. d2/=2) THEN ! swap 1 <--> 3
  CALL ASSERT(S(1)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = 1,S(2)
    DO J = K+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(K,I,J);  A(K,I,J) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE  ! swap 3 <--> 2
  CALL ASSERT(S(2)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = K+1,S(2)
    DO J = 1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(J,K,I);  A(J,K,I) = T;
    ENDDO
   ENDDO
  ENDDO
END IF
END SUBROUTINE

SUBROUTINE swapDimInplace3c(A, d1, d2)  ! A: 3D array, swap it's d1 & d2 diemsions in-place
COMPLEX(SPC), intent(inout)   :: A(:,:,:)
COMPLEX(SPC)  :: T
INTEGER(I4B)  :: d1,d2, I,J,K, S(3)
CALL ASSERT(d1/=d2, d1<4, d2<4, 'Dimension indices to swap must be valid (unequal, 1-->3)')
S = SHAPE(A)
IF (d1/=3 .AND. d2/=3) THEN  ! swap 1 <--> 2
  CALL ASSERT(S(1)==S(2), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)
   DO I = 1,S(2)-1
    DO J = I+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(I,J,K);  A(I,J,K) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE IF(d1/=2 .AND. d2/=2) THEN ! swap 1 <--> 3
  CALL ASSERT(S(1)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = 1,S(2)
    DO J = K+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(K,I,J);  A(K,I,J) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE  ! swap 3 <--> 2
  CALL ASSERT(S(2)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = K+1,S(2)
    DO J = 1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(J,K,I);  A(J,K,I) = T;
    ENDDO
   ENDDO
  ENDDO
END IF
END SUBROUTINE
SUBROUTINE swapDimInplace3d(A, d1, d2)  ! A: 3D array, swap it's d1 & d2 diemsions in-place
REAL(DP), intent(inout)   :: A(:,:,:)
REAL(DP)  :: T
INTEGER(I4B) :: d1,d2, I,J,K, S(3)
CALL ASSERT(d1/=d2, d1<4, d2<4, 'Dimension indices to swap must be valid (unequal, 1-->3)')
S = SHAPE(A)
IF (d1/=3 .AND. d2/=3) THEN  ! swap 1 <--> 2
  CALL ASSERT(S(1)==S(2), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)
   DO I = 1,S(2)-1
    DO J = I+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(I,J,K);  A(I,J,K) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE IF(d1/=2 .AND. d2/=2) THEN ! swap 1 <--> 3
  CALL ASSERT(S(1)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = 1,S(2)
    DO J = K+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(K,I,J);  A(K,I,J) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE  ! swap 3 <--> 2
  CALL ASSERT(S(2)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = K+1,S(2)
    DO J = 1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(J,K,I);  A(J,K,I) = T;
    ENDDO
   ENDDO
  ENDDO
END IF
END SUBROUTINE

SUBROUTINE swapDimInplace3z(A, d1, d2)  ! A: 3D array, swap it's d1 & d2 diemsions in-place
COMPLEX(DPC), intent(inout)  :: A(:,:,:)
COMPLEX(DPC)  :: T
INTEGER(I4B)   :: d1,d2, I,J,K, S(3)
CALL ASSERT(d1/=d2, d1<4, d2<4, 'Dimension indices to swap must be valid (unequal, 1-->3)')
S = SHAPE(A)
IF (d1/=3 .AND. d2/=3) THEN  ! swap 1 <--> 2
  CALL ASSERT(S(1)==S(2), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)
   DO I = 1,S(2)-1
    DO J = I+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(I,J,K);  A(I,J,K) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE IF(d1/=2 .AND. d2/=2) THEN ! swap 1 <--> 3
  CALL ASSERT(S(1)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = 1,S(2)
    DO J = K+1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(K,I,J);  A(K,I,J) = T;
    ENDDO
   ENDDO
  ENDDO
ELSE  ! swap 3 <--> 2
  CALL ASSERT(S(2)==S(3), 'dimension to swap in-place must be of equal sizes')
  DO K = 1,S(3)-1
   DO I = K+1,S(2)
    DO J = 1,S(1)
    T = A(J,I,K);  A(J,I,K) = A(J,K,I);  A(J,K,I) = T;
    ENDDO
   ENDDO
  ENDDO
END IF
END SUBROUTINE

!~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
! pppppppppppppppp  PERMUTE pppppppppppppppp
SUBROUTINE permute_r(Y, X, dims)
REAL(SP), POINTER    :: Y(:,:,:)
REAL(SP), intent(in) :: X(:,:,:)
INTEGER(I4B)      :: dims(3), shpx(3), shpy(3), indy(3), i,j,k
shpx = shape(X)
shpy = shpx(dims)
IF(ASSOCIATED(Y)) DEALLOCATE(Y)
ALLOCATE (Y(shpy(1),shpy(2),shpy(3)))
do k = 1, shpx(3)
  do j = 1, shpx(2)
    do i = 1, shpx(1)
      shpy = (/ i,j,k /) ! act as tmp
      indy = shpy(dims)
      Y(indy(1),indy(2),indy(3)) = X(i,j,k)
    enddo
  enddo
enddo
END SUBROUTINE
SUBROUTINE permute_c(Y, X, dims)
COMPLEX(SPC), POINTER    :: Y(:,:,:)
COMPLEX(SPC), intent(in) :: X(:,:,:)
INTEGER(I4B)          :: dims(3), shpx(3), shpy(3), indy(3), i,j,k
shpx = shape(X)
shpy = shpx(dims)
IF(ASSOCIATED(Y)) DEALLOCATE(Y)
ALLOCATE (Y(shpy(1),shpy(2),shpy(3)))
do k = 1, shpx(3)
  do j = 1, shpx(2)
    do i = 1, shpx(1)
      shpy = (/ i,j,k /) ! act as tmp
      indy = shpy(dims)
      Y(indy(1),indy(2),indy(3)) = X(i,j,k)
    enddo
  enddo
enddo
END SUBROUTINE
SUBROUTINE permute_d(Y, X, dims)
REAL(DP), POINTER    :: Y(:,:,:)
REAL(DP), intent(in) :: X(:,:,:)
INTEGER(I4B)      :: dims(3), shpx(3), shpy(3), indy(3), i,j,k
shpx = shape(X)
shpy = shpx(dims)
IF(ASSOCIATED(Y)) DEALLOCATE(Y)
ALLOCATE (Y(shpy(1),shpy(2),shpy(3)))
do k = 1, shpx(3)
  do j = 1, shpx(2)
    do i = 1, shpx(1)
      shpy = (/ i,j,k /) ! act as tmp
      indy = shpy(dims)
      Y(indy(1),indy(2),indy(3)) = X(i,j,k)
    enddo
  enddo
enddo
END SUBROUTINE
SUBROUTINE permute_z(Y, X, dims)
COMPLEX(DPC), POINTER    :: Y(:,:,:)
COMPLEX(DPC), intent(in) :: X(:,:,:)
INTEGER(I4B)          :: dims(3), shpx(3), shpy(3), indy(3), i,j,k
shpx = shape(X)
shpy = shpx(dims)
IF(ASSOCIATED(Y)) DEALLOCATE(Y)
ALLOCATE (Y(shpy(1),shpy(2),shpy(3)))
do k = 1, shpx(3)
  do j = 1, shpx(2)
    do i = 1, shpx(1)
      shpy = (/ i,j,k /) ! act as tmp
      indy = shpy(dims)
      Y(indy(1),indy(2),indy(3)) = X(i,j,k)
    enddo
  enddo
enddo
END SUBROUTINE

! pppppppppppppppppppppppppppppppppppppppppp

! * * * * * * * * * * * CAT * * * * * * * * * * *

! Need to implement all cases of 1d vector, 2d matrix, etc.
!
! Difficulty: has to know the output shape beforehand, because the output argument's
! shape has to be specified in the beginning of the subroutine.  For example, concate.
! two col. vectors along the column or along the row would produce different rank (2 or 1)
! of the result.
!
! Solution: split 'cat' into three categories:
! call cat1(D, A, B)    concat. along dim1   (subroutine: D <== A [+] B)
! call cat2(D, A, B)    concat. along dim2
! call cat3(D, A, B)    concat. along dim3
! Within each category, ranks and types are overloaded
!
! Also implement functions:
! D = catfun1(A,B)
! D = catfun2(A,B)
! D = catfun3(A,B)

! * * * * * * * * * * * CAT1 * * * * * * * * * * *

SUBROUTINE cat1_iv(D, A, B)  ! integer (column) vector
INTEGER(I4B), INTENT(IN)  :: A(:), B(:)
INTEGER(I4B), INTENT(out) :: D(:)
integer(I4B) :: na, nb, nd
na = size(A);   nb = size(B);  nd = size(D);
call assert(nd == na+nb, ' cat dim1: Ldest /= La + Lb')
D(1:na)     = A
D(na+1 :nd) = B
end SUBROUTINE cat1_iv

SUBROUTINE cat1_rv(D, A, B)  ! real (column) vector
REAL(SP), INTENT(IN)  :: A(:), B(:)
REAL(SP), INTENT(out) :: D(:)
integer(I4B) :: na, nb, nd
na = size(A);   nb = size(B);  nd = size(D);
call assert(nd == na+nb, ' cat dim1: Ldest /= La + Lb')
D(1:na)     = A
D(na+1 :nd) = B
end SUBROUTINE cat1_rv

SUBROUTINE cat1_cv(D, A, B) ! complex (column) vector
COMPLEX(SPC), INTENT(IN)  :: A(:), B(:)
COMPLEX(SPC), INTENT(out) :: D(:)
integer(I4B) :: na, nb, nd
na = size(A);   nb = size(B);  nd = size(D);
call assert(nd == na+nb, ' cat dim1: Ldest /= La + Lb')
D(1:na)     = A
D(na+1 :nd) = B
end SUBROUTINE cat1_cv

SUBROUTINE cat1_dv(D, A, B)  ! double (column) vector
REAL(DP), INTENT(IN)  :: A(:), B(:)
REAL(DP), INTENT(out) :: D(:)
integer(I4B) :: na, nb, nd
na = size(A);   nb = size(B);  nd = size(D);
call assert(nd == na+nb, ' cat dim1: Ldest /= La + Lb')
D(1:na)     = A
D(na+1 :nd) = B
end SUBROUTINE cat1_dv

SUBROUTINE cat1_zv(D, A, B) ! complex double (column) vector
COMPLEX(DPC), INTENT(IN)  :: A(:), B(:)
COMPLEX(DPC), INTENT(out) :: D(:)
integer(I4B) :: na, nb, nd
na = size(A);   nb = size(B);  nd = size(D);
call assert(nd == na+nb, ' cat dim1: Ldest /= La + Lb')
D(1:na)     = A
D(na+1 :nd) = B
end SUBROUTINE cat1_zv

SUBROUTINE cat1_im(D, A, B)  ! integer matrix
INTEGER(I4B), INTENT(IN)  :: A(:,:), B(:,:)
INTEGER(I4B), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(1)== sa(1)+sb(1), sd(2)==sa(2), sd(2)==sb(2), &
               ' cat dim 1, size inconsist.')
D(1:sa(1),:)    = A
D(sa(1)+1 :sd(1),:)= B
end SUBROUTINE cat1_im

SUBROUTINE cat1_rm(D, A, B)  ! real matrix
REAL(SP), INTENT(IN)  :: A(:,:), B(:,:)
REAL(SP), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(1)== sa(1)+sb(1), sd(2)==sa(2), sd(2)==sb(2), &
               ' cat dim 1, size inconsist.')
D(1:sa(1),:)    = A
D(sa(1)+1 :sd(1),:)= B
end SUBROUTINE cat1_rm

SUBROUTINE cat1_cm(D, A, B) ! complex matrix
COMPLEX(SPC), INTENT(IN)  :: A(:,:), B(:,:)
COMPLEX(SPC), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(1)== sa(1)+sb(1), sd(2)==sa(2), sd(2)==sb(2), &
               ' cat dim 1, size inconsist.')
D(1:sa(1),:)    = A
D(sa(1)+1 :sd(1),:)= B
end SUBROUTINE cat1_cm

SUBROUTINE cat1_dm(D, A, B)  ! double matrix
REAL(DP), INTENT(IN)  :: A(:,:), B(:,:)
REAL(DP), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(1)== sa(1)+sb(1), sd(2)==sa(2), sd(2)==sb(2), &
               ' cat dim 1, size inconsist.')
D(1:sa(1),:)    = A
D(sa(1)+1 :sd(1),:)= B
end SUBROUTINE cat1_dm

SUBROUTINE cat1_zm(D, A, B) ! complex double matrix
COMPLEX(DPC), INTENT(IN)  :: A(:,:), B(:,:)
COMPLEX(DPC), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(1)== sa(1)+sb(1), sd(2)==sa(2), sd(2)==sb(2), &
               ' cat dim 1, size inconsist.')
D(1:sa(1),:)    = A
D(sa(1)+1 :sd(1),:)= B
end SUBROUTINE cat1_zm

!!!!!!!!!!!!!!  CAT2  !!!!!!!!!!!!!!!!!!!!!!

SUBROUTINE cat2_iv(D, A, B)  ! integer (column) vector
INTEGER(I4B), INTENT(IN)  :: A(:), B(:)
INTEGER(I4B), INTENT(out) :: D(:,:)
integer(I4B) :: sd(2), na, nb
sd = shape(D)
na = size(B);   nb = size(B);
call assert(sd(1) == na, sd(1) == nb, sd(2)==2, ' cat dim 2, shape must match.')
D(:,1) = A
D(:,2) = B
end SUBROUTINE cat2_iv

SUBROUTINE cat2_rv(D, A, B)  ! real (column) vector
REAL(SP), INTENT(IN)  :: A(:), B(:)
REAL(SP), INTENT(out) :: D(:,:)
integer(I4B) :: sd(2), na, nb
sd = shape(D)
na = size(B);   nb = size(B);
call assert(sd(1) == na, sd(1) == nb, sd(2)==2, ' cat dim 2, shape must match.')

D(:,1) = A
D(:,2) = B
end SUBROUTINE cat2_rv

SUBROUTINE cat2_cv(D, A, B)  ! complex (column) vector
COMPLEX(SPC), INTENT(IN)  :: A(:), B(:)
COMPLEX(SPC), INTENT(out) :: D(:,:)
integer(I4B) :: sd(2), na, nb
sd = shape(D)
na = size(B);   nb = size(B);
call assert(sd(1) == na, sd(1) == nb, sd(2)==2, ' cat dim 2, shape must match.')

D(:,1) = A
D(:,2) = B
end SUBROUTINE cat2_cv

SUBROUTINE cat2_dv(D, A, B)  ! double (column) vector
REAL(DP), INTENT(IN)  :: A(:), B(:)
REAL(DP), INTENT(out) :: D(:,:)
integer(I4B) :: sd(2), na, nb
sd = shape(D)
na = size(B);   nb = size(B);
call assert(sd(1) == na, sd(1) == nb, sd(2)==2, ' cat dim 2, shape must match.')

D(:,1) = A
D(:,2) = B
end SUBROUTINE cat2_dv

SUBROUTINE cat2_zv(D, A, B)  ! double complex (column) vector
COMPLEX(DPC), INTENT(IN)  :: A(:), B(:)
COMPLEX(DPC), INTENT(out) :: D(:,:)
integer(I4B) :: sd(2), na, nb
sd = shape(D)
na = size(B);   nb = size(B);
call assert(sd(1) == na, sd(1) == nb, sd(2)==2, ' cat dim 2, shape must match.')

D(:,1) = A
D(:,2) = B
end SUBROUTINE cat2_zv

SUBROUTINE cat2_im(D, A, B)  ! integer matrix
INTEGER(I4B), INTENT(IN)  :: A(:,:), B(:,:)
INTEGER(I4B), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(2)== sa(2)+sb(2), sd(1)==sa(1), sd(1)==sb(1), &
               ' cat dim 2, size inconsist.')
D(:, 1:sa(2))    = A
D(:, sa(2)+1 :)  = B
end SUBROUTINE cat2_im

SUBROUTINE cat2_rm(D, A, B)  ! real matrix
REAL(SP), INTENT(IN)  :: A(:,:), B(:,:)
REAL(SP), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(2)== sa(2)+sb(2), sd(1)==sa(1), sd(1)==sb(1), &
               ' cat dim 2, size inconsist.')
D(:, 1:sa(2))    = A
D(:, sa(2)+1 :)  = B
end SUBROUTINE cat2_rm

SUBROUTINE cat2_cm(D, A, B)  ! complex matrix
COMPLEX(SPC), INTENT(IN)  :: A(:,:), B(:,:)
COMPLEX(SPC), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(2)== sa(2)+sb(2), sd(1)==sa(1), sd(1)==sb(1), &
               ' cat dim 2, size inconsist.')
D(:, 1:sa(2))    = A
D(:, sa(2)+1 :)  = B
end SUBROUTINE cat2_cm

SUBROUTINE cat2_dm(D, A, B)  ! double matrix
REAL(DP), INTENT(IN)  :: A(:,:), B(:,:)
REAL(DP), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(2)== sa(2)+sb(2), sd(1)==sa(1), sd(1)==sb(1), &
               ' cat dim 2, size inconsist.')
D(:, 1:sa(2))    = A
D(:, sa(2)+1 :)  = B
end SUBROUTINE cat2_dm

SUBROUTINE cat2_zm(D, A, B)  ! complex matrix
COMPLEX(DPC), INTENT(IN)  :: A(:,:), B(:,:)
COMPLEX(DPC), INTENT(out) :: D(:,:)
integer(I4B) :: sa(2), sb(2), sd(2)
sa = shape(A);   sb = shape(B);  sd = shape(D);
call assert(sd(2)== sa(2)+sb(2), sd(1)==sa(1), sd(1)==sb(1), &
               ' cat dim 2, size inconsist.')
D(:, 1:sa(2))    = A
D(:, sa(2)+1 :)  = B
end SUBROUTINE cat2_zm
! * * * * * * * * * * * * * * * * * * * * * *

! * * * * * * * CATFUN1 * * * * * * *

FUNCTION catfun1_iv(A, B)  ! integer (column) vector
INTEGER(I4B)  :: A(:), B(:)
INTEGER(I4B)  :: catfun1_iv(size(A)+size(B))
catfun1_iv(1:size(A))   = A
catfun1_iv(size(A)+1 :) = B
end FUNCTION

FUNCTION catfun1_rv(A, B)  ! real (column) vector
REAL(SP)  :: A(:), B(:)
REAL(SP)  :: catfun1_rv(size(A)+size(B))
catfun1_rv(1:size(A))   = A
catfun1_rv(size(A)+1 :) = B
end FUNCTION

FUNCTION catfun1_cv(A, B) ! complex (column) vector
COMPLEX(SPC)  :: A(:), B(:)
COMPLEX(SPC)  :: catfun1_cv(size(A)+size(B))
catfun1_cv(1:size(A))   = A
catfun1_cv(size(A)+1 :) = B
end FUNCTION

FUNCTION catfun1_dv(A, B)  ! double (column) vector
REAL(DP)  :: A(:), B(:)
REAL(DP)  :: catfun1_dv(size(A)+size(B))
catfun1_dv(1:size(A))   = A
catfun1_dv(size(A)+1 :) = B
end FUNCTION

FUNCTION catfun1_zv(A, B) ! double complex (column) vector
COMPLEX(DPC)  :: A(:), B(:)
COMPLEX(DPC)  :: catfun1_zv(size(A)+size(B))
catfun1_zv(1:size(A))   = A
catfun1_zv(size(A)+1 :) = B
end FUNCTION

FUNCTION catfun1_im(A, B)  ! integer matrix
INTEGER(I4B)  :: A(:,:), B(:,:)
INTEGER(I4B)  :: catfun1_im(size(A,1)+size(B,1), size(A,2))
catfun1_im(1:size(A,1),:)   = A
catfun1_im(size(A,1)+1 :,:) = B
end FUNCTION

FUNCTION catfun1_rm(A, B)  ! real matrix
REAL(SP)  :: A(:,:), B(:,:)
REAL(SP)  :: catfun1_rm(size(A,1)+size(B,1), size(A,2))
catfun1_rm(1:size(A,1),:)   = A
catfun1_rm(size(A,1)+1 :,:) = B
end FUNCTION

FUNCTION catfun1_cm(A, B) ! complex matrix
COMPLEX(SPC)  :: A(:,:), B(:,:)
COMPLEX(SPC)  :: catfun1_cm(size(A,1)+size(B,1), size(A,2))
catfun1_cm(1:size(A,1),:)   = A
catfun1_cm(size(A,1)+1 :,:) = B
end FUNCTION

FUNCTION catfun1_dm(A, B)  ! double matrix
REAL(DP)  :: A(:,:), B(:,:)
REAL(DP)  :: catfun1_dm(size(A,1)+size(B,1), size(A,2))
catfun1_dm(1:size(A,1),:)   = A
catfun1_dm(size(A,1)+1 :,:) = B
end FUNCTION

FUNCTION catfun1_zm(A, B) ! double complex matrix
COMPLEX(DPC)  :: A(:,:), B(:,:)
COMPLEX(DPC)  :: catfun1_zm(size(A,1)+size(B,1), size(A,2))
catfun1_zm(1:size(A,1),:)   = A
catfun1_zm(size(A,1)+1 :,:) = B
end FUNCTION

!!!!!!!!!!!!!!!!! CATFUN2 !!!!!!!!!!!!!!!!!!!!

FUNCTION catfun2_iv(A, B)  ! integer (column) vector
INTEGER(I4B)  :: A(:), B(:)
INTEGER(I4B)  :: catfun2_iv(size(A),2)
catfun2_iv(:,1) = A
catfun2_iv(:,2) = B
end FUNCTION

FUNCTION catfun2_rv(A, B)  ! real (column) vector
REAL(SP)  :: A(:), B(:)
REAL(SP)  :: catfun2_rv(size(A),2)
catfun2_rv(:,1) = A
catfun2_rv(:,2) = B
end FUNCTION

FUNCTION catfun2_cv(A, B)  ! complex (column) vector
COMPLEX(SPC)  :: A(:), B(:)
COMPLEX(SPC)  :: catfun2_cv(size(A),2)
catfun2_cv(:,1) = A
catfun2_cv(:,2) = B
end FUNCTION

FUNCTION catfun2_dv(A, B)  ! double (column) vector
REAL(DP)  :: A(:), B(:)
REAL(DP)  :: catfun2_dv(size(A),2)
catfun2_dv(:,1) = A
catfun2_dv(:,2) = B
end FUNCTION

FUNCTION catfun2_zv(A, B)  ! double complex (column) vector
COMPLEX(DPC)  :: A(:), B(:)
COMPLEX(DPC)  :: catfun2_zv(size(A),2)
catfun2_zv(:,1) = A
catfun2_zv(:,2) = B
end FUNCTION

FUNCTION catfun2_im(A, B)  ! integer matrix
INTEGER(I4B)  :: A(:,:), B(:,:)
INTEGER(I4B)  :: catfun2_im(size(A,1), size(A,2)+size(B,2))
catfun2_im(:, 1:size(A,2))    = A
catfun2_im(:, size(A,2)+1 :)  = B
end FUNCTION

FUNCTION catfun2_rm(A, B)  ! real matrix
REAL(SP)  :: A(:,:), B(:,:)
REAL(SP)  :: catfun2_rm(size(A,1), size(A,2)+size(B,2))
catfun2_rm(:, 1:size(A,2))    = A
catfun2_rm(:, size(A,2)+1 :)  = B
end FUNCTION

FUNCTION catfun2_cm(A, B)  ! complex matrix
COMPLEX(SPC)  :: A(:,:), B(:,:)
COMPLEX(SPC)  :: catfun2_cm(size(A,1), size(A,2)+size(B,2))
catfun2_cm(:, 1:size(A,2))    = A
catfun2_cm(:, size(A,2)+1 :)  = B
end FUNCTION

FUNCTION catfun2_dm(A, B)  ! double matrix
REAL(DP)  :: A(:,:), B(:,:)
REAL(DP)  :: catfun2_dm(size(A,1), size(A,2)+size(B,2))
catfun2_dm(:, 1:size(A,2))    = A
catfun2_dm(:, size(A,2)+1 :)  = B
end FUNCTION

FUNCTION catfun2_zm(A, B)  ! double complex matrix
COMPLEX(DPC)  :: A(:,:), B(:,:)
COMPLEX(DPC)  :: catfun2_zm(size(A,1), size(A,2)+size(B,2))
catfun2_zm(:, 1:size(A,2))    = A
catfun2_zm(:, size(A,2)+1 :)  = B
end FUNCTION
! ****----------- CAT END ---------- ****

END MODULE


\ https://rosettacode.org/wiki/Sieve_of_Eratosthenes#Forth

: PRIME? ( n -- ? ) HERE + C@ 0= ;
: COMPOSITE! ( n -- ) HERE + 1 SWAP C! ;

: SIEVE ( n -- )
  HERE OVER ERASE
  2
  BEGIN
    2DUP DUP * >
  WHILE
    DUP PRIME? IF
      2DUP DUP * DO
        I COMPOSITE!
      DUP +LOOP
    THEN
    1+
  REPEAT
  DROP
  ." Primes: " 2 DO I PRIME? IF I . THEN LOOP CR ;

DECIMAL 100 SIEVE


module mod_rgrd1
    implicit none

contains
    !

    ! Code converted using TO_F90 by Alan Miller
    ! Date: 2013-09-18  Time: 12:22:39

    ! ... file rgrd1.f

    !     this file contains documentation for subroutine rgrd1 followed by
    !     fortran code for rgrd1 and additional subroutines.

    ! ... author

    !     John C. Adams (NCAR 1999)

    ! ... subroutine rgrd1(nx,x,p,mx,xx,q,intpol,w,lw,iw,liw,ier)

    ! ... purpose

    !     subroutine rgrd1 interpolates the values p(i) on the grid x(i)
    !     for i=1,...,nx onto q(ii) on the grid xx(ii),ii=1,...,mx.

    ! ... language

    !     coded in portable FORTRAN90 and FORTRAN77

    ! ... test program

    !     file trgrd1.f on regridpack includes a test program for subroutine rgrd1

    ! ... method

    !     Linear interpolation (intpol=1)

    !       Given ii in the integer interval [1,mx], let i be the
    !       largest integer in the integer interval [1,nx-1] such
    !       that x(i) is less than or equal to xx(ii).  Then q(ii)
    !       at xx(ii) is linearly interpolated from p(i),p(i+1) at
    !       x(i),x(i+1).

    !     Cubic interpolation (intpol=3)

    !       Given ii in the integer interval [1,mx], let i be the
    !       largest integer in the integer interval [2,nx-2] such
    !       that x(i) is less than or equal to xx(ii).  Then q(ii)
    !       at xx(ii) is cubically interpolated from p(i-1),p(i),
    !       p(i+1),p(i+2) at x(i-1),x(i),x(i+1),x(i+2).

    ! ... required files

    !     none

    ! ... requirements

    !     x must be a strictly increasing grid and xx must be an increasing
    !     grid (see ier = 4).  in addition the interval

    !          [xx(1),xx(mx)]

    !     must lie within the interval

    !          [x(1),x(nx)].

    !     extrapolation is not allowed (see ier=3).  if these intervals
    !     are identical and the x and xx grids are UNIFORM then subroutine
    !     rgrd1u (see file rgrd1u.f) should be used in place of rgrd1.

    ! ... required files

    !     none

    ! ... efficiency

    !     inner most loops in regridpack software vectorize.

    ! *** input arguments

    ! ... nx

    !     the integer dimension of the grid vector x and the dimension of p.
    !     nx > 1 if intpol = 1 or nx > 3 if intpol = 3 is required.

    ! ... x

    !     a real (kind=8) nx vector of strictly increasing values which defines the x
    !     grid on which p is given.

    ! ... p

    !     a real (kind=8) nx vector of values given on the x grid

    ! ... mx

    !     the integer dimension of the grid vector xx and the dimension of q.
    !     mx > 0 is required.

    ! ... xx

    !     a real (kind=8) mx vector of increasing values which defines the
    !     grid on which q is defined.  xx(1) < x(1) or xx(mx) > x(nx)
    !     is not allowed (see ier = 3)

    ! ... intpol

    !     an integer which sets linear or cubic
    !     interpolation as follows:

    !        intpol = 1 sets linear interpolation
    !        intpol = 3 sets cubic interpolation

    !     values other than 1 or 3 in intpol are not allowed (ier = 6).

    ! ... w

    !     a real (kind=8) work space of length at least lw which must be provided in the
    !     routine calling rgrd1

    ! ... lw

    !     the integer length of the real work space w.  let

    !          lwmin =   mx            if intpol(1) = 1
    !          lwmin = 4*mx            if intpol(1) = 3

    !     then lw must be greater than or equal to lwmin

    ! ... iw

    !     an integer work space of length at least liw which must be provided in the
    !     routine calling rgrd1

    ! ... liw

    !     tne length of the integer work space iw. liw must be greater than or equal to mx.

    ! *** output arguments

    ! ... q

    !     a real (kind=8) mx vector of values on the xx grid which are
    !     interpolated from p on the x grid

    ! ... ier

    !     an integer error flag set as follows:

    !     ier = 0 if no errors in input arguments are detected

    !     ier = 1 if  mx < 1

    !     ier = 2 if nx < 2 when intpol=1 or nx < 4 when intpol=3

    !     ier = 3 if xx(1) < x(1) or x(nx) < xx(mx)

    ! *** to avoid this flag when end points are intended to be the
    !     same but may differ slightly due to roundoff error, they
    !     should be set exactly in the calling routine (e.g., if both
    !     grids have the same x boundaries then xx(1)=x(1) and xx(mx)=x(nx)
    !     should be set before calling rgrd1)

    !     ier = 4 if the x grid is not strictly monotonically increasing
    !             or if the xx grid is not montonically increasing.  more
    !             precisely if:

    !             x(i+1) <= x(i) for some i such that 1 <= i < nx (or)

    !             xx(ii+1) < xx(ii) for some ii such that 1 <= ii < mx

    !     ier = 5 if lw or liw is too small (insufficient work space)

    !     ier = 6 if intpol is not equal to 1 or 3

    ! ************************************************************************

    !     end of rgrd1 documentation, fortran code follows:

    ! ************************************************************************

    SUBROUTINE rgrd1(nx,x,p,mx,xx,q,intpol,w,lw,iw,liw,ier)
    !     dimension x(nx),p(nx),xx(mx),q(mx),w(lw)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: x(*)
    real (kind=8), INTENT(IN)                :: p(*)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(IN)                :: xx(*)
    real (kind=8), INTENT(OUT)               :: q(*)
    INTEGER, INTENT(IN)                      :: intpol
    real (kind=8), INTENT(INOUT)             :: w(*)
    INTEGER, INTENT(IN)                      :: lw
    INTEGER, INTENT(IN OUT)                  :: iw(*)
    INTEGER, INTENT(IN)                      :: liw
    INTEGER, INTENT(OUT)                     :: ier

    INTEGER :: i,ii,i1,i2,i3,i4

    !     check arguments for errors

    ier = 1

    !     check xx grid resolution

    IF (mx < 1) RETURN

    !     check intpol

    ier = 6
    IF (intpol /= 1 .AND. intpol /= 3) RETURN

    !     check x grid resolution

    ier = 2
    IF (intpol == 1 .AND. nx < 2) RETURN
    IF (intpol == 3 .AND. nx < 4) RETURN

    !     check xx grid contained in x grid

    ier = 3
    IF (xx(1) < x(1) .OR. xx(mx) > x(nx)) RETURN

    !     check montonicity of grids

    DO i=2,nx
      IF (x(i-1) >= x(i)) THEN
        ier = 4
        RETURN
      END IF
    END DO
    DO ii=2,mx
      IF (xx(ii-1) > xx(ii)) THEN
        ier = 4
        RETURN
      END IF
    END DO

    !     check minimum work space lengths

    IF (intpol == 1) THEN
      IF (lw < mx) RETURN
    ELSE
      IF (lw < 4*mx) RETURN
    END IF
    IF (liw < mx) RETURN

    !     arguments o.k.

    ier = 0

    IF (intpol == 1) THEN

    !     linear interpolation in x

      i1 = 1
      i2 = i1+mx
      CALL linmx(nx,x,mx,xx,iw,w)
      CALL lint1(nx,p,mx,q,iw,w)
      RETURN
    ELSE

    !     cubic interpolation in x

      i1 = 1
      i2 = i1+mx
      i3 = i2+mx
      i4 = i3+mx
      CALL cubnmx(nx,x,mx,xx,iw,w(i1),w(i2),w(i3),w(i4))
      CALL cubt1(nx,p,mx,q,iw,w(i1),w(i2),w(i3),w(i4))
      RETURN
    END IF
    END SUBROUTINE rgrd1

    SUBROUTINE lint1(nx,p,mx,q,ix,dx)
    !     dimension p(nx),q(mx),ix(mx),dx(mx)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: p(nx)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(OUT)               :: q(mx)
    INTEGER, INTENT(IN)                      :: ix(mx)
    real (kind=8), INTENT(IN)                :: dx(mx)
    INTEGER :: ii,i

    !     linearly interpolate p on x onto q on xx

    DO ii=1,mx
      i = ix(ii)
      q(ii) = p(i)+dx(ii)*(p(i+1)-p(i))
    END DO
    RETURN
    END SUBROUTINE lint1

    SUBROUTINE cubt1(nx,p,mx,q,ix,dxm,dx,dxp,dxpp)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: p(nx)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(OUT)               :: q(mx)
    INTEGER, INTENT(IN)                      :: ix(mx)
    real (kind=8), INTENT(IN)                :: dxm(mx)
    real (kind=8), INTENT(IN)                :: dx(mx)
    real (kind=8), INTENT(IN)                :: dxp(mx)
    real (kind=8), INTENT(IN)                :: dxpp(mx)
    INTEGER :: i,ii

    !     cubically interpolate p on x to q on xx

    DO ii=1,mx
      i = ix(ii)
      q(ii) = dxm(ii)*p(i-1)+dx(ii)*p(i)+dxp(ii)*p(i+1)+dxpp(ii)*p(i+2)
    END DO
    RETURN
    END SUBROUTINE cubt1

    SUBROUTINE linmx(nx,x,mx,xx,ix,dx)

    !     set x grid pointers for xx grid and interpolation scale terms

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: x(*)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(IN)                :: xx(*)
    INTEGER, INTENT(OUT)                     :: ix(*)
    real (kind=8), INTENT(OUT)               :: dx(*)

    INTEGER :: isrt,ii,i

    isrt = 1
    DO ii=1,mx

    !     find x(i) s.t. x(i) < xx(ii) <= x(i+1)

      DO i=isrt,nx-1
        IF (x(i+1) >= xx(ii)) THEN
          isrt = i
          ix(ii) = i
          GO TO 3
        END IF
      END DO
      3   CONTINUE
    END DO

    !     set linear scale term

    DO ii=1,mx
      i = ix(ii)
      dx(ii) = (xx(ii)-x(i))/(x(i+1)-x(i))
    END DO
    RETURN
    END SUBROUTINE linmx

    SUBROUTINE cubnmx(nx,x,mx,xx,ix,dxm,dx,dxp,dxpp)

    IMPLICIT NONE
    INTEGER, INTENT(IN)                      :: nx
    real (kind=8), INTENT(IN)                :: x(*)
    INTEGER, INTENT(IN)                      :: mx
    real (kind=8), INTENT(IN)                :: xx(*)
    INTEGER, INTENT(OUT)                     :: ix(*)
    real (kind=8), INTENT(OUT)               :: dxm(*)
    real (kind=8), INTENT(OUT)               :: dx(*)
    real (kind=8), INTENT(OUT)               :: dxp(*)
    real (kind=8), INTENT(OUT)               :: dxpp(*)

    INTEGER :: i,ii,isrt

    isrt = 1
    DO ii=1,mx

    !     set i in [2,nx-2] closest s.t.
    !     x(i-1),x(i),x(i+1),x(i+2) can interpolate xx(ii)

      DO i=isrt,nx-1
        IF (x(i+1) >= xx(ii)) THEN
          ix(ii) = MIN0(nx-2,MAX0(2,i))
          isrt = ix(ii)
          GO TO 3
        END IF
      END DO
      3   CONTINUE
    END DO

    !     set cubic scale terms

    DO ii=1,mx
      i = ix(ii)
      dxm(ii) = (xx(ii)-x(i))*(xx(ii)-x(i+1))*(xx(ii)-x(i+2))/  &
          ((x(i-1)-x(i))*(x(i-1)-x(i+1))*(x(i-1)-x(i+2)))
      dx(ii) = (xx(ii)-x(i-1))*(xx(ii)-x(i+1))*(xx(ii)-x(i+2))/  &
          ((x(i)-x(i-1))*(x(i)-x(i+1))*(x(i)-x(i+2)))
      dxp(ii) = (xx(ii)-x(i-1))*(xx(ii)-x(i))*(xx(ii)-x(i+2))/  &
          ((x(i+1)-x(i-1))*(x(i+1)-x(i))*(x(i+1)-x(i+2)))
      dxpp(ii) = (xx(ii)-x(i-1))*(xx(ii)-x(i))*(xx(ii)-x(i+1))/  &
          ((x(i+2)-x(i-1))*(x(i+2)-x(i))*(x(i+2)-x(i+1)))
    END DO
    RETURN
    END SUBROUTINE cubnmx
end module


c     program DRDBLAS4
c>> 1994-10-19 DRDBLAS4 Krogh  Changes to use M77CON
c>> 1992-05-12 DRDBLAS4 CLL Improved consistency of various versions.
c>> 1992-04-15 CLL
c>> 1992-03-16 CLL
c>> 1991-12-02 DRDBLAS4 CLL
c>> 1991-07-31 DRDBLAS4 CLL
c
c     Demonstrates the use of BLAS subroutines DROTMG, DROTM, DAXPY,
c     and DCOPY to implement an algorithm for solving a linear
c     least squares problem using sequential accumulation of the
c     data and Modified (Fast) Givens orthogonal transformations.
c     YTAB() contains rounded values of -2 + 2*X + 3*Exp(-X)
c
c     ------------------------------------------------------------------
c--D replaces "?": DR?BLAS4, ?AXPY, ?ROTMG, ?ROTM, ?COPY, ?VECP
c     ------------------------------------------------------------------
      integer MC, MC1, MC2, MXY
      parameter ( MC=3, MC1=MC+1, MC2=MC+2, MXY=11 )
      double precision XTAB(MXY), YTAB(MXY), W(MC2), RG(MC1,MC2)
      double precision C(MC), ZERO(1), X, Y, ESTSD, DIV, PARAM(5)
      double precision ONE(1)
      integer NXY, NC, NC1, NC2, IXY, J
c
      data XTAB / 0.0d0, .1d0, .2d0, .3d0, .4d0, .5d0, .6d0, .7d0,
     *           .8d0, .9d0, 1.0d0 /
      data YTAB / 1.00d0, .91d0, .86d0, .82d0, .81d0, .82d0, .85d0,
     * .89d0, .95d0, 1.02d0, 1.10d0 /
      data NXY, NC / 11, 3 /
      data ONE(1), ZERO(1) / 1.0d0, 0.0d0 /
c     ------------------------------------------------------------------
      print'(a/)',' DRDBLAS4..  Demo for DROTMG and DROTM.'
      NC1 = NC + 1
      NC2 = NC1 + 1
      call DCOPY(MC1*MC2, ZERO, 0, RG, 1)
      call DCOPY(NC1, ONE, 0, RG(1,NC2), 1)
      do 20 IXY = 1, NXY
        X = XTAB(IXY)
        Y = YTAB(IXY)
c
c          Set W() to be the next row of the least-squares problem.
c
        W(1) = 1.0d0
        W(2) = X
        W(3) = EXP(-X)
        W(4) = Y
        W(5) = 1.0D0
c
c        Accumulate W() into the triangular matrix [R:G]
c        using Givens rotations.
c
        do 10 J = 1, NC1
          call DROTMG(RG(J,NC2), W(NC2), RG(J,J), W(J), PARAM)
          if(J .lt. NC1) call DROTM(NC1-J,RG(J,J+1),MC1,W(J+1),1,PARAM)
   10   continue
c
   20 continue
c
c               Solve the triangular system.
c
        call DCOPY(NC,RG(1,NC1),1,C,1)
        do 30 J = NC, 1, -1
          DIV = RG(J,J)
          if (DIV .EQ. 0.0d0) then
            print*,'ERROR:ZERO DIVISOR AT J =',J
            stop
          end if
          C(J) = C(J) / DIV
          call DAXPY(J-1,-C(J),RG(1,J),1,C,1)
   30 continue
c
      call DVECP(C,NC,'0 Solution: C()=')
      print*,' '
      ESTSD = abs(RG(NC1,NC1)) * sqrt(RG(NC1,NC2)) / sqrt(DBLE(NXY-NC))
      print*,'Estimated STD. DEV. of data errors =',ESTSD
      stop
      end


SUBROUTINE INVERSSYMDEF(A,AINV)
  IMPLICIT REAL*8 (A-H,O-Z)
  DIMENSION A(3,3),AINV(3,3)
  det= a(1,1)*a(2,2)*a(3,3)+a(1,2)*a(2,3)*a(3,1)+a(1,3)*a(2,1)*a(3,2)-a(3,1)*a(2,2)*a(1,3)-a(1,1)*a(3,2)*a(2,3)-a(2,1)*a(1,2)*a(3,3)
  AINV(1,1) =(   A(2,2) * A(3,3) - A(2,3) * A(3,2) ) / det
  AINV(2,1) =( - A(2,1) * A(3,3) + A(2,3) * A(3,1) ) / det
  AINV(3,1) =(   A(2,1) * A(3,2) - A(2,2) * A(3,1) ) / det
  AINV(1,2) =( - A(1,2) * A(3,3) + A(1,3) * A(3,2) ) / det
  AINV(2,2) =(   A(1,1) * A(3,3) - A(1,3) * A(3,1) ) / det
  AINV(3,2) =( - A(1,1) * A(3,2) + A(1,2) * A(3,1) ) / det
  AINV(1,3) =(   A(1,2) * A(2,3) - A(1,3) * A(2,2) ) / det
  AINV(2,3) =( - A(1,1) * A(2,3) + A(1,3) * A(2,1) ) / det
  AINV(3,3) =(   A(1,1) * A(2,2) - A(1,2) * A(2,1) ) / det
  RETURN
END SUBROUTINE INVERSSYMDEF


 Module SBMathLibrary                                               ! standard subroutines for integration and splines
      implicit none
 Contains

      SUBROUTINE QSL3D(RINT,A,B,F,E)
!
!     Adaptive integration using Lobatto formula of 11th power with guaranteed accuracy.
!
!     RINT - on exit contains the integral value
!     A, B - lower and upper limits for integration
!     F    - external subroutine with integration function
!     E    - accuracy of calculation
!     In a case when the integration function has singularities and the necessary accuracy can not be achieved
!     the program may stop with the corresponding message.
!
! Copyright (C) 1974-2021 Library of the numerical analysis, Research Computing Center,
!                         Lomonosov Moscow State University
!                         http://num-anal.srcc.msu.ru/lib_na/libnal.htm
!     The library can be used without any limitations only for non-commercial usage.
!     If the Library or any part of it is installed in organization for use in a shared access mode,
!     then the organization must arrange non-commercial usage of the Library's subprograms.
!     Users or organizations have no right to transfer the programs of the Library or their modifications
!     to other persons or organizations for non-commercial usage without written permission
!     from the Research Computing Center of Moscow State University.
!     For commercial usage please contact Research Computing Center at <arush@srcc.msu.ru>
!
      External F
      DIMENSION AY(7),BY(7),KSI(7),OM(3),D(3)
      INTEGER OM,N,IL,O
      real(8) RINT,A,B,F,E,XA,AY,BY,KSI,D,XAA,INT,INT2,I,J,K,L,M,C,W,E1,Z2,H,Z1,EPS,P,H0,Q,R,SYS051
      LOGICAL NI
      DATA AY/0.023809523809D0,0.243809523809D0,0.023809523809D0,0.138413023681D0,0.215872690605D0,0.215872690605D0,0.138413023681D0/
      DATA BY/-0.076190474D0,0.243809523809D0,-0.076190474D0,0.183701962D0,-0.229416249D0,-0.229416249D0,0.183701962D0/
      DATA KSI/0.D0,0.5D0,1.D0,0.084888051861D0,0.265575603265D0,0.734424396735D0,0.915111948139D0/
      DATA SYS051/1.1107652D-16/
      EPS=E
      IL=1
      NI=A.GT.B
      IF(.NOT.(NI)) GO TO 1
      C=A
      A=B
      B=C
    1 W=B-A
      IF(.NOT.(W.EQ.0.D0)) GO TO 2
      INT=0.D0
      E1=0.D0
      GO TO 28
    2 Z2=E/W
      H=1.D0
      N=0
      Z1=EPS/W
    3 P=0.D0
      E1=0.D0
      INT=0.D0
      OM(1)=0
      OM(2)=0
      OM(3)=0
    4 K=P+H
      L=0.D0
      M=0.D0
      DO 7 O=1,3
      IF(OM(O).EQ.0) GO TO 5
      I=D(O)
      GO TO 6
    5 J=H*KSI(O)+P
      D(O)=F(W*J+A)
      I=D(O)
      OM(O)=1
    6 L=L+AY(O)*I
      M=M+BY(O)*I
    7 CONTINUE
      DO 8 O=4,7
      J=H*KSI(O)+P
      I=F(W*J+A)
      L=L+AY(O)*I
      M=M+BY(O)*I
    8 CONTINUE
      L=H*L
      M=DABS(H*M)
      IF(M-Z1) 9,18,18
    9 P=K
      E1=E1+M
      INT=INT+L
      I=1.D0-P
      N=N+1
      IF(N-1) 11,10,11
   10 H0=H
   11 IF(1.D0+I/64.D0-1.D0) 12,12,14
   12 J=DABS(F(B))+DABS(D(3))
      J=J*I
      IF(J-Z2) 22,22,13
   13 XA=A+P*W
      INT=INT*W
      XAA=XA
      print 111,XAA
111   format('The accuracy can not be achived at singular point',E20.12)
      GO TO 28
   14 D(1)=D(3)
      OM(2)=0
      OM(3)=0
      OM(1)=1
      IF(M-Z1/2.D0**7) 15,16,16
   15 H=2.D0*H
   16 IF(H-I) 4,4,17
   17 H=I
      GO TO 4
   18 H=H/2.D0
      IF(H-SYS051*P) 19,19,21
   19 IF(P) 20,20,13
   20 IF(H/4.D0) 13,13,21
   21 D(3)=D(2)
      OM(2)=0
      GO TO 4
   22 Q=Z2*(1.D0+DABS(INT))
      IF(E1-Q) 27,27,23
   23 IF(IL-1) 24,25,24
   24 R=DABS(INT-INT2)
      IF(R-Q) 26,26,25
   25 INT2=INT
      IL=2
      EPS=EPS/2.D0**7
      H=H0
      GO TO 3
   26 E1=R
   27 INT=INT*W
      XA=B
      IF(.NOT.(NI)) GO TO 28
      C=B
      B=A
      A=C
      INT=-INT
   28 RINT=INT
      RETURN
      END SUBROUTINE QSL3D

   subroutine spline (x, y, b, c, d, n)
!======================================================================
!  Calculate the coefficients b(i), c(i), and d(i), i=1,2,...,n
!  for cubic spline interpolation
!  s(x) = y(i) + b(i)*(x-x(i)) + c(i)*(x-x(i))**2 + d(i)*(x-x(i))**3
!  for  x(i) <= x <= x(i+1)
!----------------------------------------------------------------------
!  input..
!  x = the arrays of data abscissas (in strictly increasing order)
!  y = the arrays of data ordinates
!  n = size of the arrays xi() and yi() (n>=2)
!  output..
!  b, c, d  = arrays of spline coefficients
!
!  Author: Alex Godunov, January 2010
!  https://ww2.odu.edu/~agodunov/computing/programs/
!  spline.f90 program is based on http://NetLib.org fortran version of program spline.f
!  the accompanying function ispline can be used for interpolation
!======================================================================
integer     :: n
real(8)     :: x(n), y(n), b(n), c(n), d(n)
integer     :: i, j, gap
real(8)     :: h

gap = n-1
! check input
if ( n < 2 ) return
if ( n < 3 ) then
  b(1) = (y(2)-y(1))/(x(2)-x(1))   ! linear interpolation
  c(1) = 0.
  d(1) = 0.
  b(2) = b(1)
  c(2) = 0.
  d(2) = 0.
  return
end if
!
! step 1: preparation
!
d(1) = x(2) - x(1)
c(2) = (y(2) - y(1))/d(1)
do i = 2, gap
  d(i) = x(i+1) - x(i)
  b(i) = 2.0*(d(i-1) + d(i))
  c(i+1) = (y(i+1) - y(i))/d(i)
  c(i) = c(i+1) - c(i)
end do
!
! step 2: end conditions
!
b(1) = -d(1)
b(n) = -d(n-1)
c(1) = 0.0
c(n) = 0.0
if(n /= 3) then
  c(1) = c(3)/(x(4)-x(2)) - c(2)/(x(3)-x(1))
  c(n) = c(n-1)/(x(n)-x(n-2)) - c(n-2)/(x(n-1)-x(n-3))
  c(1) = c(1)*d(1)**2/(x(4)-x(1))
  c(n) = -c(n)*d(n-1)**2/(x(n)-x(n-3))
end if
!
! step 3: forward elimination
!
do i = 2, n
  h = d(i-1)/b(i-1)
  b(i) = b(i) - h*d(i-1)
  c(i) = c(i) - h*c(i-1)
end do
!
! step 4: back substitution
!
c(n) = c(n)/b(n)
do j = 1, gap
  i = n-j
  c(i) = (c(i) - d(i)*c(i+1))/b(i)
end do
!
! step 5: compute spline coefficients
!
b(n) = (y(n) - y(gap))/d(gap) + d(gap)*(c(gap) + 2.0*c(n))
do i = 1, gap
  b(i) = (y(i+1) - y(i))/d(i) - d(i)*(c(i+1) + 2.0*c(i))
  d(i) = (c(i+1) - c(i))/d(i)
  c(i) = 3.*c(i)
end do
c(n) = 3.0*c(n)
d(n) = d(n-1)
end subroutine spline

  function ispline(u, x, y, b, c, d, n)
!======================================================================
! function ispline evaluates the cubic spline interpolation at point z
! ispline = y(i)+b(i)*(u-x(i))+c(i)*(u-x(i))**2+d(i)*(u-x(i))**3
! where  x(i) <= u <= x(i+1)
!----------------------------------------------------------------------
! input..
! u       = the abscissa at which the spline is to be evaluated
! x, y    = the arrays of given data points
! b, c, d = arrays of spline coefficients computed by spline
! n       = the number of data points
! output:
! ispline = interpolated value at point u
!
!  Author: Alex Godunov, January 2010
!  https://ww2.odu.edu/~agodunov/computing/programs/
!=======================================================================
real(8)        :: ispline
integer        :: n
real(8)        :: u, x(n), y(n), b(n), c(n), d(n)
integer        :: i, j, k
real(8)        :: dx

!*** modified by Dmitry Skachkov: adding extrapolation for points outside of X(1)..X(N)
! if u is ouside the x() interval take a boundary value (left or right)
if(u <= x(1)) then
!  ispline = y(1)
  dx = u - x(1)                                          !!***
  ispline = y(1) + dx*(b(1) + dx*(c(1) + dx*d(1)))       !!***
  return
end if
if(u >= x(n)) then
!  ispline = y(n)
  dx = u - x(n)                                          !!***
  ispline = y(n) + dx*(b(n) + dx*(c(n) + dx*d(n)))       !!***
  return
end if
!***

!*
!  binary search for for i, such that x(i) <= u <= x(i+1)
!*
i = 1
j = n+1
do while (j > i+1)
  k = (i+j)/2
  if(u < x(k)) then
    j=k
    else
    i=k
   end if
end do
!*
!  evaluate spline interpolation
!*
dx = u - x(i)
ispline = y(i) + dx*(b(i) + dx*(c(i) + dx*d(i)))
end function ispline

 end Module SBMathLibrary


program main
  ! Default
  implicit none

  ! Parameters
  integer(4) :: imax = 4000000

  ! Variables
  integer(4) :: i,sum
  integer(4) :: f1,f2,f3

  ! Init
  ! Since we're skipping 2, we initialize our sum with 2
  f1  = 1
  f2  = 2
  sum = 2
  do
     f3 = f1 + f2
     f1 = f2
     f2 = f3
     if (mod(f2,2)==0) then
        sum = sum + f2
     endif
     if (f2 > imax) then
        exit
     endif
  enddo

  ! Print answer
  write(*,*) "Sum: ",sum

end program main


	FUNCTION PR_LHVP  ( tmpc )
C************************************************************************
C* PR_LHVP 								*
C*									*
C* This function computes LHVP from TMPC.  LHVP, the latent heat of	*
C* vaporization at constant pressure, is computed as follows:		*
C*									*
C*              LHVP = ( 2.500 - .00237 * TMPC ) * 10E6			*
C*									*
C* REAL PR_LHVP  ( TMPC )						*
C*	                                                                *
C* Input parameters:							*
C*	TMPC		REAL		Temperature in Celsius		*
C*	                                                                *
C* Output parameters:							*
C*	PR_LHVP		REAL		Latent heat in J/kg		*
C**	                                                                *
C* Log:									*
C* P. Kocin/CSC	 	1980    Original code				*
C* M. Goodman/RDS	8/84	Cleaned code				*
C* I. Graffman/RDS   	11/84 	Renamed from PR_HEAT			*
C* I. Graffman/RDS   	12/87	GEMPAK4					*
C* G. Huffman/GSC	7/88	Documentation				*
C* K. Brill/NMC		2/92	Change 10e6 to 1.0e6			*
C* L. Sager/NCEP	4/96	Updated factor for latent heat of	*
C*				vaporization to NCEP standard		*
C************************************************************************
        INCLUDE   'GEMPRM.PRM'
        INCLUDE   'ERMISS.FNC'
C------------------------------------------------------------------------
C*	Check for missing data.
C
	IF  ( ERMISS ( tmpc ) )  THEN
	    PR_LHVP = RMISSD
	  ELSE
	    PR_LHVP = (2.500 - .00237 * TMPC) * 1.0E6
	END IF
C*
	RETURN
	END


      subroutine get_diurnal_sst(xhour,xlon,wind, Q,diurnal_sst)
      implicit none

      real(4), parameter :: pi=3.141592654
	real(4), parameter :: solar_constant=1360   !watts/m**2

c	real(4) sunlat,sundis,xhour,xlon,xlat,wind
	real(4) xhour,wind,xlon
      real(4) diurnal_sst, Q, rlmt
      real(4) a0,a1,a2,a3,a4,a5,b1,b2,b3,b4,b5,w

      data a0,a1,a2,a3,a4,a5/4.118E-3, -4.132E-3, 0.8746E-3, -0.2460E-3, 0.2762E-3,-0.0609E-3/
      data    b1,b2,b3,b4,b5/          -5.093E-3, 2.5830E-3, -0.5143E-3,-0.3355E-3, 0.2269E-3/
      data w/0.261799388/  !2*pi/24.

      rlmt=xhour + (xlon/360.)*24.

      if (Q>154) then
      diurnal_sst=(1.23459589668*(Q-154.)-1.56088414175378e-3*(Q-154.)**2)*exp(-.44*wind)*
     &				(a0 + a1*cos(   rlmt*w) + b1*sin(   rlmt*w) + a2*cos(2.*rlmt*w) + b2*sin(2.*rlmt*w)+
     &				      a3*cos(3.*rlmt*w) + b3*sin(3.*rlmt*w) + a4*cos(4.*rlmt*w) + b4*sin(4.*rlmt*w)+
     &                      a5*cos(5.*rlmt*w) + b5*sin(5.*rlmt*w))
	else
	diurnal_sst=0;
	endif
	if(diurnal_sst<0)diurnal_sst=0;

	RETURN
	END

	subroutine get_diurnal_sst_seviri2(xhour,xlon,wind, rsol,dsst)

c	c.gentemann 4.2008
c	inputs:
c	lyr=year
c	idyjl=ordinal day
c	xhour = LOCAL TIME IN HOURS
c	xlat=latitude in deg
c	wind = wind speed in m/s

c	output:
c	dsst = diurnal amplitude in deg

c	integer lyr,idyjl
	real xhour,wind,dsst
	real w,rsol
      real(4), parameter :: pi=3.141592654
	real*8 xpar(11)
	real diurnal_cos

	xpar(1)=0.90779440686153
	xpar(2)=-5.654018322117584E-001
	xpar(3)=-9.109286437084861E-001
	xpar(4)=4.938677367379611E-002
	xpar(5)=2.921478004135862E-001
	xpar(6)=-8.767453446309354E-004
	xpar(7)= -6.803299659334103E-002
	xpar(8)=-4.456366487917374E-003
	xpar(9)=2.214046984740299E-003
	xpar(10)=2.166914823201959E-002
	xpar(11)=-2.116565831620519E-003

c	a0=4.118;a1=-4.132;b1=-5.093;a2=.8746;b2=2.583;
c	a3=-.246;b3=-.5143;a4=.2762;b4=-.3355;a5=-.0609;b5=.2269;
	w=2.*pi/24.;

c	call fd_insolation(lyr,idyjl,43200,xlat,rsol)
      rlmt=xhour + (xlon/360.)*24.

	dsst=0;
	if (rsol>97) then
	diurnal_cos=xpar(1)+
	.			xpar(2)*cos(rlmt*w)+xpar(3)*sin(rlmt*w)+
     .			xpar(4)*cos(2*rlmt*w)+xpar(5)*sin(2*rlmt*w)+
     .			xpar(6)*cos(3*rlmt*w)+xpar(7)*sin(3*rlmt*w)+
     .			xpar(8)*cos(4*rlmt*w)+xpar(9)*sin(4*rlmt*w)+
     .			xpar(10)*cos(5*rlmt*w)+xpar(11)*sin(5*rlmt*w)

	dsst=((0.00224946*(rsol-97.))*exp(-0.27*wind) +
	+	 (2.01422e-6*(rsol-97.)**2)*exp(-0.27*wind))*diurnal_cos
     	endif

	end


implicit none
double precision :: xdata(0:2), ydata(0:2), top, bot, a(0:2)
double precision :: factor
integer :: i, j, k, n

n = 2 		! interpolate at n + 1 data points

xdata = (/ 5.0d0, 7.0d0, 10.0d0 /)
ydata = (/ 3.0d0, 1.0d0, 4.0d0 /)

a(0) = ydata(0)

do i = 1,n

	bot = (xdata(i) - xdata(0))
	do j = 1, (i - 1)
		bot = bot*(xdata(i) - xdata(j))
	end do

	top = ydata(i) - a(0)
	do j = 1, (i - 1)
		factor = xdata(i) - xdata(0)
		do k = 1, (j - 1)
			factor = factor* (xdata(i)-xdata(k))
		end do

		top = top - factor*a(j)
	end do

	a(i) = top/bot
end do

print*,'Coefficients of interpolating polynomial in Newtons Divided-Difference '
do i =0,n
	print*,a(i)
end do

stop
end

4670 Numerical Analysis/Class Examples/boneheaded.f90


program main_stats
    implicit none
    integer, parameter :: nr_data = 21
    integer :: i
    real :: mean, stddev
    integer :: n
    real, dimension(nr_data) :: data

    data = [ (100.0 + 0.3*i, i=-size(data)/2, size(data)/2) ]
    call compute_stats(data, mean, stddev, n)
    print *, mean, stddev, n

contains

    subroutine compute_stats(data, mean, stddev, n)
        implicit none
        real, dimension(:), intent(in) :: data
        real, intent(out) :: mean, stddev
        integer, intent(out) :: n
        real :: data_sum, data_sum2

        n = size(data)
        data_sum = sum(data)
        data_sum2 = sum(data**2)
        mean = data_sum/n
        stddev = sqrt((data_sum2 - data_sum**2/n)/(n - 1))
    end subroutine compute_stats

end program main_stats


!=======================================================================
! Created by
!     Keurfon Luu <keurfon.luu@mines-paristech.fr>
!     MINES ParisTech - Centre de Géosciences
!     PSL - Research University
!=======================================================================

program example_interp

  use forlab, only: IPRE, RPRE, zeros, linspace, meshgrid, interp2, spline2, &
                    bspline2, savetxt

  implicit none

  integer(kind = IPRE) :: i, j, nx, ny
  real(kind = RPRE), dimension(:), allocatable :: ax, ay, axq, ayq
  real(kind = RPRE), dimension(:,:), allocatable :: A, XX, YY, ZZ, xq, yq
  character(len = :), allocatable :: outdir

  ! Output directory
  outdir = "interp/"
  call system("mkdir -p " // outdir)

  ! Create an undersampled grid to interpolate (Rosenbrock)
  nx = 10
  ny = 20
  A = zeros(ny, nx)
  ax = linspace(-5.12, 5.12, nx)
  ay = linspace(-5.12, 5.12, ny)
  do i = 1, ny
    do j = 1, nx
      A(i,j) = rosenbrock( [ ay(i), ax(j) ] )
    end do
  end do

  ! Compute the true grid
  print *, "Computing true grid:"

  nx = 100
  ny = 200
  ZZ = zeros(ny, nx)
  axq = linspace(-5.12, 5.12, nx)
  ayq = linspace(-5.12, 5.12, ny)
  do i = 1, ny
    do j = 1, nx
      ZZ(i,j) = rosenbrock( [ ayq(i), axq(j) ] )
    end do
  end do

  call savetxt(outdir // "true.txt", ZZ)
  print *, "True grid saved in " // outdir

  ! Bilinear interpolation
  print *; print *, "Bilinear interpolation:"
  call meshgrid(axq, ayq, XX, YY)
  ZZ = interp2(ax, ay, A, XX, YY)

  call savetxt(outdir // "linear2.txt", ZZ)
  print *, "Bilinear interpolation grid saved in " // outdir

  ! Bicubic spline interpolation
  print *; print *, "Bicubic spline interpolation:"
  ZZ = spline2(ax, ay, A, XX, YY)

  call savetxt(outdir // "spline2.txt", ZZ)
  print *, "Bicubic spline interpolation grid saved in " // outdir

  ! 2D B-spline interpolation
  print *; print *, "2D B-spline interpolation:"
  ZZ = bspline2(ax, ay, A, XX, YY, 4)

  call savetxt(outdir // "bspline2.txt", ZZ)
  print *, "2D B-spline interpolation grid saved in " // outdir

  print *; print *, "Run script /utils/view_interp.py to check results."

  print *

contains

  real(kind = RPRE) function rosenbrock(x)
    real(kind = RPRE), dimension(:), intent(in) :: x
    integer(kind = IPRE) :: nd
    real(kind = RPRE) :: sum1, sum2

    nd = size(x)
    sum1 = sum( ( x(2:) - x(:nd-1)**2 )**2 )
    sum2 = sum( ( 1.0d0 - x(:nd-1) )**2 )
    rosenbrock = 100.0d0 * sum1 + sum2
    return
  end function rosenbrock

end program example_interp


subroutine gaussb(a, b, deter)
  implicit none

  real, dimension(:,:), intent(inout) :: a
  real, dimension(:), intent(inout) :: b
  real, intent(inout) :: deter

  real :: factor, piv

  integer :: n, k, i, j

  n = size(b)
  deter = 1

  do k=1,n-1
    piv=a(k,k)
    if(abs(piv) < 1.e-12) then
      print*, 'Pivote nulo na etapa: ', k
      stop
    end if

    deter = deter*piv

    a(k+1:n,k) = a(k+1:n,k)/piv
    do j=k+1,n
      a(k+1:n,j) = a(k+1:n,j)-a(k+1:n,k)*a(k,j)
    end do
    b(k+1:n) = b(k+1:n)-a(k+1:n,k)*b(k)

  end do

  if(abs(a(n,n)) < 1.e-12) then
    print*, 'Pivote nulo na etapa: ', n
    stop
  end if

  deter = deter*a(n,n)
end subroutine


      SUBROUTINE slDAFR (IDEG, IAMIN, ASEC, RAD, J)
*+
*     - - - - - -
*      D A F R
*     - - - - - -
*
*  Convert degrees, arcminutes, arcseconds to radians
*  (double precision)
*
*  Given:
*     IDEG        int       degrees
*     IAMIN       int       arcminutes
*     ASEC        dp        arcseconds
*
*  Returned:
*     RAD         dp        angle in radians
*     J           int       status:  0 = OK
*                                    1 = IDEG outside range 0-359
*                                    2 = IAMIN outside range 0-59
*                                    3 = ASEC outside range 0-59.999...
*
*  Notes:
*     1)  The result is computed even if any of the range checks
*         fail.
*     2)  The sign must be dealt with outside this routine.
*
*  P.T.Wallace   Starlink   23 August 1996
*
*  Copyright (C) 1996 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      INTEGER IDEG,IAMIN
      DOUBLE PRECISION ASEC,RAD
      INTEGER J

*  Arc seconds to radians
      DOUBLE PRECISION AS2R
      PARAMETER (AS2R=0.484813681109535994D-5)

*  Preset status
      J=0

*  Validate arcsec, arcmin, deg
      IF (ASEC.LT.0D0.OR.ASEC.GE.60D0) J=3
      IF (IAMIN.LT.0.OR.IAMIN.GT.59) J=2
      IF (IDEG.LT.0.OR.IDEG.GT.359) J=1

*  Compute angle
      RAD=AS2R*(60D0*(60D0*DBLE(IDEG)+DBLE(IAMIN))+ASEC)

      END


program area_mandelbrot

  use omp_lib

  implicit none

  integer, parameter :: sp = kind(1.0)
  integer, parameter :: dp = kind(1.0d0)
  integer :: i, j, iter, numoutside, numthreads
  integer, parameter :: npoints = 2000, maxiter = 2000
  real (kind=dp) :: area, error
  complex (kind=dp) :: c , z
  real :: starttime, endtime
!
! Calculate area of mandelbrot set
!
!    Outer loops runs over npoints, initialize z=c
!
!    Inner loop has the iteration z=z*z+c, and threshold test
!

  numoutside = 0

  starttime = omp_get_wtime()

  !$omp parallel do reduction(+:numoutside) private(i,j,iter,c,z) collapse(2)
  do i = 0,npoints-1
     do j= 0,npoints-1
        c = cmplx(-2.0+(2.5*i)/npoints + 1.0d-07,(1.125*j)/npoints + 1.0d-07)
        z = c
        iter = 0
        do while (iter < maxiter)
           z = z*z + c
           iter = iter + 1
           if (real(z)*real(z)+aimag(z)*aimag(z) > 4) then
              numoutside = numoutside + 1
              exit
           endif
        end do
     end do
  end do

  endtime = omp_get_wtime()

  !$omp parallel
   numthreads = omp_get_num_threads()
  !$omp end parallel

!
! Output results
!
  area = 2.0*2.5*1.125 * real(npoints*npoints-numoutside)/real(npoints*npoints)
  error = area/real(npoints)
  print *, "Area of Mandelbrot set = ",area," +/- ",error
  print *, "Time taken for calculation: ",endtime-starttime
!
  stop
end program area_mandelbrot


        SUBROUTINE MAXWELL(VX,VY,VZ,TEMP,INTX,INTY)
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!!!!!  Subroutine to select two cartesian components of     !!!!!
!!!!!  velocity from a Maxwell-Boltzmann distribution at    !!!!!
!!!!!  temperature, TEMP_REQ.                               !!!!!
!!!!!  uses the Box-Muller method.                          !!!!!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
        IMPLICIT NONE
        INTEGER, PARAMETER :: double = SELECTED_REAL_KIND(15,99)
        REAL(kind = double), PARAMETER :: PI2 = 2.0d0*3.141592654D0
        REAL(kind = double) :: VAR,FACT,FACT2,VX,VY,VZ,TEMP
        REAL(kind = double) :: R1,R2,R3,R4,RANDNUM
        INTEGER :: INTX,INTY

        R1 = RANDNUM(INTX,INTY)
        R2 = RANDNUM(INTX,INTY)
        R3 = RANDNUM(INTX,INTY)
        R4 = RANDNUM(INTX,INTY)

        VAR = TEMP

        FACT = SQRT(-2.0d0*LOG(R1)*VAR)
        VX = FACT*COS(PI2*R2)
        VY = FACT*SIN(PI2*R2)

        FACT2 = SQRT(-2.0d0*LOG(R3)*VAR)
        VZ = FACT2*COS(PI2*R4)

        END SUBROUTINE

      FUNCTION RANDNUM(INTX,INTY)

      IMPLICIT NONE
      INTEGER, PARAMETER :: double = SELECTED_REAL_KIND(15,99)
      INTEGER :: I,J,INTX,INTY
      REAL(kind = double) :: RANDNUM
      I = 1029*INTX + 1731
      J = I + 1029*INTY + 507*INTX - 1731
      INTX = MOD(I,2048)
      J = J + (I - INTX)/2048
      INTY = MOD(J,2048)
      RANDNUM = (INTX + 2048*INTY)/4194304.0D00

      END FUNCTION


! ==============================================================================
! Function: RANDOM (ISEED)
!
! Purpose: Generates a random number on the interval [0,1] given an
!          integer seed.
!
! Method: Efficent Fortran Programming, John Wiley and Sons, New York (1990)
!         pp. 17-18 Library of Congress code QA76.73.F25 K78
!
! Arguments:
!
!           ISEED - Four byte integer seed.
!
! History:
!
! Version    Date         Comment
! --------   ----------   -----------------------
!            01/01/2015   Original Code
!
! Dependancies:
!
! Modules -
! Functions -
! Subroutines -
!
! Author(s): Eric Dykeman
!            Copyright (c) 2015 (Please Refer to LICENCE)
!
! ==============================================================================

      DOUBLE PRECISION FUNCTION RANDOM (ISEED)

        IMPLICIT NONE

        !=== ARGUMENTS ===!

        INTEGER, INTENT(INOUT) :: iseed

        !=== VARIABLES ===!

        INTEGER :: hi,lo,test

        INTEGER, PARAMETER :: a = 16807
        INTEGER, PARAMETER :: m = 2147483647
        INTEGER, PARAMETER :: q = 127773
        INTEGER, PARAMETER :: r = 2836

        hi = INT(iseed/q)
        lo = MODULO(iseed,q)

        test = a * lo - r * hi

        IF ( test > 0 ) THEN

          iseed = test

        ELSE

          iseed = test + m

        ENDIF

        RANDOM = DBLE(iseed) / DBLE(m)

        RETURN

      END FUNCTION RANDOM


	FUNCTION GAUSS(X,X0,SIGMA)

c	Returns value of gaussian function normalized to area = 1

c	Normalization constant
	data a/0./
	if (a.eq.0) then
		pi=4.*atan(1.)
		a=1./sqrt(2.*pi)
	endif
        c=a/sigma
        gauss=c*exp(-(x-x0)**2/sigma**2/2)
!	write (998,*) x,x0,a,sigma,c
        return
        end


SUBROUTINE phi_nonlinear_3D(k,angle,x,y,z,omega,time,n_four_modes,zz,phix,phiy,phiz,phi,phit)
!
USE PRECISION
USE Constants
IMPLICIT NONE
INTEGER :: n_four_modes
REAL(KIND=long), INTENT(IN)  :: k,angle,x,y,z,omega,time,zz(2*n_four_modes+10)
REAL(KIND=long), INTENT(OUT) :: phix,phiy,phiz
REAL(KIND=long), INTENT(OUT), OPTIONAL :: phi,phit
   ! Local variables
REAL(KIND=long) :: k_omegat, km, sinkmk_omegat, sinhzh, temp1, e, b, e_inv, dir
REAL(KIND=long) :: kx, ky
INTEGER    :: m
!
dir = omega/ABS(omega) !direction of the wavefield
!
kx=cos(angle)
ky=sin(angle)
!
!kx = k*x-omega*time
k_omegat=kx*k*x+ky*k*y-omega*time
km=DBLE(n_four_modes)
!
phix = zero
phiy = zero
phiz = zero
IF(present(phit)) phit = zero
IF(present(phi))  phi  = zero
!
! FIXME: optimization of loops (remove tests inside?)
DO m=1,n_four_modes
   km=DBLE(m)
   sinkmk_omegat = SIN(km*k_omegat)
   !sinkmkx = SIN(km*kx)
   e=EXP(km*(zz(1)+z))
   temp1=zz(n_four_modes+m+10)*half/COSH(km*zz(1))
   e_inv=one/e
   b=(e+e_inv)*temp1
   sinhzh=km*(e-e_inv)*temp1
   phiz=phiz+sinhzh*sinkmk_omegat
   !
   temp1=b*km*COS(km*k_omegat)
   phix=phix+temp1*kx
   phiy=phiy+temp1*ky
   IF(present(phit)) phit=phit-omega*temp1
   IF(present(phi))  phi=phi+b*sinkmk_omegat
ENDDO
!
phiz= dir*phiz
phix= dir*(phix + kx*zz(5))
phiy= dir*(phiy + ky*zz(5))

IF(present(phi))  phi = dir*(phi + k_omegat*zz(5)) !it's k*x-omega*time      !check the time dependence...
IF(present(phit)) phit= dir*(phit)+(-zz(9)+zz(4)**2/2.d0)-dir*omega*zz(5) !check the time dependence...

END SUBROUTINE phi_nonlinear_3D