module MathClass
    use, intrinsic :: iso_fortran_env
	!use OouraFFT
	use StringClass
	implicit none

	integer(int32) :: i_i = 0
	integer(int32) :: j_j = 0
	integer(int32) :: k_k = 0

	logical :: true = .True.
	logical :: False = .False.
	!integer(int32) :: i_i = 0

	type :: Math_
		real(real64) :: PI = 3.141592653589793d0
		real(real64) :: E  = 2.718281828459045d0
		complex(kind(0d0))	 :: i = (0.0d0, 1.0d0)
		complex(kind(0d0))	 :: j = (0.0d0, 1.0d0)
	end type

	integer(int32),parameter :: complex64 = real64
	!real(real64) :: pi=3.141592653589793238d0
	!

	interface heapsort
		module procedure :: heapsortInt32, heapsortReal64
	end interface

	interface str
		module procedure fstring_Int, fstring_Real,fstring_Real32, &
			fstring_complex, fstring_Int_len, fstring_Real_len, fstring_logical, fstring_String
	end interface str

    interface fstring
        module procedure fstring_Int, fstring_Real, fstring_Int_len, fstring_Real_len, fstring_logical
	end interface fstring

	interface input
		module procedure input_Int,input_Real,input_Real32,input_Complex,input_IntVec,&
			input_RealVec,input_IntArray,input_RealArray,input_String,input_logical
	end interface input

	interface zeroif
		module procedure zeroif_Int,zeroif_Real
	end interface zeroif

	interface removeWord
		module procedure removeWord_String
	end interface

	interface radian
		module procedure radianreal32,radianreal64, radianint
	end interface

	interface array
		module procedure arrayDim1Real64,arrayDim2Real64,arrayDim3Real64
	end interface

contains
! ###############################################
recursive function FFT(x) result(hatx)
	complex(kind(0d0))	,intent(in) :: x(:)
	complex(kind(0d0))	,allocatable :: hatx(:),W(:),L(:),R(:)
	real(real64),allocatable :: a(:), wo(:)
	integer(int32),allocatable :: ip(:)
	integer(int32) :: N, i, itr,isgn
	integer(int32),allocatable :: k(:)
	type(Math_) :: Math

	!!! call Ooura-FFT
	!n = size(x)/2
	!allocate(a(0:2*n-1) )
	!allocate(wo(0:2*n-1) )
	!a(0:2*n-1) = x(1:2*n)
	!isgn = n
	!call cdft(2*n,isgn,a(0:2*n-1),ip,wo(0:n/2-1) )
	!hatx = a
	!
	!return
	!!!
	N = size(x)
	allocate(hatx(N))

	hatx(:) = 0.0d0
	allocate(k(N/2) )
	allocate(W(N/2) )
	allocate(L(N/2) )
	allocate(R(N/2) )

	do i=1,size(k)
		k(i) = i-1
		!print *, exp(-1*Math%i * 2.0d0* Math%PI * k(i)/dble(N))
		W(i) = exp(-1*Math%i * 2.0d0* Math%PI * k(i) /dble(N) )
	enddo

	if(N==2)then
		! butterfly operation
		hatx(1) = x(1) + x(2)
		hatx(2) = x(1) - x(2)
		return
	endif

	if(N>=4)then
		itr=0
		do i=1, N, 2
			itr=itr+1

			if(itr > size(L) )then
				exit
			endif
			L(itr) = x(i)
		enddo

		itr=0
		do i=2, N, 2
			itr=itr+1
			if(itr > size(R) )then
				exit
			endif
			R(itr) = x(i)
		enddo

		L = FFT(L)
		R = FFT(R)

		do i=1,N/2
			hatx(i) = L(i) + W(i)*R(i)
		enddo
		do i=N/2+1, N
			if(i-N/2 > size(L) )then
				exit
			endif
			hatx(i) = L(i-N/2) - W(i-N/2)*R(i-N/2)
		enddo
		return
	endif
end function
! ###############################################
function IFFT(x) result(hatx)
	complex(kind(0d0))	,intent(in) :: x(:)
	complex(kind(0d0))	,allocatable :: hatx(:)
	type(Math_) :: Math

	hatx = IFFT_core(x)

	hatx = 1.0d0/dble(size(x))*hatx

end function

! ###############################################
recursive function IFFT_core(x) result(hatx)
	complex(kind(0d0))	,intent(in) :: x(:)
	complex(kind(0d0))	,allocatable :: hatx(:),W(:),L(:),R(:)
	real(real64),allocatable :: a(:), wo(:)
	integer(int32),allocatable :: ip(:)
	integer(int32) :: N, i, itr,isgn
	integer(int32),allocatable :: k(:)
	type(Math_) :: Math

	!!! call Ooura-FFT
	!n = size(x)/2
	!allocate(a(0:2*n-1) )
	!allocate(wo(0:2*n-1) )
	!a(0:2*n-1) = x(1:2*n)
	!isgn = n
	!call cdft(2*n,isgn,a(0:2*n-1),ip,wo(0:n/2-1) )
	!hatx = a
	!
	!return
	!!!
	N = size(x)
	allocate(hatx(N))

	hatx(:) = 0.0d0
	allocate(k(N/2) )
	allocate(W(N/2) )
	allocate(L(N/2) )
	allocate(R(N/2) )

	do i=1,size(k)
		k(i) = i-1
		!print *, exp(-1*Math%i * 2.0d0* Math%PI * k(i)/dble(N))
		W(i) = exp(Math%i * 2.0d0* Math%PI * k(i) /dble(N) )
	enddo

	if(N==2)then
		! butterfly operation
		hatx(1) = x(1) + x(2)
		hatx(2) = x(1) - x(2)
		return
	endif

	if(N>=4)then
		itr=0
		do i=1, N, 2
			itr=itr+1

			if(itr > size(L) )then
				exit
			endif
			L(itr) = x(i)
		enddo

		itr=0
		do i=2, N, 2
			itr=itr+1
			if(itr > size(R) )then
				exit
			endif
			R(itr) = x(i)
		enddo

		L = IFFT_core(L)
		R = IFFT_core(R)

		do i=1,N/2
			hatx(i) = L(i) + W(i)*R(i)
		enddo
		do i=N/2+1, N
			if(i-N/2 > size(L) )then
				exit
			endif
			hatx(i) = L(i-N/2) - W(i-N/2)*R(i-N/2)
		enddo
		return
	endif

end function
! ###############################################

! ###############################################
function arrayDim1Real64(size1) result(ret)
	integer(int32),intent(in) :: size1
	real(real64),allocatable :: ret(:)

	allocate(ret(size1) )

	ret(:) = 0.0d0

end function
! ###############################################

! ###############################################
function arrayDim2Real64(size1,size2) result(ret)
	integer(int32),intent(in) :: size1,size2
	real(real64),allocatable :: ret(:,:)

	allocate(ret(size1,size2) )

	ret(:,:) = 0.0d0

end function
! ###############################################

! ###############################################
function arrayDim3Real64(size1,size2,size3) result(ret)
	integer(int32),intent(in) :: size1,size2,size3
	real(real64),allocatable :: ret(:,:,:)

	allocate(ret(size1,size2,size3) )

	ret(:,:,:) = 0.0d0

end function
! ###############################################

! ###############################################
function radianreal32(deg) result(ret)
	real(real32),intent(in) :: deg
	real(real64) :: ret
	ret = deg/180.0d0*3.1415926535d0
end function
! ###############################################

! ###############################################
function radianreal64(deg) result(ret)
	real(real64),intent(in) :: deg
	real(real64) :: ret
	ret = deg/180.0d0*3.1415926535d0
end function
! ###############################################

! ###############################################
function radianint(deg) result(ret)
	integer(int32),intent(in) :: deg
	real(real64) :: ret
	ret = dble(deg)/180.0d0*3.1415926535d0
end function
! ###############################################

! ###############################################
function degrees(rad) result(ret)
	real(real64),intent(in) :: rad
	real(real64) :: ret
	ret = rad/3.1415926535d0*180.0d0
end function
! ###############################################

!########################################
function norm(vec) result(a)
	real(real64),intent(in)::vec(:)
	integer(int32) :: n
	real(real64) :: a

	n=size(vec)
	a=dsqrt(dot_product(vec,vec) )

end function
!########################################

!########################################
function SearchNearestValueID(Vector,x)  result(id)
	real(real64),intent(in) :: Vector(:)
	real(real64),intent(in) :: x
	integer(int32) :: id,i

	id = 1
	do i=1,size(vector)
		if( abs(vector(id)-x) > abs(vector(i)-x) )then
			id = i
			cycle
		endif
	enddo

end function
!########################################

!########################################
function SearchNearestValueIDs(Vector,x,num)  result(id)
	real(real64),intent(in) :: Vector(:)
	real(real64),intent(in) :: x
	integer(int32),intent(in)  :: num
	integer(int32) :: id(num),i,j

	id(:) = 1
	do j=1,num
		do i=1,size(vector)
			if(j>=2 )then
				if(abs(minval(id(1:j-1) - i ))==0) cycle
			endif
			if( abs(vector(id(j) )-x) > abs(vector(i)-x) )then
				id(j) = i
				cycle
			endif
		enddo
	enddo
end function
!########################################

!########################################
function SearchNearestValue(Vector,x)  result(val)
	real(real64),intent(in) :: Vector(:)
	real(real64),intent(in) :: x
	integer(int32) :: id, i
	real(real64) :: val

	id = 1
	do i=1,size(vector)
		if( abs(vector(id)-x) > abs(vector(i)-x) )then
			id = i
			cycle
		endif
	enddo

	val = vector(id)
end function
!########################################

!########################################
function SearchNearestCoord(Array,x)  result(id)
	real(real64),intent(in) :: Array(:,:)
	real(real64),intent(in) :: x(:)
	integer(int32),allocatable::xr(:)

	integer(int32) :: i,id,n,m,norm,tr_norm

	n=size(Array,1)
	m=size(Array,2)
	if(m/=size(x) )then
		stop "ERROR :: SearchNearestCoord >> size(Array,2) should be =size(x)"
	endif

	allocate(xr(m) )
	do i=1,n
		xr(:)=Array(i,:)
		tr_norm=dot_product(xr-x,xr-x)
		if(i==1)then
			norm=tr_norm
			id  =i
		else
			if(norm > tr_norm)then
				norm=tr_norm
				id  =i
			else
				cycle
			endif
		endif
	enddo

end function
!########################################

!##################################################
function SearchIDIntVec(Vec,val) result(id_)
	integer(int32),intent(in) :: Vec(:)
	integer(int32),intent(in) :: val

	integer(int32) :: i,id_

	do i=1,size(Vec)
		if(Vec(i)==val )then
			id_=i
			return
		endif
	enddo

end function
!##################################################

!##################################################
subroutine heapsortReal64(n,array,val)
  	integer(int32),intent(in) :: n
  	real(real64),intent(inout) :: array(1:n)! rearrange order by this array
	real(real64),optional,intent(inout) :: val(1:n) ! linked data
	real(real64) :: t_real
  	integer(int32) ::i,k,j,l
  	real(real64) :: t

  	if(n.le.0)then
  		write(6,*)"Error, at heapsort"; stop
  	endif
  	if(n.eq.1)return

	l=n/2+1
	k=n
	do while(k.ne.1)
	    if(l.gt.1)then
	        l=l-1
	        t=array(L)
			if(present(val) )then
				t_real=val(L)
			endif
	    else
	        t=array(k)
			if(present(val) )then
				t_real=val(k)
			endif

	        array(k)=array(1)
			if(present(val) )then
				val(k) = val(1)
			endif

	        k=k-1
	        if(k.eq.1) then
	           	array(1)=t
				   if(present(val) )then
						val(1) = t_real
				   endif
	        	exit
	        endif
	    endif
	    i=l
	    j=l+l
	    do while(j.le.k)
	        if(j.lt.k)then
	           	if(array(j).lt.array(j+1))j=j+1

	        endif
	        if (t.lt.array(j))then
	        	array(i)=array(j)
				if(present(val) )then
				val(i)=val(j)
				endif
	        	i=j
	        	j=j+j
	        else
	        	j=k+1
	        endif
	    enddo
	 	array(i)=t
		 if(present(val) )then
		 val(i)=t_real
		 endif
  	enddo

end subroutine heapsortReal64

!##################################################
subroutine heapsortInt32(n,array,val)
	integer(int32),intent(in) :: n
	integer(int32),intent(inout) :: array(1:n)! rearrange order by this array
  real(real64),optional,intent(inout) :: val(1:n) ! linked data
  real(real64) :: t_real
	integer(int32) ::i,k,j,l
	integer(int32) :: t

	if(n.le.0)then
		write(6,*)"Error, at heapsort"; stop
	endif
	if(n.eq.1)return

  l=n/2+1
  k=n
  do while(k.ne.1)
	  if(l.gt.1)then
		  l=l-1
		  t=array(L)
		  if(present(val) )then
			  t_real=val(L)
		  endif
	  else
		  t=array(k)
		  if(present(val) )then
			  t_real=val(k)
		  endif

		  array(k)=array(1)
		  if(present(val) )then
			  val(k) = val(1)
		  endif

		  k=k-1
		  if(k.eq.1) then
				 array(1)=t
				 if(present(val) )then
					  val(1) = t_real
				 endif
			  exit
		  endif
	  endif
	  i=l
	  j=l+l
	  do while(j.le.k)
		  if(j.lt.k)then
				 if(array(j).lt.array(j+1))j=j+1

		  endif
		  if (t.lt.array(j))then
			  array(i)=array(j)
			  if(present(val) )then
			  val(i)=val(j)
			  endif
			  i=j
			  j=j+j
		  else
			  j=k+1
		  endif
	  enddo
	   array(i)=t
	   if(present(val) )then
	   val(i)=t_real
	   endif
	enddo

