!******************************************************************************
!
!    mfunctions.f95 (part of doptomog package v2.0)
!    Copyright (C) 2015  Enrico J. Kotze ejk@saao.ac.za
!
!    This program is free software: you can redistribute it and/or modify
!    it under the terms of the GNU General Public License as published by
!    the Free Software Foundation, either version 3 of the License, or
!    (at your option) any later version.
!
!    This program is distributed in the hope that it will be useful,
!    but WITHOUT ANY WARRANTY; without even the implied warranty of
!    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!    GNU General Public License for more details.
!
!    You should have received a copy of the GNU General Public License
!    along with this program.  If not, see <http://www.gnu.org/licenses/>.
!
!******************************************************************************
module mfunctions
!******************************************************************************

!******************************************************************************
	use mconstants
	implicit none
!******************************************************************************

!******************************************************************************
contains
!******************************************************************************

!******************************************************************************
	subroutine polarCoords(x, y, vphi, r)

		! determine polar coordinates
		real(kind(1d0)), intent(in)		::	x, y
		double precision, intent(out)	::	vphi, r
		integer							::	Q

		! calculate radius
		r = sqrt(x**2 + y**2)
		! get quadrant
		Q = quadrant(x, y)
		! calculate vphi
		vphi = 0.
		if (x /= 0) then
			vphi = atan(y / x) + int(0.5 * Q) * PI
		else
			select case (Q)
			case(1)
				vphi = 0.5d0 * PI
			case(4)
				vphi = 1.5d0 * PI
			end select
		end if

		return

	end subroutine polarCoords
!******************************************************************************

!******************************************************************************
	subroutine sphericalCoords(x, y, z, theta, vphi, r)

		! determine polar coordinates
		real(kind(1d0)), intent(in)		::	x, y, z
		double precision, intent(out)	::	theta, vphi, r
		integer							::	Q

		! calculate radius
		r = sqrt(x**2 + y**2 + z**2)
		! calculate theta (polar angle)
		theta = acos(z / r)
		! get xy-quadrant
		Q = quadrant(x, y)
		! calculate vphi (azimuthal angle)
		vphi = 0.
		if (x /= 0) then
			vphi = atan(y / x) + int(0.5 * Q) * PI
		else
			select case (Q)
			case(1)
				vphi = 0.5d0 * PI
			case(4)
				vphi = 1.5d0 * PI
			end select
		end if

		return

	end subroutine sphericalCoords
!******************************************************************************

!******************************************************************************
	integer function quadrant(x, y)

		real(kind(1d0)), intent(in)		::	x, y
		! determine quadrant
		if (x >= 0 .and. y >= 0) quadrant = 1
		if (x <  0 .and. y >= 0) quadrant = 2
		if (x <  0 .and. y <  0) quadrant = 3
		if (x >= 0 .and. y <  0) quadrant = 4

		return

	end function quadrant
!******************************************************************************

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

!******************************************************************************
	subroutine inoutCoords(vmax, dv, v, vprime)

		! determine inside-out coordinates
		real(kind(1d0)), intent(in)					::	vmax, dv, v
		real(kind(1d0)), intent(out)				::	vprime

		! determine inside-out coordinates
		! linearly scaled inside-out
		vprime = max((vmax + 0.5d0 * dv) - v, 0d0)

		return

	end subroutine inoutCoords
!******************************************************************************

!******************************************************************************
	subroutine interpolate(x1, y1, m, x2, y2, n)

		integer, intent(in)								::	m, n
		real(kind(1d0)), dimension(m), intent(in)		::	x1(m)
		real(kind(1d0)), dimension(0:m), intent(in)		::	y1(0:m)
		real(kind(1d0)), dimension(n), intent(in)		::	x2(n)
		real(kind(1d0)), dimension(0:n), intent(out)	::	y2(0:n)
		integer											::	i, j

		y2 = 0d0
		do j = 1, n
			do i = 1, m
				if (x2(j) == x1(i)) then
					y2(j) = y1(i)
					exit
				end if
				if(x2(j) < x1(i)) then
					! interpolate
					y2(j) = y1(i-1) + &
						(y1(i) - y1(i-1)) * (x2(j) - x1(i-1)) / (x1(i) - x1(i-1))
					exit
				end if
			end do
		end do

		return

	end subroutine interpolate
!******************************************************************************

