module build_hamiltonian_routines
use hamiltonian_types
use maths
implicit none
contains

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Spin-orbit coupling Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_spin_orbit(level,ketl,ketr)
	real(kind=8) :: H_spin_orbit
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, term1, term2

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_Sigma*delta_Omega*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Omega = ketr%Omega
		J = ketr%J
		M = ketr%M

		term1 = level%A * Lambda * Sigma
		term2 = level%A_D * Lambda * Sigma * (J*(J+1.d0) - Omega**2 + S*(S+1.d0) - Sigma**2)
		H_spin_orbit = deltas * (term1 + term2)

	end function H_spin_orbit

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Rotational Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_rotational(level,ketl,ketr)
	real(kind=8) :: H_rotational
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, term1, term2
	real(kind=8) :: i, q

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		M = ketr%M

		term1 = level%B_rot * delta_Sigma * delta_Omega * (J*(J+1.d0) - Omega**2 + S*(S+1.d0) - Sigma**2)
		term2 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			term2 = term2 - 2.d0*level%B_rot * (-1.d0)**(J-Omega_p+S-Sigma_p) * &
				w3js(int(2*J),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega))*&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma))*&
				sqrt(J*(J+1.d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0))
		enddo
		H_rotational = deltas * (term1 + term2)

	end function H_rotational

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Rotational Centrifugal Distortion Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_rotational_cd4(level,ketl,ketr)
	real(kind=8) :: H_rotational_cd4
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, Omega_pp, Sigma_pp, term1, term2, term3
	real(kind=8) :: i, q

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		M = ketr%M

		term1 = -level%D_rot * delta_Sigma * delta_Omega * (J*(J+1.d0) - Omega**2 + S*(S+1.d0) - Sigma**2)**2

		term2 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			Omega_pp = Omega - q
			Sigma_pp = Sigma - q
			term2 = term2 - 4.d0*level%D_rot*delta_Sigma*delta_Omega*&
				w3js(int(2*J),2,int(2*J),-int(2*Omega),int(2*q),int(2*Omega_pp))**2 *&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma),int(2*q),int(2*Sigma_pp))**2 *&
				(J*(J+1d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0))
		enddo

		term3 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			term3 = term3 + 2.d0*level%D_rot*(-1.d0)**(J-Omega_p+S-Sigma_p) * &
				w3js(int(2*J),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega))*&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma))*&
				sqrt(J*(J+1.d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0)) * &
				(2.d0*J*(J+1.d0)-Omega**2-Omega_p**2+2.d0*S*(S+1.d0)-Sigma**2-Sigma_p**2)
		enddo
		H_rotational_cd4 = deltas * (term1 + term2 + term3)

	end function H_rotational_cd4

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Spin-rotation coupling Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_spin_rotation(level,ketl,ketr)
	real(kind=8) :: H_spin_rotation
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, term1, term2, term3
	real(kind=8) :: i, q

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_Lambda*delta_S*delta_J*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		M = ketr%M

		term1 = level%gamma_spin * delta_Sigma * delta_Omega * (Omega*Sigma - S*(S+1.d0))

		term2 = 0.d0
		do i = 0, 1
			q = -1 + 2*i
			term2 = term2 + level%gamma_spin * (-1.d0)**(J-Omega_p+S-Sigma_p) * &
				w3js(int(2*J),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega))*&
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma))*&
				sqrt(J*(J+1.d0)*(2.d0*J+1.d0)*S*(S+1.d0)*(2.d0*S+1.d0))
		enddo
		H_spin_rotation = deltas * (term1 + term2)

	end function H_spin_rotation

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Zeeman Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function H_Zeeman(level,ketl,ketr)
	real(kind=8) :: H_Zeeman
	type(type_hamiltonian) :: level
	type(type_ket_hund_a) :: ketl, ketr
	real(kind=8) :: delta_Lambda, delta_S, delta_Sigma, delta_Omega, delta_J, delta_M, deltas
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, Sigma_p, Omega_p, J_p, term1, term2, term3
	real(kind=8) :: i, q, g_L, g_S, g_r

		delta_Lambda = delta(ketl%Lambda,ketr%Lambda)
		delta_S = delta(ketl%S,ketr%S)
		delta_Sigma = delta(ketl%Sigma,ketr%Sigma)
		delta_Omega = delta(ketl%Omega,ketr%Omega)
		delta_J = delta(ketl%J,ketr%J)
		delta_M = delta(ketl%M,ketr%M)

		deltas = delta_S*delta_M

		Lambda = ketr%Lambda
		S = ketr%S
		Sigma = ketr%Sigma
		Sigma_p = ketl%Sigma
		Omega = ketr%Omega
		Omega_p = ketl%Omega
		J = ketr%J
		J_p = ketl%J
		M = ketr%M

		g_L = level%g_L
		g_r = level%g_r
		g_S = level%g_S

		term2 = 0.d0
		do i = 0, 2
			q = -1 + i

			term1 = (g_L+g_r)*Lambda*delta_Sigma + (g_S+g_r)*(-1.d0)**(S-Sigma_p) * &
				w3js(int(2*S),2,int(2*S),-int(2*Sigma_p),int(2*q),int(2*Sigma)) * &
				sqrt(S*(S+1.d0)*(2.d0*S+1.d0))

			term2 = term2 + (-1.d0)**(J_p-M+J_p-Omega_p) * &
				sqrt((2.d0*J_p+1.d0)*(2.d0*J+1.d0)) * &
				w3js(int(2*J_p),2,int(2*J),-int(2*M),0,int(2*M))*&
				w3js(int(2*J_p),2,int(2*J),-int(2*Omega_p),int(2*q),int(2*Omega)) * term1

		enddo

		term2 = bohr_mag * level%B_field * delta_Lambda * term2

		term3 = -g_r * bohr_mag * level%B_field * M * delta_J*delta_Sigma*delta_Lambda

		H_Zeeman = deltas * (term2 + term3)

	end function H_Zeeman

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Builds the basis set and the Hamiltonian
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine build_hamiltonian(level)
	type(type_hamiltonian) :: level
	real(kind=8) :: Lambda, S, Sigma, Omega, J, M, lande, landeb
	integer :: a, b, c, d, n, a_max, nrot
	real(kind=4) :: tiempo_antes, tiempo_despues
	real(kind=8), allocatable :: caca(:,:)

		print *, 'Lambda : ', level%Lambda
		print *, 'S : ', level%S
		print *, 'J : ', level%J
		print *, 'B_rot : ', level%B_rot
		print *, 'D_rot : ', level%D_rot
		print *, 'H_rot : ', level%H_rot
		print *, 'gamma_spin : ', level%gamma_spin
		print *, 'A : ', level%A
		print *, 'A_D : ', level%A_D
		print *, 'g_L : ', level%g_L
		print *, 'g_S : ', level%g_S
		print *, 'g_r : ', level%g_r

!------------------------------------------------
		print *, 'Generating basis set...'
! First count the number of elements of the basis in which the Hamiltonian is written
		n = 0
		S = level%S

		a_max = 2
		if (level%Lambda == 0.d0) a_max = 1

		do a = 1, a_max
			Lambda = (-1)**a * level%Lambda
			do b = 0, 2*S
				Sigma = -S + b
				Omega = Lambda + Sigma
				do c = 1, 3
					J = level%J + c - 2
					if (J >= 0.d0) then
						do d = 0, 2*J
							M = -J + d
							n = n + 1
						enddo
					endif
				enddo
			enddo
		enddo

		level%hamiltonian_size = n
		allocate(level%ket(n))
		allocate(level%ket_m_ordered(n))
		allocate(level%ket_nofield(n))
		allocate(level%ket_purerotation(n))
		allocate(level%matrix(n,n))
		allocate(level%matrix_zero_field(n,n))
		allocate(level%eigenvec(n,n))
		allocate(level%eigenval(n))
		allocate(level%eigenval_zerofield(n))
		allocate(level%active(n))

		print *, 'Size of the basis : ', level%hamiltonian_size

		n = 0
! Then generate all the basis
		S = level%S

		a_max = 2
		if (level%Lambda == 0.d0) a_max = 1

		do a = 1, a_max
			Lambda = (-1)**a * level%Lambda
			do b = 0, 2*S
				Sigma = -S + b
				Omega = Lambda + Sigma
				do c = 1, 3
					J = level%J + c - 2
					if (J >= 0.d0) then
						do d = 0, 2*J
							M = -J + d
							n = n + 1
							level%ket(n)%Lambda = Lambda
							level%ket(n)%S = S
							level%ket(n)%Sigma = Sigma
							level%ket(n)%Omega = Omega
							level%ket(n)%J = J
							level%ket(n)%M = M
						enddo
					endif
				enddo
			enddo
		enddo

!----------------------------------------------------------------------
		print *, 'Ordering basis set...'
! Order the basis set by increasing value of M
		call order_basis_set(level)

! Generate the base for the no-field case
		level%ket_nofield = level%ket
		level%ket_purerotation = level%ket

		print *, 'Building pure rotational Hamiltonian...'
! Diagonalize the pure rotational Hamiltonian
		level%B_field = 0.d0
		do a = 1, level%hamiltonian_size
			do b = 1, level%hamiltonian_size
				level%matrix_zero_field(a,b) = H_rotational(level,level%ket(a),level%ket(b))
			enddo
		enddo

		print *, 'Diagonalizing pure rotational Hamiltonian...'
		tiempo_antes = second()
		call diagonalize_hamiltonian(level,level%matrix_zero_field,level%eigenval_zerofield,level%eigenvec)
		tiempo_despues = second()

! And then assign the rotational quantum numbers for each level
		call calculate_rotational_numbers(level)
! Order the pure rotation basis
		call order_basis_set_purerotation(level)

!		do a = 1, level%hamiltonian_size
!				write(*,FMT='(I3,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F12.5,1X,F12.5,1X,F12.5)') &
!					a, level%ket_nofield(a)%Lambda, &
!					level%ket_nofield(a)%S, level%ket_nofield(a)%Sigma, level%ket_nofield(a)%Omega, level%ket_nofield(a)%J, &
!					level%ket(a)%M, level%ket_nofield(a)%N, level%eigenval_zerofield(a)
!		enddo