end subroutine heapsortInt32

!==========================================================
!calculate cross product
!---------------------------
function cross_product(a,b) result (c)
	real(real64), intent(in) :: a(:),b(:)
	real(real64), allocatable :: c(:)

    if(size(a) /= 3 .or. size(b)/= 3 ) then
        stop  "wrong number on size a, b"
    endif

    allocate(c(size(a,1)))
  	if(size(c,1)==3) then
     	c(1) = a(2)*b(3) - a(3)*b(2)
     	c(2) = a(3)*b(1) - a(1)*b(3)
     	c(3) = a(1)*b(2) - a(2)*b(1)
  	else
      	stop "wrong number at cross_product"
  	endif

end function cross_product
!=========================================================
!calculate diadic
!----------------------
function diadic(a,b) result(c)
  real(real64), intent(in) :: a(:), b(:)
	real(real64), allocatable :: c(:,:)

	integer(int32) n,i,j

	allocate(c(size(a),size(b) ) )
	do i=1,size(a)
		do j=1,size(b)
			c(i,j)=a(i)*b(j)
		enddo
	enddo

end function diadic
!==========================================================
!=========================================================
!calculate diadic
!----------------------
function tensor_product(a,b) result(c)
	real(real64), intent(in) :: a(:), b(:)
	  real(real64), allocatable :: c(:,:)

	  integer(int32) n,i,j

	  allocate(c(size(a),size(b) ) )
	  do i=1,size(a)
		  do j=1,size(b)
			  c(i,j)=a(i)*b(j)
		  enddo
	  enddo

  end function tensor_product
  !==========================================================
!calculate gz
!--------------
subroutine calcgz(x2,x11,x12,nod_coord,gzi)
	real(real64), intent(in) :: nod_coord(:,:)
	real(real64),intent(out) :: gzi
	integer(int32),intent(in):: x2,x11,x12
		real(real64) l
		real(real64),allocatable::avec(:)

		allocate(avec(2))
		l = dot_product( nod_coord(x12,1:2) - nod_coord(x11,1:2), &
			nod_coord(x12,1:2) - nod_coord(x11,1:2) )
		l=l**(1.0d0/2.0d0)

		avec(1:2) = ( nod_coord(x12,1:2) - nod_coord(x11,1:2)   )/l

		if(l==0.0d0)then
			print *, "calcgz l=0"
			gzi=0.0d0
		else
			gzi=1.0d0/l*dot_product( nod_coord(x2,1:2) -nod_coord(x11,1:2),avec(1:2) )
		endif

	 deallocate(avec)

end subroutine calcgz
!==========================================================
function arg(comp) result(theta)
	complex,intent(in) :: comp
	real(real64) :: theta,re,im
	real(real64) ::pi=3.141592653589793d0

	re = dble(real(comp) )
	im = dble(aimag(comp) )

	if(re>0.0d0 )then
		theta = atan(im/re)
	elseif(re<0.0d0 .and. im>=0.0d0)then
		theta = atan(im/re+pi)
	elseif(re<0.0d0 .and. im<0.0d0)then
		theta = atan(im/re-pi)
	elseif(re==0.0d0 .and. im>0.0d0)then
		theta = pi/2.0d0
	elseif(re==0.0d0 .and. im<0.0d0)then
		theta = -pi/2.0d0
	else
		print *, "arg :: indeterminate"
		stop
	endif

end function
!==========================================================

function cubic_equation(a,b,c,d) result(x)
	real(real64),intent(in) :: a,b,c,d
	real(real64) :: x(3),theta
	real(real64) ::Deq,A_,B_,C_,p,q
	real(real64) ::pi=3.141592653589793d0
	complex  :: comp
	!https://qiita.com/yotapoon/items/42b1749b69c264d6f486

	A_ = b/a
	B_ = c/a
	C_ = d/a
	p = B_ - A_*A_/3.0d0
	q = 2.0d0*A_*A_*A_/27.0d0 - A_*B_/3.0d0 + C_
	Deq = q*q/4.0d0 + p*p*p/27.0d0

	if(Deq > 0.0d0)then
		print *, "D > 0 :: not implemented now."
	elseif(Deq==0)then
		print *, "D == 0 "
		x(1) = -2.0d0*(p/2.0d0)**(3)
		x(2) = (p/2.0d0)**(3)
		x(3) = (p/2.0d0)**(3)
		return
	else
		print *, "D < 0 "
		comp = cmplx(-q/2.0d0, sqrt(-Deq) )
		theta=arg(comp)
		x(1) = 2.0d0*sqrt(-p/3.0d0)*cos(theta)
		x(2) = 2.0d0*sqrt(-p/3.0d0)*cos( (theta+2.0d0*pi)/3.0d0 )
		x(3) = 2.0d0*sqrt(-p/3.0d0)*cos( (theta+4.0d0*pi)/3.0d0 )
	endif

end function

!==========================================================
subroutine eigen_2d(Amat,eigenvector)
	real(real64),intent(in)::Amat(:,:)
	real(real64),allocatable,intent(inout)::eigenvector(:,:)
	real(real64)::b,c,phy,eigenvalue(2)
	integer(int32) i,j

	eigenvalue=array(size(Amat,1) )
	eigenvector=array(size(Amat,1),size(Amat,1))

	b=-1.0d0*(Amat(1,1)+Amat(2,2))
	c=Amat(1,1)*Amat(2,2)-Amat(1,2)*Amat(1,2)

	if(Amat(1,2)/=Amat(2,1) )then
		 stop "input matrice is not symmetric"
	endif

	do i=1,2
		eigenvalue(i)=(-1.0d0*b+((-1.0d0)**dble(i))*(b*b-4.0d0*c)**(1.0d0/2.0d0))*(0.50d0)
	enddo

	do i=1,2
		if(Amat(1,2)==0 )then
			cycle
		elseif(Amat(1,2)/=0 )then
			phy=atan( (eigenvalue(i)-Amat(1,1))/Amat(1,2) )

			do j=1,2
				eigenvector(i,1:2)=(/cos(phy),sin(phy)/)
			enddo
		endif
	enddo

	do i=1,2
		eigenvector(i,:)=eigenvalue(i)*eigenvector(i,:)
	enddo
end subroutine eigen_2d
!==========================================================
function signmm(a) result(b)
	real(real64),intent(in)::a
	real(real64) b

	if(a>0)then
		b=1.0d0
	elseif(a<0)then
		b=-1.0d0
	elseif(a==0)then
		b=0.0d0
	else
		stop "ERROR: Invalid real(real64) in function_signm"
	endif

end function signmm
!==========================================================

! ################################################################
! From 数値計算のためのFortran90/95プログラミング入門 単行本（ソフトカバー） –
! This function is not presented with GPL or any licenses.
! this function will be replaced by LAPACK.

recursive function det_mat(a,n) result(det)
  	integer(int32), intent(in) :: n
  	real(real64), intent(in) :: a(n, n)
  	real(real64) det, b(n-1, n-1)
  	integer(int32) i
	if (n > 1) then
		det = 0.0d0
		do i = 1, n
		  	b(1:i-1, 1:n-1) = a(1:i-1, 2:n)
		  	b(i:n-1, 1:n-1) = a(i+1:n, 2:n)
		  	det = det + (-1.0d0) ** (i + 1) &
			* a(i, 1) * det_mat(b, n-1)

		enddo
	else
		det = a(1,1)
	endif
end function det_mat
!=====================================================================================

!==========================================================
recursive function det(a,n) result(det_v)
  	integer(int32), intent(in) :: n
  	real(real64), intent(in) :: a(n, n)
  	real(real64) det_v, b(n-1, n-1)
  	integer(int32) i
	if (n > 1) then
		det_v = 0.0d0
		do i = 1, n
		  	b(1:i-1, 1:n-1) = a(1:i-1, 2:n)
		  	b(i:n-1, 1:n-1) = a(i+1:n, 2:n)
		  	det_v = det_v + (-1.0d0) ** (i + 1) &
			* a(i, 1) * det(b, n-1)

		enddo
	else
		det_v = a(1,1)
	endif
end function det
!=====================================================================================
subroutine trans_rank_2(A,A_T)
	real(real64),intent(in)::A(:,:)
	real(real64),allocatable,intent(out)::A_T(:,:)
	integer(int32) n,m,i,j

	n=size(A,1)
	m=size(A,2)
	if(.not. allocated(A_T) )allocate(A_T(m,n))

	do i=1,n
	  	do j=1, m
		  	A_T(j,i)=A(i,j)
	  	enddo
	enddo

 end subroutine trans_rank_2
!==================================================================================
function trans1(A) result(A_T)
	real(real64),intent(in)::A(:)
	real(real64),allocatable::A_T(:,:)
	integer(int32) n,m,i,j

	n=size(A)
	if(.not. allocated(A_T) )allocate(A_T(1,n))

	do i=1,n
		A_T(1,i)=A(i)
	enddo

 end function trans1
!==================================================================================
function trans2(A) result(A_T)
	real(real64),intent(in)::A(:,:)
	real(real64),allocatable::A_T(:,:)
	integer(int32) n,m,i,j

	n=size(A,1)
	m=size(A,2)
	if(.not. allocated(A_T) )allocate(A_T(m,n))

	do i=1,n
	  	do j=1, m
		  	A_T(j,i)=A(i,j)
	  	enddo
	enddo

 end function trans2
!==================================================================================
subroutine inverse_rank_2(A,A_inv)
	real(real64),intent(in)::A(:,:)
	real(real64),allocatable::A_inv(:,:)
	real(real64) detA,detA_1
	integer(int32) m,n

	m=size(A,1)
	n=size(A,2)
	if(.not. allocated(A_inv) )allocate(A_inv(m,n))
	detA=det_mat(A,n)
	if(detA==0.0d0) stop "ERROR: inverse, detA=0"
	detA_1=1.0d0/detA
	if(n==2)then
	  	A_inv(1,1)=detA_1*A(2,2)
	  	A_inv(1,2)=-detA_1*A(1,2)
	  	A_inv(2,1)=-detA_1*A(2,1)
	  	A_inv(2,2)=detA_1*A(1,1)
	elseif(n==3)then
	  	A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
	  	A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3))
	  	A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2))
	  	A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3))
	  	A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1))
	  	A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3))
	  	A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
	  	A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2))
	  	A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1))
	else
	  	print *, "ERROR: Aij with i=j=",n,"/=2or3"
	endif

 end subroutine inverse_rank_2
!==================================================================================
!==================================================================================
function inverse(A) result(A_inv)
	real(real64),intent(in)::A(:,:)
	real(real64),allocatable::A_inv(:,:)
	real(real64) detA,detA_1
	integer(int32) m,n

	m=size(A,1)
	n=size(A,2)
	if(.not. allocated(A_inv) )allocate(A_inv(m,n))
	detA=det_mat(A,n)
	if(detA==0.0d0) stop "ERROR: inverse, detA=0"
	detA_1=1.0d0/detA
	if(n==2)then
	  	A_inv(1,1)=detA_1*A(2,2)
	  	A_inv(1,2)=-detA_1*A(1,2)
	  	A_inv(2,1)=-detA_1*A(2,1)
	  	A_inv(2,2)=detA_1*A(1,1)
	elseif(n==3)then
	  	A_inv(1,1)=detA_1*(A(2,2)*A(3,3)-A(2,3)*A(3,2))
	  	A_inv(1,2)=detA_1*(A(1,3)*A(3,2)-A(1,2)*A(3,3))
	  	A_inv(1,3)=detA_1*(A(1,2)*A(2,3)-A(1,3)*A(2,2))
	  	A_inv(2,1)=detA_1*(A(2,3)*A(3,1)-A(2,1)*A(3,3))
	  	A_inv(2,2)=detA_1*(A(1,1)*A(3,3)-A(1,3)*A(3,1))
	  	A_inv(2,3)=detA_1*(A(1,3)*A(2,1)-A(1,1)*A(2,3))
	  	A_inv(3,1)=detA_1*(A(2,1)*A(3,2)-A(2,2)*A(3,1))
	  	A_inv(3,2)=detA_1*(A(1,2)*A(3,1)-A(1,1)*A(3,2))
	  	A_inv(3,3)=detA_1*(A(1,1)*A(2,2)-A(1,2)*A(2,1))
	else
	  	print *, "ERROR: Aij with i=j=",n,"/=2or3"
	endif

 end function inverse
!==================================================================================
subroutine tensor_exponential(A,expA,TOL,itr_tol)
  	real(real64),intent(in)::A(:,:),TOL
  	real(real64),allocatable,intent(inout)::expA(:,:)
  	integer(int32), intent(in)::itr_tol
  	real(real64),allocatable::increA(:,:)
  	real(real64) increment,NN
  	integer(int32) i,j,n

  	if(.not. allocated(expA) )allocate(expA(size(A,1),size(A,2) ))
  	allocate(increA(size(A,1),size(A,2) ))
  	if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix"

  	expA(:,:)=0.0d0
  	do n=1,size(expA,1)
	  	expA(n,n)=1.0d0
  	enddo
  	NN=1.0d0
  	increA(:,:)=expA(:,:)
  	do n=1,itr_tol
	  	if(n>1)then
		  	NN       = NN*(NN+1.0d0)
	  	endif
	  	increA(:,:)=matmul(increA,A)
	  	expA(:,:)= expA(:,:)+1.0d0/NN*increA(:,:)

	  	increment=0.0d0
	  	do i=1,size(A,1)
		  	do j=1,size(A,2)
			  	increment=increment+1.0d0/NN*increA(i,j)*increA(i,j)
		  	enddo
	  	enddo

	  	if(increment<=TOL)then
		  	exit
	  	else
		  	if(n>=itr_tol)then
			   	stop "tensor exponential is not converged"
		  	endif
			cycle
	  	endif
  	enddo

  	deallocate(increA)