!******************************************************************************
	subroutine interpolate1(n, arrA, arrB, x, y)

		! This subroutine interpolates arrB for a value x from arrA
		integer, intent(in)								::	n
		real(kind(1d0)), intent(in), dimension(n)		::	arrA, arrB
		real(kind(1d0)), intent(in)						::	x
		real(kind(1d0)), intent(out)					::	y
		real(kind(1d0))									::	a1, a2, b1, b2
		integer											::	i

		y = 0.; a1 = 0.; a2 = 0.; b1 = 0.; b2 = 0.
		do i = 2, n
			a1 = arrA(i); a2 = arrA(i-1)
			b1 = arrB(i); b2 = arrB(i-1)
			select case (a1 < x)
			case (.TRUE.)
				! do nothing, continue with do loop...
			case (.FALSE.)
				select case (a1 == x)
				case (.TRUE.)
					y = b1
					return
				case (.FALSE.)
					y = b2 + (x - a2) * (b1 - b2) / (a1 - a2)
					return
				end select
			end select
		end do

		return

	end subroutine interpolate1
!******************************************************************************

!******************************************************************************
	subroutine multivariateLeastSquares(m, y, x, a)

		! multivariate least squares fit y = a0 + a1*x1 + a2*x2 + ... + am*xm
		integer, intent(in)								::	m
		real(kind(1d0)), intent(in)						::	y
		real(kind(1d0)), intent(in), dimension(0:m)		::	x
		real(kind(1d0)), intent(out), dimension(0:m)	::	a
		real(kind(1d0)), dimension(m+1,m+1)				::	aX
		real(kind(1d0)), dimension(m+1,1)				::	aY
		integer											::	i, j

		a = 0d0; aX = 0d0; aY = 0d0
		do i = 0, m
			do j = 0, m
				aX(i+1,j+1) = aX(i+1,j+1) + x(i) * x(j)
			end do
			aY(i+1,1) = aY(i+1,1) + y * x(i)
		end do
		aX = aX / dble(m + 1)
		aY = aY / dble(m + 1)
		call gaussj(aX, m, m, aY, 1, 1)
		do i = 0, m
			a(i) = round(aY(i+1,1), 6)
		end do

		return

	end subroutine multivariateLeastSquares
!******************************************************************************

!******************************************************************************
	real function round(a, dec)

		real(kind(1d0)), intent(in)	::	a
		integer, intent(in)			::	dec
		real(kind(1d0))				::	b

		b = a / abs(a)
		round = b * float(int(abs(a) * 10**dec + 0.5)) / 10**dec

		return

	end function round
!******************************************************************************

!******************************************************************************
	SUBROUTINE piksrt(n,arr,arr_ind)
		! Sorts an array arr(1:n) into ascending numerical order, by straight
		! insertion.
		! n is input; arr is replaced on output by its sorted rearrangement.
		INTEGER n
		REAL(kind(1d0)) arr(n),arr_ind(n)
		INTEGER i,j
		REAL(kind(1d0)) a,ind

		do j=2,n						! Pick out each element in turn.
			a=arr(j)
			ind=arr_ind(j)
			do i=j-1,1,-1				! Look for the place to insert it.
				if(arr(i).le.a) goto 10
				arr(i+1)=arr(i)
				arr_ind(i+1)=arr_ind(i)
			end do
			i=0
 	10		arr(i+1)=a					! Insert it.
 			arr_ind(i+1)=ind
		end do

		return

	END SUBROUTINE piksrt
!******************************************************************************

!******************************************************************************
	FUNCTION ran1(idum)

		! “Minimal” random number generator of Park and Miller with Bays-Durham
		! shuffle and added safeguards. Returns a uniform random deviate between
		! 0.0 and 1.0 (exclusive of the endpoint values). Call with idum a
		! negative integer to initialize; thereafter, do not alter idum between
		! successive deviates in a sequence. RNMX should approximate the largest
		! floating value that is less than 1.
		INTEGER idum,IA,IM,IQ,IR,NTAB,NDIV
		REAL ran1,AM,EPS,RNMX
		PARAMETER (IA=16807,IM=2147483647,AM=1./IM,IQ=127773,IR=2836)
		PARAMETER (NTAB=32,NDIV=1+(IM-1)/NTAB,EPS=1.2e-7,RNMX=1.-EPS)
		INTEGER j,k,iv(NTAB),iy
		SAVE iv,iy
		DATA iv /NTAB*0/, iy /0/

		if (idum.le.0.or.iy.eq.0) then
			idum=max(-idum,1)
			do j=NTAB+8,1,-1
				k=idum/IQ
				idum=IA*(idum-k*IQ)-IR*k
				if (idum.lt.0) idum=idum+IM
				if (j.le.NTAB) iv(j)=idum
			end do
			iy=iv(1)
		end if
		k=idum/IQ
		idum=IA*(idum-k*IQ)-IR*k
		if (idum.lt.0) idum=idum+IM
		j=1+iy/NDIV
		iy=iv(j)
		iv(j)=idum
		ran1=min(AM*iy,RNMX)

		return

	END FUNCTION ran1
!******************************************************************************