!----------------------------------------------------------------------
! Diagonalize the complete zero-field Hamiltonian
		level%B_field = 0.d0
		do a = 1, level%hamiltonian_size
			do b = 1, level%hamiltonian_size
				level%matrix_zero_field(a,b) = level%matrix_zero_field(a,b) + &
												H_rotational_cd4(level,level%ket(a),level%ket(b)) + &
												H_spin_orbit(level,level%ket(a),level%ket(b)) + &
												H_rotational_cd4(level,level%ket(a),level%ket(b)) + &
												H_spin_rotation(level,level%ket(a),level%ket(b))
			enddo
		enddo

		print *, 'Diagonalizing zero-field Hamiltonian...'
		tiempo_antes = second()
		call diagonalize_hamiltonian(level,level%matrix_zero_field,level%eigenval_zerofield,level%eigenvec)
		tiempo_despues = second()

!----------------------------------------------------------------------
! Diagonalize the Hamiltonian with field
		print *, 'Building Hamiltonian...'
		level%B_field = field_strength
		do a = 1, level%hamiltonian_size
			do b = 1, level%hamiltonian_size
				level%matrix(a,b) = level%matrix_zero_field(a,b) + &
									H_Zeeman(level,level%ket(a),level%ket(b))

			enddo
		enddo

		print *, 'Diagonalizing Hamiltonian...'
		tiempo_antes = second()
		call diagonalize_hamiltonian(level,level%matrix,level%eigenval,level%eigenvec)
		tiempo_despues = second()

! Order the basis set for the no-field and the field case
		call order_basis_set_field(level)
		call order_basis_set_zerofield(level)

!		do a = 1, level%hamiltonian_size
!			if (abs(level%ket_nofield(a)%J-level%J) <= 1.d-10 .and. abs(level%ket_purerotation(a)%N-level%N) <= 1.d-10 .and. &
!				level%ket(a)%Lambda == level%Lambda) then
!			if (abs(level%ket_nofield(a)%J-level%J) <= 1.d-10 .and. abs(level%ket_nofield(a)%N-level%N) <= 1.d-10) then
!				write(*,FMT='(I3,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F4.1,1X,F12.5,1X,F12.5,1X,F12.5)') &
!					a, level%ket(a)%Lambda, &
!					level%ket_nofield(a)%S, level%ket_nofield(a)%Sigma, level%ket_nofield(a)%Omega, level%ket_nofield(a)%J, &
!					level%ket(a)%M, level%ket_purerotation(a)%N, level%eigenval(a), level%eigenval_zerofield(a), &
!					level%eigenval(a)-level%eigenval_zerofield(a)
!				lande = (level%eigenval(a)-level%eigenval_zerofield(a)) / (bohr_mag * level%B_field * level%ket(a)%M)
!				write(*,FMT='(A,F5.1,1X,A,F5.1,1X,A,F5.1,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7)') 'J=', &
!					level%ket_nofield(a)%J, 'N=',level%ket_purerotation(a)%N, 'M=',level%ket(a)%M, 'E=',level%eigenval(a), &
!					'E0=',level%eigenval_zerofield(a), 'DE=',level%eigenval(a)-level%eigenval_zerofield(a), 'g=', lande
!			endif
!		enddo

! Go through all the eigenvalues selecting those which belong to the zero-field J and N value and
! select one of the two-fold degenerate Lambda-doubling levels because Lambda-doubling is not included
		level%active = -9999

		do a = 1, level%hamiltonian_size
			if (abs(level%ket_nofield(a)%J-level%J) <= 1.d-10 .and. abs(level%ket_purerotation(a)%N-level%N) <= 1.d-10 .and. &
				level%ket(a)%Lambda == level%Lambda) then

! Indicate that this eigenvalue is in the set we are interested in
					level%active(a) = level%ket(a)%M

					lande = (level%eigenval(a)-level%eigenval_zerofield(a)) / (bohr_mag * level%B_field * level%ket(a)%M)
					landeb = lande_caseb(level)
					write(*,FMT='(A,F5.1,1X,A,F5.1,1X,A,F5.1,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7,1X,A,F12.7)') 'J=', &
						level%ket_nofield(a)%J, 'N=',level%ket_purerotation(a)%N, 'M=',level%ket(a)%M, 'E=',level%eigenval(a), &
						'E0=',level%eigenval_zerofield(a), 'DE=',level%eigenval(a)-level%eigenval_zerofield(a), 'g=', lande, &
						'g(b)=',landeb
					write(20,*) level%ket(a)%m, level%eigenval(a), level%eigenval(a)-level%eigenval_zerofield(a), &
						lande, landeb

			endif
		enddo

	end subroutine build_hamiltonian

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Calculate the rotational quantum numbers
! If we include only the rotational hamiltonian, the energy can be associated with a given value of N
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine calculate_rotational_numbers(level)
	type(type_hamiltonian) :: level
	integer :: i

		do i = 1, level%hamiltonian_size
			level%ket(i)%N = (-level%B_rot + sqrt(level%B_rot**2 + 4.d0 * level%B_rot*level%eigenval_zerofield(i) + &
				4.d0 * level%B_rot**2 * level%Lambda**2)) / &
				(2.d0 * level%B_rot)
			level%ket_nofield(i)%N = level%ket(i)%N
			level%ket_purerotation(i)%N = level%ket(i)%N
		enddo
	end subroutine calculate_rotational_numbers

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Re-order the Hamiltonian to make it block-diagonal
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine order_basis_set(level)
	type(type_hamiltonian) :: level
	real(kind=8), allocatable :: m_vec(:)
	integer, allocatable :: indx(:)
	integer :: i
	type(type_ket_hund_a), allocatable :: ket_temp(:)

		allocate(m_vec(level%hamiltonian_size))
		allocate(indx(level%hamiltonian_size))

! Order the basis set by their M value
		do i = 1, level%hamiltonian_size
			m_vec(i) = level%ket(i)%M
		enddo
		call indexx(m_vec,indx)

		allocate(ket_temp(level%hamiltonian_size))
		ket_temp = level%ket

		do i = 1, level%hamiltonian_size
			level%ket(i) = ket_temp(indx(i))
			level%ket_m_ordered(i) = ket_temp(indx(i))
		enddo

		deallocate(m_vec)
		deallocate(indx)
		deallocate(ket_temp)
	end subroutine order_basis_set

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Re-order the eigenvalues in ascending order
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine order_basis_set_field(level)
	type(type_hamiltonian) :: level
	real(kind=8), allocatable :: m_vec(:), m_vec2(:,:)
	integer, allocatable :: indx(:)
	integer :: i
	type(type_ket_hund_a), allocatable :: ket_temp(:)

		allocate(m_vec(level%hamiltonian_size))
		allocate(m_vec2(level%hamiltonian_size,level%hamiltonian_size))
		allocate(indx(level%hamiltonian_size))

! Order the basis set by their eigenvalue
		m_vec = level%eigenval
		m_vec2 = level%eigenvec

		call indexx(m_vec,indx)

		allocate(ket_temp(level%hamiltonian_size))
		ket_temp = level%ket

		m_vec = level%eigenval

		do i = 1, level%hamiltonian_size
			level%eigenval(i) = m_vec(indx(i))
			level%eigenvec(:,i) = m_vec2(:,indx(i))
			level%ket(i) = ket_temp(indx(i))
		enddo

		deallocate(m_vec)
		deallocate(indx)
		deallocate(ket_temp)
		deallocate(m_vec2)
	end subroutine order_basis_set_field

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Re-order the Hamiltonian to make it block-diagonal
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine order_basis_set_zerofield(level)
	type(type_hamiltonian) :: level
	real(kind=8), allocatable :: m_vec(:)
	integer, allocatable :: indx(:)
	integer :: i
	type(type_ket_hund_a), allocatable :: ket_temp(:)

		allocate(m_vec(level%hamiltonian_size))
		allocate(indx(level%hamiltonian_size))

! Order the basis set by their M value
		do i = 1, level%hamiltonian_size
			m_vec(i) = level%eigenval_zerofield(i)
		enddo
		call indexx(m_vec,indx)

		allocate(ket_temp(level%hamiltonian_size))
		ket_temp = level%ket_nofield

		m_vec = level%eigenval_zerofield

		do i = 1, level%hamiltonian_size
			level%eigenval_zerofield(i) = m_vec(indx(i))
			level%ket_nofield(i) = ket_temp(indx(i))
		enddo

		deallocate(m_vec)
		deallocate(indx)
		deallocate(ket_temp)
	end subroutine order_basis_set_zerofield

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Re-order the Hamiltonian to make it block-diagonal
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine order_basis_set_purerotation(level)
	type(type_hamiltonian) :: level
	real(kind=8), allocatable :: m_vec(:)
	integer, allocatable :: indx(:)
	integer :: i
	type(type_ket_hund_a), allocatable :: ket_temp(:)

		allocate(m_vec(level%hamiltonian_size))
		allocate(indx(level%hamiltonian_size))

! Order the basis set by their M value
		do i = 1, level%hamiltonian_size
			m_vec(i) = level%eigenval_zerofield(i)
		enddo
		call indexx(m_vec,indx)

		allocate(ket_temp(level%hamiltonian_size))
		ket_temp = level%ket_purerotation

		m_vec = level%eigenval_zerofield

		do i = 1, level%hamiltonian_size
			level%eigenval_zerofield(i) = m_vec(indx(i))
			level%ket_purerotation(i) = ket_temp(indx(i))
		enddo

		deallocate(m_vec)
		deallocate(indx)
		deallocate(ket_temp)
	end subroutine order_basis_set_purerotation

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Diagonalize the Hamiltonian making use of the block-structure
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine diagonalize_hamiltonian(level,matrix,eigenval,eigenvec)
	type(type_hamiltonian) :: level
	real(kind=8) :: matrix(:,:), eigenval(:), eigenvec(:,:)
	real(kind=8), allocatable :: m_vec(:)
	real(kind=8) :: m_max, m_local
	real(kind=8), allocatable :: submatrix(:,:), subeigenval(:), subeigenvec(:,:)
	integer, allocatable :: indx(:)
	integer :: i, n_m, start, finish, n, nrot

		allocate(m_vec(level%hamiltonian_size))