end subroutine tensor_exponential
!==================================================================================
function identity_matrix(n) result(mat)
	integer(int32),intent(in) :: n ! rank
	real(real64) :: mat(n,n)
	integer(int32) :: i
	mat(:,:)=0.0d0
	do i=1,n
		mat(i,i)=1.0d0
	enddo

end function
!==================================================================================

!==================================================================================
function zero_matrix(n) result(mat)
	integer(int32),intent(in) :: n ! rank
	real(real64) :: mat(n,n)
	mat(:,:)=0.0d0

end function
!==================================================================================
subroutine tensor_expo_der(A,expA_A,TOL,itr_tol)
  	real(real64),intent(in)::A(:,:),TOL
  	real(real64),allocatable,intent(inout)::expA_A(:,:,:,:)
  	integer(int32), intent(in)::itr_tol
  	real(real64),allocatable::increA_1(:,:),increA_2(:,:),increA_3(:,:,:,:),I_ij(:,:),A_inv(:,:)
  	real(real64) increment,NN
  	integer(int32) i,j,k,l,n,m,o

  	if(.not. allocated(expA_A) )allocate(expA_A(size(A,1),size(A,1),size(A,1),size(A,1) ))
  	allocate(I_ij(size(A,1),size(A,1) ))
  	allocate(increA_1(size(A,1),size(A,1) ))
  	allocate(increA_2(size(A,1),size(A,1) ))
  	allocate(increA_3(size(A,1),size(A,1),size(A,1),size(A,1) ) )
  	if(size(A,1)/=size(A,2)) stop "ERROR:tensor exp is not a square matrix"

  	call inverse_rank_2(A,A_inv)

  	I_ij(:,:)=0.0d0
  	do n=1,size(expA_A,1)
		I_ij(n,n)=1.0d0
  	enddo
  	NN=1.0d0

  	do i=1,size(A,1)
	  	do j=1,size(A,1)
		  	do k=1, size(A,1)
			  	do l=1, size(A,1)
				  	expA_A(i,j,k,l)=I_ij(i,k)*I_ij(l,j)
			  	enddo
		  	enddo
	  	enddo
  	enddo

  	increA_1(:,:)=I_ij(:,:)
  	increA_2(:,:)=I_ij(:,:)
  	do n=1,itr_tol
		if(n>2)then
			NN = NN*(NN+1.0d0)
		endif
		increA_1(:,:)=A_inv(:,:)
		increA_2(:,:)=matmul(increA_2,A)

	  	increA_3(:,:,:,:)=0.0d0
	  	do m=1,n
			increA_1(:,:)=matmul(increA_1,A    )

		  	increA_2(:,:)=matmul(increA_2,A_inv)

		  	do i=1,size(A,1)
				do j=1,size(A,1)
				  	do k=1, size(A,1)
					  	do l=1, size(A,1)
						  	increA_3(i,j,k,l)=increA_3(i,j,k,l)+increA_1(i,k)*increA_2(l,j)
						  	expA_A(i,j,k,l)=expA_A(i,j,k,l)+1.0d0/NN*increA_3(i,j,k,l)
					  	enddo
					enddo
			  	enddo
		  	enddo
	  	enddo

	  	do i=1,size(A,1)
		  	do j=1,size(A,1)
			  	do k=1, size(A,1)
				  	do l=1, size(A,1)
					  	increment=increment+1.0d0/NN*increA_3(i,j,k,l)&
						  	*increA_3(i,j,k,l)&
						  	*increA_3(i,j,k,l)&
						  	*increA_3(i,j,k,l)
				  	enddo
			  	enddo
		  	enddo
	  	enddo

	  	if(increment<=TOL)then
			exit
	  	else
		  	if(n>=itr_tol)then
			   	stop "tensor exponential is not converged"
		  	endif
		  	cycle
	  	endif
  	enddo

  	deallocate(increA_1,increA_2,increA_3,I_ij,A_inv)

end subroutine tensor_expo_der
!==================================================================================

function GetNormRe(a) result(b)
	real(real64),intent(in)::a(:)
	real(real64) :: b
	b=dot_product(a,a)
end function
!==================================================================================

function GetNormMatRe(a) result(b)
	real(real64),intent(in)::a(:,:)
	real(real64) :: b
	integer(int32) :: i,j
	b=0
	do i=1,size(a,1)
		do j=1,size(a,2)
			b=b+a(i,j)*a(i,j)
		enddo
	enddo
end function
!==================================================================================

function trace(a) result(b)
	real(real64),intent(in)::a(:,:)
	real(real64) :: b
	integer(int32) :: i,j
	b=0
	do i=1,size(a,1)
		b=b+a(i,i)
	enddo
end function

!==================================================================================
function sym(a,n) result(ret)
	real(real64),intent(in) :: a(:,:)
	real(real64) :: ret(n,n)
	integer(int32) :: i,n

	ret = 0.50d0*(a) + 0.50d0*transpose(a)

end function
!==================================================================================

!==================================================================================
function asym(a,n) result(ret)
	real(real64),intent(in) :: a(:,:)
	real(real64) :: ret(n,n)
	integer(int32) :: i,n

	ret = 0.50d0*(a) - 0.50d0*transpose(a)

end function
!==================================================================================

function pi_value(n) result(res)
	integer(int32),intent(in)::n
	real(real64) :: ptr
	real(real64) :: an,bn,tn,pn
	real(real64) :: atr,btr,ttr
	real(real64) :: res

	integer(int32) :: i

	an=1.0d0
	bn=1.0d0/sqrt(2.0d0)
	tn=0.250d0
	pn=1.00d0
	do i=1,n
		atr=0.50d0*(an+bn)
		btr=dsqrt(an*bn)
		ttr=tn-pn*(atr-an)*(atr-an)
		ptr=2.0d0*pn

		an=atr
		bn=btr
		tn=ttr
		pn=ptr

		res=(atr+btr)*(atr+btr)/4.0d0/ttr
	enddo

end function
!==================================================================================

!==================================================================================
function fstring_int(x) result(a)
	integer(int32),intent(in) :: x
	character(len=20):: b
	character(len=:),allocatable	:: a

	write(b,*) x
	a = trim(adjustl(b))

end function
!==================================================================================

!==================================================================================
function fstring_logical(x) result(a)
	logical,intent(in) :: x
	character(len=5)	:: a

	write(a,*) x

end function
!==================================================================================

!==================================================================================
function fstring_String(x) result(a)
	type(String_),intent(in) :: x
	character(len=:),allocatable :: a

	a = trim(x%all)
end function
!==================================================================================

!==================================================================================
function fstring_int_len(x,length) result(a)
	integer(int32),intent(in) :: x
	integer(int32),intent(in) :: length
	character(len=length)	:: a

	if(x/=x  .or. abs(x) >= HUGE(int32) )then
		a=""
		return
	endif

	write(a,*) x
	a = adjustl(a)
end function
!==================================================================================

!==================================================================================
function fstring_real(x) result(a)
	real(real64),intent(in) :: x
	character(len=20):: b
	character(len=:),allocatable	:: a

	if(x/=x .or. abs(x) >= HUGE(real64) )then
		a=""
		return
	endif

	write(b,'(f0.8)') x
	a = trim(adjustl(b))

end function
!==================================================================================

!==================================================================================
function fstring_real32(x) result(a)
	real(real32),intent(in) :: x
	character(len=20):: b
	character(len=:),allocatable	:: a

	if(x/=x .or. abs(x) >= HUGE(real64) )then
		a=""
		return
	endif

	write(b,'(f0.8)') x
	a = trim(adjustl(b))

end function
!==================================================================================

!==================================================================================
function fstring_complex(x) result(a)
	complex(kind(0d0) ),intent(in) :: x
	character(len=30):: b
	character(len=:),allocatable	:: a

	if(x/=x  .or. abs(x) >= HUGE(real64) )then
		a=""
		return
	endif

	write(b,fmt = '(F0.0,SP,F0.0,"i")') x
	a = trim(adjustl(b))
end function
!==================================================================================

!==================================================================================
function fstring_real_len(x,length) result(a)
	real(real64),intent(in) :: x
	integer(int32),intent(in) :: length
	character(len=60)	:: a
	character*40						:: form

	if(x/=x .or. abs(x) >= HUGE(real64))then
		a=""
		return
	endif

	write(a,'(f0.10)') x
	a = adjustl(a)
end function
!==================================================================================

!==================================================================================
function fint(ch)	result(a)
	character(*),intent(in)			:: ch
	integer(int32)				:: a

	read(ch,*,err=1000) a
	return
1000 a = 0

end function
!==================================================================================

!==================================================================================
function fint16(ch)	result(a)
	character(*),intent(in)			:: ch
	integer(int16)				:: a

		read(ch,*,err=1001) a
	return
1001 a = 0

end function
!==================================================================================

!==================================================================================
function fint32(ch)	result(a)
	character(*),intent(in)			:: ch
	integer(int32)				:: a

		read(ch,*,err=1002) a
	return
1002 a = 0

end function
!==================================================================================

!==================================================================================
function fint64(ch)	result(a)
	character(*),intent(in)			:: ch
	integer(int64)				:: a

		read(ch,*,err=1003) a
	return
1003 a = 0

end function
!==================================================================================

!==================================================================================
function freal(ch)	result(a)
	character(*),intent(in)			:: ch
	real(real64)				:: a

		read(ch,*,err=1004) a
	return
1004 a = 0.0d0

end function
!==================================================================================

!==================================================================================
function freal32(ch)	result(a)
	character(*),intent(in)			:: ch
	real(real32)				:: a

		read(ch,*,err=1005) a
	return
1005 a = 0

end function
!==================================================================================

!==================================================================================
function freal64(ch)	result(a)
	character(*),intent(in)			:: ch
	real(real64)				:: a

		read(ch,*,err=1006) a
	return
1006 a = 0

end function
!==================================================================================

!==================================================================================
function freal128(ch)	result(a)
	character(*),intent(in)			:: ch
	real(real64)				:: a

		read(ch,*,err=1007) a
	return
1007 a = 0

end function
!==================================================================================

!==================================================================================
function input_Int(default,option) result(val)
	integer(int32),intent(in) :: default
	integer(int32),optional,intent(in)::option
	integer(int32) :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_Real(default,option) result(val)
	real(real64),intent(in) :: default
	real(real64),optional,intent(in)::option
	real(real64) :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_Real32(default,option) result(val)
	real(real32),intent(in) :: default
	real(real32),optional,intent(in)::option
	real(real32) :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_Complex(default,option) result(val)
	complex(real64),intent(in) :: default
	complex(real64),optional,intent(in)::option
	complex(real64) :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_IntVec(default,option) result(val)
	integer(int32),intent(in) :: default(:)
	integer(int32),optional,intent(in)::option(:)
	integer(int32),allocatable :: val(:)
	integer(int32) :: n,m

	if(present(option) )then
		n=size(option,1)
		allocate(val(n) )
		val(:)=option(:)
	else
		n=size(default,1)
		allocate(val(n) )
		val(:)=default(:)
	endif

end function
!==================================================================================

!==================================================================================
function input_Realvec(default,option) result(val)
	real(real64),intent(in) :: default(:)
	real(real64),optional,intent(in)::option(:)
	real(real64),allocatable :: val(:)
	integer(int32) :: n,m

	if(present(option) )then
		n=size(option,1)
		allocate(val(n) )
		val(:)=option(:)
	else
		n=size(default,1)
		allocate(val(n) )
		val(:)=default(:)
	endif

end function
!==================================================================================

!==================================================================================
function input_IntArray(default,option) result(val)
	integer(int32),intent(in) :: default(:,:)
	integer(int32),optional,intent(in)::option(:,:)
	integer(int32),allocatable :: val(:,:)
	integer(int32) :: n,m

	if(present(option) )then
		n=size(option,1)
		m=size(option,2)
		allocate(val(n,m) )
		val(:,:)=option(:,:)
	else
		n=size(default,1)
		m=size(default,2)
		allocate(val(n,m) )
		val(:,:)=default(:,:)
	endif

end function
!==================================================================================

!==================================================================================
function input_RealArray(default,option) result(val)
	real(real64),intent(in) :: default(:,:)
	real(real64),optional,intent(in)::option(:,:)
	real(real64),allocatable :: val(:,:)
	integer(int32) :: n,m

	if(present(option) )then
		n=size(option,1)
		m=size(option,2)
		allocate(val(n,m) )
		val(:,:)=option(:,:)
	else
		n=size(default,1)
		m=size(default,2)
		allocate(val(n,m) )
		val(:,:)=default(:,:)
	endif

end function
!==================================================================================

!==================================================================================
function input_String(default,option) result(val)
	character(*),intent(in) :: default
	character(*),optional,intent(in)::option
	character(200 ) :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

!==================================================================================
function input_logical(default,option) result(val)
	logical,intent(in) :: default
	logical,optional,intent(in)::option
	logical :: val

	if(present(option) )then
		val=option
	else
		val=default
	endif

end function
!==================================================================================

function zeroif_Int(val,negative,positive) result(retval)
	integer(int32),intent(in)::val
	integer(int32) :: retval
	logical,optional,intent(in) :: negative,positive

	if(val/=val)then
		print *, "ERROR :: MAthClass >> zeroif_Int is invalid"
	endif
	retval=val
	if(present(negative) )then
		if(negative .eqv. .true.)then
			if(val<0)then
				retval=0
			endif
		endif
	endif

	if(present(positive) )then
		if(positive .eqv. .true.)then
			if(val>0)then
				retval=0
			endif
		endif
	endif

