  module m_select
    !! Perform a quickselect on an array. Quick select finds the kth smallest number in an array. It also puts values lower than the kth on the left, and those higher on the right
    !! This makes it perfect for finding the median.
  use variableKind

  implicit none

  private

  public  :: select

  interface select
    !!Use an in-place quick select on an array of numbers
    !!
    !!Example usage
    !!```fortran
    !!program selectTest
    !!use variableKind
    !!use m_strings, only: str
    !!use m_allocate, only: allocate
    !!use m_random, only: rngInteger,rngNormal
    !!use m_select, only: select
    !!real(r64),allocatable :: d1D(:)
    !!integer(i32),allocatable :: i1D(:)
    !!integer(i32) :: k
    !!real(r64) :: dv
    !!integer(i32) :: iv
    !!
    !!write(*,'(a)') 'Select the kth smallest element from a 10000 length array of random double precision numbers'
    !!call allocate(d1D, 10000)
    !!call rngNormal(d1D)
    !!k = (1+size(d1D))/2
    !!dv = select(d1D,k)
    !!write(*,'(a)') 'kth element? '//str(dv)
    !!write(*,'(a)') 'Select the kth smallest element from a 10000 length array of random integers''
    !!call allocate(i1D, 10000)
    !!call rngInteger(i1D)
    !!iv = select(i1D, k)
    !!write(*,'(a)') 'kth element? '//str(iv)
    !!end program
    !!```
    module subroutine quickSelect_i1D(this, k, res)
      !! Interfaced with select()
      integer(i32), intent(inout) :: this(:) !! Array to choose kth smallest from
      integer(i32), intent(in) :: k !! kth smallest element
      integer(i32) :: res
    end subroutine
    module subroutine quickSelect_id1D(this, k, res)
      !! Interfaced with select()
      integer(i64), intent(inout) :: this(:) !! Array to choose kth smallest from
      integer(i32), intent(in) :: k !! kth smallest element
      integer(i64) :: res
    end subroutine
    module subroutine quickSelect_r1D(this, k, res)
      !! Interfaced with select()
      real(r32), intent(inout) :: this(:) !! Array to choose kth smallest from
      integer(i32), intent(in) :: k !! kth smallest element
      real(r32) :: res
    end subroutine
    module subroutine quickSelect_d1D(this, k, res)
      !! Interfaced with select()
      real(r64), intent(inout) :: this(:) !! Array to choose kth smallest from
      integer(i32), intent(in) :: k !! kth smallest element
      real(r64) :: res
    end subroutine
  end interface

  public :: argSelect

  interface argSelect
    !!Use an indirect introspection sort on an array of numbers
    !!
    !!Example usage
    !!```fortran
    !!program argSortTest
    !!use variableKind
    !!use m_strings, only: str
    !!use m_random, only: rngInteger,rngNormal
    !!use m_arrays, only: isSorted
    !!use m_Sort, only: argSort
    !!real(r64),allocatable :: d1D(:)
    !!integer(i32),allocatable :: i1D(:)
    !!integer(i32),allocatable :: indx(:)
    !!integer(i32) :: i, k, N
    !!N = 10000
    !!call allocate(indx,N)
    !!call arange(indx, 1, N)
    !!call allocate(d1D,N)
    !!call rngNormal(d1D)
    !!k = (size(d1D)+1)/2
    !!call argSelect(d1D, indx, k)
    !!write(*,'(a)') 'Double array is indirectly sorted? '//str(isSorted(d1D(indx)))
    !!
    !!call arange(indx, 1, N)
    !!call allocate(i1D,N)
    !!call rngInteger(i1D)
    !!call argSelectt(i1D, indx, k)
    !!write(*,'(a)') 'Integer array is indirectly sorted? '//str(isSorted(i1D(indx)))
    !!end program
    !!```
    module subroutine argQuickSelect_i1D(this, indx, k, res, left, right)
      !! Interfaced with argSelect()
      integer(i32), intent(in) :: this(:) !! 1D array
      integer(i32), intent(inout) :: indx(:) !! Index to choose kth smallest from
      integer(i32), intent(in) :: k !! kth smallest element
      integer(i32) :: res !! Index of the kth smallest element
      integer(i32), intent(in), optional :: left !! Select over the region left:right
      integer(i32), intent(in), optional :: right !! Select over the region left:right
    end subroutine
    module subroutine argQuickSelect_id1D(this, indx, k, res, left, right)
      !! Interfaced with argSelect()
      integer(i64), intent(in) :: this(:) !! 1D array
      integer(i32), intent(inout) :: indx(:) !! Index to choose kth smallest from
      integer(i32), intent(in) :: k  !! kth smallest element
      integer(i32) :: res !! Index of the kth smallest element
      integer(i32), intent(in), optional :: left !! Select over the region left:right
      integer(i32), intent(in), optional :: right !! Select over the region left:right
    end subroutine
    module subroutine argQuickSelect_r1D(this, indx, k, res, left, right)
      !! Interfaced with argSelect()
      real(r32), intent(in) :: this(:) !! 1D array
      integer(i32), intent(inout) :: indx(:) !! Index to choose kth smallest from
      integer(i32), intent(in) :: k !! kth smallest element
      integer(i32) :: res !! Index of the kth smallest element
      integer(i32), intent(in), optional :: left !! Select over the region left:right
      integer(i32), intent(in), optional :: right !! Select over the region left:right
    end subroutine
    module subroutine argQuickSelect_d1D(this, indx, k, res, left, right)
      !! Interfaced with argSelect()
      real(r64), intent(in) :: this(:) !! 1D array
      integer(i32), intent(inout) :: indx(:) !! Index to choose kth smallest from
      integer(i32), intent(in) :: k!! kth smallest element
      integer(i32) :: res !! Index of the kth smallest element
      integer(i32), intent(in), optional :: left !! Select over the region left:right
      integer(i32), intent(in), optional :: right !! Select over the region left:right
    end subroutine
  end interface

  end module


PROGRAM EXAMPLE

!  -- LAPACK95 EXAMPLE DRIVER ROUTINE (VERSION 1.0) --
!     UNI-C, DENMARK
!     DECEMBER, 1999
!
!  .. "Use Statements" ..
USE LA_PRECISION, ONLY: WP => dp
USE F95_LAPACK, ONLY: LA_GESVX
!  .. "Implicit Statement" ..
IMPLICIT NONE
!  .. "Local Scalars" ..
INTEGER :: I, J, N, NRHS, u, info
!  .. "Local Arrays" ..
INTEGER, ALLOCATABLE :: IPIV(:)
REAL(WP) :: RCOND, RPVGRW
REAL(WP), ALLOCATABLE :: A(:,:), AA(:,:), B(:,:), X(:,:),BB(:,:), FERR(:), BERR(:)
REAL(WP), ALLOCATABLE :: RR(:,:)
character(1024) :: argv

!  .. "Executable Statements" ..
print *, 'SGESVX Example Program Results.'

N = 4
NRHS = 3

ALLOCATE( A(N,N), AA(N,N), B(N,NRHS), X(N,NRHS),BB(N,NRHS), IPIV(N), RR(N,N), FERR(NRHS), BERR(NRHS) )

call get_command_argument(1,argv)