! Order the basis set by their M value
		do i = 1, level%hamiltonian_size
			m_vec(i) = level%ket(i)%M
		enddo

		m_max = minval(m_vec)
		n_m = 2*abs(m_max) + 1

		do i = 1, n_m

! Select the elements of the basis with M equal to an equal value of M
			m_local = m_max + i - 1
			n = count(m_vec == m_local)

			allocate(submatrix(n,n))
			allocate(subeigenval(n))
			allocate(subeigenvec(n,n))
			allocate(indx(n))

! Built a vector with the indexes of these elements
			indx = where_index(m_vec,m_local,n)

! Build the submatrix (because the Hamiltonian is block-diagonal) and diagonalize it
			submatrix = matrix(indx,indx)
			call jacobi(submatrix,subeigenval,subeigenvec,nrot)

! Put the eigenvalues and eigenvectors on the Hamiltonian structure
			eigenval(indx) = subeigenval
			eigenvec(indx,indx) = subeigenvec

			deallocate(submatrix)
			deallocate(subeigenval)
			deallocate(subeigenvec)
			deallocate(indx)
		enddo

		deallocate(m_vec)

	end subroutine diagonalize_hamiltonian

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Return the Lande factor in case (b)
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	function lande_caseb(level)
	real(kind=8) :: lande_caseb
	type(type_hamiltonian) :: level
	real(kind=8) :: J, N, S, Lambda, term1, term2
		J = level%J
		N = level%N
		S = level%S
		Lambda = level%Lambda

		term1 = (J*(J+1.d0) + S*(S+1.d0) - N*(N+1.d0) ) / (J*(J+1.d0))
		term2 = Lambda**2 * (J*(J+1.d0) + N*(N+1.d0) - S*(S+1.d0) ) / &
			(2.d0*J*(J+1.d0)*N*(N+1.d0))

		lande_caseb = term1 + term2

	end function lande_caseb

!----------------------------------------------------------------------
!----------------------------------------------------------------------
! Clean all the structures
!----------------------------------------------------------------------
!----------------------------------------------------------------------
	subroutine clean_all(level)
	type(type_hamiltonian) :: level
		deallocate(level%ket)
		deallocate(level%ket_m_ordered)
		deallocate(level%ket_nofield)
		deallocate(level%ket_purerotation)
		deallocate(level%matrix)
		deallocate(level%matrix_zero_field)
		deallocate(level%eigenvec)
		deallocate(level%eigenval)
		deallocate(level%eigenval_zerofield)
		deallocate(level%active)
	end subroutine clean_all

end module build_hamiltonian_routines


!--------------------------------------------------------------------------------
! Copyright (c) 2016 Peter Grünberg Institut, Forschungszentrum Jülich, Germany
! This file is part of FLEUR and available as free software under the conditions
! of the MIT license as expressed in the LICENSE file in more detail.
!--------------------------------------------------------------------------------

      MODULE m_vacp5_z
      CONTAINS
      SUBROUTINE vacp5_z(
     >     nmzxyd,nmzxy,z1,delz,fpi,II,KK,rxy,m,
     <     pvac)

c     calculates a part of a vacuum potential caused
c     by the vacuum charge density for the g_z.ne.0 component
c     based on the using of the Green function
c                      Y. Mokrousov

      USE m_modcyli
      USE m_modcylk
      USE m_qsf
      IMPLICIT NONE

      INTEGER, INTENT (IN) :: nmzxy,nmzxyd,m
      REAL,    INTENT (IN) :: z1,delz,fpi
      REAL,    INTENT (IN) :: II(nmzxyd),KK(nmzxyd)
      COMPLEX, INTENT (IN) :: rxy(nmzxyd)
      COMPLEX, INTENT (OUT):: pvac(nmzxyd)

      INTEGER imz,imz1
      REAL    z,zp,vr(nmzxyd),vi(nmzxyd)
      REAL    grfr(nmzxyd),grfi(nmzxyd)

      DO 200 imz = 1,nmzxy

         z = z1 + delz*(imz-1)

         DO 300 imz1 = 1,nmzxy

            zp = z1 + delz*(imz1-1)

            IF (imz1.LE.imz) THEN

               grfr(imz1) = fpi*II(imz1)*KK(imz)*zp*
     *              real(rxy(imz1))
               grfi(imz1) = fpi*II(imz1)*KK(imz)*zp*
     *              aimag(rxy(imz1))

            ELSE

               grfr(imz1) = fpi*II(imz)*KK(imz1)*zp*
     *              real(rxy(imz1))
               grfi(imz1) = fpi*II(imz)*KK(imz1)*zp*
     *              aimag(rxy(imz1))

            END IF

 300     CONTINUE               ! imz1

         CALL qsf(delz,grfr(1),vr,nmzxy,0)
         CALL qsf(delz,grfi(1),vi,nmzxy,0)

         pvac(imz) = cmplx(vr(1),vi(1))

 200  CONTINUE                  ! imz

      END SUBROUTINE vacp5_z
      END MODULE m_vacp5_z


      subroutine runY_0000li(k,l,i1,Xtwiddle,Gtwiddle,Shat6zz,N0)
      implicit none
C---  Expression for Eq. 5.58b
C---  Calculates D0000li, requires D0000ll
C---  Small terms of order Xtwiddle(0,k)*D00iii,Xtwiddle(0,0)*D00iiii
C---  Denominator Gtwiddle(k,l)
      include 'pvDnames.f'
      include 'pvDv.f'
      include 'Darraydef.f'
      include 'Darrays.f'
      integer ep,N0,k,l,i1,np
      parameter(np=3)
      double precision Xtwiddle(0:np,0:np),Gtwiddle(np,np)
      double complex Shat6zz(np,z3max,-2:0)

      if ((i1 .eq. l) .or. (i1 .eq. 0)) then
      return
      endif

      do ep=-2,0

      Dv(dzzzzii(z2(l,i1))+N0,ep)=
     . (-2d0*Gtwiddle(k,i1)*Dv(dzzzzii(z2(l,l))+N0,ep)
     . +Gtwiddle(k,1)*Shat6zz(1,z3(l,l,i1),ep)
     . +Gtwiddle(k,2)*Shat6zz(2,z3(l,l,i1),ep)
     . +Gtwiddle(k,3)*Shat6zz(3,z3(l,l,i1),ep)
     . +Xtwiddle(0,k)*Dv(dzziii(z3(l,l,i1))+N0,ep)
     . -Xtwiddle(0,0)*Dv(dzziiii(z4(k,l,l,i1))+N0,ep)
     . )/(4d0*Gtwiddle(k,l))

      enddo

      return
      end


#include "eiscor.h"
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! ZUFCHF (Zomplex Unitary hessenberg Factored CHeck Factorization)
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! This routine checks the factorization input into ZUFFQR to make sure
! is represents a unitary hessenberg matrix to machine precision.
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
!
! INPUT VARIABLES:
!
!  N               INTEGER
!                    dimension of matrix
!
!  Q               REAL(8) array of dimension (3*(N-1))
!                    array of generators for givens rotations
!
!  D               REAL(8) array of dimension (2*N)
!                    array of generators for complex diagonal matrix
!                    on output contains the eigenvalues
!
! OUTPUT VARIABLES:
!
!  INFO           INTEGER
!                   INFO = 0 implies valid factorization
!                   INFO = -1 implies N is invalid
!                   INFO = -2 implies Q is invalid
!                   INFO = -3 implies D is invalid
!
!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!
subroutine ZUFCHF(N,Q,D,INFO)

  implicit none

  ! input variables
  integer, intent(in) :: N
  real(8), intent(inout) :: Q(3*N-3), D(2*N)
  integer, intent(inout) :: INFO

  ! compute variables
  integer :: ii
  real(8),parameter :: tol = 10d0*epsilon(1d0)
  real(8) :: nrm

  ! initialize INFO
  INFO = 0

  ! check N
  call IARNAN(N,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,INFO)
    end if
    INFO = -1
    return
  end if
  call IARINF(N,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N is invalid",INFO,INFO)
    end if
    INFO = -1
    return
  end if
  if (N < 2) then
    INFO = -1
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"N must be at least 2",INFO,INFO)
    end if
    return
  end if

  ! check Q for NANs and INFs
  call DARACH1(3*(N-1),Q,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"Q is invalid",INFO,INFO)
    end if
    INFO = -2
    return
  end if

  ! check Q for orthogonality
  do ii=1,(N-1)
    nrm = sqrt(Q(3*ii-2)**2 + Q(3*ii-1)**2 + Q(3*ii)**2)
    if (abs(nrm-1d0) > tol) then
      INFO = -2
      ! print error in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"Q is not unitary",INFO,INFO)
      end if
      return
   end if
  end do

  ! check D
  call DARACH1(2*N,D,INFO)
  if (INFO.NE.0) then
    ! print error in debug mode
    if (DEBUG) then
      call UARERR(__FILE__,__LINE__,"D is invalid",INFO,INFO)
    end if
    INFO = -3
    return
  end if

  ! check D for orthogonality
  do ii=1,N
    nrm = sqrt(D(2*ii-1)**2 + D(2*ii)**2)
    if (abs(nrm-1d0) > tol) then
      INFO = -3
      ! print error in debug mode
      if (DEBUG) then
        call UARERR(__FILE__,__LINE__,"D is not unitary",INFO,INFO)
      end if
      return
   end if
  end do

end subroutine ZUFCHF


      PROGRAM xellf