end function

function zeroif_Real(val,negative,positive) result(retval)
	real(real64),intent(in)::val
	real(real64) :: retval
	logical,optional,intent(in) :: negative,positive

	if(val/=val)then
		print *, "ERROR :: MAthClass >> zeroif_Int is invalid"
	endif
	retval=val
	if(present(negative) )then
		if(negative .eqv. .true.)then
			if(val<0.0d0)then
				retval=0.0d0
			endif
		endif
	endif

	if(present(positive) )then
		if(positive .eqv. .true.)then
			if(val>0.0d0)then
				retval=0.0d0
			endif
		endif
	endif

end function

! ########################################################
subroutine removeWord_String(str,keyword,itr,Compare)
	character(*),intent(inout)::str
	character(*),intent(in   )::keyword

	integer(int32) :: len_total,len_kw,i,j,n,itr_max
	integer(int32),optional,intent(in)::itr
	logical,optional,intent(in)::Compare
	logical :: bk

	if(present(Compare))then
		if(Compare .eqv. .true.)then
			print *, "Before :: ",str
		endif
	endif

	itr_max=input(default=1,option=itr)
	bk=.false.
	len_total=len(str)
	len_kw	 =len(keyword)

	do i=1,itr_max
		n=index(str,keyword)
		do j=n,n+len_kw
			str(j:j)=" "
		enddo
		if(n==0)then
			exit
		endif
	enddo

	if(present(Compare))then
		if(Compare .eqv. .true.)then
			print *, "After :: ",str
		endif
	endif

end subroutine
! ########################################################

! ########################################################
function Invariant_I1(sigma) result(I1)
	real(real64),intent(in) :: sigma(:,:)
	real(real64) :: I1
	integer(int32) :: i,j

	I1=0.0d0
	do i=1,size(sigma,1)
		I1=I1+sigma(i,i)
	enddo

end function
! ########################################################

! ########################################################
function Invariant_J2(sigma) result(J2)
	real(real64),intent(in) :: sigma(:,:)
	real(real64) :: I1,J2,delta(3,3),M_d(3,3)
	integer(int32) :: i,j

	delta(:,:)=0.0d0
	delta(1,1)=1.0d0
	delta(2,2)=1.0d0
	delta(3,3)=1.0d0

	I1=Invariant_I1(sigma)
	M_d(:,:)=sigma(:,:)-I1/3.0d0*delta(:,:)
	J2=0.0d0
	do i=1,size(sigma,1)
		do j=1,size(sigma,1)
			J2=J2+0.50d0*M_d(i,j)*M_d(i,j)
		enddo
	enddo

end function
! ########################################################

! ########################################################
function Invariant_J3(sigma) result(J3)
	real(real64),intent(in) :: sigma(:,:)
	real(real64) :: I1,J3,delta(3,3),M_d(3,3)
	integer(int32) :: i,j,k

	delta(:,:)=0.0d0
	delta(1,1)=1.0d0
	delta(2,2)=1.0d0
	delta(3,3)=1.0d0

	I1=Invariant_I1(sigma)
	M_d(:,:)=sigma(:,:)-I1/3.0d0*delta(:,:)
	J3=0.0d0

	do i=1,size(sigma,1)
		do j=1,size(sigma,1)
			do k=1,size(sigma,1)
				J3=J3+1.0d0/3.0d0*M_d(i,j)*M_d(j,k)*M_d(k,i)
			enddo
		enddo
	enddo

end function
! ########################################################

! ########################################################
function Invariant_theta(sigma) result(theta)
	real(real64),intent(in) :: sigma(:,:)
	real(real64) :: I1,J2,J3,delta(3,3),M_d(3,3),theta
	integer(int32) :: i,j,k

	delta(:,:)=0.0d0
	delta(1,1)=1.0d0
	delta(2,2)=1.0d0
	delta(3,3)=1.0d0
	J2=Invariant_J2(sigma)
	J3=Invariant_J3(sigma)
	theta=1.0d0/3.0d0*asin(-3.0d0*sqrt(3.0d0)*0.50d0*J3/J2/sqrt(J2)  )

end function
! ########################################################

! ########################################################
function inv_mod(a_in,m_in,ItrMax) result(x)
	integer(int32),intent(in) :: a_in,m_in
	integer(int32),optional,intent(in) :: ItrMax
	integer(int32) :: d, q,t, Kmat_n(2,2),Kmat_npp(2,2),k,itr_tol,r0,r1,r2,i,x,y,m0
	integer(int32) :: a,m

	a=a_in
	m=m_in

	itr_tol=input(default=10000,option=ItrMax)
	! inverse modula by Extended Euclidean algorithm
	! d = e^-1 (mod (lambda))
	! d*e = 1 (mod (lambda))
	! one integer q
	! d*e - q*lambda = 1, e, lambda are known, d, q are unknown.
	! get d, q by extended Euclidean algorithm
	! gcd(e, lambda) = 1
	!Kmat_npp(1,1)=1
	!Kmat_npp(1,2)=0
	!Kmat_npp(2,1)=0
	!Kmat_npp(2,2)=1
	!r0=e
	!r1=lambda
	!do i=1, itr_tol
	!	r2=mod(r0,r1)
	!	if(r2==0)then
	!		print *, "gcd of ",e," and",lambda,"is", r1
	!		exit
	!	endif
	!	k=(r0-r2)/r1
	!	Kmat_n(1,1)=0
	!	Kmat_n(1,2)=1
	!	Kmat_n(2,1)=1
	!	Kmat_n(2,2)=-k
	!	a=matmul(Kmat_npp,Kmat_n)
	!	Kmat_npp=a
	!	print *, r0,"=",k,"*",r1,"+",r2
	!	r0=r1
	!	r1=r2
	!enddo
	!d = Kmat_npp(1,2)
	!print *, "Kmat_npp=",Kmat_npp
	! cited by https://www.geeksforgeeks.org/multiplicative-inverse-under-modulo-m/
	m0=m
	y=0
	x=1
	if(gcd(a,m)/=1 )then
		a = mod(a,m)
		do x=1,m
			if( mod(a*x,m)==1)then
				return
			endif
		enddo
	endif
	if(m==1)then
		return
	endif

	do i=1,itr_tol
		if(a > 1)then
			q=(a -mod(a,m))/m

			t=m

			m= mod(a,m)
			a=t
			t=y

			y=x - q*y
			x=t
		else
			exit
		endif
	enddo
	if(x < 0)then
		x = x+m0
	endif

end function
! ########################################################

! ########################################################
function gcd(a,b,ItrMax) result(c)
	integer(int32),intent(in) :: a,b
	integer(int32),optional,intent(in) :: ItrMax
	integer(int32) :: i,r0,r1,r2,k,itr_tol,c
	c=1
	itr_tol=input(default=10000,option=ItrMax)
	r0=a
	r1=b
	do i=1, itr_tol
		r2=mod(r0,r1)
		if(r2==0)then
			!print *, "gcd of ",a," and",b,"is", r1
			exit
		endif
		k=(r0-r2)/r1
		!print *, r0,"=",k,"*",r1,"+",r2
		r0=r1
		r1=r2
	enddo
	c=r1

end function
! ########################################################

! ########################################################
function lcm(a,b,ItrMax) result(c)
	integer(int32),intent(in) :: a,b
	integer(int32),optional,intent(in) :: ItrMax
	integer(int32) :: i,r0,r1,r2,k,itr_tol,c

	itr_tol=input(default=10000,option=ItrMax)
	r0=a
	r1=b
	do i=1, itr_tol
		r2=mod(r0,r1)
		if(r2==0)then
			!print *, "gcd of ",a," and",b,"is", r1
			exit
		endif
		k=(r0-r2)/r1
		!print *, r0,"=",k,"*",r1,"+",r2
		r0=r1
		r1=r2
	enddo
	c=a*b/r1

end function
! ########################################################

! ########################################################
function convertStringToInteger(message) result(ret)
	character(*),intent(in):: message
	character(1) :: x
	character(2*len(message) ) :: ret
	integer(int32) :: i
	ret = ""
	!allocate(ret(len(message)*2 ) )
	do i=1,len(message)
		x =  message(i:i)
		select case(x)
			case(" ")
				cycle
			case("a","A")
				ret(2*i-1:2*i) =  "01"
			case("b","B")
				ret(2*i-1:2*i) =  "02"
			case("c","C")
				ret(2*i-1:2*i) =  "03"
			case("d","D")
				ret(2*i-1:2*i) =  "04"
			case("e","E")
				ret(2*i-1:2*i) =  "05"
			case("f","F")
				ret(2*i-1:2*i) =  "06"
			case("g","G")
				ret(2*i-1:2*i) =  "07"
			case("h","H")
				ret(2*i-1:2*i) =  "08"
			case("i","I")
				ret(2*i-1:2*i) =  "09"
			case("j","J")
				ret(2*i-1:2*i) =  "10"
			case("k","K")
				ret(2*i-1:2*i) =  "11"
			case("l","L")
				ret(2*i-1:2*i) =  "12"
			case("m","M")
				ret(2*i-1:2*i) =  "13"
			case("n","N")
				ret(2*i-1:2*i) =  "14"
			case("o","O")
				ret(2*i-1:2*i) =  "15"
			case("p","P")
				ret(2*i-1:2*i) =  "16"
			case("q","Q")
				ret(2*i-1:2*i) =  "17"
			case("r","R")
				ret(2*i-1:2*i) =  "18"
			case("s","S")
				ret(2*i-1:2*i) =  "19"
			case("t","T")
				ret(2*i-1:2*i) =  "20"
			case("u","U")
				ret(2*i-1:2*i) =  "21"
			case("v","V")
				ret(2*i-1:2*i) =  "22"
			case("w","W")
				ret(2*i-1:2*i) =  "23"
			case("x","X")
				ret(2*i-1:2*i) =  "24"
			case("y","Y")
				ret(2*i-1:2*i) =  "25"
			case("z","Z")
				ret(2*i-1:2*i) =  "26"
		end select
	enddo

end function
! ########################################################

! ########################################################
function convertIntegerToString(message) result(ret)
	character(*),intent(in):: message
	character(2) :: x
	character(len(message) ) :: ret
	integer(int32) :: i
	ret = ""
	!allocate(ret(len(message)*2 ) )
	do i=1,len(message)
		x(1:2) =  message(2*i-1:2*i)
		select case(x)
			case("99")
				cycle
			case(" ")
				cycle
			case("01")
				ret(i:i) =  "a"
			case("02")
				ret(i:i) =  "b"
			case("03")
				ret(i:i) =  "c"
			case("04")
				ret(i:i) =  "d"
			case("05")
				ret(i:i) =  "e"
			case("06")
				ret(i:i) =  "f"
			case("07")
				ret(i:i) =  "g"
			case("08")
				ret(i:i) =  "h"
			case("09")
				ret(i:i) =  "i"
			case("10")
				ret(i:i) =  "j"
			case("11")
				ret(i:i) =  "k"
			case("12")
				ret(i:i) =  "l"
			case("13")
				ret(i:i) =  "m"
			case("14")
				ret(i:i) =  "n"
			case("15")
				ret(i:i) =  "o"
			case("16")
				ret(i:i) =  "p"
			case("17")
				ret(i:i) =  "q"
			case("18")
				ret(i:i) =  "r"
			case("19")
				ret(i:i) =  "s"
			case("20")
				ret(i:i) =  "t"
			case("21")
				ret(i:i) =  "u"
			case("22")
				ret(i:i) =  "v"
			case("23")
				ret(i:i) =  "w"
			case("24")
				ret(i:i) =  "x"
			case("25")
				ret(i:i) =  "y"
			case("26")
				ret(i:i) =  "z"
		end select
	enddo

end function
! ########################################################
! ########################################################
subroutine rsa_keygen(prime1,prime2,seed,id_rsa,id_rsa_pub)
	integer(int32),intent(in) :: prime1,prime2,seed
	integer(int32),intent(out) :: id_rsa(2),id_rsa_pub(2)
	integer(int32) :: n,e,lambda,d,p,q

	p=prime1
	q=prime2

	n=p*q
	lambda=(p-1)*(q-1)/gcd(p-1,q-1)
	!print *, "lambda=",lambda

	id_rsa_pub(1)=n
	id_rsa_pub(2)=seed

	id_rsa(1)=n
	id_rsa(2)=inv_mod(seed, lambda) !get d

	print *, "#######################################################"
	print *, "Encrypted by RSA algorithm, public keys "
	print *, "^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^"
	print *, "Multiplication of two prime numbers is ",id_rsa_pub(1)
	print *, "Seed value (1 < seed < ",id_rsa_pub(1),") is", id_rsa_pub(2)
	print *, "Notice:: message should be (1 < seed < ",id_rsa_pub(1),")."
	print *, "#######################################################"

end subroutine
! ########################################################

! ########################################################
function rsa_encrypt(id_rsa_pub,message) result(ciphertext)
	integer(int32),intent(in) ::id_rsa_pub(2),message
	integer(int32) :: ciphertext,i

	ciphertext = 1
	do i=1, id_rsa_pub(2)
		ciphertext= mod(ciphertext* message,  id_rsa_pub(1) )
	enddo

end function
! ########################################################

! ########################################################
function rsa_decrypt(id_rsa,ciphertext) result(message)
	integer(int32),intent(in) ::id_rsa(2),ciphertext
	integer(int32) :: d,n,e,message,i

	message = 1
	do i=1, id_rsa(2)
		message= mod(message* ciphertext,  id_rsa(1) )
	enddo

end function
! ########################################################