OPEN(newunit=u,FILE=trim(argv)//'/gesv.ma',STATUS='old')
DO J=1,N
DO I=1,N
   READ(u,'(F2.0)') AA(I,J)
ENDDO
ENDDO
CLOSE(u)

!      DO I = 1, N; READ (*, *) (RR(I, J), J = 1, N); ENDDO
!      AA=RR

DO J = 1, NRHS; BB(:,J) = SUM( AA, DIM=2)*J; ENDDO

print *, 'The matrix A:'
DO I=1,N; WRITE(*,"(4(I3,1X),I3,1X)") INT(AA(I,:)); ENDDO

print *, 'The RHS matrix B:'
DO I=1,N; WRITE(*,"(2(I3,1X),I3,1X)") INT(BB(I,:)); ENDDO

A=AA; B=BB
CALL LA_GESVX( A, B, X, FERR=FERR, BERR=BERR, RCOND=RCOND, RPVGRW=RPVGRW, info=info )

print *, 'FERR = ', FERR
print *, 'BERR = ', BERR
print *, 'RCOND = ', RCOND
print *, 'RPVGRW = ', RPVGRW

print *, '\noindent'
print *, 'The solution of the system $ A\,X = B $ is:'
print *, '$$ X = \left( \begin{array}{rrr}'
DO I=1,N; WRITE(*,"(2(F9.5,' & '),F9.5,' \\')") X(I,:); ENDDO
print *, '\end{array} \right). $$'

stop info

END PROGRAM


module math_vars
implicit none
	integer, parameter :: nfac = 301
	real(kind=8) :: fact(0:nfac)
	real(kind=8) :: identity(4,4)

	real(kind=8), parameter :: L_weideman = 2.2248028d0
	real(kind=8), parameter :: a_weideman(7) = (/1.0547115,0.60504614,0.20181603,0.0080914418,-0.021688188,-0.0038423489,0.0030903311/)
end module math_vars

module math_functions
use math_vars
use vars
implicit none
contains

!----------------------------------------------------------------
! Calculates the factorial of the integers up to 301 and save it into the fact array
!----------------------------------------------------------------
   subroutine factrl
	integer :: i
      fact(0) = 1.d0
      do i=1,301
			fact(I) = fact(I-1) * dble(I)
		enddo
   END subroutine factrl

!----------------------------------------------------------------
! This function calculates the 3-j symbol
! J_i and M_i have to be twice the actual value of J and M
!----------------------------------------------------------------
   function w3js(j1,j2,j3,m1,m2,m3)
   integer :: m1, m2, m3, j1, j2, j3
	integer :: ia, ib, ic, id, ie, im, ig, ih, z, zmin, zmax, jsum
	real(kind=8) :: w3js, cc, denom, cc1, cc2

!		w3js = w3js_regge(j1/2,j2/2,j3/2,m1/2,m2/2,m3/2)
!		return
      w3js = 0.d0
      if (m1+m2+m3 /= 0) return
      ia = j1 + j2
      if (j3 > ia) return
      ib = j1 - j2
      if (j3 < abs(ib)) return
		if (abs(m1) > j1) return
		if (abs(m2) > j2) return
		if (abs(m3) > j3) return

      jsum = j3 + ia
      ic = j1 - m1
      id = j2 - m2

		ie = j3 - j2 + m1
		im = j3 - j1 - m2
		zmin = max0(0,-ie,-im)
		ig = ia - j3
		ih = j2 + m2
		zmax = min0(ig,ih,ic)
		cc = 0.d0

		do z = zmin, zmax, 2
			denom = fact(z/2)*fact((ig-z)/2)*fact((ic-z)/2)*fact((ih-z)/2)*&
				fact((ie+z)/2)*fact((im+z)/2)
      	if (mod(z,4) /= 0) denom = -denom
			cc = cc + 1.d0/denom
		enddo

		cc1 = fact(ig/2)*fact((j3+ib)/2)*fact((j3-ib)/2)/fact((jsum+2)/2)
      cc2 = fact((j1+m1)/2)*fact(ic/2)*fact(ih/2)*fact(id/2)*fact((j3-m3)/2)*fact((j3+m3)/2)
      cc = cc * sqrt(1.d0*cc1*cc2)
		if (mod(ib-m3,4) /= 0) cc = -cc
		w3js = cc
		if (abs(w3js) < 1.d-8) w3js = 0.d0
1000 		return
   end function w3js

!--------------------------------------------------------------
! Generates Voigt and anomalous dispersion profiles
! See Humlicek (1982) JQSRT 27, 437
!--------------------------------------------------------------
	function fvoigt(da, dv)
	real*8 :: da
	real*8 :: dv(:), fvoigt(size(dv))
	complex :: w4, z, t, u, v4
	real*8 :: s
	integer :: i, n

		n = size(dv)
		do i = 1, n
			z = cmplx(dv(i), da)
			t = cmplx(da, -dv(i))
			s = dabs(dv(i)) + da
			u = t*t

			if (s >= 15.d0) then
				w4 = t * 0.5641896d0 / (0.5d0+u)
			elseif (s >= 5.5) then
				w4 = t*(1.410474d0+u*0.5641896d0)/(0.75d0+u*(3.d0+u))
			elseif (da >= 0.195d0*dabs(dv(i))-0.176d0) then
				w4 = (16.4955d0+t*(20.20933d0+t*(11.96482d0+t*(3.778987d0+t*0.5642236d0)))) / &
					(16.4955d0+t*(38.82363d0+t*(39.27121d0+t*(21.69274d0+t*(6.699398d0+t)))))
			else
				w4 = t*(36183.31d0-u*(3321.9905d0-u*(1540.787d0-u*(219.0313d0-u*(35.76683d0-&
					u*(1.320522d0-u*0.56419d0))))))
				v4 = (32066.6d0-u*(24322.84d0-u*(9022.228d0-u*(2186.181d0-u*(364.2191d0-&
					u*(61.57037d0-u*(1.841439d0-u)))))))
				w4 = cexp(u) - w4/v4
			endif
			fvoigt(i) = dble(w4)
		enddo

end function fvoigt

!--------------------------------------------------------------
! Generates Voigt and anomalous dispersion profiles
! See Humlicek (1982) JQSRT 27, 437
!--------------------------------------------------------------
	function fvoigt_zeeman(da, dv)
	real*8 :: da
	real*8 :: dv(:), fvoigt_zeeman(2,size(dv))
	complex :: w4, z, t, u, v4
	real*8 :: s
	integer :: i, n

		n = size(dv)
		do i = 1, n
			z = cmplx(dv(i), da)
			t = cmplx(da, -dv(i))
			s = dabs(dv(i)) + da
			u = t*t

			if (s >= 15.d0) then
				w4 = t * 0.5641896d0 / (0.5d0+u)
			elseif (s >= 5.5) then
				w4 = t*(1.410474d0+u*0.5641896d0)/(0.75d0+u*(3.d0+u))
			elseif (da >= 0.195d0*dabs(dv(i))-0.176d0) then
				w4 = (16.4955d0+t*(20.20933d0+t*(11.96482d0+t*(3.778987d0+t*0.5642236d0)))) / &
					(16.4955d0+t*(38.82363d0+t*(39.27121d0+t*(21.69274d0+t*(6.699398d0+t)))))
			else
				w4 = t*(36183.31d0-u*(3321.9905d0-u*(1540.787d0-u*(219.0313d0-u*(35.76683d0-&
					u*(1.320522d0-u*0.56419d0))))))
				v4 = (32066.6d0-u*(24322.84d0-u*(9022.228d0-u*(2186.181d0-u*(364.2191d0-&
					u*(61.57037d0-u*(1.841439d0-u)))))))
				w4 = cexp(u) - w4/v4
			endif
			fvoigt_zeeman(1,i) = dble(w4)
			fvoigt_zeeman(2,i) = aimag(w4)
		enddo

	end function fvoigt_zeeman

!--------------------------------------------------------------
! Generates Voigt and anomalous dispersion profiles using a different damping for each frequency
! point
! See Humlicek (1982) JQSRT 27, 437
!--------------------------------------------------------------
	function vecfvoigt(da, dv)
	real*8 :: da(:)
	real*8 :: dv(:), vecfvoigt(size(dv))
	complex :: w4, z, t, u, v4
	real*8 :: s
	integer :: i, n

		n = size(dv)
		do i = 1, n
! There is a problem for very small dampings. We force it to be 0 using a threshold
			if (da(i) < 1.d-3) da(i) = 0.d0
			z = cmplx(dv(i), da(i))
			t = cmplx(da(i), -dv(i))
			s = dabs(dv(i)) + da(i)
			u = t*t

			if (s >= 15.d0) then
				w4 = t * 0.5641896d0 / (0.5d0+u)
			elseif (s >= 5.5) then
				w4 = t*(1.410474d0+u*0.5641896d0)/(0.75d0+u*(3.d0+u))
			elseif (da(i) >= 0.195d0*dabs(dv(i))-0.176d0) then
				w4 = (16.4955d0+t*(20.20933d0+t*(11.96482d0+t*(3.778987d0+t*0.5642236d0)))) / &
					(16.4955d0+t*(38.82363d0+t*(39.27121d0+t*(21.69274d0+t*(6.699398d0+t)))))
			else
				w4 = t*(36183.31d0-u*(3321.9905d0-u*(1540.787d0-u*(219.0313d0-u*(35.76683d0-&
					u*(1.320522d0-u*0.56419d0))))))
				v4 = (32066.6d0-u*(24322.84d0-u*(9022.228d0-u*(2186.181d0-u*(364.2191d0-&
					u*(61.57037d0-u*(1.841439d0-u)))))))
				w4 = cexp(u) - w4/v4
			endif
			vecfvoigt(i) = dble(w4)
		enddo

	end function vecfvoigt

!--------------------------------------------------------------
! Generates Voigt and anomalous dispersion profiles using a different damping for each frequency
! point
! See Humlicek (1982) JQSRT 27, 437
!--------------------------------------------------------------
	function vecfvoigt_zeeman(da, dv)
	real*8 :: da(:)
	real*8 :: dv(:), vecfvoigt_zeeman(2,size(dv))
	complex :: w4, z, t, u, v4
	real*8 :: s
	integer :: i, n

		n = size(dv)
		do i = 1, n
! There is a problem for very small dampings. We force it to be 0 using a threshold
			if (da(i) < 1.d-3) da(i) = 0.d0
			z = cmplx(dv(i), da(i))
			t = cmplx(da(i), -dv(i))
			s = dabs(dv(i)) + da(i)
			u = t*t

			if (s >= 15.d0) then
				w4 = t * 0.5641896d0 / (0.5d0+u)
			elseif (s >= 5.5) then
				w4 = t*(1.410474d0+u*0.5641896d0)/(0.75d0+u*(3.d0+u))
			elseif (da(i) >= 0.195d0*dabs(dv(i))-0.176d0) then
				w4 = (16.4955d0+t*(20.20933d0+t*(11.96482d0+t*(3.778987d0+t*0.5642236d0)))) / &
					(16.4955d0+t*(38.82363d0+t*(39.27121d0+t*(21.69274d0+t*(6.699398d0+t)))))
			else
				w4 = t*(36183.31d0-u*(3321.9905d0-u*(1540.787d0-u*(219.0313d0-u*(35.76683d0-&
					u*(1.320522d0-u*0.56419d0))))))
				v4 = (32066.6d0-u*(24322.84d0-u*(9022.228d0-u*(2186.181d0-u*(364.2191d0-&
					u*(61.57037d0-u*(1.841439d0-u)))))))
				w4 = cexp(u) - w4/v4
			endif
			vecfvoigt_zeeman(1,i) = dble(w4)
			vecfvoigt_zeeman(2,i) = aimag(w4)
		enddo

	end function vecfvoigt_zeeman

!--------------------------------------------------------------
! Generates Voigt and anomalous dispersion profiles using a different damping for each frequency
! point
! See Humlicek (1982) JQSRT 27, 437
!--------------------------------------------------------------
	function vecfvoigt_zeeman2(da, dv)
	real*8 :: da(:)
	real*8 :: dv(:), vecfvoigt_zeeman2(2,size(dv))
	complex :: w4(size(dv)), z(size(dv)), t(size(dv)), u(size(dv)), v4(size(dv))
	real*8 :: s(size(dv))
	integer :: i, n

		n = size(dv)

!		allocate(w4(n))
!		allocate(z(n))
!		allocate(t(n))
!		allocate(u(n))
!		allocate(v4(n))
!		allocate(s(n))

		where(da < 1.d-3)
			da = 0.d0
		endwhere

		z = cmplx(dv,da)
		t = cmplx(da, -dv)
		s = dabs(dv) + da
		u = t*t

		where(s >= 15.d0)
			w4 = t * 0.5641896d0 / (0.5d0+u)
		endwhere
		where(s < 15.d0 .and. s >= 5.5d0)
			w4 = t*(1.410474d0+u*0.5641896d0)/(0.75d0+u*(3.d0+u))
		endwhere
		where(s < 15.d0 .and. s < 5.5d0 .and. da >= 0.195d0*dabs(dv)-0.176d0)
			w4 = (16.4955d0+t*(20.20933d0+t*(11.96482d0+t*(3.778987d0+t*0.5642236d0)))) / &
					(16.4955d0+t*(38.82363d0+t*(39.27121d0+t*(21.69274d0+t*(6.699398d0+t)))))
		endwhere
		where(s < 15.d0 .and. s < 5.5d0 .and. da < 0.195d0*dabs(dv)-0.176d0)
			w4 = t*(36183.31d0-u*(3321.9905d0-u*(1540.787d0-u*(219.0313d0-u*(35.76683d0-&
					u*(1.320522d0-u*0.56419d0))))))
			v4 = (32066.6d0-u*(24322.84d0-u*(9022.228d0-u*(2186.181d0-u*(364.2191d0-&
					u*(61.57037d0-u*(1.841439d0-u)))))))
			w4 = cexp(u) - w4/v4
		endwhere

		vecfvoigt_zeeman2(1,:) = dble(w4)
		vecfvoigt_zeeman2(2,:) = aimag(w4)

!		deallocate(w4)
!		deallocate(z)
!		deallocate(t)
!		deallocate(u)
!		deallocate(v4)
!		deallocate(s)

	end function vecfvoigt_zeeman2

!----------------------------------------------------------------
! This function returns the strength of the Zeeman components
!----------------------------------------------------------------
	function strength_zeeman(J_up,J_low,M_up,M_low)
	real(kind=8) :: J_up, J_low, M_up, M_low, strength_zeeman

		strength_zeeman = 3.d0 * w3js(int(2.d0*J_up),int(2.d0*J_low),2,-int(2.d0*M_up),&
					int(2.d0*M_low),-int(2.d0*(M_low-M_up)))**2
	end function strength_zeeman

!----------------------------------------------------------------
! This function initializes some things
!----------------------------------------------------------------
		subroutine init_maths
		integer :: i
			call factrl
      end subroutine init_maths

end module math_functions


!-------------------------------------------------------------------------------
! Copyright (c) 2019 FrontISTR Commons
! This software is released under the MIT License, see LICENSE.txt
!-------------------------------------------------------------------------------
!> \brief  This module contains functions for interpolation in 15 node
!!    prism element  (Langrange  interpolation)
module shape_prism15n
  implicit none
  integer, parameter, private :: kreal = kind(0.0d0)

contains
  subroutine ShapeFunc_prism15n(ncoord,shp)
    real(kind=kreal), intent(in)  :: ncoord(3)
    real(kind=kreal) :: shp(15)
    real(kind=kreal) :: xi,et,a,ze
    xi = ncoord(1);  et = ncoord(2)
    a=1.d0-xi-et
    ze = ncoord(3)
    shp(1)=0.5* a*(1.0-ze)*(2.0*a -2.0-ze)
    shp(2)=0.5*xi*(1.0-ze)*(2.0*xi-2.0-ze)
    shp(3)=0.5*et*(1.0-ze)*(2.0*et-2.0-ze)
    shp(4)=0.5* a*(1.0+ze)*(2.0*a -2.0+ze)
    shp(5)=0.5*xi*(1.0+ze)*(2.0*xi-2.0+ze)
    shp(6)=0.5*et*(1.0+ze)*(2.0*et-2.0+ze)
    shp(7)=2.0*xi*a*(1.0-ze)
    shp(8)=2.0*xi*et*(1.0-ze)
    shp(9)=2.0*et*a*(1.0-ze)
    shp(10)=2.0*xi*a*(1.0+ze)
    shp(11)=2.0*xi*et*(1.0+ze)
    shp(12)=2.0*et*a*(1.0+ze)
    shp(13)= a*(1.0-ze*ze)
    shp(14)=xi*(1.0-ze*ze)
    shp(15)=et*(1.0-ze*ze)
  end subroutine

  subroutine ShapeDeriv_prism15n(ncoord,func)
    real(kind=kreal), intent(in)  :: ncoord(3)
    real(kind=kreal) :: func(15,3)
    real(kind=kreal) :: xi,et,a,ze
    xi = ncoord(1);  et = ncoord(2)
    a=1.d0-xi-et
    ze = ncoord(3)
    !
    !     local derivatives of the shape functions: xi-derivative
    !
    func(1,1)= -0.5*(1.0-ze)*(4.0*a -ze-2.0)
    func(2,1)=  0.5*(1.0-ze)*(4.0*xi-ze-2.0)
    func(3,1)=  0.d0
    func(4,1)= -0.5*(1.0+ze)*(4.0*a +ze-2.0)
    func(5,1)=  0.5*(1.0+ze)*(4.0*xi+ze-2.0)
    func(6,1)=  0.d0
    func(7,1)=  2.0*(1.0-ze)*(1.0-2.0*xi-et)
    func(8,1)=  2.0*et*(1.0-ze)
    func(9,1)= -2.0*et*(1.0-ze)
    func(10,1)= 2.0*(1.0+ze)*(1.0-2.0*xi-et)
    func(11,1)= 2.0*et*(1.0+ze)
    func(12,1)= -2.0*et*(1.0+ze)
    func(13,1)= -(1.0-ze*ze)
    func(14,1)=  (1.0-ze*ze)
    func(15,1)=  0.d0
    !
    !     local derivatives of the shape functions: eta-derivative
    !
    func(1,2)=-0.5*(1.0-ze)*(4.0*a -ze-2.0)
    func(2,2)= 0.d0
    func(3,2)= 0.5*(1.0-ze)*(4.0*et-ze-2.0)
    func(4,2)=-0.5*(1.0+ze)*(4.0*a +ze-2.0)
    func(5,2)= 0.d0
    func(6,2)= 0.5*(1.0+ze)*(4.0*et+ze-2.0)
    func(7,2)=-2.0*xi*(1.0-ze)
    func(8,2)= 2.0*xi*(1.0-ze)
    func(9,2)= 2.0*(1.0-ze)*(1.0-xi-2.0*et)
    func(10,2)=-2.0*xi*(1.0+ze)
    func(11,2)= 2.0*xi*(1.0+ze)
    func(12,2)= 2.0*(1.0+ze)*(1.0-xi-2.0*et)
    func(13,2)=-(1.0-ze*ze)
    func(14,2)= 0.0d0
    func(15,2)= (1.0-ze*ze)
    !
    !     local derivatives of the shape functions: zeta-derivative
    !
    func(1,3)=  a*(xi+et+ze-0.5)
    func(2,3)= xi*(-xi+ze+0.5)
    func(3,3)= et*(-et+ze+0.5)
    func(4,3)=  a*(-xi-et+ze+0.5)
    func(5,3)= xi*(xi+ze-0.5)
    func(6,3)= et*(et+ze-0.5)
    func(7,3)= -2*xi*a
    func(8,3)= -2*xi*et
    func(9,3)= -2*et*a
    func(10,3)= 2*xi*a
    func(11,3)= 2*xi*et
    func(12,3)= 2*et*a
    func(13,3)=-2*a*ze
    func(14,3)=-2*xi*ze
    func(15,3)=-2*et*ze
  end subroutine

end module


      subroutine mapc2m_annulus2(xc,yc,xp,yp,zp)
      implicit none

      double precision xc,yc,xp,yp,zp

      double precision theta, r

      call map_comp2annulus(xc,yc,theta,r)

      xp = r*cos(theta)
      yp = r*sin(theta)
      zp = 0

      end


rho1 = 2.30485d-6*1d0/mbh*r**1.5d0/(alpha*cgs_kapes**3*mdot**2*f(r)**2)
T1 = 4.61893d+7*alpha**(-0.25d0)*cgs_kapes**(-0.25d0)*mbh**(-0.25d0)*r** &
      (-0.375d0)
H1 = 982981.0d0*cgs_kapes*mbh**1.0d0*mdot*f(r)
rho2 = 21.9208d0*alpha**(-0.7d0)*cgs_kapes**(-0.3d0)*mbh**(-0.7d0)*mdot &
      **0.4d0*r**(-1.65d0)*f(r)**0.4d0
T2 = 6.72321d+8*alpha**(-0.2d0)*cgs_kapes**0.2d0*mbh**(-0.2d0)*mdot** &
      0.4d0*r**(-0.9d0)*f(r)**0.4d0
H2 = 4639.53d0*alpha**(-0.1d0)*cgs_kapes**0.1d0*mbh**0.9d0*mdot**0.2d0*r &
      **1.05d0*f(r)**0.2d0
rho3 = 594575.0d0*alpha**(-0.7d0)*kappa_abs_0**(-0.15d0)*mbh**(-0.7d0)* &
      mdot**0.55d0*r**(-1.875d0)*f(r)**0.55d0
T3 = 744750.0d0*alpha**(-0.2d0)*kappa_abs_0**0.1d0*mbh**(-0.2d0)*mdot** &
      0.3d0*r**(-0.75d0)*f(r)**0.3d0
H3 = 154.415d0*alpha**(-0.1d0)*kappa_abs_0**0.05d0*mbh**0.9d0*mdot** &
      0.15d0*r**1.125d0*f(r)**0.15d0
r12 = 164.175d0*alpha**0.0952381d0*cgs_kapes**0.857143d0*mbh** &
      0.0952381d0*mdot**0.761905d0*f(r12)**0.761905d0
r23 = 5.05562d+19*cgs_kapes**1.33333d0*kappa_abs_0**(-0.666667d0)*mdot** &
      0.666667d0*f(r23)**0.666667d0


    program demo_dim
    use, intrinsic :: iso_fortran_env, only : real64
    implicit none
    integer           :: i
    real(kind=real64) :: x
        i = dim(4, 15)
        x = dim(4.321_real64, 1.111_real64)
        print *, i
        print *, x
        ! elemental
        print *, dim([1,2,3],2)
        print *, dim([1,2,3],[3,2,1])
        print *, dim(-10,[0,-10,-20])
    end program demo_dim


      function v_to_b(v)

!     Convert visual magnitude per square second (v) to brightness in
!     nanolamberts (b)

      v_to_b = 34.08 * exp(20.7233 - 0.92104 * v)

      return
      end

      function b_to_v(b)

!     Convert brightness in nanolamberts (b) to visual magnitude per square
!     second (v)

      b_to_v = (log(b/34.08) - 20.7233) / (- 0.92104)

      return
      end

      function b_to_maglim(b)

!     Convert brightness in nanolamberts (b) to visual magnitude limit.
!     This starts with Weavers formula (1947). Also Eq. 20 of Garstang (1986).
!     Then, a Schaaf - Albers correction of +0.23 magnitude is applied.

      if(b .le. 1479.)then
          b_to_maglim = 7.930 - 2.171 * log(1. + .1122   * sqrt(b))
      else ! b > 1479.
          b_to_maglim = 4.305 - 2.171 * log(1. + .001122 * sqrt(b))
      endif

!     b_to_maglim = b_to_maglim + 0.23

!     write(13,1)b,b_to_maglim
!     format('  b/b_to_maglim',2f9.2)

      return
      end

      function b_to_maglim_hecht(b)

!     Convert brightness in nanolamberts (b) to visual magnitude limit.
!     This starts with Hecht's formula (1947) as quoted in Schaefer using
!     Schaefer's Equations.

      real*4 k

      blog = log10(b)

      if(blog .ge. 3.17)then
          c = 10. ** (-8.35)
          k = 10. ** (-5.90)
      else ! blog < 3.17
          c = 10. ** (-9.80)
          k = 10. ** (-1.90)
      endif

      rith = c * (1. + sqrt(k * b)) ** 2       ! Eq 34
      rmag_v = -16.57 - 2.5 * alog10(rith)     ! Eq 10
      b_to_maglim_hecht = rmag_v - 0.3         ! Eq 9,48

!     write(22,*)b,c,k,rith,rmag_v,b_to_maglim_hecht

      return
      end

      function rmaglim_to_b(rmaglim)

      bestval = 0.
      resid_min = 999.
!     do i = 1000,10000,2
      do i = 1000,10000,5
          testb = 10. ** (float(i) / 1000.)
          testmag = b_to_maglim(testb)
          resid = testmag - rmaglim
          if(abs(resid) .lt. resid_min)then
              resid_min = resid
              rmaglim_to_b = testb
              ibest = i
          endif
!         write(6,1)rmaglim,ibest,resid_min,rmaglim_to_b
      enddo ! i

!     write(13,1)rmaglim,ibest,resid_min,rmaglim_to_b
1     format('  rmaglim/ibest/resid_min/rmaglim_to_b ',f9.2,i6,2f9.2)

      return
      end

      subroutine addmaglims(rmaglim1,rmaglim2,rmaglim_out)

      b1 = rmaglim_to_b(rmaglim1)
      b2 = rmaglim_to_b(rmaglim2)

      bsum = b1 + b2

      rmaglim_out = b_to_maglim(bsum)

      return
      end


PROGRAM power
!
!  Purpose:
!    To calculate the current, real, reactive, and apparent power,
!    and the power factor supplied to a load.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/03/06    S. J. Chapman        Original code
!

IMPLICIT NONE

! Data dictionary: declare constants
REAL,PARAMETER :: DEG_2_RAD = 0.01745329 ! Deg to radians factor

! Data dictionary: declare variable types, definitions, & units
REAL :: amps            ! Current in the load (A)
REAL :: p               ! Real power of load (W)
REAL :: pf              ! Power factor of load (no units)
REAL :: q               ! Reactive power of the load (VAR)
REAL :: s               ! Apparent power of the load (VA)
REAL :: theta           ! Impedance angle of the load (deg)
REAL :: volts           ! Rms voltage of the power source (V)
REAL :: z               ! Magnitude of the load impedance (ohms)

! Prompt the user for the rms voltage.
WRITE (*,*) 'Enter the rms voltage of the source: '
READ  (*,*) volts

! Prompt the user for the magnitude and angle of the impedance.
WRITE (*,*) 'Enter the magnitude and angle of the impedance '
WRITE (*,*) 'in ohms and degrees: '
READ  (*,*) z, theta

! Perform calculations
amps = volts / z                           ! Rms current
p = volts * amps * cos (theta * DEG_2_RAD) ! Real power
q = volts * amps * sin (theta * DEG_2_RAD) ! Reactive power
s = volts * amps                           ! Apparent power
pf = cos ( theta * DEG_2_RAD)              ! Power factor

! Write out the results.
WRITE (*,*) 'Voltage        = ', volts, ' volts'
WRITE (*,*) 'Impedance      = ', z, ' ohms at ', theta,' degrees'
WRITE (*,*) 'Current        = ', amps, ' amps'
WRITE (*,*) 'Real Power     = ', p, ' watts'
WRITE (*,*) 'Reactive Power = ', q, ' VAR'
WRITE (*,*) 'Apparent Power = ', s, ' VA'
WRITE (*,*) 'Power Factor   = ', pf

! Finish up.
END PROGRAM power


module tensor

implicit none

public :: t0, t1, t2

contains

function t0(r_a, r_b) result(var)
  double precision, intent(in), dimension(3) :: r_a
  double precision, intent(in), dimension(3) :: r_b
  double precision :: var

  double precision :: R2
  double precision, dimension(3) :: dr

  dr = r_b - r_a
  R2 = dot_product(dr, dr)
  var = 1.0d0 / sqrt(R2)

end function t0

function t1(r_a, r_b) result(var)
  double precision, intent(in), dimension(3) :: r_a
  double precision, intent(in), dimension(3) :: r_b
  double precision, dimension(3) :: var

  double precision :: R, R2
  double precision, dimension(3) :: dr

  dr = r_b - r_a
  R2 = dot_product(dr, dr)
  R = sqrt(R2)
  var = dr / (R*R2)

end function t1

function t2(r_a, r_b) result(var)
  double precision, intent(in), dimension(3) :: r_a
  double precision, intent(in), dimension(3) :: r_b
  double precision, dimension(6) :: var

  double precision :: R, R2
  double precision, dimension(3) :: dr

  dr = r_b - r_a
  R2 = dot_product(dr, dr)
  R = sqrt(R2)

  var(1) = 3 * dr(1) * dr(1) - R2   ! xx
  var(2) = 3 * dr(1) * dr(2)        ! xy
  var(3) = 3 * dr(1) * dr(3)        ! xz
  var(4) = 3 * dr(2) * dr(2) - R2   ! yy
  var(5) = 3 * dr(2) * dr(3)        ! yz
  var(6) = 3 * dr(3) * dr(3) - R2   ! zz

  var = var / (R*R2*R2)

end function t2

end module tensor


c     ============================================
      subroutine setaux(maxmx,mbc,mx,xlower,dx,maux,aux)
c     ============================================
c
c     # set auxiliary arrays
c     # aux(i,1) = b in cell i, bottom topography "hillinbasin"
c
c
      implicit double precision (a-h,o-z)
      dimension aux(1-mbc:maxmx+mbc, *)

      ! set user-defined topography as aux(i,1)
      do 50 i=1,mx
         xcell = xlower + (i-0.5d0)*dx
         aux(i,1)=1.8d0*dexp(-1000.d0*xcell**2)
     &         + .5d0*1.0d0*dexp(-50.d0*(xcell-0.5d0)**2)
     &         + 1.8d0*dexp(-1000.d0*(xcell-1.d0)**2)

         write(17,701) aux(i,1)
 701       format(e22.12)

 50   continue

      return
      end


program spherical_harmonics
  use special_functions
  integer, parameter :: num_theta_pts = 100, num_phi_pts = 100, lmax=4
  real(kind=dp) :: alp(num_theta_pts, 0:lmax,-lmax:lmax), theta_pts(num_theta_pts), dtheta, dphi
  real(kind=dp) :: fac, phi
  integer :: i, j, k, l, m, fact(2*lmax)
  complex(kind=dp) :: spha_ylm(num_theta_pts, num_phi_pts)

  dtheta = pi/(num_theta_pts-1)
  dphi = 2*pi/(num_phi_pts-1)
  theta_pts = [ (-pi/2+i*dtheta, i=0, num_theta_pts-1) ]
  l=2
  m=0

  call calc_factorials(2*lmax, fact)
  call gen_assoc_legendre_pol(cos(theta_pts), num_theta_pts, lmax, alp)

  do i=0,num_phi_pts-1
    phi = i*dphi
    fac=dsqrt((2*l+1)*fact(l-m)/(4.0d0*pi*fact(l+m)))
    spha_ylm(:,i)=fac*alp(:,l,m)*cmplx(cos(m*phi),sin(m*phi))
  end do

  do i=1,num_theta_pts
     do j=1,num_phi_pts
    print '(5f10.4)', theta_pts(i), (j-1)*dphi,  spha_ylm(i,j)%re, spha_ylm(i,j)%im, abs(spha_ylm(i, j))
     end do
  end do
end program spherical_harmonics


      SUBROUTINE posin1 (a,nmax,ndd)

!     Inverse of matrix perhaps ??????????

      IMPLICIT NONE
      INTEGER (kind=4),INTENT(IN)  :: nmax,ndd
      REAL (kind=8),INTENT(IN OUT) :: a(ndd,ndd)

      INTEGER (kind=4) i,j,n
      REAL (kind=8) d

      DO n=1,nmax

        d = a(n,n)
        DO j=1,nmax
          a(n,j) = -a(n,j)/d
        END DO

        DO i=1,nmax
          IF(n /= i)THEN
            DO j=1,nmax
              IF(n /= j) a(i,j) = a(i,j) + a(i,n)*a(n,j)
            END DO
          END IF
          a(i,n) = a(i,n)/d
        END DO

        a(n,n) = 1.0/d

      END DO

      RETURN
      END SUBROUTINE posin1


	SUBROUTINE VC_PFTH  ( theta, tmp, nxy, p, iret )
C************************************************************************
C* VC_PFTH								*
C*									*
C* This subroutine computes pressure on an isentropic surface given	*
C* temperature.								*
C*									*
C* VC_PFTH ( THETA, TMP, NXY, P, IRET )					*
C*									*
C* Input parameters:							*
C*	THETA		REAL		Potential temperature		*
C*	TMP  (NXY)	REAL		Temperature			*
C*	NXY		INTEGER		Number of points		*
C*									*
C* Output parameters:							*
C*	P    (NXY)	REAL		Output pressure values		*
C*	IRET		INTEGER		Return code			*
C*					  0 = normal return		*
C*					 +1 = all missing		*
C**									*
C* Log:									*
C* K. Brill/NMC      06/92						*
C************************************************************************
	INCLUDE		'GEMPRM.PRM'
C*
	REAL		tmp (*), p (*)
C*
	INCLUDE		'ERMISS.FNC'
C-----------------------------------------------------------------------
	iret = 0
C
C*	Compute the theta coordinate values.
C
	icnt = 0
	DO i = 1, nxy
	    IF ( ERMISS ( tmp (i) ) .or. ERMISS ( theta ) ) THEN
		p (i) = RMISSD
		icnt = icnt + 1
	    ELSE
		p (i) = 1000. * ( tmp (i) / theta ) ** 3.5
	    END IF
	END DO
C*
	IF ( icnt .eq. nxy ) iret = +1
C*
	RETURN
	END


!-----------------------------------------------------------------------------------
!
!
! PURPOSE
!
! This program numerically solves the 3D incompressible Navier-Stokes
! on a Cubic Domain [0,2pi]x[0,2pi]x[0,2pi] using pseudo-spectral methods and
! Implicit Midpoint rule timestepping. The numerical solution is compared to
! an exact solution reported by Shapiro
!
! Analytical Solution:
! u(x,y,z,t)=-0.25*(cos(x)sin(y)sin(z)+sin(x)cos(y)cos(z))exp(-t/Re)
! v(x,y,z,t)= 0.25*(sin(x)cos(y)sin(z)-cos(x)sin(y)cos(z))exp(-t/Re)
! w(x,y,z,t)= 0.5*cos(x)cos(y)sin(z)exp(-t/Re)
!
! .. Parameters ..
! Nx = number of modes in x - power of 2 for FFT
! Ny = number of modes in y - power of 2 for FFT
! Nz = number of modes in z - power of 2 for FFT
! Nt = number of timesteps to take
! Tmax = maximum simulation time
! pi = 3.14159265358979323846264338327950288419716939937510d0
! Re = Reynolds number
! .. Scalars ..
! i = loop counter in x direction
! j = loop counter in y direction
! k = loop counter in z direction
! n = loop counter for timesteps direction
! nn = loop conuter for timesteps between plots
! allocatestatus = error indicator during allocation
! count = keep track of information written to disk
! iol = size of array to write to disk
! start = variable to record start time of program
! finish = variable to record end time of program
! count_rate = variable for clock count rate
! theta = variable to modify exact solution used
! dt = timestep
! filesize = MPI variable to indicate file size to be written to disk
! disp = MPI variable to indicate where in file local portion to be written
! p_row = variable used by 2decomp to store number of rows
! p_col= variable used by 2decomp to store number of columns
! numprocs = number of processros
! myid = number of local process
! ierr = error codes returned in this variable
! t = time
! plotInt= plot number
! ind = index for file number
! start = timing variable
! finish = fiming variable
! count_rate = clock rate to convert to seconds

! .. Arrays ..
! u = velocity in x direction
! v = velocity in y direction
! w = velocity in z direction
! uexact = array for exact solution
! vexact = array for exact solution
! wexact = array for exact solution
! uold = velocity in x direction at previous timestep
! vold = velocity in y direction at previous timestep
! wold = velocity in z direction at previous timestep
! ux = x derivative of velocity in x direction
! uy = y derivative of velocity in x direction
! uz = z derivative of velocity in x direction
! vx = x derivative of velocity in y direction
! vy = y derivative of velocity in y direction
! vz = z derivative of velocity in y direction
! wx = x derivative of velocity in z direction
! wy = y derivative of velocity in z direction
! wz = z derivative of velocity in z direction
! uxold = x derivative of velocity in x direction
! uyold = y derivative of velocity in x direction
! uzold = z derivative of velocity in x direction
! vxold = x derivative of velocity in y direction
! vyold = y derivative of velocity in y direction
! vzold = z derivative of velocity in y direction
! wxold = x derivative of velocity in z direction
! wyold = y derivative of velocity in z direction
! wzold = z derivative of velocity in z direction
! utemp = temporary storage of u to check convergence
! vtemp = temporary storage of u to check convergence
! wtemp = temporary storage of u to check convergence
! temp_r = temporary storage for untransformed variables
! uhat = Fourier transform of u
! vhat = Fourier transform of v
! what = Fourier transform of w
! rhsuhatfix = Fourier transform of righthand side for u for timestepping
! rhsvhatfix = Fourier transform of righthand side for v for timestepping
! rhswhatfix = Fourier transform of righthand side for w for timestepping
! nonlinuhat = Fourier transform of nonlinear term for u
! nonlinvhat = Fourier transform of nonlinear term for u
! nonlinwhat = Fourier transform of nonlinear term for u
! phat = Fourier transform of nonlinear term for pressure, p
! temp_c = temporary storage for Fourier transforms
!
! .. Vectors ..
! kx = fourier frequencies in x direction
! ky = fourier frequencies in y direction
! kz = fourier frequencies in z direction
! x = x locations
! y = y locations
! z = y locations
! time = times at which save data
! name_config = array to store filename for data to be saved
! number_file = array to store number of filename being saved
! temp1 = array to collect local sums for MPI reductions
! temp2 = array to perform MPI reductions in
! mychg = array to collect local differences between fixed point iterates
! allchg = array to collect global differences between fixed point iterates
! KE = array to record kinetic energy
! Enstrophy = array to record enstrophy
! KEdissipationRate = array to record kinetic energy dissipation rate
!
! .. Special types ..
!
! decomp = structure from 2decomp with information on complex array sizes
! sp = structure from 2decomp with information on real array sizes
!
! REFERENCES
!
! A. Shapiro " The use of an exact solution of the Navier-Stokes equations
! in a validation test of a three-dimensional nonhydrostatic numerical model"
! Monthly Weather Review vol. 121, 2420-2425, (1993).
!
! ACKNOWLEDGEMENTS
!
! ACCURACY
!
! ERROR INDICATORS AND WARNINGS
!
! FURTHER COMMENTS
!
! This program has not been optimized to use the least amount of memory
! or be as efficeint as possible, but is intended to be portable and produc
! correcte results
!
!--------------------------------------------------------------------------------
! External routines required
!
! External libraries required
! 2DECOMP&FFT -- Fast Fourier Transform in the West Library
! (http://2decomp.org/)

PROGRAM main
	USE decomp_2d
	USE decomp_2d_fft
	USE decomp_2d_io

	IMPLICIT NONE
	include "mpif.h"
	!Grid & Timing
   	INTEGER(kind=4), PARAMETER 		:: Nx=512, Ny=512, Nz=512
   	INTEGER(kind=4), PARAMETER 		:: Lx=1, Ly=1, Lz=1
	INTEGER(kind=4), PARAMETER		:: Nt=1000, plotgap=100
	INTEGER(kind=4)				:: numplots=Nt/plotgap
	!choose initial conditions
	logical                         ::readinput=.false.,&
                                    TGvortex=.true.,&
                                    exactsoln=.false.
	!option to save output
	INTEGER(kind=4), PARAMETER 	  	:: savedata1=1
	!runtime parameters
	REAL(kind=8), PARAMETER			:: dt=0.005d0
	REAL(kind=8), PARAMETER			:: Re=1600.0d0
	REAL(kind=8), PARAMETER			:: tol=0.1d0**10
	REAL(kind=8), PARAMETER			:: theta=0.0d0
	!additional parameters & constants
	REAL(kind=8), PARAMETER	&
		::  pi=3.14159265358979323846264338327950288419716939937510d0
	REAL(kind=8), PARAMETER         :: dx=2.0d0*pi*Lx/REAL(Nx,kind(0d0))
	REAL(kind=8), PARAMETER         :: dy=2.0d0*pi*Ly/REAL(Ny,kind(0d0))
	REAL(kind=8), PARAMETER         :: dz=2.0d0*pi*Lz/REAL(Nz,kind(0d0))
	REAL(kind=8), PARAMETER         :: ReInv=1.0d0/REAL(Re,kind(0d0))
	REAL(kind=8), PARAMETER         :: dtInv=1.0d0/REAL(dt,kind(0d0))
	!computational arrays/scalars
	REAL(kind=8)                                    :: scalemodes,chg,factor,temp3
	REAL(kind=8), DIMENSION(:), ALLOCATABLE			:: x, y, z, time,mychg,allchg
	REAL(kind=8), DIMENSION(:), ALLOCATABLE			:: KE,Enstrophy,&
                                                    KEdissipationRate
   	REAL(kind=8), DIMENSION(:), ALLOCATABLE			:: temp1,temp2
   	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE		:: temp,omega
	REAL(kind=8), DIMENSION(:,:,:), ALLOCATABLE		:: u, v, w,&
                                                    ux, uy, uz,&
                                                    vx, vy, vz,&
                                                    wx, wy, wz,&
                                                    uold, uxold, uyold, uzold,&
                                                    vold, vxold, vyold, vzold,&
                                                    wold, wxold, wyold, wzold,&
                                                    utemp, vtemp, wtemp, temp_r

	COMPLEX(kind=8), DIMENSION(:), ALLOCATABLE		:: kx, ky, kz
	COMPLEX(kind=8), DIMENSION(:,:,:), ALLOCATABLE	:: uhat, vhat, what,&
                                                    rhsuhatfix, rhsvhatfix,&
                                                    rhswhatfix, nonlinuhat,&
                                                    nonlinvhat, nonlinwhat,&
                                                    phat,temp_c
	! MPI and 2DECOMP variables
	TYPE(DECOMP_INFO)                               ::  decomp,sp
	INTEGER(kind=MPI_OFFSET_KIND)                   ::  filesize, disp
	INTEGER(kind=4)                                 ::  p_row=0, p_col=0, numprocs, myid, ierr

	! variables used for saving data and timing
	INTEGER(kind=4)                                 :: count, iol, convDiag=0
	INTEGER(kind=4)                                 :: i,j,k,n,nn,t,allocatestatus,plotInt=0
	INTEGER(kind=4)                                 :: ind
	CHARACTER*100                                   :: name_config,number_file
	INTEGER(kind=4)                                 :: start, finish, count_rate

	! initialisation of 2DECOMP&FFT and MPI
	CALL MPI_INIT(ierr)
	CALL MPI_COMM_SIZE(MPI_COMM_WORLD, numprocs, ierr)
	CALL MPI_COMM_RANK(MPI_COMM_WORLD, myid, ierr)
	CALL decomp_2d_init(Nx,Ny,Nz,p_row,p_col)
	CALL decomp_info_init(Nx,Ny,Nz,decomp)
  	CALL decomp_info_init(Nx/2+1,Ny,Nz,sp)
	CALL decomp_2d_fft_init

	IF (myid.eq.0) THEN
		PRINT *,'Solve 3D incompressible NS equations with Fourier pseudospectral methods'
		PRINT *,'and Implicit-Midpoint rule timestepping.'
		PRINT *,'Grid:',Nx,'X',Ny,'X',Nz
		PRINT *,'dt:',dt
		PRINT *,'Re:',Re
		PRINT *,'Nt:',Nt
      		PRINT *,'plotgap:',plotgap
	END IF
	ALLOCATE(x(1:Nx),y(1:Ny),z(1:Nz),time(1:numplots+1),mychg(1:3),allchg(1:3),temp1(1:9),temp2(1:9),&
            KE(1:numplots+1),Enstrophy(1:numplots+1),KEdissipationRate(1:numplots+1),&
				u(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
 				v(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
 				w(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
 				ux(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				uy(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				uz(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				vx(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				vy(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				vz(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				wx(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				wy(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				wz(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				uold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				uxold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				uyold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				uzold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				vold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				vxold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				vyold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				vzold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				wold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				wxold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				wyold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				wzold(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
				utemp(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
 				vtemp(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
 				wtemp(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
 				temp_r(decomp%xst(1):decomp%xen(1),&
   					decomp%xst(2):decomp%xen(2),&
   					decomp%xst(3):decomp%xen(3)),&
            omega(decomp%xst(1):decomp%xen(1),&
                  decomp%xst(2):decomp%xen(2),&
                  decomp%xst(3):decomp%xen(3)),&
	         temp(decomp%xst(1):decomp%xen(1),&
                 decomp%xst(2):decomp%xen(2),&
                 decomp%xst(3):decomp%xen(3)),&
				kx(1:Nx),ky(1:Ny),kz(1:Nz),&
				uhat(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
				vhat(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
	 			what(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
	 			rhsuhatfix(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
 				rhsvhatfix(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
 				rhswhatfix(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
 				nonlinuhat(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
 				nonlinvhat(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
 				nonlinwhat(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
 				phat(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
 				temp_c(sp%zst(1):sp%zen(1),&
   					sp%zst(2):sp%zen(2),&
   					sp%zst(3):sp%zen(3)),&
				stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	IF (myid.eq.0) THEN
	 	PRINT *,'allocated space'
	END IF

	! setup fourier frequencies in x-direction
	DO i=1,Nx/2+1
		kx(i)= cmplx(0.0d0,1.0d0)*REAL(i-1,kind(0d0))/Lx
	END DO
	kx(1+Nx/2)=0.0d0
	DO i = 1,Nx/2 -1
		kx(i+1+Nx/2)=-kx(1-i+Nx/2)
	END DO
	ind=1
	DO i=-Nx/2,Nx/2-1
		x(ind)=2.0d0*pi*REAL(i,kind(0d0))*Lx/REAL(Nx,kind(0d0))
		ind=ind+1
	END DO
	! setup fourier frequencies in y-direction
	DO j=1,Ny/2+1
		ky(j)= cmplx(0.0d0,1.0d0)*REAL(j-1,kind(0d0))/Ly
	END DO
	ky(1+Ny/2)=0.0d0
	DO j = 1,Ny/2 -1
		ky(j+1+Ny/2)=-ky(1-j+Ny/2)
	END DO
	ind=1
	DO j=-Ny/2,Ny/2-1
		y(ind)=2.0d0*pi*REAL(j,kind(0d0))*Ly/REAL(Ny,kind(0d0))
		ind=ind+1
	END DO
	! setup fourier frequencies in z-direction
	DO k=1,Nz/2+1
		kz(k)= cmplx(0.0d0,1.0d0)*REAL(k-1,kind(0d0))/Lz
	END DO
	kz(1+Nz/2)=0.0d0
	DO k = 1,Nz/2 -1
		kz(k+1+Nz/2)=-kz(1-k+Nz/2)
	END DO
	ind=1
	DO k=-Nz/2,Nz/2-1
		z(ind)=2.0d0*pi*REAL(k,kind(0d0))*Lz/REAL(Nz,kind(0d0))
		ind=ind+1
	END DO
	IF (myid.eq.0) THEN
		PRINT *,'Setup grid and fourier frequencies'
	END IF
	scalemodes=1.0d0/REAL(Nx*Ny*Nz,kind(0d0)); time(1)=0.0d0;

   IF(readInput.eqv..true.) THEN
		name_config='./data/restartData'
		OPEN(unit=11,file=name_config,status='old')
		REWIND(11)
		READ(11,*) time(1),plotInt
		CLOSE(11)
      name_config='./data/u'
      CALL getName(name_config,plotInt)
      CALL decomp_2d_read_one(1,u,name_config)
      name_config='./data/v'
      CALL getName(name_config,plotInt)
      CALL decomp_2d_read_one(1,v,name_config)
      name_config='./data/w'
      CALL getName(name_config,plotInt)
      CALL decomp_2d_read_one(1,w,name_config)
      IF(myid.eq.0) THEN
         PRINT*,'Read in values'
      END IF
   ELSE If(TGvortex.eqv..true.) THEN
	   !initial conditions for Taylor-Green vortex
	   factor=2.0d0/sqrt(3.0d0)
      DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	      u(i,j,k)=factor*sin(theta+2.0d0*pi/3.0d0)*sin(x(i))*cos(y(j))*cos(z(k))
      END DO; END DO; END DO
      DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	      v(i,j,k)=factor*sin(theta-2.0d0*pi/3.0d0)*cos(x(i))*sin(y(j))*cos(z(k))
      END DO ; END DO ; END DO
      DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
	      w(i,j,k)=factor*sin(theta)*cos(x(i))*cos(y(j))*sin(z(k))
      END DO ; END DO ; END DO
      IF(myid.eq.0) THEN
         PRINT*,'Taylor-Green Vortex initial conditions'
      END IF
   ELSE IF(exactsoln.eqv..true.) THEN
		!special exact sol'n usted for testing
		factor=sqrt(3.0d0)
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			u(i,j,k)=-0.5*( factor*cos(x(i))*sin(y(j))*sin(z(k))&
							+sin(x(i))*cos(y(j))*cos(z(k)) )*exp(-(factor**2)*time(1)/Re)
		END DO; END DO; END DO
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			v(i,j,k)=0.5*(  factor*sin(x(i))*cos(y(j))*sin(z(k))&
							-cos(x(i))*sin(y(j))*cos(z(k)) )*exp(-(factor**2)*time(1)/Re)
		END DO ; END DO ; END DO
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			w(i,j,k)=cos(x(i))*cos(y(j))*sin(z(k))*exp(-(factor**2)*time(1)/Re)
		END DO ; END DO ; END DO
      IF(myid.eq.0) THEN
         PRINT*,'Exact Solution initial conditions'
      END IF
	ELSE
      IF(myid.eq.0) THEN
         PRINT*,'--------------------------------------------------------------------'
		   PRINT*,'Set initial conditions to either readinput, TGvortex, or exactsoln.'
         PRINT*,'--------------------------------------------------------------------'
         goto 111
      END IF
	END IF

	CALL decomp_2d_fft_3d(u,uhat)
        CALL decomp_2d_fft_3d(v,vhat)
	CALL decomp_2d_fft_3d(w,what)

	! derivative of u with respect to x, y, and z
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=uhat(i,j,k)*kx(i)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,ux)
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=uhat(i,j,k)*ky(j)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,uy)
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=uhat(i,j,k)*kz(k)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,uz)

	! derivative of v with respect to x, y, and z
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=vhat(i,j,k)*kx(i)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,vx)
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=vhat(i,j,k)*ky(j)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,vy)
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=vhat(i,j,k)*kz(k)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,vz)

	! derivative of w with respect to x, y, and z
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=what(i,j,k)*kx(i)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,wx)
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=what(i,j,k)*ky(j)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,wy)
	DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		temp_c(i,j,k)=what(i,j,k)*kz(k)*scalemodes
	END DO ; END DO ; END DO
	CALL decomp_2d_fft_3d(temp_c,wz)

	!calculate vorticity
	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		temp(i,j,k)=wy(i,j,k)-vz(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		omega(i,j,k)=temp(i,j,k)*temp(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		temp(i,j,k)=uz(i,j,k)-wx(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		omega(i,j,k)=temp(i,j,k)*temp(i,j,k)+omega(i,j,k)
	END DO ; END DO ; END DO

	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		temp(i,j,k)=vx(i,j,k)-uy(i,j,k)
	END DO ; END DO ; END DO
	DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		omega(i,j,k)=temp(i,j,k)*temp(i,j,k)+omega(i,j,k)
	END DO ; END DO ; END DO

	!Calculate Kinetic Energy
	temp1(1) = sum(u*u)
	temp1(2) = sum(v*v)
	temp1(3) = sum(w*w)
	CALL MPI_ALLREDUCE(temp1(1:3),temp2(1:3),3,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	temp3=temp2(1)+temp2(2)+temp2(3)
	KE(1)=dx*dy*dz*temp3/(8.0d0*2.0d0*pi*pi*pi)

	!Calculate Enstrophy
   temp1(1)=sum(omega)
	CALL MPI_ALLREDUCE(temp1(1),temp3,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
   Enstrophy(1)=dx*dy*dz*temp3/(8.0d0*2.0d0*pi*pi*pi)

	temp1=0.0;temp2=0.0
	!Calculate Kinetic Energy Dissipation Rate
	temp1(1)=sum(ux*ux)
	temp1(2)=sum(uy*uy)
	temp1(3)=sum(uz*uz)
	temp1(4)=sum(vx*vx)
	temp1(5)=sum(vy*vy)
	temp1(6)=sum(vz*vz)
	temp1(7)=sum(wx*wx)
	temp1(8)=sum(wy*wy)
	temp1(9)=sum(wz*wz)
	CALL MPI_ALLREDUCE(temp1,temp2,9,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	temp3=temp2(1)+temp2(2)+temp2(3)+temp2(4)+temp2(5)+temp2(6)+temp2(7)+temp2(8)+temp2(9)
	KEdissipationRate(1)=dx*dy*dz*temp3/(8.0d0*Re*pi*pi*pi)

   IF(myid.eq.0) THEN
      PRINT *,'time=',time(1)
	   PRINT*,'KE=',KE(1)
	   PRINT*,'Enstrophy=',Enstrophy(1)
	   PRINT*,'KEdissipationRate=',KEdissipationRate(1)
      PRINT*,'---------------------------------'
		PRINT*,'starting timestepping and timer'
     	PRINT*,'---------------------------------'
   END IF
   CALL system_clock(start,count_rate)
   DO n=1,numplots
      DO nn=1,plotgap
		   !fixed point
		   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			   uold(i,j,k)=u(i,j,k)
			   uxold(i,j,k)=ux(i,j,k)
			   uyold(i,j,k)=uy(i,j,k)
			   uzold(i,j,k)=uz(i,j,k)
		   END DO ; END DO ; END DO
		   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			   vold(i,j,k)=v(i,j,k)
			   vxold(i,j,k)=vx(i,j,k)
			   vyold(i,j,k)=vy(i,j,k)
			   vzold(i,j,k)=vz(i,j,k)
		   END DO ; END DO ; END DO
		   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			   wold(i,j,k)=w(i,j,k)
			   wxold(i,j,k)=wx(i,j,k)
			   wyold(i,j,k)=wy(i,j,k)
			   wzold(i,j,k)=wz(i,j,k)
		   END DO ; END DO ; END DO

		   DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
            		rhsuhatfix(i,j,k) = (dtInv+(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)))*uhat(i,j,k)
		   END DO ; END DO ; END DO
		   DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
			   rhsvhatfix(i,j,k) = (dtInv+(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)))*vhat(i,j,k)
		   END DO ; END DO ; END DO
		   DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
			   rhswhatfix(i,j,k) = (dtInv+(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)))*what(i,j,k)
		   END DO ; END DO ; END DO

		   chg=1
                   convDiag=0
		   DO WHILE (chg .gt. tol)
			   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				   temp_r(i,j,k)=0.25d0*((u(i,j,k)+uold(i,j,k))*(ux(i,j,k)+uxold(i,j,k))&
										   +(v(i,j,k)+vold(i,j,k))*(uy(i,j,k)+uyold(i,j,k))&
										   +(w(i,j,k)+wold(i,j,k))*(uz(i,j,k)+uzold(i,j,k)))
			   END DO ; END DO ; END DO
			   CALL decomp_2d_fft_3d(temp_r,nonlinuhat)
			   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				   temp_r(i,j,k)=0.25d0*((u(i,j,k)+uold(i,j,k))*(vx(i,j,k)+vxold(i,j,k))&
										   +(v(i,j,k)+vold(i,j,k))*(vy(i,j,k)+vyold(i,j,k))&
										   +(w(i,j,k)+wold(i,j,k))*(vz(i,j,k)+vzold(i,j,k)))
			   END DO ; END DO ; END DO
			   CALL decomp_2d_fft_3d(temp_r,nonlinvhat)
			   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
				   temp_r(i,j,k)=0.25d0*((u(i,j,k)+uold(i,j,k))*(wx(i,j,k)+wxold(i,j,k))&
										   +(v(i,j,k)+vold(i,j,k))*(wy(i,j,k)+wyold(i,j,k))&
										   +(w(i,j,k)+wold(i,j,k))*(wz(i,j,k)+wzold(i,j,k)))
			   END DO ; END DO ; END DO
			   CALL decomp_2d_fft_3d(temp_r,nonlinwhat)
			   DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
				   phat(i,j,k)=-1.0d0*(  kx(i)*nonlinuhat(i,j,k)&
							+ky(j)*nonlinvhat(i,j,k)&
							+kz(k)*nonlinwhat(i,j,k))&
						/(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k)+0.1d0**13)
			   END DO ; END DO ; END DO

			   DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
				   uhat(i,j,k)=(rhsuhatfix(i,j,k)-nonlinuhat(i,j,k)-kx(i)*phat(i,j,k))/&
							   (dtInv-(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k))) !*scalemodes
			   END DO ; END DO ; END DO
			   DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
				   vhat(i,j,k)=(rhsvhatfix(i,j,k)-nonlinvhat(i,j,k)-ky(j)*phat(i,j,k))/&
							   (dtInv-(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k))) !*scalemodes
			   END DO ; END DO ; END DO
			   DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
				   what(i,j,k)=(rhswhatfix(i,j,k)-nonlinwhat(i,j,k)-kz(k)*phat(i,j,k))/&
							   (dtInv-(0.5d0*ReInv)*(kx(i)*kx(i)+ky(j)*ky(j)+kz(k)*kz(k))) !*scalemodes
			   END DO ; END DO ; END DO

	         ! derivative of u with respect to x, y, and z
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=uhat(i,j,k)*kx(i)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,ux)
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=uhat(i,j,k)*ky(j)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,uy)
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=uhat(i,j,k)*kz(k)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,uz)

	         ! derivative of v with respect to x, y, and z
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=vhat(i,j,k)*kx(i)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,vx)
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=vhat(i,j,k)*ky(j)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,vy)
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=vhat(i,j,k)*kz(k)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,vz)

	         ! derivative of w with respect to x, y, and z
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=what(i,j,k)*kx(i)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,wx)
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=what(i,j,k)*ky(j)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,wy)
	         DO k=sp%zst(3),sp%zen(3) ; DO j=sp%zst(2),sp%zen(2) ; DO i=sp%zst(1),sp%zen(1)
		         temp_c(i,j,k)=what(i,j,k)*kz(k)*scalemodes
	         END DO ; END DO ; END DO
	         CALL decomp_2d_fft_3d(temp_c,wz)

		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			utemp(i,j,k)=u(i,j,k)
		END DO ; END DO ; END DO
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			vtemp(i,j,k)=v(i,j,k)
		END DO ; END DO ; END DO
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			wtemp(i,j,k)=w(i,j,k)
		END DO ; END DO ; END DO

		CALL decomp_2d_fft_3d(uhat,u)
		CALL decomp_2d_fft_3d(vhat,v)
		CALL decomp_2d_fft_3d(what,w)

	       DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   u(i,j,k)=u(i,j,k)*scalemodes
	       END DO ; END DO ; END DO
	       DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   v(i,j,k)=v(i,j,k)*scalemodes
	       END DO ; END DO ; END DO
	       DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   w(i,j,k)=w(i,j,k)*scalemodes
	       END DO ; END DO ; END DO

		mychg(1) =maxval(abs(utemp-u))
		mychg(2) =maxval(abs(vtemp-v))
		mychg(3) =maxval(abs(wtemp-w))
		CALL MPI_ALLREDUCE(mychg,allchg,3,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
		chg=allchg(1)+allchg(2)+allchg(3)
                convDiag=convDiag+1
	END DO
      END DO

	   !calculate vorticity
	   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   temp(i,j,k)=REAL(wy(i,j,k)-vz(i,j,k),KIND=8)
	   END DO ; END DO ; END DO

	   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   omega(i,j,k)=REAL(temp(i,j,k)*temp(i,j,k),KIND=8)
	   END DO ; END DO ; END DO

	   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   temp(i,j,k)=REAL(uz(i,j,k)-wx(i,j,k),KIND=8)
	   END DO ; END DO ; END DO

	   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   omega(i,j,k)=REAL(temp(i,j,k)*temp(i,j,k)+omega(i,j,k),KIND=8)
	   END DO ; END DO ; END DO

	   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   temp(i,j,k)=REAL(vx(i,j,k)-uy(i,j,k),KIND=8)
	   END DO ; END DO ; END DO
	   DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
		   omega(i,j,k)=REAL(temp(i,j,k)*temp(i,j,k)+omega(i,j,k),KIND=8)
	   END DO ; END DO ; END DO

	   !Calculate Kinetic Energy
	   temp1(1) = sum(u*u)
	   temp1(2) = sum(v*v)
	   temp1(3) = sum(w*w)
	   CALL MPI_ALLREDUCE(temp1(1:3),temp2(1:3),3,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	   temp3=temp2(1)+temp2(2)+temp2(3)
	   KE(n+1)=dx*dy*dz*temp3/(8.0d0*2.0d0*pi*pi*pi)

	   !Calculate Enstrophy
      	   temp1(1)=sum(omega)
	   CALL MPI_ALLREDUCE(temp1(1),temp3,1,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
      	   Enstrophy(n+1)=dx*dy*dz*temp3/(8.0d0*2.0d0*pi*pi*pi)

	   temp1=0.0;temp2=0.0
	   !Calculate Kinetic Energy Dissipation Rate
	   temp1(1)=sum(ux*ux)
	   temp1(2)=sum(uy*uy)
	   temp1(3)=sum(uz*uz)
	   temp1(4)=sum(vx*vx)
	   temp1(5)=sum(vy*vy)
	   temp1(6)=sum(vz*vz)
	   temp1(7)=sum(wx*wx)
	   temp1(8)=sum(wy*wy)
	   temp1(9)=sum(wz*wz)
	   CALL MPI_ALLREDUCE(temp1,temp2,9,MPI_DOUBLE_PRECISION,MPI_SUM,MPI_COMM_WORLD,ierr)
	   temp3=temp2(1)+temp2(2)+temp2(3)+temp2(4)+temp2(5)+temp2(6)+temp2(7)+temp2(8)+temp2(9)
           KEdissipationRate(n+1)=dx*dy*dz*temp3/(8.0d0*Re*pi*pi*pi)

      time(n+1)=time(1)+plotgap*dt*n
      IF(myid.eq.0) THEN
         PRINT*,'time=',time(n+1)
	      PRINT*,'KE=',KE(n+1)
	      PRINT*,'Enstrophy=',Enstrophy(n+1)
	      PRINT*,'KEdissipationRate=',KEdissipationRate(n+1)
              PRINT*,'Number of Steps for Convergence=',convDiag
         PRINT*,'---------------------------------'
      END IF
      IF(savedata1==1) THEN
	 plotInt=plotInt+1
         name_config='./data/u'
         CALL savedata(Nx,Ny,Nz,plotInt,name_config,u,decomp)
         name_config='./data/v'
         CALL savedata(Nx,Ny,Nz,plotInt,name_config,v,decomp)
         name_config='./data/w'
         CALL savedata(Nx,Ny,Nz,plotInt,name_config,w,decomp)
	 name_config='./data/omega'
         CALL savedata(Nx,Ny,Nz,plotInt,name_config,omega,decomp)
      END IF
         IF (savedata1==1) THEN
      IF (myid.eq.0) THEN
         name_config='./data/KineticEnergy'
	 OPEN(UNIT=13, FILE=name_config,position='append')
	 write(13,*) KE(n+1)
         CLOSE(13)

         name_config='./data/Enstrophy'
	 OPEN(UNIT=13, FILE=name_config,position='append')
	 write(13,*)  Enstrophy(n)
         CLOSE(13)

         name_config='./data/KEdissipationRate'
	 OPEN(UNIT=13, FILE=name_config,position='append')
	 write(13,*) KEdissipationRate(n)
         CLOSE(13)

         name_config='./data/tdata'
	 OPEN(UNIT=13, FILE=name_config,position='append')
	 write(13,*) time(n)
         CLOSE(13)

			!time and plot number needed for restart
         name_config='./data/restartData'
	 OPEN(UNIT=13, FILE=name_config, status='unknown')
	 REWIND(13)
	 write(13,*) time(n),plotInt
         CLOSE(13)
      END IF
   END IF

	END DO

   CALL system_clock(finish,count_rate)
   IF (myid.eq.0) then
      PRINT *, 'Program took', REAL(finish-start)/REAL(count_rate), 'for main timestepping loop'
   END IF

	IF(exactsoln.eqv..true.) THEN
		!Calculate error in final numerical solution
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			utemp(i,j,k)=u(i,j,k) -&
					(-0.5*( factor*cos(x(i))*sin(y(j))*sin(z(k))&
					+sin(x(i))*cos(y(j))*cos(z(k)) )*exp(-(factor**2)*time(numplots+1)/Re))
		END DO; END DO; END DO
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			vtemp(i,j,k)=v(i,j,k) -&
					(0.5*(  factor*sin(x(i))*cos(y(j))*sin(z(k))&
						-cos(x(i))*sin(y(j))*cos(z(k)) )*exp(-(factor**2)*time(numplots+1)/Re))
		END DO ; END DO ; END DO
		DO k=decomp%xst(3),decomp%xen(3); DO j=decomp%xst(2),decomp%xen(2); DO i=decomp%xst(1),decomp%xen(1)
			wtemp(i,j,k)=w(i,j,k)-&
					(cos(x(i))*cos(y(j))*sin(z(k))*exp(-(factor**2)*time(numplots+1)/Re))
		END DO ; END DO ; END DO
		mychg(1) = maxval(abs(utemp)); mychg(2) = maxval(abs(vtemp)); mychg(3) = maxval(abs(wtemp))
		CALL MPI_ALLREDUCE(mychg,allchg,3,MPI_DOUBLE_PRECISION,MPI_MAX,MPI_COMM_WORLD,ierr)
		chg=allchg(1)+allchg(2)+allchg(3)
		IF (myid.eq.0) THEN
			PRINT*,'The error at time',time(numplots+1),'is=',chg
		END IF
	END IF

   111 continue
   !clean up
  	CALL decomp_2d_fft_finalize
  	CALL decomp_2d_finalize

	DEALLOCATE(x,y,z,time,mychg,allchg,temp,temp1,temp2,&
              	u,v,w,ux,uy,uz,vx,vy,vz,wx,wy,wz,uold,uxold,uyold,uzold,&
		vold,vxold,vyold,vzold,wold,wxold,wyold,wzold,utemp,vtemp,wtemp,&
		temp_r,kx,ky,kz,uhat,vhat,what,rhsuhatfix,rhsvhatfix,&
 		rhswhatfix,phat,nonlinuhat,nonlinvhat,nonlinwhat,temp_c,&
		stat=AllocateStatus)
	IF (AllocateStatus .ne. 0) STOP
	IF (myid.eq.0) THEN
		PRINT *,'Program execution complete'
	END IF
	CALL MPI_FINALIZE(ierr)
END PROGRAM main

   SUBROUTINE getName(name_config,plotInt)
      implicit none
      CHARACTER*100,intent(inout)   :: name_config
      INTEGER(kind=4)               :: plotInt
      CHARACTER*100                 :: number_file
      INTEGER(kind=4)               :: ind

      ind = index(name_config,' ') - 1
      WRITE(number_file,'(i0)') 10000000+plotInt
      number_file = name_config(1:ind)//number_file
      ind = index(number_file,' ') - 1
      name_config = number_file(1:ind)//'.datbin'
   END SUBROUTINE getname


!
! fingas1996_module.f90
! Contributors: Pi-Yueh Chuang <pychuang@gwu.edu>
!
! Distributed under terms of the BSD 3-Clause license.
!

!> @brief Implementation of Fingas 1996 models for non-volatile fluids.
module fingas1996_module
    use:: evap_base_module
    implicit none
    private
    public:: EvapFingas1996Log, EvapFingas1996SQRT

    !> @brief A model from Fingas 1996 based on natural log law.
    type, extends(EvapBase):: EvapFingas1996Log
        private
        !> @brief Final and combined coefficients used in Fingas 1996 model.
        real(kind=8):: final_coeffs
        !> @brief Time point at which evaporation percentage is 100%.
        real(kind=8):: t100

        contains
        !> @brief Initialization with an opened file unit.
        procedure:: init_with_funit => init_with_funit_fingas1996log
        !> @brief The kernel calculating remained percentage from t to t+dt.
        procedure:: remained_kernel => remained_kernel_fingas1996log
        !> @brief Destructor.
        final:: destructor_fingas1996log
    end type EvapFingas1996Log

    !> @brief A model from Fingas 1996 based on square-root law.
    type, extends(EvapFingas1996Log):: EvapFingas1996SQRT
        private
        contains
        !> @brief Initialization with an opened file unit.
        procedure:: init_with_funit => init_with_funit_fingas1996sqrt
        !> @brief The kernel calculating remained percentage from t to t+dt.
        procedure:: remained_kernel => remained_kernel_fingas1996sqrt
        !> @brief Destructor.
        final:: destructor_fingas1996sqrt
    end type EvapFingas1996SQRT

contains

    ! init the common part of Fingas models
    subroutine init_with_funit_common(this, funit, T)
        class(EvapFingas1996Log), intent(inout):: this
        integer(kind=4), intent(in):: funit
        real(kind=8), intent(in):: T
        integer(kind=4):: n_coeffs
        real(kind=8):: C1, C2

        this%ambient_temperature = T
        this%evap_volume_tracker = 0D0

        read(funit, *) n_coeffs

        if (n_coeffs /= 2) then
            print *, "The number of coefficients in Fingas' model should be 2."
            stop
        end if

        read(funit, *) C1
        read(funit, *) C2

        this%final_coeffs = C1 + C2 * this%ambient_temperature
    end subroutine init_with_funit_common

    ! init_with_funit_fingas1996log
    subroutine init_with_funit_fingas1996log(this, funit, T)
        class(EvapFingas1996Log), intent(inout):: this
        integer(kind=4), intent(in):: funit
        real(kind=8), intent(in):: T

        this%model_name = "Fingas1996 Log"
        call init_with_funit_common(this, funit, T)

        this%t100 = 6D1 * dexp(1D2/this%final_coeffs)
    end subroutine init_with_funit_fingas1996log

    ! remained_kernel_fingas1996log
    function remained_kernel_fingas1996log(this, t, dt) result(remained_percent)
        class(EvapFingas1996Log), intent(in):: this
        real(kind=8), intent(in):: t
        real(kind=8), intent(in):: dt
        real(kind=8):: remained_percent

        ! before 1 minute, no evaporation
        if (t <= 6D1) then
            remained_percent = 1D0
            return
        end if

        if ((t + dt) >= this%t100) then
            remained_percent = 0D0
            return
        end if

        remained_percent = &
            (1D2 - this%final_coeffs * dlog((t+dt)/6D1)) / &
            (1D2 - this%final_coeffs * dlog(t/6D1))
    end function remained_kernel_fingas1996log

    ! destructor_fingas1996log
    subroutine destructor_fingas1996log(this)
        type(EvapFingas1996Log), intent(inout):: this
        this%model_name = "none"
        this%ambient_temperature = 0D0
        this%evap_volume_tracker = 0D0
        this%final_coeffs = 0D0
    end subroutine destructor_fingas1996log

    ! init_with_funit_fingas1996sqrt
    subroutine init_with_funit_fingas1996sqrt(this, funit, T)
        class(EvapFingas1996SQRT), intent(inout):: this
        integer(kind=4), intent(in):: funit
        real(kind=8), intent(in):: T

        this%model_name = "Fingas1996 Square-Root"
        call init_with_funit_common(this, funit, T)

        this%t100 = 6D1 * 1D4 / (this%final_coeffs**2)
    end subroutine init_with_funit_fingas1996sqrt

    ! remained_kernel_fingas1996sqrt
    function remained_kernel_fingas1996sqrt(this, t, dt) result(remained_percent)
        class(EvapFingas1996SQRT), intent(in):: this
        real(kind=8), intent(in):: t
        real(kind=8), intent(in):: dt
        real(kind=8):: remained_percent

        if ((t + dt) >= this%t100) then
            remained_percent = 0D0
            return
        end if

        remained_percent = &
            (1D2 - this%final_coeffs * dsqrt((t+dt)/6D1)) / &
            (1D2 - this%final_coeffs * dsqrt(t/6D1))
    end function remained_kernel_fingas1996sqrt

    ! destructor_fingas1996sqrt
    subroutine destructor_fingas1996sqrt(this)
        type(EvapFingas1996SQRT), intent(inout):: this
        this%model_name = "none"
        this%ambient_temperature = 0D0
        this%evap_volume_tracker = 0D0
        this%final_coeffs = 0D0
    end subroutine destructor_fingas1996sqrt

end module fingas1996_module


PROGRAM celsius2fahrenheit
    IMPLICIT NONE

    REAL(8) celsius, fahrenheit

    WRITE(*, *) "Valor da temperatura em Celsius:"
    READ(*, *) celsius

    IF (celsius >= -273.15d0) THEN ! zero absoluto
        fahrenheit = 1.8d0 * celsius + 32.0d0

        WRITE(*, *) "Valor da temperatura em Fahrenheit"
        WRITE(*, *) fahrenheit
    ELSE
        WRITE(*, *) "Temperatura inválida"
    END IF
END PROGRAM celsius2fahrenheit


PROGRAM MAIN

  IMPLICIT NONE

  ! Loop counter and maximum value
  INTEGER :: i, max_val
  ! Variables for current value
  ! If I use an INTEGER, I get exactly the right answer UNTIL I overflow
  ! I have to catch the overflow and do something
  INTEGER(KIND=SELECTED_INT_KIND(15)) :: factorial

  ! TRY the first 20 terms
  max_val = 30

  ! Optional last but to add- sanity check on max_val
  IF(max_val < 1 .OR. max_val > 30) THEN
    PRINT*, "Sequence is too short or long. max_val should be between 1 and 30"
  END IF

  factorial = 1

  ! Loop from first value to max_value, calculating and printing the term
  DO i = 1, max_val

    ! this iterattion will exceed HUGE()
    ! If I continue regardless I wil get a plausible but WRONG answer
    IF(factorial .GT. HUGE(factorial)/i) THEN
      PRINT*, "Value Overflowing!"
      STOP
    END IF
    factorial = factorial * i
    ! Print the calculated value
    PRINT*, "n= ", i, " n!=", factorial

  END DO

END PROGRAM


!	convert an n by n symmetric matrix from compact to regular form.
function expandmat(n,compmat)
implicit none
integer,intent(in)::n
real(kind=8),intent(in)::compmat(:)
real(kind=8)::expandmat(n,n)
integer::row,position
position=1
do row=1,n
	expandmat(row,1:row)=compmat(position:position+row-1)
	if(row>1)then
		expandmat(row,1:row-1)=expandmat(row,1:row-1)/2.0_8
		expandmat(1:row-1,row)=expandmat(row,1:row-1)
	end if
	position=position+row
end do
return
end function expandmat


! { dg-do  run }
! { dg-options "-ffrontend-optimize" }
program main

  real, dimension(2,2) :: a,b,c

  data a /2., 4., 8., 16. /
  data b /3., 9., 27., 81./

  c = matmul(a,b)
  a = matmul(a,b)
  if (any(a /= c)) call abort
end program main


program test_spectral_interpolation_ipol_0

use kind_values, only:  wp => kind_swd_internal
use spectral_interpolation_def, only: spectral_interpolation

implicit none

! This program tests the ipol=0 temporal scheme

! Dummy polynomials: f(t) = a0 + a1*t + a2*t**2 + a3*t**3 + a4*t**4 + a5*t**5
complex(wp), parameter :: a0 = cmplx(0.156_wp, 0.17_wp, wp)
complex(wp), parameter :: a1 = cmplx(1.234_wp, -0.54_wp, wp)
complex(wp), parameter :: a2 = cmplx(-2.34_wp, 0.154_wp, wp)
complex(wp), parameter :: a3 = cmplx(-0.18_wp, -0.25_wp, wp)
complex(wp), parameter :: a4 = cmplx(0.58_wp, -0.74_wp, wp)
complex(wp), parameter :: a5 = cmplx(0.23_wp, 0.09_wp, wp)

real(wp), parameter :: delta_t = 0.34_wp
real(wp), parameter :: t_im1 = 0.15_wp
real(wp), parameter :: t_i = t_im1 + delta_t
real(wp), parameter :: t_ip1 = t_i + delta_t
real(wp), parameter :: t_ip2 = t_ip1 + delta_t

type(spectral_interpolation) :: si
real(wp) :: t, delta
complex(wp) :: c1, dc1, ddc1, c2, dc2, ddc2
complex(wp) :: f_im1, f_i, f_ip1, f_ip2
complex(wp) :: df_im1, df_i, df_ip1, df_ip2
complex(wp) :: ddf_i, ddf_ip1

integer :: ipol, i, ierr, n_error = 0
real(wp), parameter :: deltas(5) = [0.0_wp, 0.29_wp, 0.64_wp, 0.84_wp, 1.0_wp]

print*, " Test of ipol=0..."
ipol = 0
call si % construct(ipol, delta_t, ierr)
if (ierr /= 0) then
    print *, "Unknown interpolation scheme: ", ipol
    stop
end if

f_im1 = f5(t_im1)
f_i = f5(t_i)
f_ip1 = f5(t_ip1)
f_ip2 = f5(t_ip2)
df_im1 = df5(t_im1)
df_i = df5(t_i)
df_ip1 = df5(t_ip1)
df_ip2 = df5(t_ip2)
! Adjust f_im1 make ddf_i based on finite-difference match polynomial at t_i
ddf_i = ddf5(t_i)
f_im1 = 0.5_wp * ddf_i * delta_t**2 + 2 * f_i - f_ip1 + (df_ip1 - df_im1) * delta_t / 4
! Adjust f_ip2 to make ddf_ip1 based on finite-difference match polynomial at t_ip1
ddf_ip1 = ddf5(t_ip1)
f_ip2 = 0.5_wp * ddf_ip1 * delta_t**2 + 2 * f_ip1 - f_i + (df_ip2 - df_i) * delta_t / 4

do i = 1, size(deltas)
    delta = deltas(i)
    t = t_i + delta * delta_t
    c1 = f5(t)
    dc1 = df5(t)
    ddc1 = ddf5(t)
    call si % scheme(delta, &
                     f_im1, f_i, f_ip1, f_ip2, &
                     df_im1, df_i, df_ip1, df_ip2, &
                     c2, dc2)
    print*, "Delta = ", delta
    print*, "Compare function values: ", c1, c2, compare(c1, c2)
    print*, "Compare function derivatives: ", dc1, dc2, compare(dc1, dc2)
    if (i==1) then
        print*, "f_i, df_i: ", f_i, df_i
        print*, "compare(c2, f_i)", compare(c2, f_i)
        print*, "compare(dc2, df_i)", compare(dc2, df_i)
        print*, "compare(ddc1, ddf_i)", compare(ddc1, ddf_i)
    else if (i==size(deltas)) then
        print*, "f_ip1, df_ip1: ", f_ip1, df_ip1
        print*, "compare(c2, f_ip1)", compare(c2, f_ip1)
        print*, "compare(dc2, df_ip1)", compare(dc2, df_ip1)
        print*, "compare(ddc1, ddf_ip1)", compare(ddc1, ddf_ip1)
    end if
end do

print*, "Number of detected ERRORs = ", n_error

contains

function f5(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = a0 + a1*t + a2*t**2 + a3*t**3 + a4*t**4 + a5*t**5
end function f5

function df5(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = a1 + 2.0_wp * a2*t + 3.0_wp * a3*t**2 + 4.0_wp * a4*t**3 + 5.0_wp * a5*t**4
end function df5

function ddf5(t) result(res)
real(wp), intent(in) :: t
complex(wp) res
res = 2.0_wp * a2 + 6.0_wp * a3*t + 12.0_wp * a4*t**2 + 20.0_wp * a5*t**3
end function ddf5

function compare(c1, c2) result(res)
complex(wp), intent(in) :: c1, c2
character(len=10) res
real(wp), parameter :: eps = 100*epsilon(eps)
if (abs(c1 % re - c2 % re) > eps * max(abs(c1 % re), abs(c2 % re)) .or. &
    abs(c1 % im - c2 % im) > eps * max(abs(c1 % im), abs(c2 % im))) then
    res = "ERROR!"
    n_error = n_error + 1
else
    res = "OK"
end if
end function compare

end program test_spectral_interpolation_ipol_0


      SUBROUTINE ROOTS (A     ,NA    ,CROOTS,IRL   )
      IMPLICIT COMPLEX*16 (C),  REAL*8 (A-B,D-H,O-Z)
      DIMENSION         A(NA) ,CROOTS(NA)   ,Z(2)  ,ZS(2)
      EQUIVALENCE      (Z(1),CZ)     ,(ZS(1),CZS)
C
C.......................................................................
C
C   VERSION OF APRIL 5, 1976
C
C   PURPOSE:
C    THIS SUBROUTINE COMPUTES ANY DESIRED COMPLEX ROOTS (ZEROES) OF A
C    GIVEN POLYNOMIAL, IF APPROXIMATIONS TO THE DESIRED ROOTS ARE KNOWN.
C
C   METHOD:
C    NEWTON'S METHOD, AS DESCRIBED IN THE REFERENCE.
C
C   REFERENCE:
C    HENRICI, P., 'ELEMENTS OF NUMERICAL ANALYSIS', NEW YORK, WILEY,
C    1965, PAGE 84.
C
C   CALLING SEQUENCE EXPLANATION :
C
C     VARIABLE  I/O   DESCRIPTION
C     --------  ---   --------------------------------------------------
C     A          I    IS AN INPUT DIMENSION NA ARRAY OF REAL
C                     (NON-IMAGINARY) POLYNOMIAL COEFFICIENTS, STARTING
C                     WITH THE LOWEST POWER.
C     NA         I    IS THE NUMBER OF IMPUT COEFFICIENTS (ONE MORE
C                     THAN THE DEGREE OF THE POLYNOMIAL).
C     CROOTS    I/O   IS A COMPLEX*16 ARRAY OF DIMENSION NA
C                     CONTAINING THE STARTING APPROXIMATIONS TO THE
C                     DESIRED ROOTS ON INPUT AND THE SOLUTIONS ON
C                     OUTPUT.
C     IRL        I    IS THE NUMBER OF ROOTS (ZEROES) DESIRED TO BE
C                     SOLVED FOR
C
C   COMMON BLOCK PARAMETERS;
C    NONE
C
C   SUBROUTINES AND FUNCTIONS REQUIRED:
C    NONE
C
C   CALLED BY:
C    LOWALT
C
C.......................................................................
C
C
C   IR COUNTS ROOTS SOLVED SO FAR
C
      IR = 0
      N1 = NA - 1
C
  100 IR = IR + 1
      IF (IR .GT. IRL)  RETURN
C
C   IT COUNTS ITERATIONS ON THIS ROOT SO FAR
C
      IT = 0
C
C   CZ IS THE CURRENTLY ITERATED VALUE OF THE ROOT.
C
      CZ = CROOTS(IR)
C
  150 CB = A(NA)
      CC = A(NA)
C
      DO 200 I=1,N1
         J = NA - I
C
C   CB & CC ARE THE VALUES OF THE POLYNOMIAL(P(Z)) AND ITS DERIVATIVE
C                                                            (P'(Z)).
C
         CB = CZ*CB + A(J)
         IF (J .EQ. 1)  GO TO 200
C
         CC = CZ*CC + CB
  200 CONTINUE
C
      IT = IT + 1
C
C   THE RESULT OF THE LAST ITERATION IS SAVED IN CZS.
C
      CZS = CZ
C
C   NEWTONS METHOD SAYS THAT
C                  Z(I)  =  Z(I-1) - P(Z(I-1))/P'(Z(I-1))
C    TENDS TOWARD A ROOT OF THE POLYNOMIAL P(Z).
C
      CZ = CZ - CB/CC
C
C   THE CONVERGENCE CRITERION (DIF) IS THE SUM OF THE RELATIVE CHANGES
C   IN THE REAL AND IMMAGINARY PARTS OF THE ROOT (CZ).
C
      DIF =DABS((ZS(1) - Z(1))/ZS(1))
      IF (ZS(2) .NE. 0.D0)  DIF = DIF + DABS((ZS(2) - Z(2))/ZS(2))
C
C   IF THE CONVERGENCE CRITERION IS TOO LARGE, ITERATE AGAIN.
C
      IF (DIF .GT.1.D-14)  GO TO 150
C
C   OTHERWISE, THE CONVERGENCE IS COMPLETE.  STORE THE ANSWER FOR OUTPUT
C   AND START ON THE NEXT ROOT.
C
      CROOTS(IR) = CZ
      GO TO 100
C
      END


program test
  use quadratures, only: clencurt, polytest
  implicit none
  integer, parameter :: dp = kind(1.d0)
  integer, parameter :: sp = kind(1.0)
  real(dp), parameter :: PI = 3.141592653589793_dp
  integer(8) :: N
  real(dp), dimension(:), allocatable :: mu, wt
  character(len=12) :: arg

  if (command_argument_count() .ne. 1) then
     write (*, '(A)') &
          '> Runtime error: must supply the number of gridpoints as input.'
     write (*, '(A)') 'Example: ./test 16'
     stop
  else
     call get_command_argument(1, arg)
     read(arg, *) N
  endif
  allocate(mu(N), wt(N))

  call clencurt(N, mu, wt)
  call polytest(N, 0, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 1, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 2, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 3, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 4, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 16, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 32, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 50, -1.0_dp, 1.0_dp, mu, wt)
  call polytest(N, 0, -1.0_dp, 1.0_dp, mu, wt)

  deallocate(mu, wt)

end program test


program main
    use LinearSolverClass
    implicit none

    real(8),allocatable :: a(:,:),b(:),x(:)
    integer :: i,n,itrmax
    real(8) :: er

    open(10,file="gpbicg.txt")
    read(10,*) n

    allocate(a(n,n),b(n),x(n) )
    do i=1,n
        read(10,* ) a(i,:)
    enddo
    do i=1,n
        read(10,* ) b(i)
    enddo
    close(10)

    x(:)=1.0d0
    call GPBiCG(a,b,x,n)

    do i=1,n
        print *,  i,"|value ",x(i),"|residual ",b(i)-dot_product(a(i,:),x(:) )
    enddo

    call gauss_jordan_pv(a,x,b,n)

    do i=1,n
        print *,  i,"|value ",x(i),"|residual ",b(i)-dot_product(a(i,:),x(:) )
    enddo

    itrmax=1000
    er=1.0e-20
    x(:)=0.0d0
    call bicgstab1d(a,b,x,n,itrmax, er)

    do i=1,n
        print *,  i,"|value ",x(i),"|residual ",b(i)-dot_product(a(i,:),x(:) )
    enddo

end program main


subroutine tara1dHydSer(arg)

use cfgio_mod, only: cfg_t, parse_cfg

implicit none

type(cfg_t):: cfg

real (kind=8), parameter :: pi = 3.14159265358979323846d0

include "fftw3.f"

integer (kind=4) N,Nh

real (kind = 8), dimension (:), allocatable :: x, ux, dux, ddux

complex (kind=8), dimension(:), allocatable :: uk,duk,dduk

integer*8 :: plan
real*8 :: L

integer :: i,t
real*8 dx,k,time,time_min,time_max,dt,nu
real (kind = 8), dimension (:), allocatable :: force_u_n, force_u_o

character (len=90) :: filename
character (len=32) :: arg

cfg = parse_cfg(arg)

call cfg%get("grid","Nx",N)

Nh = (N/2) + 1

allocate(x(N))
allocate(ux(N))
allocate(dux(N))
allocate(ddux(N))

allocate(force_u_n(N))
allocate(force_u_o(N))

allocate(uk(Nh))
allocate(duk(Nh))
allocate(dduk(Nh))

call cfg%get("length","Lx",L)

call cfg%get("resistivity","nu",nu)

call cfg%get("time","time_min",time_min)
call cfg%get("time","time_max",time_max)
call cfg%get("time","dt",dt)

L  = L*pi
dx = L/dfloat(N)

do i = 1,N
  x(i) = dfloat(i-1)*dx
  ux(i) = dsin(x(i))
enddo

do time = time_min, time_max, dt

t = nint(time/dt) - int(time_min/dt)

call dfftw_plan_dft_r2c_1d(plan, N, ux, uk, FFTW_ESTIMATE)
call dfftw_execute_dft_r2c(plan, ux, uk)
call dfftw_destroy_plan(plan)

do i = 1,Nh
  k = 2.0d0*pi*dfloat(i-1)/L
  duk(i) = (0.0d0,1.0d0) * k * uk(i)
  dduk(i) = - k * k * uk(i)
enddo

call dfftw_plan_dft_c2r_1d(plan, N, duk, dux, FFTW_ESTIMATE)
call dfftw_execute_dft_c2r(plan, duk, dux)
call dfftw_destroy_plan(plan)

call dfftw_plan_dft_c2r_1d(plan, N, dduk, ddux, FFTW_ESTIMATE)
call dfftw_execute_dft_c2r(plan, dduk, ddux)
call dfftw_destroy_plan(plan)

do i = 1,N
dux(i) = dux(i)/dfloat(N)
ddux(i) = ddux(i)/dfloat(N)
  if (t .ge. 1000 .and. mod(t,500) == 0) then
    write(filename, '("output/fort.",I8.8)') t
    open(unit=t,file=filename,status='unknown')
    write(t,*) t, x(i), ux(i)
  endif
enddo

do i = 1,N
  force_u_n(i) = -ux(i)*dux(i) + nu*ddux(i)
    if (t==0) then
    ux(i) = ux(i) + dt * force_u_n(i)
    else
    ux(i) = ux(i) + dt* ( (3.0/2.0) * force_u_n(i) - (1.0/2.0) * force_u_o(i))
    endif
 force_u_o(i) = force_u_n(i)
enddo

enddo

end subroutine tara1dHydSer