C     driver for routine ellf
      REAL FAC
      PARAMETER (FAC=3.1415926535/180.)
      INTEGER i,nval
      REAL ak,alpha,ellf,phi,value
      CHARACTER text*37
      open(7,file='FNCVAL.DAT',status='OLD')
10    read(7,'(a)') text
      if (text.ne.'Legendre Elliptic Integral First Kind') goto 10
      read(7,*) nval
      write(*,*) text
      write(*,'(1x,t4,a3,t9,a10,t23,a6,t41,a12)')
     *     'PHI','SIN(ALPHA)','Actual','ELLF(PHI,AK)'
      do 11 i=1,nval
        read(7,*) phi,alpha,value
        alpha=alpha*FAC
        ak=sin(alpha)
        phi=phi*FAC
        write(*,'(2f6.2,2e20.6)') phi,ak,value,ellf(phi,ak)
11    continue
      close(7)
      END

NR-Functions/Numerical Recipes- Example & Functions/Examples/xellf.for


   ! NOTE: This MODULE isused in HydroDyn and TurbSim.
   ! BJJ: 02/22/2008: Updated to work with NWTC_Library v1.01.09
   !      all Abort() functions changed to ProgAbort()
   ! BJJ: 12/03/2010: Updated to add optional ErrStat return values
   !                  instead of aborting on errors (note not all changes documented)
   ! BJJ: 12/20/2010: Updated to add defined type and remove global data variables
   !                  Also updated to check that transform has been initialized for the
   !                    correct type (to avoid having wSave too small)
   ! ADP: 07/28/2014: Added in the complex FFT routines from fftpack v. 4.1
!=======================================================================
! File last committed: $Date: 2016-06-15 11:12:21 -0600 (Wed, 15 Jun 2016) $
! (File) Revision #: $Rev: 387 $
! URL: $HeadURL: https://windsvn2.nrel.gov/NWTC_Library/branches/NetLib/NWTC_source/NWTC_FFTPACK.f90 $
!=======================================================================
MODULE NWTC_FFTPACK
!-----------------------------------------------------------------------
! DESCRIPTION OF THE INVERSE FOURIER TRANSFORM ROUTINE:
!
! Given an array, H, of N complex numbers, calculate an array, h, of N real
! numbers:
!     h(J) = the sum from K=1,...,N of [ H(K)*exp(i*(J-1)*(K-1)*2*pi/N) ]
!     for J = 1,...,N
!
! where:
!     i=sqrt(-1)
!
! In order for h to be real, the real components of H must be an even function
! of frequency and the imaginary components of H must be an odd function of
! frequency.  Thus, only the first N/2 + 1 values of H are unique.  (The first
! N/2 + 1 are the positive frequencies including zero; the last N/2 - 1 values
! are the negative frequencies.)
!
! We accomplish this by defining a real array, R, where:
!     R(1) = REAL( H(1) ),
!     R(2) = REAL( H(2) ), R(3) = IMAG( H(2) ),
!     R(4) = REAL( H(3) ), R(5) = IMAG( H(3) ),...
!     R(N) = REAL( H(N/2 + 1) ).
! Note that the values of IMAG( H(1) ) and IMAG( H(N/2 + 1) ) must be zero for
! the result to be real, else the routine will abort.
!
! We return the array, r = h, of real numbers as calculated by:
!     h(J) = r(J) = R(1) + (-1)**(J-1)*R(N)
!                 + the sum from K=2,...,N/2 of
!                   [  2*R(2*K-2)*COS((K-1)*(J-1)*2*PI/N)
!                     -2*R(2*K-1)*SIN((K-1)*(J-1)*2*PI/N) ]
!     for J = 1,...,N, where N is an even number
!
! The routine is most effecient when N is a product of small primes.
!
! If the Normalization flag is set to "TRUE" in the initialization, we
! normalize the result by 1/N.
!------------------------------------------------------------------------
! DESCRIPTION OF THE COSINE TRANSFORM ROUTINE:
!
! Given an array, X, of N real numbers, calculate an array, x, of N real
! numbers:
!     x(J) = X(1) + (-1)**(J-1)*X(N)
!          + the sum from K=2,...,N-1 of [ 2*X(K)*COS((K-1)*(J-1)*PI/(N-1)) ]
!     for J = 1,...,N, where N is an odd number
!
! The routine is most effecient when N-1 is a product of small primes.
!
! If the Normalization flag is set to "TRUE" in the initialization, we
! normalize the result by 1/(N-1).
!------------------------------------------------------------------------
! DESCRIPTION OF THE SINE TRANSFORM ROUTINE:
!
! Given an array, X, of N real numbers, calculate an array, x, of N real
! numbers:
!     x(1) = X(1) = 0
!     x(J) = the sum from K=2,...,N-1 of [ 2*X(K)*SIN((K-1)*(J-1)*PI/(N-1)) ]
!     for J = 2,...,N-1, where N is an odd number
!     x(N) = X(N) = 0
!
! Note that the values of X(1) and X(N) must be zero, else the routine will
! abort.
!
! The routine is most effecient when N-1 is a product of small primes.
!
! If the Normalization flag is set to "TRUE" in the initialization, we
! normalize the result by 1/(N-1).
!------------------------------------------------------------------------

! We need the Precision module and the Abort() and
! Int2LStr() functions from the NWTC_IO module.

   USE                                    NWTC_Library

   IMPLICIT                               NONE

   INTEGER, PARAMETER, PRIVATE         :: Undef_trans   = -1            ! transformation type is undefined
   INTEGER, PARAMETER, PRIVATE         :: COS_trans     = 1             ! COSINE transformation
   INTEGER, PARAMETER, PRIVATE         :: Fourier_trans = 2             ! FAST FOURIER transformation
   INTEGER, PARAMETER, PRIVATE         :: SIN_trans     = 3             ! SINE transformation

   TYPE, PUBLIC :: FFT_DataType
      PRIVATE
      REAL(SiKi)                       :: InvN          = 0.0_SiKi      ! Normalization constant
      REAL(SiKi), ALLOCATABLE          :: wSave(:)                      ! Working array for performing transforms
      INTEGER                          :: N             = -1            ! Number of steps
      LOGICAL                          :: Normalize     = .FALSE.       ! Whether or not to normalize
      INTEGER                          :: TransformType = Undef_trans   ! the type of transfer function this is for
   END TYPE FFT_DataType