function IsItNumber(char) result(res)
	character(*),intent(inout) :: char
	logical :: res
	integer :: i
	character(1) :: firstchar

	res=.false.
	! search all
	firstchar=trim(adjustl(char(1:1)))

	if(firstchar == "1" )then
		res=.true.
		return
	elseif(firstchar == "2" )then
		res=.true.
		return
	elseif(firstchar == "3" )then
		res=.true.
		return
	elseif(firstchar == "4" )then
		res=.true.
		return
	elseif(firstchar == "5" )then
		res=.true.
		return
	elseif(firstchar == "6" )then
		res=.true.
		return
	elseif(firstchar == "7" )then
		res=.true.
		return
	elseif(firstchar == "8" )then
		res=.true.
		return
	elseif(firstchar == "9" )then
		res=.true.
		return
	elseif(firstchar == "0" )then
		res=.true.
		return
	elseif(firstchar == "." )then
		res=.true.
		return
	else
		return
	endif

end function IsItNumber

! BitInversion
!recursive function BitInversion(i,numBit) result(ret)
!	integer(int32),intent(in) :: i
!	integer(int32),intent(in) :: numBit
!
!	if(numBit==1)then
!		! 1 Bit 0 or 1
!
!	elseif(numBit==2)then
!	elseif(numBit==3)then
!	if(numBit > 3) then
!	endif
!
!end function

! Window functions

function RectangularWindow(Width,DataSize) result(ret)
	integer(int32),intent(in) :: Width,DataSize
	real(real64) :: ret(DataSize)

	ret = 0.0d0
	ret(DataSize/2-Width/2:DataSize/2+Width/2) = 1

end function

function HanningWindow(Width,DataSize) result(ret)
	integer(int32),intent(in) :: Width,DataSize
	real(real64) :: ret(DataSize)
	type(Math_) :: math
	integer(int32) :: i

	print *, "[CAUTION] EXPERIMENTAL!"

	ret = 0.0d0
	do i=1,width/2
		ret(DataSize/2-i) &
		= 0.50d0 - 0.50d0*cos(2.0d0*Math%PI*i/(Width/2) )
		ret(DataSize/2+i) &
		= 0.50d0 - 0.50d0*cos(2.0d0*Math%PI*i/(Width/2) )
	enddo

end function

function HammingWindow(Width,DataSize) result(ret)
	integer(int32),intent(in) :: Width,DataSize
	real(real64) :: ret(DataSize)
	type(Math_) :: math
	integer(int32) :: i

	print *, "[CAUTION] EXPERIMENTAL!"

	ret = 0.0d0
	do i=1,width/2
		ret(DataSize/2-i) &
		= 0.540d0 - 0.46d0*cos(2.0d0*Math%PI*i/(Width/2) )
		ret(DataSize/2+i) &
		= 0.540d0 - 0.46d0*cos(2.0d0*Math%PI*i/(Width/2) )
	enddo

end function
! #######################################################################
function log2(x) result(ret)
	real(real64),intent(in) :: x
	real(real64) :: ret

	ret = log(x)/log(2.0d0)

end function
! #######################################################################

end module MathClass


subroutine work(lo, hi, a, a_l1, a_l2, a_l3, a_h1, a_h2, a_h3)
  integer, intent(in) :: lo(3), hi(3), a_l1, a_l2, a_l3, a_h1, a_h2, a_h3
  double precision :: a(a_l1:a_h1, a_l2:a_h2, a_l3:a_h3)

  integer :: i, j, k

  do k       = lo(3), hi(3)
     do j    = lo(2), hi(2)
        do i = lo(1), hi(1)
           a(i,j,k) = exp(-dble(i*i+j*j+k*k)/512.d0)
        end do
     end do
  end do

end subroutine work


module permutations

  use types, only: dp

  implicit none

  interface permuteColumns
     module procedure permuteColumns_i, permuteColumns_dp
  end interface permuteColumns

contains

  function permutation(n) result (p)
    !!! Copied and adapted from http://ftp.aset.psu.edu/pub/ger/fortran/hdk/byterand.f90
    !===Generate a random permutation, P, of the first N integers.
    !   (Shuffling, equivalent to sampling WITHOUT REPLACEMENT).
    !   Adaptation of Knuth Volume 2, Algorithm 3.4.2P.
    integer n,p(n), k,j,i,ipj,itemp,m
    real u(100)
    do i=1,n
      p(i)=i
    end do
    !---Generate up to 100 U(0,1) numbers at a time.
    do i=1,n,100
      m=min(n-i+1,100)
      call random_number(u)
      do j=1,m
        ipj=i+j-1
        k=int(u(j)*(n-ipj+1))+ipj
        itemp=p(ipj)
        p(ipj)=p(k)
        p(k)=itemp
      end do
    end do
  end function permutation

  function permuteColumns_dp(matrix, perm) result(permuted)
    real(dp), dimension(:, :), intent(in) :: matrix
    integer, dimension(size(matrix, 2)), intent(in) :: perm
    real(dp), dimension(size(matrix, 1), size(matrix, 2)) :: permuted

    integer :: i

    !do concurrent (i = 1:size(perm))
    do i = 1, size(perm)
       permuted(:, i) = matrix(:, perm(i))
    end do
  end function permuteColumns_dp

  function permuteColumns_i(matrix, perm) result(permuted)
    integer, dimension(:, :), intent(in) :: matrix
    integer, dimension(size(matrix, 2)), intent(in) :: perm
    integer, dimension(size(matrix, 1), size(matrix, 2)) :: permuted

    integer :: i

    !do concurrent (i = 1:size(perm))
    do i = 1, size(perm)
       permuted(:, i) = matrix(:, perm(i))
    end do
  end function permuteColumns_i

end module permutations


! { dg-do run }
! PR70235 Incorrect output with PF format.
! Test case provided by Antoine Gardeux.
program pr70235
use ISO_FORTRAN_ENV
    implicit none
    integer, parameter :: j(size(real_kinds)+4)=[REAL_KINDS, [4, 4, 4, 4]]
    logical :: l_skip(4) = .false.
    integer :: i
    integer :: n_tst = 0, n_cnt = 0, n_skip = 0
    character(len=20) :: s, s1

!   Check that the default rounding mode is to nearest and to even on tie.
    do i=1,size(real_kinds)
      if (i == 1) then
        write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(1)), &
                                  real(9.49999905,kind=j(1)),  &
                                  real(9.5,kind=j(1)), real(8.5,kind=j(1))
        write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(1)), &
                                       real(98765.0,kind=j(1))
      else if (i == 2) then
        write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(2)), &
                                  real(9.49999905,kind=j(2)),  &
                                  real(9.5,kind=j(2)), real(8.5,kind=j(2))
        write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(2)), &
                                       real(98765.0,kind=j(2))
      else if (i == 3) then
        write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(3)), &
                                  real(9.49999905,kind=j(3)),  &
                                  real(9.5,kind=j(3)), real(8.5,kind=j(3))
        write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(3)), &
                                       real(98765.0,kind=j(3))
      else if (i == 4) then
        write(s, '(2F4.1,2F4.0)') real(-9.49999905,kind=j(4)), &
                                  real(9.49999905,kind=j(4)),  &
                                  real(9.5,kind=j(4)), real(8.5,kind=j(4))
        write(s1, '(3PE10.3,2PE10.3)') real(987350.,kind=j(4)), &
                                       real(98765.0,kind=j(4))
      end if
      if (s /= '-9.5 9.5 10.  8.' .or. s1 /= ' 987.4E+03 98.76E+03') then
        l_skip(i) = .true.
!        print "('Unsupported rounding for real(',i0,')')", j(i)
      end if
    end do

! Original test.
    call checkfmt("(-6PF8.3)", 1.0e4,    "   0.010")
    call checkfmt("(-6PF8.3)",   0.0,    "   0.000")

! Test for the bug in comment 6.
    call checkfmt("(-8pf18.3)", 643.125, "             0.000")
    call checkfmt("(-7pf18.3)", 643.125, "             0.000")
    call checkfmt("(-6pf18.3)", 643.125, "             0.001")
    call checkfmt("(-5pf18.3)", 643.125, "             0.006")
    call checkfmt("(-4pf18.3)", 643.125, "             0.064")
    call checkfmt("(-3pf18.3)", 643.125, "             0.643")
    call checkfmt("(-2pf18.3)", 643.125, "             6.431")
    call checkfmt("(-1pf18.3)", 643.125, "            64.312")
    call checkfmt("( 0pf18.3)", 643.125, "           643.125")

    call checkfmt("(ru,-8pf18.3)", 643.125, "             0.001")
    call checkfmt("(ru,-7pf18.3)", 643.125, "             0.001")
    call checkfmt("(ru,-6pf18.3)", 643.125, "             0.001")
    call checkfmt("(ru,-5pf18.3)", 643.125, "             0.007")
    call checkfmt("(ru,-4pf18.3)", 643.125, "             0.065")
    call checkfmt("(ru,-3pf18.3)", 643.125, "             0.644")
    call checkfmt("(ru,-2pf18.3)", 643.125, "             6.432")
    call checkfmt("(ru,-1pf18.3)", 643.125, "            64.313")
    call checkfmt("(ru, 0pf18.3)", 643.125, "           643.125")

    call checkfmt("(rd,-8pf18.3)", 643.125, "             0.000")
    call checkfmt("(rd,-7pf18.3)", 643.125, "             0.000")
    call checkfmt("(rd,-6pf18.3)", 643.125, "             0.000")
    call checkfmt("(rd,-5pf18.3)", 643.125, "             0.006")
    call checkfmt("(rd,-4pf18.3)", 643.125, "             0.064")
    call checkfmt("(rd,-3pf18.3)", 643.125, "             0.643")
    call checkfmt("(rd,-2pf18.3)", 643.125, "             6.431")
    call checkfmt("(rd,-1pf18.3)", 643.125, "            64.312")
    call checkfmt("(rd, 0pf18.3)", 643.125, "           643.125")

    call checkfmt("(rz,-8pf18.3)", 643.125, "             0.000")
    call checkfmt("(rz,-7pf18.3)", 643.125, "             0.000")
    call checkfmt("(rz,-6pf18.3)", 643.125, "             0.000")
    call checkfmt("(rz,-5pf18.3)", 643.125, "             0.006")
    call checkfmt("(rz,-4pf18.3)", 643.125, "             0.064")
    call checkfmt("(rz,-3pf18.3)", 643.125, "             0.643")
    call checkfmt("(rz,-2pf18.3)", 643.125, "             6.431")
    call checkfmt("(rz,-1pf18.3)", 643.125, "            64.312")
    call checkfmt("(rz, 0pf18.3)", 643.125, "           643.125")

    call checkfmt("(rc,-8pf18.3)", 643.125, "             0.000")
    call checkfmt("(rc,-7pf18.3)", 643.125, "             0.000")
    call checkfmt("(rc,-6pf18.3)", 643.125, "             0.001")
    call checkfmt("(rc,-5pf18.3)", 643.125, "             0.006")
    call checkfmt("(rc,-4pf18.3)", 643.125, "             0.064")
    call checkfmt("(rc,-3pf18.3)", 643.125, "             0.643")
    call checkfmt("(rc,-2pf18.3)", 643.125, "             6.431")
    call checkfmt("(rc,-1pf18.3)", 643.125, "            64.313")
    call checkfmt("(rc, 0pf18.3)", 643.125, "           643.125")

    call checkfmt("(rn,-8pf18.3)", 643.125, "             0.000")
    call checkfmt("(rn,-7pf18.3)", 643.125, "             0.000")
    call checkfmt("(rn,-6pf18.3)", 643.125, "             0.001")
    call checkfmt("(rn,-5pf18.3)", 643.125, "             0.006")
    call checkfmt("(rn,-4pf18.3)", 643.125, "             0.064")
    call checkfmt("(rn,-3pf18.3)", 643.125, "             0.643")
    call checkfmt("(rn,-2pf18.3)", 643.125, "             6.431")
    call checkfmt("(rn,-1pf18.3)", 643.125, "            64.312")
    call checkfmt("(rn, 0pf18.3)", 643.125, "           643.125")

    call checkfmt("(rp,-8pf18.3)", 643.125, "             0.000")
    call checkfmt("(rp,-7pf18.3)", 643.125, "             0.000")
    call checkfmt("(rp,-6pf18.3)", 643.125, "             0.001")
    call checkfmt("(rp,-5pf18.3)", 643.125, "             0.006")
    call checkfmt("(rp,-4pf18.3)", 643.125, "             0.064")
    call checkfmt("(rp,-3pf18.3)", 643.125, "             0.643")
    call checkfmt("(rp,-2pf18.3)", 643.125, "             6.431")
    call checkfmt("(rp,-1pf18.3)", 643.125, "            64.312")
    call checkfmt("(rp, 0pf18.3)", 643.125, "           643.125")

    call checkfmt("(-8pf18.3)", -643.125, "            -0.000")
    call checkfmt("(-7pf18.3)", -643.125, "            -0.000")
    call checkfmt("(-6pf18.3)", -643.125, "            -0.001")
    call checkfmt("(-5pf18.3)", -643.125, "            -0.006")
    call checkfmt("(-4pf18.3)", -643.125, "            -0.064")
    call checkfmt("(-3pf18.3)", -643.125, "            -0.643")
    call checkfmt("(-2pf18.3)", -643.125, "            -6.431")
    call checkfmt("(-1pf18.3)", -643.125, "           -64.312")
    call checkfmt("( 0pf18.3)", -643.125, "          -643.125")

    call checkfmt("(ru,-8pf18.3)", -643.125, "            -0.000")
    call checkfmt("(ru,-7pf18.3)", -643.125, "            -0.000")
    call checkfmt("(ru,-6pf18.3)", -643.125, "            -0.000")
    call checkfmt("(ru,-5pf18.3)", -643.125, "            -0.006")
    call checkfmt("(ru,-4pf18.3)", -643.125, "            -0.064")
    call checkfmt("(ru,-3pf18.3)", -643.125, "            -0.643")
    call checkfmt("(ru,-2pf18.3)", -643.125, "            -6.431")
    call checkfmt("(ru,-1pf18.3)", -643.125, "           -64.312")
    call checkfmt("(ru, 0pf18.3)", -643.125, "          -643.125")

    call checkfmt("(rd,-8pf18.3)", -643.125, "            -0.001")
    call checkfmt("(rd,-7pf18.3)", -643.125, "            -0.001")
    call checkfmt("(rd,-6pf18.3)", -643.125, "            -0.001")
    call checkfmt("(rd,-5pf18.3)", -643.125, "            -0.007")
    call checkfmt("(rd,-4pf18.3)", -643.125, "            -0.065")
    call checkfmt("(rd,-3pf18.3)", -643.125, "            -0.644")
    call checkfmt("(rd,-2pf18.3)", -643.125, "            -6.432")
    call checkfmt("(rd,-1pf18.3)", -643.125, "           -64.313")
    call checkfmt("(rd, 0pf18.3)", -643.125, "          -643.125")

    call checkfmt("(rz,-8pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rz,-7pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rz,-6pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rz,-5pf18.3)", -643.125, "            -0.006")
    call checkfmt("(rz,-4pf18.3)", -643.125, "            -0.064")
    call checkfmt("(rz,-3pf18.3)", -643.125, "            -0.643")
    call checkfmt("(rz,-2pf18.3)", -643.125, "            -6.431")
    call checkfmt("(rz,-1pf18.3)", -643.125, "           -64.312")
    call checkfmt("(rz, 0pf18.3)", -643.125, "          -643.125")

    call checkfmt("(rc,-8pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rc,-7pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rc,-6pf18.3)", -643.125, "            -0.001")
    call checkfmt("(rc,-5pf18.3)", -643.125, "            -0.006")
    call checkfmt("(rc,-4pf18.3)", -643.125, "            -0.064")
    call checkfmt("(rc,-3pf18.3)", -643.125, "            -0.643")
    call checkfmt("(rc,-2pf18.3)", -643.125, "            -6.431")
    call checkfmt("(rc,-1pf18.3)", -643.125, "           -64.313")
    call checkfmt("(rc, 0pf18.3)", -643.125, "          -643.125")

    call checkfmt("(rn,-8pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rn,-7pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rn,-6pf18.3)", -643.125, "            -0.001")
    call checkfmt("(rn,-5pf18.3)", -643.125, "            -0.006")
    call checkfmt("(rn,-4pf18.3)", -643.125, "            -0.064")
    call checkfmt("(rn,-3pf18.3)", -643.125, "            -0.643")
    call checkfmt("(rn,-2pf18.3)", -643.125, "            -6.431")
    call checkfmt("(rn,-1pf18.3)", -643.125, "           -64.312")
    call checkfmt("(rn, 0pf18.3)", -643.125, "          -643.125")

    call checkfmt("(rp,-8pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rp,-7pf18.3)", -643.125, "            -0.000")
    call checkfmt("(rp,-6pf18.3)", -643.125, "            -0.001")
    call checkfmt("(rp,-5pf18.3)", -643.125, "            -0.006")
    call checkfmt("(rp,-4pf18.3)", -643.125, "            -0.064")
    call checkfmt("(rp,-3pf18.3)", -643.125, "            -0.643")
    call checkfmt("(rp,-2pf18.3)", -643.125, "            -6.431")
    call checkfmt("(rp,-1pf18.3)", -643.125, "           -64.312")
    call checkfmt("(rp, 0pf18.3)", -643.125, "          -643.125")

    ! print *, n_tst, n_cnt, n_skip
    if (n_cnt /= 0) STOP 1
    if (all(.not. l_skip)) print *, "All kinds rounded to nearest"