!******************************************************************************
	SUBROUTINE gaussj(a,n,nr,b,m,mr)

		! Linear equation solution by Gauss-Jordan elimination.
		! a(1:n,1:n) is an input matrix stored in an array of physical
		! dimensions nr by nr.
		! b(1:n,1:m) is an input matrix containing the m right-hand side
		! vectors, stored in an array of physical dimensions nr by mr.
		! On output, a(1:n,1:n) is replaced by its matrix inverse, and
		! b(1:n,1:m) is replaced by the corresponding set of solution vectors.
		! Parameter: NMAX is the largest anticipated value of n.
		!USE nrtype; USE nrutil, ONLY : nrerror
		INTEGER m,mr,n,nr,NMAX
		REAL(kind(1d0)) a(nr,nr),b(nr,mr)
		PARAMETER (NMAX=50)
		INTEGER i,icol,irow,j,k,l,ll,indxc(NMAX),indxr(NMAX),ipiv(NMAX)
		! The integer arrays ipiv, indxr and indxc are used for bookkeeping on
		! the pivoting.
		REAL big,dum,pivinv

		do j=1,n
			ipiv(j)=0
		enddo
		do i=1,n		! This is the main loop over the columns to be reduced.
			big=0.
			do j=1,n	! This is the outer loop of the search for a pivot element.
				if(ipiv(j).ne.1) then
					do k=1,n
						if (ipiv(k).eq.0) then
							if (abs(a(j,k)).ge.big) then
								big=abs(a(j,k))
								irow=j
								icol=k
							endif
						else if (ipiv(k).gt.1) then
							!pause 'singular matrix in gaussj'
							call nrerror('gaussj: singular matrix (1)')
						endif
					enddo
				endif
			enddo
			ipiv(icol)=ipiv(icol)+1
			! We now have the pivot element, so we interchange rows, if needed,
			! to put the pivot	element on the diagonal. The columns are not
			! physically interchanged, only relabeled:
			! indxc(i), the column of the ith pivot element, is the ith column
			! that is reduced, while indxr(i) is the row in which that pivot
			! element was originally located. If indxr(i)<>indxc(i) there is an
			! implied column interchange. With this form of bookkeeping, the
			! solution b's will end up in the correct order, and the inverse
			! matrix will be scrambled by columns.
			if (irow.ne.icol) then
				do l=1,n
					dum=a(irow,l)
					a(irow,l)=a(icol,l)
					a(icol,l)=dum
				enddo
				do l=1,m
					dum=b(irow,l)
					b(irow,l)=b(icol,l)
					b(icol,l)=dum
				enddo
			endif
			indxr(i)=irow		! We are now ready to divide the pivot row by
			indxc(i)=icol		! the pivot element, located at irow and icol.
			!if (a(icol,icol).eq.0.) pause 'singular matrix in gaussj'
			if (a(icol,icol).eq.0.) &
				call nrerror('gaussj: singular matrix (2)')
			pivinv=1./a(icol,icol)
			a(icol,icol)=1.
			do l=1,n
				a(icol,l)=a(icol,l)*pivinv
			enddo
			do l=1,m
				b(icol,l)=b(icol,l)*pivinv
			enddo
			do ll=1,n				! Next, we reduce the rows...
				if(ll.ne.icol) then	! ...except for the pivot one, of course.
					dum=a(ll,icol)
					a(ll,icol)=0.
					do l=1,n
						a(ll,l)=a(ll,l)-a(icol,l)*dum
					enddo
					do l=1,m
						b(ll,l)=b(ll,l)-b(icol,l)*dum
					enddo
				endif
			enddo
		enddo		! End of the main loop over columns of the reduction.
		do l=n,1,-1
			! It only remains to unscramble the solution in view of the column
			! interchanges. We do this by interchanging pairs of columns in the
			! reverse order that the permutation was built up.
			if(indxr(l).ne.indxc(l)) then
				do k=1,n
					dum=a(k,indxr(l))
					a(k,indxr(l))=a(k,indxc(l))
					a(k,indxc(l))=dum
				enddo
			endif
		enddo

		return			! And we are done.

	END SUBROUTINE gaussj
!******************************************************************************

!******************************************************************************
	SUBROUTINE nrerror(string)

		! Report a message, then die.
		CHARACTER(LEN=*), INTENT(IN)	::	string

		write (*, *) 'nrerror: ', string
		STOP 'program terminated by nrerror'

	END SUBROUTINE nrerror
!******************************************************************************

!******************************************************************************
	SUBROUTINE pause_here

		! subroutine to pause program; requiring user to re-initiate execution
		IMPLICIT NONE
		CHARACTER :: PAUSE

		WRITE(*,'(A)', ADVANCE = 'NO') 'Press < ENTER > to continue ==>'
		READ(*,'(A)') PAUSE

	END SUBROUTINE pause_here
!******************************************************************************

!******************************************************************************
end module mfunctions
!******************************************************************************

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