!------------------------------------------------------------------------
CONTAINS

   SUBROUTINE ApplyCOST( TRH, FFT_Data, ErrStat )

         ! Perform cosine transform.

      IMPLICIT                         NONE

      REAL(SiKi), INTENT(INOUT)     :: TRH(:)
      TYPE(FFT_DataType), INTENT(IN):: FFT_Data             ! the handle to this instance of the FFT Module

      INTEGER, INTENT(OUT), OPTIONAL:: ErrStat

      LOGICAL                       :: TrapErrors

      IF ( PRESENT(ErrStat) ) THEN
         TrapErrors = .TRUE.
         ErrStat = ErrID_None
      ELSE
         TrapErrors = .FALSE.
      END IF

        ! Make sure the array isn't too small

      IF ( SIZE(TRH) < FFT_Data%N )  THEN
          CALL ProgAbort( 'Error in call to cosine transform.  Array size is not large enough.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

      IF ( FFT_Data%TransformType /= COS_trans ) THEN
          CALL ProgAbort( 'Error in call to cosine transform. FFT_Data not initialized for cosine transform.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Perform the cosine transform with a FFTpack routine

      CALL COST(FFT_Data%N, TRH, FFT_Data%wSave) ! FFTpack routine

      IF (FFT_Data%Normalize) THEN
          TRH(1:FFT_Data%N) = FFT_Data%InvN * TRH(1:FFT_Data%N)
      ENDIF

   END SUBROUTINE ApplyCOST
!------------------------------------------------------------------------
   SUBROUTINE ApplyCFFT( TRH_complex_return, TRH_complex, FFT_Data, ErrStat )
         ! Perform Backward complex FFT: given TRH_complex, an array of complex numbers,
         ! return an array TRH_complex_return, of complex numbers

         ! TRH_complex is of size FFT_Data%N/2 and represents the complex amplitude in frequency
         !  space of only the positive frequencies.  This is padded with zeros for the upper half
         !  the frequency domain.

         ! TRH_complex_return is of size FFT_Data%N and represents the complex amplitude in the
         !  time domain.

      IMPLICIT                         NONE

      COMPLEX(SiKi), INTENT(OUT)    :: TRH_complex_return(:)
      COMPLEX(SiKi), INTENT(IN)     :: TRH_complex(:)
      TYPE(FFT_DataType), INTENT(IN):: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL:: ErrStat

      REAL(SiKi), ALLOCATABLE       :: TRH(:)   ! real array to help process the complex-array that fftpack defines as IMPLICIT (real)

      INTEGER                       :: I

      INTEGER(IntKi)                :: ErrStatTmp
      LOGICAL                       :: TrapErrors
      character(1024)               :: ErrMsg

      ErrStatTmp  = ErrID_None

      IF ( PRESENT(ErrStat) ) THEN
         TrapErrors = .TRUE.
         ErrStat = ErrID_None
      ELSE
         TrapErrors = .FALSE.
      END IF

        ! Make sure the arrays aren't too small
      IF ( ( SIZE(TRH_complex_return) < FFT_Data%N ) .OR. ( SIZE(TRH_complex) < ( FFT_Data%N/2 + 1 ) ) )  THEN
          CALL ProgAbort( 'Error in call to FFT.  Array size is not large enough.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

      IF ( FFT_Data%TransformType /= Fourier_trans ) THEN
          CALL ProgAbort( 'Error in call to FFT. FFT_Data not initialized for Fourier transform.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Make sure that the imaginary components at the zeroeth and largest
        ! positive frequency are zero, else abort.

      IF ( .NOT. EqualRealNos( 0.0_SiKi, AIMAG( TRH_complex(1    ) ) ) ) THEN
          CALL ProgAbort( 'Error in call to FFT.  The imaginary component at the zeroeth frequency must be zero.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      ELSE IF ( .NOT. EqualRealNos( 0.0_SiKi, AIMAG( TRH_complex(FFT_Data%N/2+1) ) ) )  THEN
          CALL ProgAbort( 'Error in call to FFT. '// &
                          'The imaginary component at the largest positive frequency must be zero.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

         ! Populate the array for the frequency information.  Only the first half is populated (note that
         ! this algorithm does not make any assumptions about double sided conjugate pairing)
      TRH_complex_return = CMPLX(0.0_SiKi,0.0_SiKi)
      DO I=1,FFT_Data%N/2
         TRH_complex_return(I) = TRH_complex(I)
      ENDDO

      CALL AllocAry( TRH, 2*size(TRH_complex_return,1), 'ApplyCFFT:TRH', ErrStat, ErrMsg  ) !allocate two real for each complex variable
         IF (ErrStat >= AbortErrLev) THEN
            CALL WrScr( TRIM(ErrMsg) )
            RETURN
         END IF

         !TRH = TRANSFER(TRH_complex_return, TRH)  ! this function apparently uses stack space and is causing stack overflow on large models
      do i=1,size(TRH_complex_return,1)
         TRH(2*i-1)   = REAL(TRH_complex_return(i))
         TRH(2*i  ) = AIMAG(TRH_complex_return(i))
      end do

      CALL CFFTB(FFT_Data%N, TRH, FFT_Data%wSave)

      ! put real values back into complex array
         !TRH = TRH_complex_return = TRANSFER(TRH, TRH_complex)  ! this function apparently uses stack space and is causing stack overflow on large models
      do i=1,size(TRH_complex_return,1)
         TRH_complex_return(i) = CMPLX(TRH(2*i-1),TRH(2*i))
      end do

      DEALLOCATE(TRH)

         ! Apply normalization, if any

      IF (FFT_Data%Normalize) THEN
          TRH_complex_return(1:FFT_Data%N) = FFT_Data%InvN * TRH_complex_return(1:FFT_Data%N)
      ENDIF

   END SUBROUTINE ApplyCFFT
  !------------------------------------------------------------------------
   SUBROUTINE ApplyCFFT_f( TRH_complex, FFT_Data, ErrStat )
!FIXME: THIS ROUTINE HAS NOT BEEN TESTED!!!!!
         ! Perform Forward complex FFT:
         ! give an array TRH, of complex amplitudes in the time domain,
         ! return TRH, a complex array in the frequency domain

      IMPLICIT                         NONE

      COMPLEX(SiKi), INTENT(INOUT)  :: TRH_complex(:)
      TYPE(FFT_DataType), INTENT(IN):: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL:: ErrStat

      REAL(SiKi), ALLOCATABLE       :: TRH(:)

      LOGICAL                       :: TrapErrors
      character(1024)               :: ErrMsg

      IF ( PRESENT(ErrStat) ) THEN
         TrapErrors = .TRUE.
         ErrStat = ErrID_None
      ELSE
         TrapErrors = .FALSE.
      END IF

        ! Make sure the array isn't too small

      IF ( SIZE(TRH_complex) < FFT_Data%N )  THEN
          CALL ProgAbort( 'Error in call to FFT.  Array size is not large enough.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

      IF ( FFT_Data%TransformType /= Fourier_trans ) THEN
          CALL ProgAbort( 'Error in call to FFT. FFT_Data not initialized for Fourier transform.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Perform the FFT with a FFTpack routine

      CALL AllocAry( TRH, 2*size(TRH,1), 'ApplyCFFT_f:TRH', ErrStat, ErrMsg )
         IF (ErrStat >= AbortErrLev) THEN
            CALL WrScr( TRIM(ErrMsg) )
            RETURN
         END IF

      TRH = TRANSFER(TRH_complex, TRH)

      CALL CFFTF(FFT_Data%N, TRH, FFT_Data%wSave) ! FFTpack routine

      ! put real values back into complex array
      TRH_complex = TRANSFER(TRH, TRH_complex)
      DEALLOCATE(TRH)

      IF (FFT_Data%Normalize) THEN
          TRH_complex(1:FFT_Data%N) = FFT_Data%InvN * TRH_complex(1:FFT_Data%N)
      ENDIF

   END SUBROUTINE ApplyCFFT_f
  !------------------------------------------------------------------------
   SUBROUTINE ApplyFFT( TRH, FFT_Data, ErrStat )
         ! Perform Backward FFT: given TRH, a REAL array representing complex numbers,
         ! return an array TRH, of real numbers.
         !     CALL FOURTH ( TRH, NumSteps, 1, WorkT, NumSteps+2 ) ! Sandia

      IMPLICIT                         NONE

      REAL(SiKi), INTENT(INOUT)     :: TRH(:)
      TYPE(FFT_DataType), INTENT(IN):: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL:: ErrStat

      LOGICAL                       :: TrapErrors

      IF ( PRESENT(ErrStat) ) THEN
         TrapErrors = .TRUE.
         ErrStat = ErrID_None
      ELSE
         TrapErrors = .FALSE.
      END IF

        ! Make sure the array isn't too small

      IF ( SIZE(TRH) < FFT_Data%N )  THEN
          CALL ProgAbort( 'Error in call to FFT.  Array size is not large enough.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

      IF ( FFT_Data%TransformType /= Fourier_trans ) THEN
          CALL ProgAbort( 'Error in call to FFT. FFT_Data not initialized for Fourier transform.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Perform the FFT with a FFTpack routine

      CALL RFFTB(FFT_Data%N, TRH, FFT_Data%wSave) ! FFTpack routine

      IF (FFT_Data%Normalize) THEN
          TRH(1:FFT_Data%N) = FFT_Data%InvN * TRH(1:FFT_Data%N)
      ENDIF

   END SUBROUTINE ApplyFFT
  !------------------------------------------------------------------------
   SUBROUTINE ApplyFFT_f( TRH, FFT_Data, ErrStat )
         ! Perform Forward FFT:
         ! give an array TRH, of real numbers,
         ! return TRH, a REAL array representing complex numbers (magnitude and phase).

      IMPLICIT                         NONE

      REAL(SiKi), INTENT(INOUT)     :: TRH(:)
      TYPE(FFT_DataType), INTENT(IN):: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL:: ErrStat

      LOGICAL                       :: TrapErrors

      IF ( PRESENT(ErrStat) ) THEN
         TrapErrors = .TRUE.
         ErrStat = ErrID_None
      ELSE
         TrapErrors = .FALSE.
      END IF

        ! Make sure the array isn't too small

      IF ( SIZE(TRH) < FFT_Data%N )  THEN
          CALL ProgAbort( 'Error in call to FFT.  Array size is not large enough.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

      IF ( FFT_Data%TransformType /= Fourier_trans ) THEN
          CALL ProgAbort( 'Error in call to FFT. FFT_Data not initialized for Fourier transform.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Perform the FFT with a FFTpack routine

      CALL RFFTF(FFT_Data%N, TRH, FFT_Data%wSave) ! FFTpack routine

      IF (FFT_Data%Normalize) THEN
          TRH(1:FFT_Data%N) = FFT_Data%InvN * TRH(1:FFT_Data%N)
      ENDIF

   END SUBROUTINE ApplyFFT_f
!------------------------------------------------------------------------
   SUBROUTINE ApplyFFT_cx( TRH, TRH_complex, FFT_Data, ErrStat )
         ! Perform Backward FFT: given TRH, a REAL array representing complex numbers,
         ! return an array TRH, of real numbers.

      IMPLICIT                         NONE

      REAL(SiKi),    INTENT(OUT)    :: TRH(:)
      COMPLEX(SiKi), INTENT(IN)     :: TRH_complex(:)
      TYPE(FFT_DataType), INTENT(IN):: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL:: ErrStat

      INTEGER                       :: I
      INTEGER                       :: Indx

      LOGICAL                       :: TrapErrors

      IF ( PRESENT(ErrStat) ) THEN
         TrapErrors = .TRUE.
         ErrStat = ErrID_None
      ELSE
         TrapErrors = .FALSE.
      END IF

        ! Make sure the arrays aren't too small

      IF ( ( SIZE(TRH) < FFT_Data%N ) .OR. ( SIZE(TRH_complex) < ( FFT_Data%N/2 + 1 ) ) )  THEN
          CALL ProgAbort( 'Error in call to FFT.  Array size is not large enough.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

      IF ( FFT_Data%TransformType /= Fourier_trans ) THEN
          CALL ProgAbort( 'Error in call to FFT. FFT_Data not initialized for Fourier transform.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Make sure that the imaginary components at the zeroeth and largest
        ! positive frequency are zero, else abort.

      IF ( .NOT. EqualRealNos( 0.0_SiKi, AIMAG( TRH_complex(1    ) ) ) ) THEN
          CALL ProgAbort( 'Error in call to FFT.  The imaginary component at the zeroeth frequency must be zero.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      ELSE IF ( .NOT. EqualRealNos( 0.0_SiKi, AIMAG( TRH_complex(FFT_Data%N/2+1) ) ) )  THEN
          CALL ProgAbort( 'Error in call to FFT. '// &
                          'The imaginary component at the largest positive frequency must be zero.', TrapErrors )
          ErrStat = ErrID_Fatal         ! The code can't get here unless PRESENT(ErrStat)
          RETURN
      END IF

        ! Initialize the TRH array with Complex numbers

      TRH(1) = REAL( TRH_complex(1    ) )

      Indx = 1
      DO I=2,FFT_Data%N-2, 2
        Indx     = Indx + 1  ! I/2 + 1

        TRH(I)   =  REAL( TRH_complex(Indx) )
        TRH(I+1) = AIMAG( TRH_complex(Indx) )
      ENDDO

      TRH(FFT_Data%N) = REAL( TRH_complex(FFT_Data%N/2+1) )

        ! Perform the FFT with a FFTpack routine

      CALL RFFTB(FFT_Data%N, TRH, FFT_Data%wSave)

      IF (FFT_Data%Normalize) THEN
          TRH(1:FFT_Data%N) = FFT_Data%InvN * TRH(1:FFT_Data%N)
      ENDIF

   END SUBROUTINE ApplyFFT_cx
  !------------------------------------------------------------------------
   SUBROUTINE ApplySINT( TRH, FFT_Data, ErrStat )
         ! Perform sine transform.

      IMPLICIT                         NONE

      REAL(SiKi), INTENT(INOUT)     :: TRH(:)
      TYPE(FFT_DataType), INTENT(IN):: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL:: ErrStat

      LOGICAL                       :: TrapErrors

      IF ( PRESENT(ErrStat) ) THEN
         TrapErrors = .TRUE.
         ErrStat = ErrID_None
      ELSE
         TrapErrors = .FALSE.
      END IF

        ! Make sure the array isn't too small

      IF ( SIZE(TRH) < FFT_Data%N )  THEN
          CALL ProgAbort( 'Error in call to sine transform.  Array size is not large enough.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

      IF ( FFT_Data%TransformType /= SIN_trans ) THEN
          CALL ProgAbort( 'Error in call to sine transform. FFT_Data not initialized for sine transform.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Make sure that the value at the zeroeth and largest positive
        ! frequency are zero, else abort.

      IF ( TRH(1) /= 0.0 )  THEN
          CALL ProgAbort( 'Error in call to FFT.  The value at the zeroeth frequency must be zero.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      ELSE IF ( TRH(FFT_Data%N) /= 0.0 ) THEN
          CALL ProgAbort( 'Error in call to FFT.  The value at the largest positive frequency must be zero.', TrapErrors )
          ErrStat = ErrID_Fatal
          RETURN
      END IF

        ! Perform the sine transform with a FFTpack routine

      CALL SINT(FFT_Data%N-2, TRH(2:FFT_Data%N-1), FFT_Data%wSave) ! FFTpack routine

      IF (FFT_Data%Normalize) THEN
          TRH(1:FFT_Data%N) = FFT_Data%InvN * TRH(1:FFT_Data%N)
      ENDIF

   END SUBROUTINE ApplySINT
  !------------------------------------------------------------------------
   SUBROUTINE ExitCFFT(FFT_Data, ErrStat)

      TYPE(FFT_DataType), INTENT(INOUT) :: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL    :: ErrStat
      INTEGER                           :: Alloc_Stat

        ! This subroutine cleans up the backward FFT working space

      FFT_Data%N = -1
      FFT_Data%TransformType = Undef_trans

      Alloc_Stat = 0
      IF ( ALLOCATED (FFT_Data%wSave)    ) DEALLOCATE( FFT_Data%wSave, STAT=Alloc_Stat )

      IF ( PRESENT( ErrStat ) ) ErrStat = Alloc_Stat

   END SUBROUTINE ExitCFFT
  !------------------------------------------------------------------------
   SUBROUTINE ExitCOST(FFT_Data, ErrStat)

      TYPE(FFT_DataType), INTENT(INOUT) :: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL    :: ErrStat
      INTEGER                           :: Alloc_Stat

        ! This subroutine cleans up the cosine transform working space

      FFT_Data%N = -1
      FFT_Data%TransformType = Undef_trans

      Alloc_Stat = 0
      IF ( ALLOCATED (FFT_Data%wSave)    ) DEALLOCATE( FFT_Data%wSave, STAT=Alloc_Stat )

      IF ( PRESENT( ErrStat ) ) ErrStat = Alloc_Stat

   END SUBROUTINE ExitCOST
  !------------------------------------------------------------------------
   SUBROUTINE ExitFFT(FFT_Data, ErrStat)

      TYPE(FFT_DataType), INTENT(INOUT) :: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL    :: ErrStat
      INTEGER                           :: Alloc_Stat

        ! This subroutine cleans up the backward FFT working space

      FFT_Data%N = -1
      FFT_Data%TransformType = Undef_trans

      Alloc_Stat = 0
      IF ( ALLOCATED (FFT_Data%wSave)    ) DEALLOCATE( FFT_Data%wSave, STAT=Alloc_Stat )

      IF ( PRESENT( ErrStat ) ) ErrStat = Alloc_Stat

   END SUBROUTINE ExitFFT
  !------------------------------------------------------------------------
   SUBROUTINE ExitSINT(FFT_Data, ErrStat)

      TYPE(FFT_DataType), INTENT(INOUT) :: FFT_Data             ! the handle to this instance of the FFT Module
      INTEGER, INTENT(OUT), OPTIONAL    :: ErrStat
      INTEGER                           :: Alloc_Stat

        ! This subroutine cleans up the sine transform working space

      FFT_Data%N = -1
      FFT_Data%TransformType = Undef_trans

      Alloc_Stat = 0
      IF ( ALLOCATED (FFT_Data%wSave)    ) DEALLOCATE( FFT_Data%wSave, STAT=Alloc_Stat )

      IF ( PRESENT( ErrStat ) ) ErrStat = Alloc_Stat

   END SUBROUTINE ExitSINT
  !------------------------------------------------------------------------
   SUBROUTINE InitCOST( NumSteps, FFT_Data, NormalizeIn, ErrStat )

        ! This subroutine initializes the cosine transform working space

      IMPLICIT                         NONE

      INTEGER, INTENT(IN)           :: NumSteps       ! Number of steps in the array
      INTEGER                       :: Sttus          ! Array allocation status

      TYPE(FFT_DataType),INTENT(OUT):: FFT_Data       ! the handle to this instance of the FFT Module
      LOGICAL, INTENT(IN), OPTIONAL :: NormalizeIn    ! Whether or not to normalize
      INTEGER, INTENT(OUT),OPTIONAL :: ErrStat        ! returns non-zero if an error occurred

      IF ( PRESENT(ErrStat) ) ErrStat = ErrID_None

        ! Number of timesteps in the time series returned from the cosine transform
        ! N should be odd:

      FFT_Data%N  = NumSteps

      IF ( MOD(FFT_Data%N,2) /= 1 ) THEN
         CALL ProgAbort ( 'The number of steps in the cosine transform must be odd', PRESENT(ErrStat) )
         ErrStat = ErrID_Fatal
         RETURN
      ENDIF

        ! Determine if we should normalize the cosine transform:

      IF ( PRESENT( NormalizeIn ) ) THEN
          FFT_Data%Normalize = NormalizeIn
          FFT_Data%InvN      = 1. / ( FFT_Data%N - 1 )
      ELSE
          FFT_Data%Normalize = .FALSE.
      ENDIF

        ! According to FFTPACK documentation, the working array must be at
        ! least size 3N+15

      ALLOCATE ( FFT_Data%wSave(3*FFT_Data%N + 15) , STAT=Sttus )

      IF ( Sttus /= 0 )  THEN
         CALL ProgAbort ( 'Error allocating memory for the cosine transform working array.', PRESENT(ErrStat) )
         ErrStat = Sttus
         RETURN
      ENDIF

        ! Initialize the FFTPACK working space

      CALL COSTI(FFT_Data%N, FFT_Data%wSave)

      FFT_Data%TransformType = COS_trans

   END SUBROUTINE InitCOST
  !------------------------------------------------------------------------
   SUBROUTINE InitCFFT( NumSteps, FFT_Data, NormalizeIn, ErrStat )

        ! This subroutine initializes the backward FFT working space

      IMPLICIT                         NONE

      INTEGER, INTENT(IN)           :: NumSteps       ! Number of steps in the array
      INTEGER                       :: Sttus          ! Array allocation status

      TYPE(FFT_DataType),INTENT(OUT):: FFT_Data       ! the handle to this instance of the FFT Module
      LOGICAL, INTENT(IN), OPTIONAL :: NormalizeIn    ! Whether or not to normalize the FFT
      INTEGER, INTENT(OUT),OPTIONAL :: ErrStat        ! returns non-zero if an error occurred

      IF ( PRESENT(ErrStat) ) ErrStat = ErrID_None

        ! Number of timesteps in the time series returned from the backward FFT
        ! N should be even:

      FFT_Data%N  = NumSteps

      IF ( MOD(FFT_Data%N,2) /= 0 ) THEN
         CALL ProgAbort ( 'The number of steps in the FFT must be even', PRESENT(ErrStat) ) ! For this Real FFT
         ErrStat = ErrID_Fatal
         RETURN
      ENDIF

        ! Determine if we should normalize the FFT

      IF ( PRESENT( NormalizeIn ) ) THEN
          FFT_Data%Normalize = NormalizeIn
          FFT_Data%InvN      = 1. / FFT_Data%N
      ELSE
          FFT_Data%Normalize = .FALSE.
      ENDIF

        ! According to FFTPACK documentation, the working array must be at
        ! least size 4N+15

      ALLOCATE ( FFT_Data%wSave(4*FFT_Data%N + 15) , STAT=Sttus )

      IF ( Sttus /= 0 )  THEN
         CALL ProgAbort ( 'Error allocating memory for the complex FFT working array.', PRESENT(ErrStat) )
         ErrStat = ErrID_Fatal
         RETURN
      ENDIF

        ! Initialize the FFTPACK working space

      CALL CFFTI(FFT_Data%N, FFT_Data%wSave)

      FFT_Data%TransformType = Fourier_trans

   END SUBROUTINE InitCFFT
  !------------------------------------------------------------------------
   SUBROUTINE InitFFT( NumSteps, FFT_Data, NormalizeIn, ErrStat )

        ! This subroutine initializes the backward FFT working space

      IMPLICIT                         NONE

      INTEGER, INTENT(IN)           :: NumSteps       ! Number of steps in the array
      INTEGER                       :: Sttus          ! Array allocation status

      TYPE(FFT_DataType),INTENT(OUT):: FFT_Data       ! the handle to this instance of the FFT Module
      LOGICAL, INTENT(IN), OPTIONAL :: NormalizeIn    ! Whether or not to normalize the FFT
      INTEGER, INTENT(OUT),OPTIONAL :: ErrStat        ! returns non-zero if an error occurred

      IF ( PRESENT(ErrStat) ) ErrStat = ErrID_None

        ! Number of timesteps in the time series returned from the backward FFT
        ! N should be even:

      FFT_Data%N  = NumSteps

      IF ( MOD(FFT_Data%N,2) /= 0 ) THEN
         CALL ProgAbort ( 'The number of steps in the FFT must be even', PRESENT(ErrStat) ) ! For this Real FFT
         ErrStat = ErrID_Fatal
         RETURN
      ENDIF

        ! Determine if we should normalize the FFT

      IF ( PRESENT( NormalizeIn ) ) THEN
          FFT_Data%Normalize = NormalizeIn
          FFT_Data%InvN      = 1. / FFT_Data%N
      ELSE
          FFT_Data%Normalize = .FALSE.
          FFT_Data%InvN      = 1.
      ENDIF

        ! According to FFTPACK documentation, the working array must be at
        ! least size 2N+15

      ALLOCATE ( FFT_Data%wSave(2*FFT_Data%N + 15) , STAT=Sttus )

      IF ( Sttus /= 0 )  THEN
         CALL ProgAbort ( 'Error allocating memory for the FFT working array.', PRESENT(ErrStat) )
         ErrStat = ErrID_Fatal
         RETURN
      ENDIF

        ! Initialize the FFTPACK working space

      CALL RFFTI(FFT_Data%N, FFT_Data%wSave)

      FFT_Data%TransformType = Fourier_trans

   END SUBROUTINE InitFFT
  !------------------------------------------------------------------------
   SUBROUTINE InitSINT( NumSteps, FFT_Data, NormalizeIn, ErrStat )

        ! This subroutine initializes the sine transform working space

      IMPLICIT                         NONE

      INTEGER, INTENT(IN)           :: NumSteps       ! Number of steps in the array
      INTEGER                       :: Sttus          ! Array allocation status

      TYPE(FFT_DataType),INTENT(OUT):: FFT_Data       ! the handle to this instance of the FFT Module
      LOGICAL, INTENT(IN), OPTIONAL :: NormalizeIn    ! Whether or not to normalize
      INTEGER, INTENT(OUT),OPTIONAL :: ErrStat        ! returns non-zero if an error occurred

      IF ( PRESENT(ErrStat) ) ErrStat = ErrID_None

        ! Number of timesteps in the time series returned from the sine transform
        ! N should be odd:

      FFT_Data%N  = NumSteps

      IF ( MOD(FFT_Data%N,2) /= 1 ) THEN
         CALL ProgAbort ( 'The number of steps in the sine transform must be odd.', PRESENT(ErrStat) )
         ErrStat = ErrID_Fatal
         RETURN
      ENDIF

        ! Determine if we should normalize the sine transform:

      IF ( PRESENT( NormalizeIn ) ) THEN
          FFT_Data%Normalize = NormalizeIn
          FFT_Data%InvN      = 1. / ( FFT_Data%N - 1 )
      ELSE
          FFT_Data%Normalize = .FALSE.
      ENDIF

        ! According to FFTPACK documentation, the working array must be at
        ! least size 2.5N+15; however, our N is +2 greater than their N

      ALLOCATE ( FFT_Data%wSave( CEILING( 2.5*(FFT_Data%N-2) ) + 15 ) , STAT=Sttus )

      IF ( Sttus /= 0 )  THEN
         CALL ProgAbort ( 'Error allocating memory for the sine transform working array.', PRESENT(ErrStat) )
         ErrStat = ErrID_Fatal
         RETURN
      ENDIF

        ! Initialize the FFTPACK working space

      CALL SINTI(FFT_Data%N-2, FFT_Data%wSave)

      FFT_Data%TransformType = SIN_trans

   END SUBROUTINE InitSINT
  !------------------------------------------------------------------------

END MODULE NWTC_FFTPACK
!=======================================================================


! { dg-do run }
! PR 22607: PURE return-by-reference functions
program main
  implicit none
  integer, dimension(2) :: b
  b = fun(size(b))
  if (b(1) /= 1 .or. b(2) /= 2) call abort()
contains
  pure function fun(n)
    integer, intent(in) :: n
    integer :: fun(n)
    integer :: i
    do i = 1, n
        fun(i) = i
    end do
  end function fun
end program main


      SUBROUTINE MB01TD( N, A, LDA, B, LDB, DWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To compute the matrix product A * B, where A and B are upper
C     quasi-triangular matrices (that is, block upper triangular with
C     1-by-1 or 2-by-2 diagonal blocks) with the same structure.
C     The result is returned in the array B.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the matrices A and B.  N >= 0.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             upper quasi-triangular matrix A. The elements below the
C             subdiagonal are not referenced.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,N)
C             On entry, the leading N-by-N part of this array must
C             contain the upper quasi-triangular matrix B, with the same
C             structure as matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the computed product A * B, with the same structure as
C             on entry.
C             The elements below the subdiagonal are not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (N-1)
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  if the matrices A and B have not the same structure,
C                   and/or A and B are not upper quasi-triangular.
C
C     METHOD
C
C     The matrix product A * B is computed column by column, using
C     BLAS 2 and BLAS 1 operations.
C
C     FURTHER COMMENTS
C
C     This routine can be used, for instance, for computing powers of
C     a real Schur form matrix.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, June 1998.
C
C     REVISIONS
C
C     V. Sima, Feb. 2000.
C
C     KEYWORDS
C
C     Elementary matrix operations, matrix operations.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, N
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), DWORK(*)
C     .. Local Scalars ..
      INTEGER           I, J, JMIN, JMNM
C     .. External Subroutines ..
      EXTERNAL          DAXPY, DTRMV, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX, MIN
C
C     .. Executable Statements ..
C
C     Test the input scalar arguments.
C
      INFO  = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -3
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -5
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB01TD', -INFO )
         RETURN
      END IF
C
C     Quick return, if possible.
C
      IF ( N.EQ.0 ) THEN
         RETURN
      ELSE IF ( N.EQ.1 ) THEN
         B(1,1) = A(1,1)*B(1,1)
         RETURN
      END IF
C
C     Test the upper quasi-triangular structure of A and B for identity.
C
      DO 10 I = 1, N - 1
         IF ( A(I+1,I).EQ.ZERO ) THEN
            IF ( B(I+1,I).NE.ZERO ) THEN
               INFO = 1
               RETURN
            END IF
         ELSE IF ( I.LT.N-1 ) THEN
            IF ( A(I+2,I+1).NE.ZERO ) THEN
               INFO = 1
               RETURN
            END IF
         END IF
   10 CONTINUE
C
      DO 30 J = 1, N
         JMIN = MIN( J+1,  N )
         JMNM = MIN( JMIN, N-1 )
C
C        Compute the contribution of the subdiagonal of A to the
C        j-th column of the product.
C
         DO 20 I = 1, JMNM
            DWORK(I) = A(I+1,I)*B(I,J)
   20    CONTINUE
C
C        Multiply the upper triangle of A by the j-th column of B,
C        and add to the above result.
C
         CALL DTRMV( 'Upper', 'No transpose', 'Non-unit', JMIN, A, LDA,
     $               B(1,J), 1 )
         CALL DAXPY( JMNM, ONE, DWORK, 1, B(2,J), 1 )
   30 CONTINUE
C
      RETURN
C *** Last line of MB01TD ***
      END


program gen_grid
!
! this program generates a the grid files to be read by the xdmf file
! the output file from CaNS 'grid.bin' must be on this folder
!
! Pedro Costa (p.simoes.costa@gmail.com)
!
implicit none
include 'param.h90'
!
integer :: iunit,i,j,k,lenr
real(8), dimension(nz) :: dummy,zc
!
iunit = 99
inquire (iolength=lenr) dummy(1)
!
! generate cell-centered grid in x (uniform)
!
open(iunit,file='x.bin',access='direct',recl=nx*lenr)
write(iunit,rec=1) ((i-0.5)*dx,i=1,nx)
close(iunit)
!
! generate cell-centered grid in y (uniform)
!
open(iunit,file='y.bin',access='direct',recl=ny*lenr)
write(iunit,rec=1) ((j-0.5)*dy,j=1,ny)
close(iunit)
!
! generate cell-centered grid in z (non-uniform) from file 'grid.bin'
!
open(iunit,file='grid.bin',access='direct',recl=4*nz*lenr)
read(iunit,rec=1) dummy(1:nz),dummy(1:nz),zc(1:nz),dummy(1:nz)
close(iunit)
open(iunit,file='z.bin',access='direct',recl=nz*lenr)
write(iunit,rec=1) zc(1:nz)
close(iunit)
end program gen_grid


MODULE tropical_cyclone

!=======================================================================
!
!  Date:  July 29, 2015
!
!  Function for setting up idealized tropical cyclone initial conditions
!
!  SUBROUTINE tropical_cyclone_sample(
!    lon,lat,p,z,zcoords,u,v,t,thetav,phis,ps,rho,q)
!
!  Given a point specified by:
!      lon    longitude (radians)
!      lat    latitude (radians)
!      p/z    pressure (Pa) / height (m)
!  zcoords    1 if z is specified, 0 if p is specified
!
!  the functions will return:
!        p    pressure if z is specified (Pa)
!        z    geopotential height if p is specified (m)
!        u    zonal wind (m s^-1)
!        v    meridional wind (m s^-1)
!        t    temperature (K)
!   thetav    virtual potential temperature (K)
!     phis    surface geopotential (m^2 s^-2)
!       ps    surface pressure (Pa)
!      rho    density (kj m^-3)
!        q    specific humidity (kg/kg)
!
!  Initial data are currently identical to:
!
!       Reed, K. A., and C. Jablonowski, 2011: An analytic
!       vortex initialization technique for idealized tropical
!       cyclone studies in AGCMs. Mon. Wea. Rev., 139, 689-710.
!
!  Author: Kevin A. Reed
!          Stony Brook University
!          Email: kevin.a.reed@stonybrook.edu
!
!=======================================================================

  IMPLICIT NONE
  PUBLIC :: tropical_cyclone_test
!=======================================================================
!    Physical constants
!=======================================================================

  REAL(8), PARAMETER ::               &
       a     = 6371220.0d0,           & ! Reference Earth's Radius (m)
       Rd    = 287.0d0,               & ! Ideal gas const dry air (J kg^-1 K^1)
       g     = 9.80616d0,             & ! Gravity (m s^2)
       cp    = 1004.5d0,              & ! Specific heat capacity (J kg^-1 K^1)
       Lvap  = 2.5d6,                 & ! Latent heat of vaporization of water
       Rvap  = 461.5d0,               & ! Ideal gas constnat for water vapor
       Mvap  = 0.608d0,               & ! Ratio of molar mass of dry air/water
       pi    = 3.14159265358979d0,    & ! pi
       p0    = 100000.0d0,            & ! surface pressure (Pa)
       kappa = 2.d0/7.d0,             & ! Ratio of Rd to cp
       omega = 7.29212d-5,            & ! Reference rotation rate of the Earth (s^-1)
       deg2rad  = pi/180.d0             ! Conversion factor of degrees to radians

!=======================================================================
!    Test case parameters
!=======================================================================
  REAL(8), PARAMETER ::         &
       rp         = 282000.d0,  & ! Radius for calculation of PS
       dp         = 1115.d0,    & ! Delta P for calculation of PS
       zp         = 7000.d0,    & ! Height for calculation of P
       q0         = 0.021d0,    & ! q at surface from Jordan
       gamma      = 0.007d0,    & ! lapse rate
       Ts0        = 302.15d0,   & ! Surface temperature (SST)
       p00        = 101500.d0,  & ! global mean surface pressure
       cen_lat    = 10.d0,      & ! Center latitude of initial vortex
       cen_lon    = 180.d0,     & ! Center longitufe of initial vortex
       zq1        = 3000.d0,    & ! Height 1 for q calculation
       zq2        = 8000.d0,    & ! Height 2 for q calculation
       exppr      = 1.5d0,      & ! Exponent for r dependence of p
       exppz      = 2.d0,       & ! Exponent for z dependence of p
       ztrop      = 15000.d0,   & ! Tropopause Height
       qtrop      = 1.d-11,     & ! Tropopause specific humidity
       rfpi       = 1000000.d0, & ! Radius within which to use fixed-point iter.
       constTv    = 0.608d0,    & ! Constant for Virtual Temp Conversion
       deltaz     = 2.d-13,     & ! Small number to ensure convergence in FPI
       epsilon    = 1.d-25,     & ! Small number to aviod dividing by zero in wind calc
       exponent = Rd*gamma/g,   & ! exponent
       T0    = Ts0*(1.d0+constTv*q0),             & ! Surface temp
       Ttrop = T0 - gamma*ztrop,                  & ! Tropopause temp
       ptrop = p00*(Ttrop/T0)**(1.d0/exponent)      ! Tropopause pressure

CONTAINS

!=======================================================================
!    Evaluate the tropical cyclone initial conditions
!=======================================================================
  SUBROUTINE tropical_cyclone_test(lon,lat,p,z,zcoords,u,v,t,thetav,phis,ps,rho,q) &
    BIND(c, name = "tropical_cyclone_test")

    IMPLICIT NONE

    !------------------------------------------------
    !   Input / output parameters
    !------------------------------------------------

    REAL(8), INTENT(IN) ::     &
              lon,             &     ! Longitude (radians)
              lat                    ! Latitude (radians)

    REAL(8), INTENT(INOUT) ::  &
              p,               &     ! Pressure (Pa)
              z                      ! Height (m)

    INTEGER, INTENT(IN) :: zcoords     ! 1 if z coordinates are specified
                                     ! 0 if p coordinates are specified

    REAL(8), INTENT(OUT) ::    &
              u,               &     ! Zonal wind (m s^-1)
              v,               &     ! Meridional wind (m s^-1)
              t,               &     ! Temperature (K)
              thetav,          &     ! Virtual potential temperature (K)
              phis,            &     ! Surface Geopotential (m^2 s^-2)
              ps,              &     ! Surface Pressure (Pa)
              rho,             &     ! Density (kg m^-3)
              q                      ! Specific Humidity (kg/kg)

    !------------------------------------------------
    !   Local variables
    !------------------------------------------------
    real(8)  :: d1, d2, d, vfac, ufac, height, zhere, gr, f, zn

    integer  n

    !------------------------------------------------
    !   Define Great circle distance (gr) and
    !   Coriolis parameter (f)
    !------------------------------------------------
    f  = 2.d0*omega*sin(cen_lat*deg2rad)           ! Coriolis parameter
    gr = a*acos(sin(cen_lat*deg2rad)*sin(lat) + &  ! Great circle radius
         (cos(cen_lat*deg2rad)*cos(lat)*cos(lon-cen_lon*deg2rad)))

    !------------------------------------------------
    !   Initialize PS (surface pressure)
    !------------------------------------------------
    ps = p00-dp*exp(-(gr/rp)**exppr)

    !------------------------------------------------
    !   Initialize altitude (z) if pressure provided
    !   or pressure if altitude (z) is provided
    !------------------------------------------------
    if (zcoords .eq. 1) then

       height = z

       if (height > ztrop) then
          p = ptrop*exp(-(g*(height-ztrop))/(Rd*Ttrop))
       else
          p = (p00-dp*exp(-(gr/rp)**exppr)*exp(-(height/zp)**exppz)) &
              * ((T0-gamma*height)/T0)**(1/exponent)
       end if

    else

       height = (T0/gamma)*(1.d0-(p/ps)**exponent)

       ! If inside a certain distance of the center of the storm
       ! perform a Fixed-point iteration to calculate the height
       ! more accurately

       if (gr < rfpi ) then
          zhere = height
          n = 1
          20 continue
          n = n+1
          zn = zhere - fpiF(p,gr,zhere)/fpidFdz(gr,zhere)
          if (n.gt.20) then
              PRINT *,'FPI did not converge after 20 interations in q & T!!!'
          else if ( abs(zn-zhere)/abs(zn) > deltaz) then
              zhere = zn
              goto 20
          end if
          height = zn
       end if
    end if

    !------------------------------------------------
    !   Initialize U and V (wind components)
    !------------------------------------------------
    d1 = sin(cen_lat*deg2rad)*cos(lat) - &
         cos(cen_lat*deg2rad)*sin(lat)*cos(lon-cen_lon*deg2rad)
    d2 = cos(cen_lat*deg2rad)*sin(lon-cen_lon*deg2rad)
    d  = max(epsilon, sqrt(d1**2.d0 + d2**2.d0))
    ufac = d1/d
    vfac = d2/d

    if (height > ztrop) then
        u = 0.d0
        v = 0.d0
    else
        v = vfac*(-f*gr/2.d0+sqrt((f*gr/2.d0)**(2.d0) &
            - exppr*(gr/rp)**exppr*Rd*(T0-gamma*height) &
            /(exppz*height*Rd*(T0-gamma*height)/(g*zp**exppz) &
            +(1.d0-p00/dp*exp((gr/rp)**exppr)*exp((height/zp)**exppz)))))
        u = ufac*(-f*gr/2.d0+sqrt((f*gr/2.d0)**(2.d0) &
            - exppr*(gr/rp)**exppr*Rd*(T0-gamma*height) &
            /(exppz*height*Rd*(T0-gamma*height)/(g*zp**exppz) &
            +(1.d0-p00/dp*exp((gr/rp)**exppr)*exp((height/zp)**exppz)))))
    end if

    !------------------------------------------------
    !   Initialize water vapor mixing ratio (q)
    !------------------------------------------------
    if (height > ztrop) then
        q = qtrop
    else
        q = q0*exp(-height/zq1)*exp(-(height/zq2)**exppz)
    end if

    !------------------------------------------------
    !   Initialize temperature (T)
    !------------------------------------------------
    if (height > ztrop) then
        t = Ttrop
    else
        t = (T0-gamma*height)/(1.d0+constTv*q)/(1.d0+exppz*Rd*(T0-gamma*height)*height &
            /(g*zp**exppz*(1.d0-p00/dp*exp((gr/rp)**exppr)*exp((height/zp)**exppz))))
    end if

    !-----------------------------------------------------
    !   Initialize virtual potential temperature (thetav)
    !-----------------------------------------------------
    thetav = t * (1.d0+constTv*q) * (p0/p)**(Rd/cp)

    !-----------------------------------------------------
    !   Initialize surface geopotential (PHIS)
    !-----------------------------------------------------
    phis = 0.d0  ! constant

    !-----------------------------------------------------
    !   Initialize density (rho)
    !-----------------------------------------------------
    rho = p/(Rd*t*(1.d0+constTv*q))

  END SUBROUTINE tropical_cyclone_test

!-----------------------------------------------------------------------
!    First function for fixed point iterations
!-----------------------------------------------------------------------
  REAL(8) FUNCTION fpiF(phere, gr, zhere)
    IMPLICIT NONE
    REAL(8), INTENT(IN) :: phere, gr, zhere

      fpiF = phere-(p00-dp*exp(-(gr/rp)**exppr)*exp(-(zhere/zp)**exppz)) &
             *((T0-gamma*zhere)/T0)**(g/(Rd*gamma))

  END FUNCTION fpiF

!-----------------------------------------------------------------------
!    Second function for fixed point iterations
!-----------------------------------------------------------------------
  REAL(8) FUNCTION fpidFdz(gr, zhere)
    IMPLICIT NONE
    REAL(8), INTENT(IN) :: gr, zhere

      fpidFdz =-exppz*zhere*dp*exp(-(gr/rp)**exppr)*exp(-(zhere/zp)**exppz)/(zp*zp)*((T0-gamma*zhere)/T0)**(g/(Rd*gamma)) &
               +g/(Rd*T0)*(p00-dp*exp(-(gr/rp)**exppr)*exp(-(zhere/zp)**exppz))*((T0-gamma*zhere)/T0)**(g/(Rd*gamma)-1.d0)

  END FUNCTION fpidFdz

END MODULE tropical_cyclone