contains
    subroutine checkfmt(fmt, x, cmp)
        implicit none
        integer :: i
        character(len=*), intent(in) :: fmt
        real, intent(in) :: x
        character(len=*), intent(in) :: cmp
        do i=1,size(real_kinds)
          if (i == 1) then
            write(s, fmt) real(x,kind=j(1))
          else if (i == 2) then
            write(s, fmt) real(x,kind=j(2))
          else if (i == 3) then
            write(s, fmt) real(x,kind=j(3))
          else if (i == 4) then
            write(s, fmt) real(x,kind=j(4))
          end if
          n_tst = n_tst + 1
          if (s /= cmp) then
            if (l_skip(i)) then
              n_skip = n_skip + 1
            else
              print "(a,1x,a,' expected: ',1x,a)", fmt, s, cmp
              n_cnt = n_cnt + 1
            end if
          end if
        end do

    end subroutine
end program
! { dg-output "All kinds rounded to nearest" { xfail { hppa*-*-hpux* } } }


        subroutine idd_pairsamps(n,l,ind,l2,ind2,marker)
c
c       calculates the indices of the l2 pairs of integers
c       to which the l individual integers from ind belong.
c       The integers in ind may range from 1 to n.
c
c       input:
c       n -- upper bound on the integers in ind
c            (the number 1 must be a lower bound);
c            n must be even
c       l -- length of ind
c       ind -- integers selected from 1 to n
c
c       output:
c       l2 -- length of ind2
c       ind2 -- indices in the range from 1 to n/2 of the pairs
c               of integers to which the entries of ind belong
c
c       work:
c       marker -- must be at least n/2 integer elements long
c
c       _N.B._: n must be even.
c
        implicit none
        integer l,n,ind(l),ind2(l),marker(n/2),l2,k
c
c
c       Unmark all pairs.
c
        do k = 1,n/2
          marker(k) = 0
        enddo ! k
c
c
c       Mark the required pairs.
c
        do k = 1,l
          marker((ind(k)+1)/2) = marker((ind(k)+1)/2)+1
        enddo ! k
c
c
c       Record the required pairs in indpair.
c
        l2 = 0
c
        do k = 1,n/2
c
          if(marker(k) .ne. 0) then
            l2 = l2+1
            ind2(l2) = k
          endif
c
        enddo ! k
c
c
        return
        end
c
c
c
c


      module constants
         integer, parameter :: np=2000, dbl=selected_real_kind(14,100)
         real(dbl) :: g=9.807,dtmin=.001
      end module constants

      program fall
      use constants
      implicit none
!
!   Program to calculate the dynamics
!
!   Module "constants" is used for ...
      real(dbl) dt
      print *,g
      stop
      end


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception

! maxloc in initialization with repeat real elements

program p
integer :: rslt = 2
integer, parameter, dimension(1) :: mn = maxloc((/4.5, 6.8, 6.8, 3.1/))
call check(mn, rslt, 1)
end


SUBROUTINE prm_gravity (PRMfname)

! ----------------------------------------------------------------------
! SUBROUTINE: prm_gravity.f03
! ----------------------------------------------------------------------
! Purpose:
!  Read/Set the parameterization regarding the Earth gravity field
! ----------------------------------------------------------------------
! Author :	Dr. Thomas Papanikolaou
!			Cooperative Research Centre for Spatial Information, Australia
! Created:	5 April 2018
! ----------------------------------------------------------------------

      USE mdl_precision
      USE mdl_num
      USE mdl_param
      !USE mdl_gfc
      USE m_gfc
      USE m_gfc3
      use pod_yaml
      use mdl_config
      IMPLICIT NONE

! ----------------------------------------------------------------------
! Dummy arguments declaration
! ----------------------------------------------------------------------
! IN
      CHARACTER (LEN=100), INTENT(IN) :: PRMfname
! OUT

! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Variables declaration
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int2) :: ForceMod
! Gravity Field model variables
      INTEGER (KIND = prec_int8) :: Ntrunc, Ntrunc_tv
      INTEGER (KIND = prec_int8) :: Nmax, Mmax
      !INTEGER (KIND = prec_int8) :: n_max, m_max
      INTEGER (KIND = prec_int2) :: sigma_shc, gfc_opt
      CHARACTER (LEN=300) :: gfmfilename
      REAL (KIND = prec_q) :: mjd_t
      REAL (KIND = prec_q) :: GM_gfc, ae_gfc
      INTEGER (KIND = prec_int8) :: Nmax_gfc
      CHARACTER (LEN=50) :: tide_gfc
! Spherical Harmonic Coefficients (SHC) lower triangular matrices (Dynamic Allocatable arrays)
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Cnm
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: Snm
! Errors/Variances of SHC (Dynamic Allocatable arrays)
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: sCnm
      REAL (KIND = prec_q), DIMENSION(:,:), ALLOCATABLE :: sSnm
! ----------------------------------------------------------------------
      CHARACTER (LEN=300) :: filename
      INTEGER (KIND = prec_int2) :: AllocateStatus,DeAllocateStatus
! ----------------------------------------------------------------------
      INTEGER (KIND = prec_int8) :: i, read_i
      INTEGER (KIND = prec_int2) :: UNIT_IN, ios
      INTEGER (KIND = prec_int2) :: ios_line, ios_key, ios_data
      INTEGER (KIND = prec_int2) :: space_i
      CHARACTER (LEN=7) :: Format1, Format2, Format3
      CHARACTER (LEN=500) :: line_ith
      CHARACTER (LEN=150) :: word1_ln, word_i, t0
! ----------------------------------------------------------------------

if (.not. yaml_found) then
! ----------------------------------------------------------------------
! Orbit parameterization INPUT file read:
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
      UNIT_IN = 9
      Format1 = '(A)'
      Format2 = '(F)'
      Format3 = '(I100)'
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Open .in file
      OPEN (UNIT = UNIT_IN, FILE = TRIM (PRMfname), IOSTAT = ios)
      IF (ios /= 0) THEN
         PRINT *, "Error in opening file:", PRMfname
         PRINT *, "OPEN IOSTAT=", ios
      END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Read input file
i = 0
DO

READ (UNIT=UNIT_IN,FMT=Format1,IOSTAT=ios_line) line_ith
i = i + 1
!PRINT *, "READ Line (i,ios):", i, ios_line

! ----------------------------------------------------------------------
! End of file
         IF (ios_line < 0) THEN
!            PRINT *, "End of file, i=", i
            EXIT
         END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! 1st Word of Line ith
READ (line_ith, * , IOSTAT=ios_data) word1_ln  ! 1st word
!READ (line_ith, * , IOSTAT=ios_data) word1_ln, charN
! ----------------------------------------------------------------------
!PRINT *, "word1_ln: ", word1_ln

! ----------------------------------------------------------------------
! Parameters Keywords read
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Gravitational forces considered:
! ----------------------------------------------------------------------
! FMOD_GRAV setting (global variable in the module mdl_param.f03)
! FMOD_GRAV(1) : Earth gravity Field
! 1. FMOD_GRAV(i)=1 : Effect is considered
! 2. FMOD_GRAV(i)=0 : Effect is neglected
!
! Gravity Field
!IF (word1_ln == "Gravity_field") THEN
!   READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, ForceMod
	!FMOD_GRAV(1) = ForceMod
	!print *,"ForceMod", ForceMod
!END IF
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Earth Gravity Field
! ----------------------------------------------------------------------
! Gravity Field model options:
! 0. Central gravity field (Keplerian orbit only)	: gravity_model = 0
! 1. Static global gravity field model     		    : gravity_model = 1
! 2. Time-variable global gravity field model 		: gravity_model = 2
! 3. IERS conventional geopotential model 			: gravity_model = 3
IF (word1_ln == "gravity_model") THEN
   READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, gfc_opt
   FMOD_GRAVFIELD = 1
   yml_gravity_model = gfc_opt
   if (gfc_opt == CENTRAL_MODEL) then
      FMOD_GRAVFIELD = 0
   end if
END IF

! FMOD_GRAVFIELD global variable in mdl_param.f03

! Gravity Field model
IF (word1_ln == "gravity_model_filename") THEN
   READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, gfmfilename
   yml_gravity_filename = gfmfilename
END IF

! Degree truncation limit (Spherical harmonics expansion series)
IF (word1_ln == "degree_max") THEN
   READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, Nmax
	Ntrunc = Nmax
   yml_gravity_max_degree = Nmax
END IF

! Degree truncation limit for the time-variable coefficients (case: gfc_opt=2)
IF (word1_ln == "degree_max_timevar") THEN
   READ ( line_ith, FMT = * , IOSTAT=ios_key ) word_i, Nmax
	Ntrunc_tv = Nmax
   yml_gravity_time_max_degree = Nmax
END IF

! ----------------------------------------------------------------------

END DO
CLOSE (UNIT=UNIT_IN)
! Close of input parameterization file
! ----------------------------------------------------------------------
else
    FMOD_GRAVFIELD = 1
    if (yml_gravity_model == CENTRAL_MODEL) FMOD_GRAVFIELD = 0
    yml_gravity_time_max_degree = yml_eqm_gravity_time_max_degree
    yml_gravity_max_degree = yml_eqm_gravity_max_degree
    Ntrunc = yml_gravity_max_degree
    Ntrunc_tv = yml_gravity_time_max_degree
end if

! Errors of spherical harmonic coefficients: Store errors in arrays or Not
sigma_shc = 0

! ----------------------------------------------------------------------
! Earth Gravity Field
! ----------------------------------------------------------------------
IF (FMOD_GRAVFIELD == 0) then

GFM_GM = GM_global
GFM_ae = Earth_radius
GFM_tide = 'tide_free'

Else

if (.false.) then
print *, "gravity model = ", yml_gravity_model
print *, "gravity file = ", yml_gravity_filename
print *, "max degree = ", yml_gravity_max_degree
print *, "max time degree = ", yml_gravity_time_max_degree
print *, "non central gravity field = ", FMOD_GRAVFIELD
end if

! ----------------------------------------------------------------------
! Gravity model's data: Spherical Harmonic Coefficients (icgem format)
! ----------------------------------------------------------------------
      if (yml_gravity_model == STATIC_MODEL) then
          CALL gfc1 (yml_gravity_filename, yml_gravity_max_degree, sigma_shc, GM_gfc,&
                  ae_gfc, Nmax_gfc, tide_gfc, Cnm, Snm, sCnm, sSnm)

      else if (yml_gravity_model == TIME_MODEL) then
		  mjd_t = MJD_to ! Module mdl_param.f03
          CALL gfc2 (yml_gravity_filename,yml_gravity_max_degree,sigma_shc, mjd_t, &
                  yml_gravity_time_max_degree, GM_gfc, ae_gfc, Nmax_gfc, tide_gfc, Cnm, Snm, sCnm, sSnm)

      else if (yml_gravity_model == IERS_MODEL) then
		  mjd_t = MJD_to ! Module mdl_param.f03
          CALL gfc3_iers (yml_gravity_filename, yml_gravity_max_degree, sigma_shc,&
                  mjd_t, GM_gfc, ae_gfc, Nmax_gfc, tide_gfc, Cnm, Snm, sCnm, sSnm)

      end if
! ----------------------------------------------------------------------

! ----------------------------------------------------------------------
! Gravity model's global variables set in mdl_param.f03
GFM_GM = GM_gfc
GFM_ae = ae_gfc
GFM_degmax = Nmax_gfc
GFM_tide = tide_gfc

! Truncation maximum degree and order
! Nmax
IF (yml_gravity_max_degree == -1) THEN
   GFM_Nmax = Nmax_gfc
ELSE
   GFM_Nmax = yml_gravity_max_degree
END IF
! Mmax
GFM_Mmax = GFM_Nmax

ALLOCATE (GFM_Cnm(GFM_Nmax+1,GFM_Nmax+1), STAT = AllocateStatus)
ALLOCATE (GFM_Snm(GFM_Nmax+1,GFM_Nmax+1), STAT = AllocateStatus)
GFM_Cnm  = Cnm
GFM_Snm  = Snm

IF (sigma_shc /= 0) THEN
  	ALLOCATE (GFM_sCnm(GFM_Nmax+1,GFM_Nmax+1), STAT = AllocateStatus)
   	ALLOCATE (GFM_sSnm(GFM_Nmax+1,GFM_Nmax+1), STAT = AllocateStatus)
	GFM_sCnm = sCnm
	GFM_sSnm = sSnm
END IF

END IF
! End of parameters setting for Gravity Field
! ----------------------------------------------------------------------
!print *,"gfmfilename: ",gfmfilename

END


SUBROUTINE enum(r, c, n, m, ifault)

! Code converted using TO_F90 by Alan Miller
! Date: 2002-02-18  Time: 10:00:55

!    ALGORITHM AS 205 APPL. STATIST. (1984) VOL 33, NO. 3.

!    ENUMERATES ALL R*C CONTINGENCY TABLES WITH GIVEN ROW TOTALS N(I)
!    AND COLUMN TOTALS M(J) AND CALCULATES THE HYPERGEOMETRIC
!    PROBABILITY OF EACH TABLE.

!    FOR TABLES HAVING TWO OR MORE ROW SUMS REPEATED, EQUIVALENT
!    TABLES DIFFERING ONLY BY A ROW PERMUTATION ARE NOT SEPARATELY
!    ENUMERATED.  A REPRESENTATIVE OF EACH EQUIVALENCE CLASS IS ENUMERATED
!    AND THE MULTIPLICITY OF EACH CLASS CALCULATED.

!    FOR EACH TABLE ENUMERATED, SUBROUTINE EVAL IS CALLED TO CARRY OUT
!    CALCULATIONS ON THE TABLE.

IMPLICIT NONE

INTEGER, INTENT(IN OUT)  :: r
INTEGER, INTENT(IN OUT)  :: c
INTEGER, INTENT(IN OUT)  :: n(10)
INTEGER, INTENT(IN OUT)  :: m(10)
INTEGER, INTENT(OUT)     :: ifault

INTERFACE
  SUBROUTINE eval(table, r, c, n, m, prob, mult)
    IMPLICIT NONE
    INTEGER, INTENT(IN)  :: table(10,10)
    INTEGER, INTENT(IN)  :: r
    INTEGER, INTENT(IN)  :: c
    INTEGER, INTENT(IN)  :: n(10)
    INTEGER, INTENT(IN)  :: m(10)
    REAL, INTENT(IN)     :: prob
    INTEGER, INTENT(IN)  :: mult
  END SUBROUTINE eval
END INTERFACE

INTEGER :: table(10,10), bound(10,10), z(10)
INTEGER :: reps(10), mult(10), repsr, repsc, maxrc, multr, multc
INTEGER :: ntotal, ntot, rm, cm, left, rowbnd, rowsum
INTEGER :: i, j, ii, ij, iip, iim, ip, jj, jjm, jkeep, jm, jnext, jp, k, KEEP
REAL    :: prob(10,10), flogm(201), factlm(201)
REAL    :: prob0
LOGICAL :: rept(10), reptc(10), ieqim

!    LOCAL VARIABLES -
!      TABLE(I,J)   - (I,J)-TH ENTRY OF CURRENT TABLE
!      NTOTAL       - TOTAL OF TABLE ENTRIES
!      BOUND(I,J)   - CURRENT UPPER BOUND ON TABLE(I,J) TO SATISFY
!                     ROW AND COLUMN TOTALS
!      REPT(I)      - LOGICAL = TRUE IF ROW TOTALS N(I), N(I-1) ARE EQUAL
!                             = FALSE OTHERWISE
!      REPS(I)      - NUMBER OF PREVIOUS ROWS EQUAL TO ROW I
!      MULT(I)      - MAXIMUM NUMBER OF EQUIVALENT TABLES
!                     GIVEN FIRST I ROWS
!      Z(J)         - LOWER BOUND ON SUM OF ENTRIES USED BY ALGORITHM C
!      PROB(I,J)    - PARTIAL SUM OF TERMS IN LOG(P)

INTEGER, PARAMETER  :: maxt = 10, nmax = 201, zero = 0.0, one = 1

!      MAXT - MAXIMUM DIMENSION OF TABLE
!      NMAX - MAXIMUM NUMBER OF OBSERVATIONS + 1

!       CHECK INPUT VALUES

ifault = 1
IF (r > MAXT .OR. c > MAXT .OR. r <= 0 .OR. c <= 0) RETURN

ifault = 3
ntotal = 0
DO  i = 1, r
  IF (n(i) <= 0) RETURN
  ntotal = ntotal + n(i)
END DO
ntot = 0
DO  j = 1, c
  IF (m(j) <= 0) RETURN
  ntot = ntot + m(j)
END DO
ifault = 2
IF (ntot /= ntotal) RETURN

ifault = 4
IF (ntotal >= nmax) RETURN

ifault = 0

!       INITIALISE FLOGM(K)=LOG(K-1), FACTLM(K)=LOG(K-1 FACTORIAL)

flogm(1) = zero
factlm(1) = zero
DO  k = 1, ntotal
  flogm(k+1) = LOG(REAL(k))
  factlm(k+1) = factlm(k) + flogm(k+1)
END DO

!       CONSTANTS

rm = r - 1
cm = c - 1

!       SORT ROWS AND COLUMNS INTO ASCENDING ORDER

DO  i = 1, rm
  ip = i + 1
  DO  ii = ip, r
    IF (n(i) > n(ii)) THEN
      KEEP = n(i)
      n(i) = n(ii)
      n(ii) = KEEP
    END IF
  END DO
END DO

DO  j = 1, cm
  jp = j + 1
  DO  jj = jp, c
    IF (m(j) > m(jj)) THEN
      KEEP = m(j)
      m(j) = m(jj)
      m(jj) = KEEP
    END IF
  END DO
END DO

!       CALCULATE MULTIPLICITIES OF ROWS AND COLUMNS

!       REPTC(J) = .TRUE. IF COLUMNS J AND J-1 HAVE THE SAME TOTAL
!       REPT(I)  = .TRUE. IF ROWS I AND I-1 HAVE THE SAME TOTAL

multc = one
repsc = one
reptc(1) = .false.
DO  j = 2, c
  reptc(j) = (m(j) == m(j-1))
  IF (.NOT.reptc(j)) THEN
    repsc = one
  ELSE
    repsc = repsc + one
    multc = multc * repsc
  END IF
END DO

multr = one
repsr = one
rept(1) = .false.
DO  i = 2, r
  rept(i) = (n(i) == n(i-1))
  IF (.NOT.rept(i)) THEN
    repsr = one
  ELSE
    repsr = repsr + one
    multr = multr * repsr
  END IF
END DO

!       IF COLUMN MULTIPLICITY EXCEEDS ROW MULTIPLICITY TRANSPOSE TABLE

IF (multr < multc) THEN
  maxrc = MAX(r,c)
  DO  ij = 1, maxrc
    KEEP = n(ij)
    n(ij) = m(ij)
    m(ij) = KEEP
  END DO
  KEEP = r
  r = c
  c = KEEP
  rm = r - 1
  cm = c - 1
  DO  i = 1, r
    rept(i) = reptc(i)
  END DO
  multr = multc
END IF

!       SET UP INITIAL TABLE

!       MAXIMUM MULTIPLICITY

mult(1) = multr
reps(1) = one

!       CONSTANT TERM IN PROBABILITY

prob0 = -factlm(ntotal+1)
DO  i = 1, r
  ii = n(i)
  prob0 = prob0 + factlm(ii+1)
END DO
DO  j = 1, c
  jj = m(j)
  prob0 = prob0 + factlm(jj+1)
END DO

!       CALCULATE BOUNDS  ON ROW 1

DO  j = 1, c
  bound(1,j) = m(j)
END DO

!       FOR EACH I FIND GREATEST I-TH ROW SATISFYING BOUNDS

DO  i = 1, r
  IF (i /= 1) prob0 = prob(i-1,c)
  left = n(i)

!         ELEMENTS OF ROW I

  ieqim = rept(i)
  DO  j = 1, cm
    ij = MIN(left,bound(i,j))
    table(i,j) = ij
    IF (j == 1) prob(i,j) = prob0 - factlm(ij+1)
    IF (j /= 1) prob(i,j) = prob(i,j-1) - factlm(ij+1)
    left = left - table(i,j)
    IF (i < r) bound(i+1,j) = bound(i,j) - table(i,j)
    IF (left == 0) GO TO 160
    IF (ieqim) ieqim = table(i,j) == table(i-1,j)
  END DO
  table(i,c) = left
  prob(i,c) = prob(i,cm) - factlm(left+1)
  IF (i < r) bound(i+1,c) = bound(i,c) - left
  GO TO 180

  160 jp = j + 1
  DO  jj = jp, c
    table(i,jj) = 0
    prob(i,jj) = prob(i,jj-1)
    bound(i+1,jj) = bound(i,jj)
  END DO
  180 IF (i /= 1) THEN
    mult(i) = mult(i-1)
    reps(i) = one
    IF (ieqim) THEN
      reps(i) = reps(i-1) + one
      mult(i) = mult(i) / reps(i)
    END IF
  END IF

END DO

!       CALL EVAL FOR TABLE 1

CALL eval(table, r, c, n, m, prob(r,c), mult(r))

!       COMMENCE ENUMERATION OF REMAINING TABLES
!       START OF MAIN LOOP

200 i = r
210 i = i - 1

!       IF I = 0 NO MORE TABLES ARE POSSIBLE

IF (i == 0) RETURN

j = cm
left = table(i,c)
rowbnd = bound(i,c)

!       TRY TO DECREASE ELEMENT (I,J)

220 IF (table(i,j) <= 0 .OR. left >= rowbnd) THEN

!       ELEMENT (I,J) CANNOT BE DECREASED - TRY (I,J-1)

  IF (j == 1) GO TO 210
  left = left + table(i,j)
  rowbnd = rowbnd + bound(i,j)
  j = j - 1
  GO TO 220
END IF

!       DECREASE ELEMENT (I,J)

ij = table(i,j)
prob(i,j) = prob(i,j) + flogm(ij+1)
table(i,j) = table(i,j) - 1
bound(i+1,j) = bound(i+1,j) + 1

!       IF ROW I WAS THE SAME AS ROW I-1 IT IS NO LONGER

IF (reps(i) /= one) THEN
  reps(i) = one
  mult(i) = mult(i-1)
END IF

!       COMPLETE ROW I WITH THE LARGEST POSSIBLE VALUES

ii = i
iip = ii + 1
iim = ii - 1
jnext = j + 1
left = left + 1
GO TO 320

!       FILL UP REMAINING ROWS

230 ii = ii + 1

!       THE LAST ROW IS TREATED SEPARATELY

IF (ii == r) GO TO 370
iip = ii + 1
iim = ii - 1
IF (.NOT.rept(ii)) THEN

!       ROW TOTAL N(II) IS NOT A REPEAT - MAKE ROW II AS LARGE AS POSSIBLE

  left = n(ii)
  jnext = 1
ELSE

!       REPEATED ROW TOTALS

!       (I) IF ROW II-1 SATISFIES THE BOUNDS ON ROW II REPEAT IT

  DO  j = 1, c
    IF (table(iim,j) > bound(ii,j)) GO TO 250
    ij = table(iim,j)
    table(ii,j) = ij
    bound(iip,j) = bound(ii,j) - table(ii,j)
    IF (j == 1) prob(ii,j) = prob(iim,c) - factlm(ij+1)
    IF (j /= 1) prob(ii,j) = prob(ii,j-1) - factlm(ij+1)
  END DO

!       ROW II IS A REPEAT OF ROW II-1

  reps(ii) = reps(iim) + one
  mult(ii) = mult(iim) / reps(ii)
  GO TO 230

!       ELEMENT J OF ROW II-1 WAS TOO BIG

!       CONSTRUCT THE SEQUENCE Z(J) OF LOWER BOUNDS

  250 IF (j <= 1) THEN

!       IF J=1 THE BOUNDS ARE SATISFIED AUTOMATICALLY

    ij = bound(ii,1)
    table(ii,1) = ij
    prob(ii,1) = prob(iim,c) - factlm(ij+1)
    jnext = 2
    left = n(ii) - table(ii,1)
    bound(iip,1) = 0
  ELSE
    z(j) = n(ii)
    jm = j - 1
    IF (j /= c) THEN
      jp = j + 1
      DO  jj = jp, c
        z(j) = z(j) - bound(ii,jj)
      END DO
    END IF
    DO  jjm = 1, jm
      jj = j - jjm
      z(jj) = z(jj+1) - bound(ii,jj+1)
    END DO

!       (II) IF THE CUMULATIVE TOTALS OF ROW II-1 ALL EXCEED THE BOUNDS Z(J)
!                      MAKE ELEMENT (II,J) EQUAL TO ITS BOUND

    rowsum = 0
    jkeep = 0
    DO  jj = 1, jm
      rowsum = rowsum + table(iim,jj)
      IF (rowsum < z(jj)) GO TO 300
      IF (rowsum > z(jj) .AND. table(iim,jj) > 0) jkeep = jj
    END DO
    table(ii,j) = bound(ii,j)
    bound(iip,j) = 0
    ij = table(ii,j)
    prob(ii,j) = prob(ii,jm) - factlm(ij+1)
    reps(ii) = one
    mult(ii) = mult(iim)

!       COMPLETE ROW II WITH THE LARGEST POSSIBLE ELEMENTS

    jnext = jp
    left = n(ii)
    DO  jj = 1, j
      left = left - table(ii,jj)
    END DO
    GO TO 320

!       (III) THE CUMULATIVE SUMS VIOLATE THE BOUNDS
!       IF NO ELEMENT OF ROW II-1 CAN BE CHANGED TO SATISFY THE BOUNDS
!                 NO SUITABLE ROW II IS POSSIBLE
!       IN THAT CASE GO BACK AND TRY DECREASING ROW II-1

    300 IF (jkeep == 0) THEN
      i = ii
      GO TO 210
    END IF

!       ELEMENT (II,JKEEP) CAN BE DECREASED

    bound(iip,jkeep) = bound(iip,jkeep) + 1
    ij = table(ii,jkeep)
    prob(ii,jkeep) = prob(ii,jkeep) + flogm(ij+1)
    table(ii,jkeep) = table(ii,jkeep) - 1

!       COMPLETE THE ROW

    jnext = jkeep + 1
    left = n(ii)
    DO  jj = 1, jkeep
      left = left - table(ii,jj)
    END DO
  END IF
END IF

!       ROW II IS COMPLETE UP TO ELEMENT JNEXT-1
!       MAKE THE REMAINING ELEMENTS AS LARGE AS POSSIBLE
!       (THIS SECTION OF CODE IS USED FOR EVERY ROW, REPEATED OR NOT)

320 IF (jnext /= c) THEN

  DO  j = jnext, cm
    table(ii,j) = MIN(left,bound(ii,j))
    left = left - table(ii,j)
    bound(iip,j) = bound(ii,j) - table(ii,j)
    ij = table(ii,j)
    IF (j == 1) prob(ii,j) = prob(iim,c) - factlm(ij+1)
    IF (j /= 1) prob(ii,j) = prob(ii,j-1) - factlm(ij+1)
    IF (left == 0) GO TO 340
  END DO
END IF
table(ii,c) = left
prob(ii,c) = prob(ii,cm) - factlm(left+1)
bound(iip,c) = bound(ii,c) - left
GO TO 360

340 jp = j + 1
DO  jj = jp, c
  table(ii,jj) = 0
  prob(ii,jj) = prob(ii,jj-1)
  bound(iip,jj) = bound(ii,jj)
END DO
360 reps(ii) = one
IF (ii > 1) mult(ii) = mult(iim)
GO TO 230

!       THE FINAL ROW

370 IF (.NOT.rept(r)) THEN

!       NOT A REPEAT - SET ROW R EQUAL TO ITS BOUNDS

  ij = bound(r,1)
  table(r,1) = ij
  prob(r,1) = prob(rm,c) - factlm(ij+1)
  DO  j = 2, c
    ij = bound(r,j)
    table(r,j) = ij
    prob(r,j) = prob(r,j-1) - factlm(ij+1)
  END DO
  mult(r) = mult(rm)
ELSE

!       ROW TOTAL R IS A REPEAT - ENSURE THAT IT IS LESS THAN ROW R-1

  DO  j = 1, c
    IF (bound(r,j) > table(rm,j)) GO TO 400
    ij = bound(r,j)
    table(r,j) = ij
    IF (j == 1) prob(r,j) = prob(rm,c) - factlm(ij+1)
    IF (j /= 1) prob(r,j) = prob(r,j-1) - factlm(ij+1)
    IF (table(r,j) /= table(rm,j)) GO TO 410
  END DO

!       ROW R IS A REPEAT OF ROW R-1

  reps(r) = reps(rm) + one
  mult(r) = mult(rm) / reps(r)
  GO TO 430

!       IF ROW R WOULD BE BIGGER THAN ROW R-1 GO BACK AND TRY
!          DECREASING ROW R-2

  400   i = rm
  GO TO 210

!       ROW R IS ALREADY LESS THEN ROW R-1 SO NO MORE CHECKS ARE NEEDED

  410   jp = j + 1
  DO  jj = jp, c
    ij = bound(r,jj)
    table(r,jj) = ij
    prob(r,jj) = prob(r,jj-1) - factlm(ij+1)
  END DO
  mult(r) = mult(rm)
END IF

!       THE TABLE IS COMPLETE - CALL SUBROUTINE EVAL

430 CALL eval(table, r, c, n, m, prob(r,c), mult(r))

!       END OF MAIN LOOP

GO TO 200

END SUBROUTINE enum

SUBROUTINE eval(table, r, c, n, m, prob, mult)
IMPLICIT NONE

INTEGER, INTENT(IN)  :: table(10,10)
INTEGER, INTENT(IN)  :: r
INTEGER, INTENT(IN)  :: c
INTEGER, INTENT(IN)  :: n(10)
INTEGER, INTENT(IN)  :: m(10)
REAL, INTENT(IN)     :: prob
INTEGER, INTENT(IN)  :: mult

RETURN

END SUBROUTINE eval


SUBROUTINE reservoir_routing(upstream,help,help2)

!Till: computationally irrelevant: outcommented unused vars
!2012-09-14

! Code converted using TO_F90 by Alan Miller
! Date: 2005-08-23  Time: 12:57:31

use common_h
use time_h
use reservoir_h
use params_h

IMPLICIT NONE

INTEGER, INTENT(IN OUT)               :: upstream
REAL, INTENT(IN OUT)                  :: help
REAL, INTENT(IN OUT)                  :: help2

INTEGER :: i,n !j,k,,npts
INTEGER :: ninterac !,nbrbat1

REAL :: par_c,par_d
REAL :: y1,y2,vol1,vol2,dvol !out1,out2,elev
REAL :: frtime,inflow_t,inflow_mean,outflow_mean
REAL :: inflow,outflow
REAL :: dummy1,dummy2,error !,dummy3,dummy4,dummy5
REAL :: volmax,volstep,time !,areamax
REAL :: hmax0,vmax0,par_k,par_alpha
! -----------------------------------------------------------------------

! Initialization
inflow=help/(86400./nt)
outflow=outflow_last(upstream)
volmax=daystorcap(step,upstream) !storage capacity in the subbasin's reservoir [m**3]
volstep=help2
par_c=damc(upstream)
par_d=damd(upstream)
par_k=k_over(upstream)
par_alpha=alpha_over(upstream)
vmax0=(storcap(upstream)*1.e6)
hmax0=hmax(upstream)

!write(*,'(I6,4F7.3,F13.1,2F8.3,F13.1)')upstream,par_c,par_d,par_k,par_alpha,hmax0,vmax0

!stop

! if this is the initial timestep, volume_last might be > 0 even if outflow_last = 0
! because there is no information about outflow_last at initial timestep but volume_last might be > 0 depending on parameter vol0
IF (outflow==0. .and. dtot > 1) THEN
  vol2=0.
ELSE
  vol2=volume_last(upstream)
ENDIF

!write(*,'(10F12.1)') vol2,volume_last(upstream),volstep,volmax,inflow,outflow

! initial condition from previous timestep
y2=max((((vol2+vmax0)/par_k)**(1./par_alpha))-hmax0,0.)

!write(*,'(10F20.6)') y2,vol2,volstep,volmax,inflow,outflow

IF (vol2 > 0.) THEN
  time=(86400./nt)
ELSE
  time=(86400./nt)-((volmax-volstep)/inflow)
ENDIF

!write(*,'(10F20.6)') time,volmax,volstep,inflow

!write(*,'(2I6,10F20.6)') i,n,y2,elev,volact(step,upstream),inflow,outflow

ninterac=60
frtime=0.
error=1.
dummy1=outflow
dummy2=y2
!inflow_mean=0. TODO: unnecessary?
outflow_mean=0.

! loop over sub-steps
DO i=1,ninterac
  frtime=frtime+(time/ninterac)
  inflow_t=inflow*(time/ninterac)

!write(*,'(I6,10F20.6)') i,frtime,inflow_t

  y1=y2
  vol1=max((par_k*((hmax0+y1)**par_alpha))-vmax0,0.)

!write(*,'(I6,10F13.3)') i,y1,y2,vol1,vol2,volmax

  ! predictor-corrector until convergence (?)
  n=0
  DO WHILE (ABS(error) > 0.001)
    n=n+1
	dvol=inflow_t-((outflow+dummy1)*(time/ninterac)/2.)
	vol2=max(vol1+dvol,0.)
!write(*,'(5F12.3)')frtime,inflow,outflow,dummy1,dvol
	y2=max((((vol2+vmax0)/par_k)**(1./par_alpha))-hmax0,0.)
	dummy1=par_c*(y2**par_d) ! outflow m3/s

!if(upstream==29)write(*,'(I4,8F9.1)')upstream,frtime,y1,y2,vol1,vol2,dummy1,hmax0,vmax0
! boundary condition for constant inflow
!******************************************************************************************
    IF (dummy1*(time/ninterac)>inflow_t*(time/ninterac)+vol1 .or. y2==0. .or. n>=10) THEN !tp corrected units, Feb 2018
	 dummy1=inflow
     y2=0.
	 vol2=0.
	 error=0.
!write(*,*)frtime,inflow,dummy1
!write(*,'(2I6,10F20.6)') i,n,frtime,inflow,inflow_t,y1,vol1,dvol,vol2,y2,dummy1,error
!if(upstream==29)write(*,'(I4,F10.1,F10.3,3F12.3,2F8.3)')upstream,frtime,inflow,inflow_t,vol1,vol2,y2,dummy1
	 exit
!else
!if(upstream==29)write(*,'(I4,F10.1,F10.3,3F12.3,2F8.3)')upstream,frtime,inflow,inflow_t,vol1,vol2,y2,dummy1
	ENDIF
!******************************************************************************************
	error=y2-dummy2
	dummy2=y2
!write(*,'(2I6,10F20.6)') i,n,frtime,inflow,inflow_t,y1,vol1,dvol,vol2,y2,dummy1,error
  ENDDO
!write(*,*)frtime,inflow,dummy1
  outflow=dummy1
  outflow_mean=outflow_mean+outflow*(time/ninterac) ! cumulated outflow over sub-steps in m3
  !inflow_mean=inflow_mean+inflow*(time/ninterac) TODO: unnecessary?
  error=1.

  outflow_last(upstream)=outflow
ENDDO

overflow(step,upstream)=outflow_mean
volume_last(upstream)=vol2
volact(step,upstream)=volmax+vol2 ! current reservoir volume in m3

!write(*,'(I4,10F15.3)')upstream,frtime,overflow(step,upstream)/86400.,outflow_last(upstream),volact(step,upstream)

RETURN
END SUBROUTINE reservoir_routing


subroutine getv()
! calculates the velocities in the grid by u = d(psi)/dy, v=-d(psi)/dx

    use vars
    use parallel

    implicit none

    integer :: i, j

    !calculate velocities
    !$OMP DO PRIVATE(j,i)
    do j=1,ny
        do i=1,nx
            if (j .gt. 1 .or. j .lt. ny) u(i,j) = (psi(i,j+1)-psi(i,j-1))/2./dy
            if (i .gt. 1 .or. i .lt. nx) v(i,j) = -(psi(i+1,j)-psi(i-1,j))/2./dx
        enddo
    enddo
    !$OMP END DO

    !apply top/bottom boundary conditions
    !$OMP SINGLE
    if (down .eq. MPI_PROC_NULL) u(:,1) = u(:,2)
    if (up .eq. MPI_PROC_NULL) u(:,ny)=u(:,ny-1)
    !$OMP END SINGLE

    !$OMP DO PRIVATE(j)
    do j=1,ny
        !apply side
        v(1,j) = v(2,j)
        v(nx,j)=v(nx-1,j)

        !ensure u and v are zero inside the object
        u(:,j)=u(:,j)*(1-mask(:,j))
        v(:,j)=v(:,j)*(1-mask(:,j))
    enddo
    !$OMP END DO

end subroutine