program test_matrix_math
	use constants,		only:				dp, fp_acc
	use matrix_math,	only:				get_levi_civita, 	&
											crossP,				&
											is_equal_vect,		&
											is_equal_mat,		&
											zheevd_wrapper,		&
											blas_matmul,		&
											matrix_comm

    use test_helpers,	only:				my_exit,									&
    										push_to_outFile, write_test_results, 		&
    										random_matrix, random_vector

	implicit none

	logical		::	all_passed
	integer		::	smpl_size, succ_cnt, nTests
	real(dp)	::	acc_limit=1e-11_dp
	logical,		   allocatable		::	passed(:)
	character(len=80), allocatable		::	label(:)
	!
	all_passed	= 	.false.
	nTests		= 	7
	succ_cnt	= 	0
	smpl_size	=	500
	allocate(	passed(nTests)	)
	allocate(	label(nTests)	)
	!
	!	PERFORM TESTS
	!
	label(		1	)			=	"Levi Civitia operartor"
	passed(		1	)			=	test_levi_civita()
	!-----------------------------------------------------------------
	label(		2	)			=	"3D cross product"
	passed(		2	)			=	test_cross_product()
	!-----------------------------------------------------------------
	label(		3	)			=	"equality of  vectors"
	passed(		3	)			=	test_vect_equal()
	!-----------------------------------------------------------------
	label(		4	)			=	"equality of  matrices"
	passed(		4	)			=	test_mat_equal()
	!-----------------------------------------------------------------
	label(		5	)			=	"Gauge rotation"
	passed(		5	)			=	test_gauge_trafo()
	!-----------------------------------------------------------------
	label(		6	)			=	"matmul with Blas"
	passed(		6	)			=	test_blas_matmul()
	!-----------------------------------------------------------------
	label(		7	)			=	"matrix commutator"
	passed(		7	)			=	test_mat_comm()
	!
	!
	!	WRITE RESULTS TO LOG
	!
	call write_test_results(	'matrix_math_test', passed, label, succ_cnt, nTests	)
	call push_to_outFile("------------------------------------------------------")
	call push_to_outFile("")
	!
	!	EXIT
	!
	all_passed	=	( succ_cnt	==	nTests)
	call my_exit(all_passed)

contains

!private:------------------------------------------------------------------------------------------------------------------------
!--------------------------------------------------------------------------------------------------------------------------------
!
!
	logical function test_levi_civita()
		integer				::	my_Levi_Civita(3,3,3)
		!
		call get_levi_civita(my_Levi_Civita)
		!
		test_levi_civita	= 							(	my_Levi_Civita(1,2,3) ==  1	)
		test_levi_civita 	= test_levi_civita .and.	(	my_Levi_Civita(2,3,1) ==  1	)
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(3,1,2) ==  1	)
		!
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(3,2,1) == -1	)
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(1,3,2) == -1	)
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(2,1,3) == -1	)
		!
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(1,1,2) == 0	)
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(1,2,2) == 0	)
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(2,1,2) == 0	)
		test_levi_civita	= test_levi_civita .and.	( 	my_Levi_Civita(1,1,1) == 0	)
		!
		return
	end function
!--------------------------------------------------------------------------------------------------------------------------------
!
!

	logical function test_cross_product()
		logical				::	re_crossp, im_crossp
		!
		re_crossp			=	d_test_crossp()
		im_crossp			=	z_test_crossp()
		!
		test_cross_product	=	re_crossp .and. im_crossp
		return
	end function

	logical function d_test_crossp()
		real(dp)		::	real_a(3), real_b(3), real_c_sol(3), real_c_test(3)
		!
		!REAL(DP) TEST
		real_a(1)		= 	-1.4_dp
		real_a(2)		=	3.5_dp
		real_a(3)		=	2.6_dp
		!
		real_b(1)		=	0.9_dp
		real_b(2)		=	-14.5_dp
		real_b(3)		=	0.001_dp
		!
		real_c_sol(1)	=	37.703500_dp
		real_c_sol(2)	=	2.341400_dp
		real_c_sol(3)	=	17.1500_dp
		!
		real_c_test		=	crossP(real_a,real_b)
		d_test_crossp	= 	norm2(real_c_test - real_c_sol) < fp_acc
		!
		return
	end function

	logical function z_test_crossp()
		!cplx_a(1)		=	cmplx(-1.4_dp, 1.0_dp,dp)
		!cplx_a(2)		=	cmplx(3.5_dp,-0.5_dp,dp)
		!cplx_a(3)		=	cmplx(2.6_dp,0.0_dp,dp)
		!!
		!cplx_b(1)		=	cmplx(0.9_dp,0.0_dp,dp)
		!cplx_b(2)		=	cmplx(-14.5_dp,0.0_dp,dp)
		!cplx_b(3)		=	cmplx(0.001_dp,-0.001_dp,dp)
		!!
		!cplx_c_sol(1)	=	cmplx(37.7030_dp,0.004_dp,dp)
		!cplx_c_sol(2)	=	cmplx( 2.3404_dp,0.0024_dp,dp)
		!cplx_c_sol(3)	=	cmplx(17.15_dp,14.05_dp,dp)
		!!
		!cplx_c_test		=	crossP(cplx_a, cplx_b)
		!cplx_delta		=	cplx_c_test - cplx_c_sol
		!z_test_crossp	=	abs(	sum(cplx_delta)		) < fp_prec
		!
		z_test_crossp	=	.true.
		!
		return
	end function

!--------------------------------------------------------------------------------------------------------------------------------
!
!
	logical function test_vect_equal()
		real(dp), 	allocatable				::	a(:), b(:), a_cpy(:)
		!integer								::	smpl_size
		!
		!smpl_size	= 1000
		allocate( a(		smpl_size)	)
		allocate( b(		smpl_size)	)
		allocate( a_cpy(	smpl_size)	)
		!
		call random_vector(a)
		call random_vector(b)
		b(1)		=	a(1)-acc_limit
		a_cpy(:)	= 	a(:)

		!
		test_vect_equal	=  .not. is_equal_vect(fp_acc, a,b)
		test_vect_equal	=	test_vect_equal .and. is_equal_vect(fp_acc, a,a_cpy)
		!
		return
	end function
!--------------------------------------------------------------------------------------------------------------------------------
!
!
	logical function test_mat_equal()
		logical							::	real_test, imag_test
		!
		real_test	=	d_test_mat_equal()
		imag_test	=	z_test_mat_equal()
		!
		if(.not.	real_test)	call push_to_outFile('[test_mat_equal]:  FAILED real test')
		if(.not.	real_test)	call push_to_outFile('[test_mat_equal]:  FAILED cplx test')
		!
		test_mat_equal	=	real_test .and. imag_test
		!
		return
	end function

	!-------
	logical function d_test_mat_equal()
		real(dp),		allocatable		::	A(:,:), B(:,:), A_cpy(:,:)
		real(dp)						::	acc
		character(len=120)				:: 	msg
		!
		allocate(		A(		smpl_size,	smpl_size)		)
		allocate(		A_cpy(	smpl_size,	smpl_size)		)
		allocate(		B(	smpl_size,	smpl_size)		)
		!
		d_test_mat_equal	= .false.
		!
		call random_matrix(A)
		A_cpy	=	A
		!	now get B matrix
		call random_matrix(B)
		!		(make explicitly sure that it is not equal A)
		B(smpl_size,smpl_size)	=	A(smpl_size,smpl_size)	+ 1.0_dp
		!
		!
		acc	= fp_acc
		do while(.not. d_test_mat_equal .and. acc< acc_limit)
			d_test_mat_equal	= 	is_equal_mat(acc,A, A_cpy) .and. (	.not. is_equal_mat(acc,A,B)	)
			acc					=	acc * 10.0_dp
		end do
		!
		if( 		d_test_mat_equal)	write(msg,*) '[d_test_mat_equal]: test was successful with accuracy ',acc
		if( .not. 	d_test_mat_equal)	write(msg,*) '[d_test_mat_equal]: FAILED with final accuracy ',acc
		call push_to_outFile(msg)
		!
		return
	end function

	logical function z_test_mat_equal()
		complex(dp),		allocatable		::	A(:,:), B(:,:), A_cpy(:,:)
		real(dp)							::	acc
		character(len=120)					:: 	msg
		!
		z_test_mat_equal	= .false.
		!
		allocate(		A(		smpl_size,	smpl_size)		)
		allocate(		A_cpy(	smpl_size,	smpl_size)		)
		allocate(		B(	smpl_size,	smpl_size)		)
		!
		call random_matrix(A)
		A_cpy	=	A
		!	now get B matrix
		call random_matrix(B)
		!		(make explicitly sure that it is not equal A)
		B(smpl_size,smpl_size)	=	A(smpl_size,smpl_size)	+ 1.0_dp
		!
		!
		acc	= fp_acc
		do while(.not. z_test_mat_equal .and. acc< acc_limit)
			z_test_mat_equal	= is_equal_mat(acc,A, A_cpy) .and. .not. is_equal_mat(acc,A,B)
			acc					=	acc * 10.0_dp
		end do
		!
		if( 		z_test_mat_equal)	write(msg,*) '[z_test_mat_equal]: test was successful with accuracy ',acc
		if( .not. 	z_test_mat_equal)	write(msg,*) '[z_test_mat_equal]: FAILED with final accuracy ',acc
		call push_to_outFile(msg)
		!
		return
	end function
!--------------------------------------------------------------------------------------------------------------------------------
!
!
	logical function test_tens_vect()
		test_tens_vect		=	.false.

		return
	end function
!--------------------------------------------------------------------------------------------------------------------------------
!
!
	logical function test_gauge_trafo()
		complex(dp),	allocatable			::	M_W(:,:),				&
												U(:,:), tmp(:,:)
		real(dp),		allocatable			::	eigVal(:)
		real(dp)							::	acc
		character(len=120)					::	msg
		!
		test_gauge_trafo	=	.false.
		!
		allocate(	M_W(	smpl_size, smpl_size	)		)
		allocate(	tmp(	smpl_size, smpl_size	)		)
		allocate(	U(		smpl_size, smpl_size	)		)
		allocate(	eigVal(	smpl_size		)		)
		!
		call random_matrix(M_W)
		!GET EIGVAL & EIGVEC
		U	=	M_W
		call zheevd_wrapper(U,	eigVal)

		!rotate M_W with U should yield diagonal matrix (matrix in H gauge)
		tmp	=	blas_matmul(	conjg(transpose(U))	,	M_W		)
		M_W	=	blas_matmul(			tmp			,	 U		)
		!
		!
		!todo: check now if M_H is diagonal with eival on diago
		acc = fp_acc
		do while( .not. test_gauge_trafo .and. (acc	<	acc_limit)	)
			test_gauge_trafo	=	test_gauge_with_acc(acc, M_W, eigVal)
			acc 				=	acc * 10.0_dp
		end do
		!
		if( test_gauge_trafo)	 then
			write(msg,*)	'[test_gauge_trafo]:	PASSED gauge rotation with accuracy', acc
			call push_to_outFile(msg)
		else
			write(msg,*)	'[test_gauge_trafo]:	FAILED gauge rotation with final accuracy', acc
			call push_to_outFile(msg)
		end if

		return
	end function

	logical function test_gauge_with_acc(acc, M_W, eigVal)
		real(dp),		intent(in)			::	acc, eigVal(:)
		complex(dp),	intent(in)			::	M_W(:,:)
		integer								::	n,m
		!
		test_gauge_with_acc	= .true.
		outer_loop:	do m = 1, size(M_W,2)
			do n = 1, size(M_W,1)
				if(	n==m	) then
					test_gauge_with_acc =	test_gauge_with_acc .and. 		(	abs(	M_W(n,n)-eigVal(n) 	) < acc	)
				else
					test_gauge_with_acc =	test_gauge_with_acc .and.		(	abs(		M_W(n,m)		) < acc	)
				end if
				!
				if(.not. test_gauge_with_acc	)	exit outer_loop
			end do
		end do outer_loop
		!
		return
	end function

!--------------------------------------------------------------------------------------------------------------------------------
!
!
	logical function test_blas_matmul()
		logical					::	real_test, imag_test
		!
		real_test			= test_d_blas_matmul()
		imag_test			= test_z_blas_matmul()
		!
		if(.not. real_test)	call push_to_outFile("[test_blas_matmul]: failed real matrix ")
		if(.not. imag_test)	call push_to_outFile("[test_blas_matmul]: failed imag matrix ")
		!
		test_blas_matmul	= real_test .and. imag_test
		return
	end function
	!
	logical function test_d_blas_matmul()
		real(dp),	allocatable			::	A(:,:), B(:,:), C_intern(:,:), C_blas(:,:)
		real(dp)						::	acc
		character(len=130)				::	msg
		!
		allocate(	A(			smpl_size	, smpl_size		)		)
		allocate(	B(			smpl_size	, smpl_size		)		)
		allocate(	C_intern(	smpl_size	, smpl_size		)		)
		allocate(	C_blas(		smpl_size	, smpl_size		)		)
		!
		call random_matrix(A)
		call random_matrix(B)
		!
		C_intern	=	matmul(A,B)
		C_blas		=	blas_matmul(A,B)
		!
		test_d_blas_matmul	=	.false.
		acc					= 	fp_acc
		do while ((.not. test_d_blas_matmul) .and. (acc < 1e-5_dp))
			test_d_blas_matmul	=	 is_equal_mat(acc, C_intern, C_blas)
			acc	= acc * 10.0_dp
		end do
		if(test_d_blas_matmul )	then
			write(msg,*)	"d_blas_matmul has accuracy ",acc
			call push_to_outFile(msg)
		end if
		!
		return
	end function
	!
	logical function test_z_blas_matmul()
		complex(dp),	allocatable		::	A(:,:), B(:,:), C_intern(:,:), C_blas(:,:)
		real(dp)						::	acc
		character(len=130)				::	msg
		!
		allocate(	A(			smpl_size	, smpl_size		)		)
		allocate(	B(			smpl_size	, smpl_size		)		)
		allocate(	C_intern(	smpl_size	, smpl_size		)		)
		allocate(	C_blas(		smpl_size	, smpl_size		)		)
		!
		call random_matrix(A)
		call random_matrix(B)
		!
		C_intern	=	matmul(A,B)
		C_blas		=	blas_matmul(A,B)
		!
		!
		test_z_blas_matmul	= .false.
		acc			= 	fp_acc
		do while ((.not. test_z_blas_matmul) .and. (acc < 1e-5_dp))
			test_z_blas_matmul	=	 is_equal_mat(acc,C_intern, C_blas)
			acc	= acc * 10_dp
		end do
		if( test_z_blas_matmul)	then
			write(msg,*)	"z_blas_matmul has accuracy ",acc
			call push_to_outFile(msg)
		end if
		!
		return
	end function
!--------------------------------------------------------------------------------------------------------------------------------
!
!
	logical function test_mat_comm()
		!
		!	wikipedia test from
		!			https://en.wikipedia.org/wiki/Commuting_matrices
		!
		complex(dp),	allocatable		::	I_mat(:,:), M_mat(:,:), cplx_comm(:,:)
		real(dp)						::	A(2,2), B(2,2), real_comm(2,2)
		integer							::	m,n, succ_cnt
		real(dp)						::	scale, rand1, rand2
		logical							::	identity_test, wikipedia_comm, wikipedia_non_comm
		!
		!----------------------------------------------------------------------------------------------------------
		!	IDENTITY_TEST:	TEST IF RANDOM MATRIX M COMMUTES WITH IDENTITY
		!
		test_mat_comm	=	.false.
		scale			=	1023.34514_dp
		!
		allocate(	I_mat(		smpl_size, smpl_size	)		)
		allocate(	M_mat(		smpl_size, smpl_size	)		)
		allocate(	cplx_comm(	smpl_size, smpl_size	)		)
		I_mat(:,:)	=	cmplx(0.0_dp, 0.0_dp, dp)
		M_mat(:,:)	=	cmplx(0.0_dp, 0.0_dp, dp)
		!
		!FILL MATRICES
		do n = 1, smpl_size
			do m = 1, smpl_size
				if(m==n)	I_mat(m,n)	=	cmplx(1.0,0.0_dp, dp)
				call random_number(	rand1	)
				call random_number(	rand2	)
				M_mat(m,n)	=	cmplx( 		scale*(	rand1-.5_dp)	,	scale*(	rand2-.5_dp),	dp)
			end do
		end do
		!
		!GET COMMUTATOR
		cplx_comm	=	 matrix_comm(I_mat, M_mat)
		!
		!TEST IF COMMUTATOR IS ZERO
		succ_cnt = 0
		do n = 1, smpl_size
			do m = 1, smpl_size
				if(	 abs(	cplx_comm(m,n)	) < fp_acc		)	succ_cnt = succ_cnt + 1
			end do
		end do
		identity_test	=	( succ_cnt == smpl_size**2 )
		!----------------------------------------------------------------------------------------------------------
		!	wikipedia_comm:	COMMUTING MATRICES TEST
		!
		A(:,:)	=	0.0_dp
		A(1,2)	=	1.0_dp
		B(:,:)	=	0.0_dp
		B(1,1)	=	1.0_dp
		B(2,2)	=	1.0_dp
		!
		real_comm		=	matrix_comm(A,B)
		wikipedia_comm	=							(	abs(real_comm(1,1))	< fp_acc	)
		wikipedia_comm	=	wikipedia_comm	.and.	(	abs(real_comm(1,2))	< fp_acc	)
		wikipedia_comm	=	wikipedia_comm	.and.	(	abs(real_comm(2,1))	< fp_acc	)
		wikipedia_comm	=	wikipedia_comm	.and.	(	abs(real_comm(2,2))	< fp_acc	)
		!----------------------------------------------------------------------------------------------------------
		!	wikipedia_comm:	NON COMMUTING MATRICES TEST
		!
		A(1,1)	=	1.0_dp
		A(1,2)	=	2.0_dp
		A(2,1)	=	0.0_dp
		A(2,2)	=	3.0_dp

		B(:,:)	=	1.0_dp
		B(2,1)	=	0.0_dp
		!
		real_comm			=	matrix_comm(A,B)
		wikipedia_non_comm	=								(	abs(real_comm(1,1))	< fp_acc	)
		wikipedia_non_comm	=	wikipedia_non_comm	.and.	(	abs(real_comm(1,2))	< fp_acc	)
		wikipedia_non_comm	=	wikipedia_non_comm	.and.	(	abs(real_comm(2,1))	< fp_acc	)
		wikipedia_non_comm	=	wikipedia_non_comm	.and.	(	abs(real_comm(2,2))	< fp_acc	)
		!
		wikipedia_non_comm	=	.not. wikipedia_non_comm
		!----------------------------------------------------------------------------------------------------------
		!
		test_mat_comm	=	identity_test .and. wikipedia_comm .and. wikipedia_non_comm
		!
		return
	end function
!--------------------------------------------------------------------------------------------------------------------------------

end program


!> Author:   Jabir Ali Ouassou
!> Category: Programs
!>
!> This program calculates the critical temperature of a one-dimensional superconducting structure.

program critical_p
  use :: structure_m
  use :: stdio_m
  use :: math_m

  !--------------------------------------------------------------------------------!
  !                                GLOBAL VARIABLES                                !
  !--------------------------------------------------------------------------------!

  ! Declare the superconducting structure
  type(structure)                 :: stack

  ! Declare program control parameters
  integer,      parameter         :: bisections = 20
  integer,      parameter         :: bootstraps = 10
  integer,      parameter         :: iterations = 10
  real(wp),     parameter         :: threshold  = 1e-08_wp
  real(wp),     parameter         :: initgap    = 1e-02_wp

  ! Declare variables used by the program
  real(wp)                        :: minimum    = 0.00_wp
  real(wp)                        :: maximum    = 1.00_wp
  real(wp)                        :: critical   = 0.50_wp
  integer                         :: n          = 0

  !--------------------------------------------------------------------------------!
  !                           INITIALIZATION PROCEDURE                             !
  !--------------------------------------------------------------------------------!

  ! Redefine stdout and stderr
  stdout = output('output.log')
  stderr = output('error.log')

  ! Construct the material stack
  stack = structure()

  ! Disable convergence acceleration
  call stack % cmap('boost', .false.)

  ! Initialize the stack to a barely superconducting state
  call stack % cmap('gap', initgap)

  ! Reset the states of the propagators throughout the stack
  call stack % initialize

  ! Bootstrap the material states while locking the gap
  call stack % converge(threshold = threshold, iterations = bootstraps, bootstrap = .true.)

  ! Save the current state of the materials
  call stack % save

  !--------------------------------------------------------------------------------!
  !                           BINARY SEARCH PROCEDURE                              !
  !--------------------------------------------------------------------------------!

  do n = 1,bisections
    ! Set the temperature of the materials
    call stack % cmap('temperature', critical)

    ! Reinitialize at the new temperature
    call stack % initialize

    ! Load the saved material states
    call stack % load

    ! Update the material states
    call stack % converge(iterations = iterations, prehook = prehook)

    ! Update the critical temperature estimate
    if (stack % gap() >= initgap) then
      minimum = critical
    else
      maximum = critical
    end if
    critical = (minimum + maximum)/2
  end do

  ! Write out the final results
  call finalize

  !--------------------------------------------------------------------------------!
  !                                 SUBROUTINES                                    !
  !--------------------------------------------------------------------------------!

contains
  impure subroutine prehook
    ! Write out status information.
    call status_body('Temperature', critical)
    call status_body('Bisection',   n)
  end subroutine

  impure subroutine finalize
    ! Status information
    call status_head('CRITICAL TEMPERATURE')
    call status_body('Result', critical)
    call status_foot

    ! Write the result to file
    call dump('critical.dat', critical)

    ! Close output files
    close(stdout)
    close(stderr)
  end subroutine
end program


      SUBROUTINE MB03JD( COMPQ, N, A, LDA, D, LDD, B, LDB, F, LDF, Q,
     $                   LDQ, NEIG, IWORK, LIWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To move the eigenvalues with strictly negative real parts of an
C     N-by-N real skew-Hamiltonian/Hamiltonian pencil aS - bH in
C     structured Schur form,
C
C           (  A  D  )      (  B  F  )
C       S = (        ), H = (        ),
C           (  0  A' )      (  0 -B' )
C
C     with A upper triangular and B upper quasi-triangular, to the
C     leading principal subpencil, while keeping the triangular form.
C     The notation M' denotes the transpose of the matrix M.
C     The matrices S and H are transformed by an orthogonal matrix Q
C     such that
C
C                            (  Aout  Dout  )
C       Sout = J Q' J' S Q = (              ),
C                            (    0   Aout' )
C                                                                    (1)
C                            (  Bout  Fout  )           (  0  I  )
C       Hout = J Q' J' H Q = (              ), with J = (        ),
C                            (  0    -Bout' )           ( -I  0  )
C
C     where Aout is upper triangular and Bout is upper quasi-triangular.
C     Optionally, if COMPQ = 'I' or COMPQ = 'U', the orthogonal matrix Q
C     that fulfills (1), is computed.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             Specifies whether or not the orthogonal transformations
C             should be accumulated in the array Q, as follows:
C             = 'N':  Q is not computed;
C             = 'I':  the array Q is initialized internally to the unit
C                     matrix, and the orthogonal matrix Q is returned;
C             = 'U':  the array Q contains an orthogonal matrix Q0 on
C                     entry, and the matrix Q0*Q is returned, where Q
C                     is the product of the orthogonal transformations
C                     that are applied to the pencil aS - bH to reorder
C                     the eigenvalues.
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the pencil aS - bH.  N >= 0, even.
C
C     A       (input/output) DOUBLE PRECISION array, dimension
C                            (LDA, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular matrix A. The elements of the
C             strictly lower triangular part of this array are not used.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed matrix Aout.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= MAX(1, N/2).
C
C     D       (input/output) DOUBLE PRECISION array, dimension
C                           (LDD, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the skew-symmetric
C             matrix D. The diagonal need not be set to zero.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed upper triangular part of the
C             matrix Dout.
C             The strictly lower triangular part of this array is
C             not referenced, except for the element D(N/2,N/2-1), but
C             its initial value is preserved.
C
C     LDD     INTEGER
C             The leading dimension of the array D.  LDD >= MAX(1, N/2).
C
C     B       (input/output) DOUBLE PRECISION array, dimension
C                            (LDB, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper quasi-triangular matrix B.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed upper quasi-triangular part of
C             the matrix Bout.
C             The part below the first subdiagonal of this array is
C             not referenced.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= MAX(1, N/2).
C
C     F       (input/output) DOUBLE PRECISION array, dimension
C                           (LDF, N/2)
C             On entry, the leading N/2-by-N/2 part of this array must
C             contain the upper triangular part of the symmetric matrix
C             F.
C             On exit, the leading  N/2-by-N/2 part of this array
C             contains the transformed upper triangular part of the
C             matrix Fout.
C             The strictly lower triangular part of this array is not
C             referenced, except for the element F(N/2,N/2-1), but its
C             initial value is preserved.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= MAX(1, N/2).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ, N)
C             On entry, if COMPQ = 'U', then the leading N-by-N part of
C             this array must contain a given matrix Q0, and on exit,
C             the leading N-by-N part of this array contains the product
C             of the input matrix Q0 and the transformation matrix Q
C             used to transform the matrices S and H.
C             On exit, if COMPQ = 'I', then the leading N-by-N part of
C             this array contains the orthogonal transformation matrix
C             Q.
C             If COMPQ = 'N' this array is not referenced.
C
C     LDQ     INTEGER
C             The leading dimension of the array Q.
C             LDQ >= 1,         if COMPQ = 'N';
C             LDQ >= MAX(1, N), if COMPQ = 'I' or COMPQ = 'U'.
C
C     NEIG    (output) INTEGER
C             The number of eigenvalues in aS - bH with strictly
C             negative real part.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C
C     LIWORK  INTEGER
C             The dimension of the array IWORK.
C             LIWORK >= N+1.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             If COMPQ = 'N',
C                LDWORK >= MAX(2*N+32,108);
C             if COMPQ = 'I' or COMPQ = 'U',
C                LDWORK >= MAX(4*N+32,108).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0: succesful exit;
C             < 0: if INFO = -i, the i-th argument had an illegal value;
C             = 1: error occured during execution of MB03DD;
C             = 2: error occured during execution of MB03HD.
C
C     METHOD
C
C     The algorithm reorders the eigenvalues like the following scheme:
C
C     Step 1: Reorder the eigenvalues in the subpencil aA - bB.
C          I. Reorder the eigenvalues with negative real parts to the
C             top.
C         II. Reorder the eigenvalues with positive real parts to the
C             bottom.
C
C     Step 2: Reorder the remaining eigenvalues with negative real
C             parts in the pencil aS - bH.
C          I. Exchange the eigenvalues between the last diagonal block
C             in aA - bB and the last diagonal block in aS - bH.
C         II. Move the eigenvalues of the R-th block to the (MM+1)-th
C             block, where R denotes the number of upper quasi-
C             triangular blocks in aA - bB and MM denotes the current
C             number of blocks in aA - bB with eigenvalues with negative
C             real parts.
C
C     The algorithm uses a sequence of orthogonal transformations as
C     described on page 33 in [1]. To achieve those transformations the
C     elementary subroutines MB03DD and MB03HD are called for the
C     corresponding matrix structures.
C
C     REFERENCES
C
C     [1] Benner, P., Byers, R., Losse, P., Mehrmann, V. and Xu, H.
C         Numerical Solution of Real Skew-Hamiltonian/Hamiltonian
C         Eigenproblems.
C         Tech. Rep., Technical University Chemnitz, Germany,
C         Nov. 2007.
C
C     NUMERICAL ASPECTS
C                                                               3
C     The algorithm is numerically backward stable and needs O(N ) real
C     floating point operations.
C
C     CONTRIBUTOR
C
C     Matthias Voigt, Fakultaet fuer Mathematik, Technische Universitaet
C     Chemnitz, October 16, 2008.
C     V. Sima, Dec. 2009 (SLICOT version of the routine DHAUNX).
C
C     REVISIONS
C
C     V. Sima, Aug. 2009; Jan. 2010, Oct. 2010, Nov. 2010.
C     M. Voigt, Jan. 2012.
C
C     KEYWORDS
C
C     Eigenvalue reordering, upper (quasi-)triangular matrix,
C     skew-Hamiltonian/Hamiltonian pencil, structured Schur form.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE, HALF, TEN
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0, HALF = 0.5D+0,
     $                     TEN = 1.0D+1 )
C
C     .. Scalar Arguments ..
      CHARACTER          COMPQ
      INTEGER            INFO, LDA, LDB, LDD, LDF, LDQ, LDWORK, LIWORK,
     $                   N, NEIG
C
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), D( LDD, * ),
     $                   DWORK( * ),  F( LDF, * ), Q( LDQ, * )
C
C     .. Local Scalars ..
      LOGICAL            LCMPQ, LINIQ, LUPDQ
      INTEGER            DIM1, DIM2, HLP, I, IA, IAUPLE, IB, IB1, IB2,
     $                   IB3, IBUPLE, IBUPRI, IC, ICS, IQ1, IQ2, IQLOLE,
     $                   IQLORI, IQUPLE, IQUPRI, IR, IS, ITMP1, ITMP2,
     $                   ITMP3, IUPD, IWRK1, IWRK2, IWRK3, IWRK4, IWRK5,
     $                   J, K, LDW, M, MM, MP, NCOL, NCOLS, NROW, NROWS,
     $                   OPTDW, R, SDIM, UPDS
      DOUBLE PRECISION   A2, D1, D2, D3, F2, NRMA, NRMB, PREC, Q11, Q12,
     $                   Q21, Q22, TMP, TOL
C
C     .. Local Arrays ..
      DOUBLE PRECISION   PAR( 2 )
C
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DDOT, DLAMCH, DLANHS, DLANTR
      EXTERNAL           DDOT, DLAMCH, DLANHS, DLANTR, LSAME
C
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEMV, DLACPY, DLASET,
     $                   DSCAL, MB01LD, MB01RU, MB01RX, MB03DD, MB03HD,
     $                   XERBLA
C
C     .. Intrinsic Functions ..
      INTRINSIC          ABS, DBLE, INT, MAX, MIN, MOD, SIGN
C
C     .. Executable Statements ..
C
C     Decode the input arguments.
C
      M = N/2
      LINIQ = LSAME( COMPQ, 'I' )
      LUPDQ = LSAME( COMPQ, 'U' )
      LCMPQ = LINIQ .OR. LUPDQ
      IF( LCMPQ ) THEN
         OPTDW = MAX( 4*N+32, 108 )
      ELSE
         OPTDW = MAX( 2*N+32, 108 )
      END IF
C
C     Test the input arguments.
C
      INFO = 0
      IF( .NOT.( LSAME( COMPQ, 'N' ) .OR. LCMPQ ) ) THEN
         INFO = -1
      ELSE IF( N.LT.0 .OR. MOD( N, 2 ).NE.0 ) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, M ) ) THEN
         INFO = -4
      ELSE IF( LDD.LT.MAX( 1, M ) ) THEN
         INFO = -6
      ELSE IF( LDB.LT.MAX( 1, M ) ) THEN
         INFO = -8
      ELSE IF( LDF.LT.MAX( 1, M ) ) THEN
         INFO = -10
      ELSE IF( LDQ.LT.1 .OR. ( LCMPQ .AND. LDQ.LT.N ) ) THEN
         INFO = -12
      ELSE IF( LIWORK.LT.N+1 ) THEN
         INFO = -15
      ELSE IF( LDWORK.LT.OPTDW ) THEN
         INFO = -17
      END IF
      IF( INFO.NE.0) THEN
         CALL XERBLA( 'MB03JD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         NEIG = 0
         RETURN
      END IF
C
C     Determine machine constants.
C
      PREC = DLAMCH( 'Precision' )
      TOL  = MIN( DBLE( N ), TEN )*PREC
C
      PAR( 1 ) = PREC
      PAR( 2 ) = DLAMCH( 'Safe minimum' )
C
C     STEP 0: Determine location and size of diagonal blocks.
C             IWORK(J) and IWORK(IS+J) are used to indicate the
C             beginning index and the kind of eigenvalues of the
C             J-th diagonal block of the subpencil aA - bB. For a
C             2-by-2 block, it is assumed that both eigenvalues have
C             real parts with the same sign (true for a structured
C             Schur form).
C
      I  = 1
      J  = 1
      IS = M + 1
C
      NRMA = DLANTR( 'One', 'Upper', 'Non-diag', M, M, A, LDA, DWORK )
      NRMB = DLANHS( 'One', M, B, LDB, DWORK )
C
C     Partition blocks.
C
C     WHILE( I.LE.M-1 ) DO
C
   10 CONTINUE
      IF( I.LE.M-1 ) THEN
         IWORK( J ) = I
         IF( ABS( B( I+1, I ) ).LE.TOL*NRMB ) THEN
C
C           1-by-1 block.
C
            B( I+1, I ) = ZERO
            IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR.
     $          ABS( B( I, I ) ).LE.TOL*NRMB ) THEN
C
C              Eigenvalue is infinite, 0, or 0/0.
C
               IWORK( IS+J ) = 0
            ELSE
               IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) )
            END IF
            I = I + 1
         ELSE
C
C           2-by-2 block.
C
            IF( A( I, I ).EQ.ZERO .OR. A( I+1, I+1 ).EQ.ZERO ) THEN
C
C              Eigenvalue is infinite.
C
               IWORK( IS+J ) = 0
            ELSE
               TMP = ( B( I, I ) - ( B( I+1, I )   / A( I+1, I+1 ) )*
     $                               A( I, I+1 ) ) / A( I, I )  +
     $                               B( I+1, I+1 ) / A( I+1, I+1 )
               IF( TMP.EQ.ZERO ) THEN
                  IWORK( IS+J ) = 0
               ELSE
                  IWORK( IS+J ) = INT( SIGN( ONE, TMP ) )
               END IF
            END IF
            I = I + 2
         END IF
         J = J + 1
      GO TO 10
C
C     END WHILE 10
C
      END IF
C
      IF( I.EQ.M ) THEN
         IWORK( J ) = I
         IF( ABS( A( I, I ) ).LE.TOL*NRMA .OR.
     $       ABS( B( I, I ) ).LE.TOL*NRMB ) THEN
C
C           Eigenvalue is infinite or zero.
C
            IWORK( IS+J ) = 0
         ELSE
            IWORK( IS+J ) = INT( SIGN( ONE, A( I, I )*B( I, I ) ) )
         END IF
         J = J + 1
      END IF
C
      R = J - 1
C
C     Initialize Q if appropriate.
C
      IF( LINIQ ) THEN
         IUPD = M + 1
         UPDS = M
         CALL DLASET( 'Full', N, N, ZERO, ONE, Q, LDQ )
      ELSE IF( LUPDQ ) THEN
         IUPD = 1
         UPDS = N
      END IF
C
      IF( M.GT.1 ) THEN
C
C        Save the lower triangle of the submatrix D(M-1:M,M-1:M) and the
C        elements A(M,M-1), F(M,M-1), which might be overwritten.
C
         D1 = D( M-1, M-1 )
         D2 = D(   M, M-1 )
         D3 = D(   M,   M )
         A2 = A(   M, M-1 )
         F2 = F(   M, M-1 )
      END IF
C
C     STEP 1: Reorder the eigenvalues in the subpencil aA - bB.
C
      MM = 0
      MP = J
C
C     I. Reorder the eigenvalues with negative real parts to the top.
C
C     Set pointers for the inputs and outputs of MB03DD.
C
      IQ1   = 1
      IQ2   = IQ1 + 16
      IA    = IQ2 + 16
      IB    = IA  + 16
      IWRK1 = IB  + 16
      IWRK2 = IA
C
      K   = 1
      IB3 = M + 1
      IWORK( R+1 ) = IB3
C
C     WHILE( K.LE.R ) DO
C
   20 CONTINUE
      IF( K.LE.R ) THEN
         IF( IWORK( IS+K ).LT.0 ) THEN
            DO 30 J = K - 1, MM + 1, -1
C
C              IB1, IB2, and IB3 are pointers to 3 consecutive blocks.
C
               IB1  = IWORK( J )
               IB2  = IWORK( J+1 )
               IB3  = IWORK( J+2 )
               DIM1 = IB2  - IB1
               DIM2 = IB3  - IB2
               SDIM = DIM1 + DIM2
C
C              Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and
C              B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD.
C              Also, set the additional zero elements.
C
               CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                      DWORK( IA ), SDIM )
               CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      DWORK( IA+1 ), SDIM )
               CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB,
     $                      DWORK( IB ), SDIM )
               CALL DCOPY(  SDIM-1, B( IB1+1, IB1 ), LDB+1,
     $                      DWORK( IB+1 ), SDIM+1 )
               CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO,
     $                      DWORK( IB+2 ), SDIM )
C
C              Perform eigenvalue/matrix block exchange.
C              Workspace: IWRK1 + 43.
C
               CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ),
     $                      SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM,
     $                      DWORK( IQ2 ), SDIM, DWORK( IWRK1 ),
     $                      LDWORK-IWRK1+1, INFO )
               IF( INFO.GT.0 ) THEN
                  INFO = 1
                  RETURN
               END IF
C
C              Copy the transformed diagonal blocks, if sdim > 2.
C
               NROWS = IB1 - 1
               NCOLS = M - IB3 + 1
               ICS   = IB3
               IF( SDIM.GT.2 ) THEN
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM,
     $                         A( IB1, IB1 ), LDA )
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM,
     $                         B( IB1, IB1 ), LDB )
                  CALL DCOPY(  SDIM-1, DWORK( IB+1 ), SDIM+1,
     $                         B( IB1+1, IB1 ), LDB+1 )
                  NROW = NROWS
                  NCOL = NCOLS
                  IC   = ICS
                  LDW  = MAX( 1, NROW )
               ELSE
                  TMP = A( IB1+1, IB1 )
                  A( IB1+1, IB1 ) = ZERO
                  NROW = IB3 - 1
                  NCOL = M - IB1 + 1
                  IC   = IB1
                  LDW  = NROW
               END IF
C
C              Update A.
C              Workspace: IWRK2 + 2*N - 1.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                      A( 1, IB1 ), LDA )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ),
     $                      LDA, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      A( IB1, IC ), LDA )
               IF( SDIM.EQ.2 )
     $            A( IB1+1, IB1 ) = TMP
C
C              Update D.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      D( 1, IB1 ), LDD )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                      D( IB1, ICS ), LDD )
               CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM,
     $                      D( IB1, IB1 ), LDD, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
C
C              Update B.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                      B( 1, IB1 ), LDB )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ),
     $                      LDB, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      B( IB1, IC ), LDB )
C
C              Update F.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      F( 1, IB1 ), LDF )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                      F( IB1, ICS ), LDF )
               CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM,
     $                      F( IB1, IB1 ), LDF, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
               CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C                 Workspace: IWRK2 + 2*N - 1, if COMPQ = 'I';
C                            IWRK2 + 4*N - 1, if COMPQ = 'U'.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ,
     $                         DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( 1, IB1 ), LDQ )
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( IUPD, M+IB1 ), LDQ )
               END IF
C
C              Update index lists IWORK(1:M) and IWORK(M+2:N+1) if a
C              1-by-1 and 2-by-2 block have been swapped.
C
               HLP = DIM2 - DIM1
               IF( HLP.EQ.1 ) THEN
C
C                 First block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 1
               ELSE IF( HLP.EQ.-1 ) THEN
C
C                 Second block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 2
               END IF
C
C              Update IWORK(M+2:N+1).
C
               HLP = IWORK( IS+J )
               IWORK( IS+J )   = IWORK( IS+J+1 )
               IWORK( IS+J+1 ) = HLP
   30       CONTINUE
            MM = MM + 1
         END IF
         K = K + 1
      GO TO 20
C
C     END WHILE 20
C
      END IF
C
C     II. Reorder the eigenvalues with positive real parts to the bottom.
C
      K = R
C
C     WHILE( K.GE.MM+1 ) DO
C
   40 CONTINUE
      IF( K.GE.MM + 1 ) THEN
         IF( IWORK( IS+K ).GT.0 ) THEN
            DO 50 J = K, MP - 2
               IB1  = IWORK( J )
               IB2  = IWORK( J+1 )
               IB3  = IWORK( J+2 )
               DIM1 = IB2  - IB1
               DIM2 = IB3  - IB2
               SDIM = DIM1 + DIM2
C
C              Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and
C              B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD.
C              Also, set the additional zero elements.
C
               CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                      DWORK( IA ), SDIM )
               CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                      DWORK( IA+1 ), SDIM )
               CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB,
     $                      DWORK( IB ), SDIM )
               CALL DCOPY(  SDIM-1, B( IB1+1, IB1 ), LDB+1,
     $                      DWORK( IB+1 ), SDIM+1 )
               CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO,
     $                      DWORK( IB+2 ), SDIM )
C
C              Perform eigenvalue/matrix block exchange.
C
               CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ),
     $                      SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM,
     $                      DWORK( IQ2 ), SDIM, DWORK( IWRK1 ),
     $                      LDWORK-IWRK1+1, INFO )
               IF( INFO.GT.0 ) THEN
                  INFO = 1
                  RETURN
               END IF
C
C              Copy the transformed diagonal blocks, if sdim > 2.
C
               NROWS = IB1 - 1
               NCOLS = M - IB3 + 1
               ICS   = IB3
               IF( SDIM.GT.2 ) THEN
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM,
     $                         A( IB1, IB1 ), LDA )
                  CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM,
     $                         B( IB1, IB1 ), LDB )
                  CALL DCOPY(  SDIM-1, DWORK( IB+1 ), SDIM+1,
     $                         B( IB1+1, IB1 ), LDB+1 )
                  NROW = NROWS
                  NCOL = NCOLS
                  IC   = ICS
                  LDW  = MAX( 1, NROW )
               ELSE
                  TMP = A( IB1+1, IB1 )
                  A( IB1+1, IB1 ) = ZERO
                  NROW = IB3 - 1
                  NCOL = M - IB1 + 1
                  IC   = IB1
                  LDW  = NROW
               END IF
C
C              Update A.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                      A( 1, IB1 ), LDA )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ),
     $                      LDA, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      A( IB1, IC ), LDA )
               IF( SDIM.EQ.2 )
     $            A( IB1+1, IB1 ) = TMP
C
C              Update D.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      D( 1, IB1 ), LDD )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                      D( IB1, ICS ), LDD )
               CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM,
     $                      D( IB1, IB1 ), LDD, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
C
C              Update B.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                      SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                      B( 1, IB1 ), LDB )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ),
     $                      LDB, ZERO, DWORK( IWRK2 ), SDIM )
               CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                      B( IB1, IC ), LDB )
C
C              Update F.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                      SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), LDW )
               CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                      F( 1, IB1 ), LDF )
               CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                      SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                      F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ),
     $                      SDIM )
               CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                      F( IB1, ICS ), LDF )
               CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                      F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM,
     $                      F( IB1, IB1 ), LDF, DWORK( IWRK2 ),
     $                      LDWORK-IWRK2+1, INFO )
               CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 )
C
               IF( LCMPQ ) THEN
C
C                 Update Q.
C
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( 1, IB1 ), LDQ,
     $                         DWORK( IQ1 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( 1, IB1 ), LDQ )
                  CALL DGEMM(  'No Transpose', 'No Transpose', UPDS,
     $                         SDIM, SDIM, ONE, Q( IUPD, M+IB1 ), LDQ,
     $                         DWORK( IQ2 ), SDIM, ZERO, DWORK( IWRK2 ),
     $                         UPDS )
                  CALL DLACPY( 'Full', UPDS, SDIM, DWORK( IWRK2 ), UPDS,
     $                         Q( IUPD, M+IB1 ), LDQ )
               END IF
C
C              Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block
C              have been swapped. IWORK(M+2:N+1) is not needed anymore,
C              so it is not necessary to update it.
C
               HLP = DIM2 - DIM1
               IF( HLP.EQ.1 ) THEN
C
C                 First block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 1
               ELSE IF( HLP.EQ.-1 ) THEN
C
C                 Second block was 2-by-2.
C
                  IWORK( J+1 ) = IB1 + 2
               END IF
   50       CONTINUE
            MP = MP - 1
         END IF
         K = K - 1
      GO TO 40
C
C     END WHILE 40
C
      END IF
C
C     STEP 2: Reorder the remaining eigenvalues with negative real parts.
C
C     Set pointers for the inputs and outputs of MB03HD.
C
      IQUPLE = 1
      IAUPLE = IQUPLE + 16
      IBUPLE = IAUPLE +  8
      IWRK5  = IBUPLE +  8
      IWRK3  = IAUPLE
      IWRK4  = IWRK3  + 2*N
      ITMP1  = IWRK3  + N
      ITMP2  = ITMP1  + 4
      ITMP3  = ITMP2  + 4
C
      DO 70 K = R, MP, -1
C
C        I. Exchange the eigenvalues between two diagonal blocks.
C
         IR   = IWORK( R )
         DIM1 = IWORK( R+1 ) - IR
         SDIM = 2*DIM1
C
         IF( DIM1.EQ.2 ) THEN
            A( M, IR ) = ZERO
C
C           Build the (small) full skew-symmetric matrix D(M-1:M,M-1:M)
C           and the (small) symmetric matrix F(M-1:M,M-1:M).
C
            D( IR, IR ) =  ZERO
            D(  M, IR ) = -D( IR, M )
            D(  M,  M ) =  ZERO
            F(  M, IR ) =  F( IR, M )
         END IF
C
C        Calculate position of submatrices in DWORK.
C
         IBUPRI = IBUPLE + DIM1*DIM1
         IQLOLE = IQUPLE + DIM1
         IQUPRI = IQUPLE + DIM1*SDIM
         IQLORI = IQUPRI + DIM1
C
C        Generate input matrices for MB03HD built of submatrices of A,
C        D, B, and F.
C
         IF( DIM1.EQ.2 ) THEN
            CALL DLACPY( 'Upper', DIM1, DIM1, A( IR, IR ), LDA,
     $                   DWORK( IAUPLE ), DIM1 )
            DWORK( IAUPLE+6 ) = D( IR, IR+1 )
            CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB,
     $                   DWORK( IBUPLE ), DIM1 )
            CALL DLACPY( 'Upper', DIM1, DIM1, F( IR, IR ), LDF,
     $                   DWORK( IBUPRI ), DIM1 )
         ELSE
            DWORK( IBUPLE ) = B( IR, IR )
            DWORK( IBUPRI ) = F( IR, IR )
         END IF
C
C        Perform eigenvalue exchange.
C        Workspace: IWRK5 + 23, if SDIM = 4.
C
         CALL MB03HD( SDIM, DWORK( IAUPLE ), DIM1, DWORK( IBUPLE ),
     $                DIM1, PAR, DWORK( IQUPLE ), SDIM, DWORK( IWRK5 ),
     $                INFO )
         IF( INFO.GT.0 ) THEN
            INFO = 2
            RETURN
         END IF
C
         IF( DIM1.EQ.2 ) THEN
C
C           Update A by transformations from the right.
C           Workspace: IWRK3 + N - 1.
C
            CALL DLACPY( 'Full', M, DIM1, A( 1, IR ), LDA,
     $                   DWORK( IWRK3 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM,
     $                   ZERO, A( 1, IR ), LDA )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, D( 1, IR ), LDD, DWORK( IQLOLE ), SDIM,
     $                   ONE, A( 1, IR ), LDA )
C
C           Update D by transformations from the right.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM,
     $                   ZERO, DWORK( ITMP1 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, D( 1, IR ), LDD, DWORK( IQLORI ), SDIM,
     $                   ONE, DWORK( ITMP1 ), M )
            CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, D( 1, IR ),
     $                   LDD )
C
C           Compute the intermediate product Af'*Q21 and the second
C           column of Af'*Q22, with Af = A(M-1:M,M-1:M).
C
            CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                  ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ),
     $                  SDIM, ZERO, DWORK( ITMP1 ), DIM1 )
            CALL DGEMV( 'Transpose', DIM1, DIM1, ONE,
     $                  DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI+SDIM ),
     $                  1, ZERO, DWORK( ITMP2 ), 1 )
C
C           Update A by transformations from the left.
C
            CALL DLACPY( 'Full', DIM1, DIM1, A( IR, IR ), LDA,
     $                   DWORK( IWRK3 ), DIM1 )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   -ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ),
     $                   DIM1, ZERO, A( IR, IR ), LDA )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   ONE, DWORK( IQLORI ), SDIM, DWORK( IWRK3 ),
     $                   DIM1, ONE, A( IR, IR ), LDA )
C
C           Update D by transformations from the left.
C
            D( IR, M ) = DDOT( DIM1, DWORK( IQLORI ), 1, D( IR, M ), 1 )
     $                 - DDOT( DIM1, DWORK( IQUPRI ), 1, DWORK( ITMP2 ),
     $                         1 )
C
C           Update B by transformations from the right.
C
            CALL DLACPY( 'Full', M, DIM1, B( 1, IR ), LDB,
     $                   DWORK( IWRK3 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPLE ), SDIM,
     $                   ZERO, B( 1, IR ), LDB )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, F( 1, IR ), LDF, DWORK( IQLOLE ), SDIM,
     $                   ONE, B( 1, IR ), LDB )
C
C           Update F by transformations from the right.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, DWORK( IWRK3 ), M, DWORK( IQUPRI ), SDIM,
     $                   ZERO, DWORK( ITMP1 ), M )
            CALL DGEMM(  'No Transpose', 'No Transpose', M, DIM1, DIM1,
     $                   ONE, F( 1, IR ), LDF, DWORK( IQLORI ), SDIM,
     $                   ONE, DWORK( ITMP1 ), M )
            CALL DLACPY( 'Full', M, DIM1, DWORK( ITMP1 ), M, F( 1, IR ),
     $                   LDF )
C
C           Compute intermediate products Bf'*Q21 and Bf'*Q22, with
C           Bf = B(M-1:M,M-1:M).
C
            CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                  ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLOLE ),
     $                  SDIM, ZERO, DWORK( ITMP1 ), DIM1 )
C
            CALL DGEMM( 'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                  ONE, DWORK( IWRK3+M-DIM1 ), M, DWORK( IQLORI ),
     $                  SDIM, ZERO, DWORK( ITMP2 ), DIM1 )
C
C           Update B by transformations from the left.
C
            CALL DLACPY( 'Full', DIM1, DIM1, B( IR, IR ), LDB,
     $                   DWORK( ITMP3 ), DIM1 )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   ONE, DWORK( IQUPRI ), SDIM, DWORK( ITMP1 ),
     $                   DIM1, ZERO, B( IR, IR ), LDB )
            CALL DGEMM(  'Transpose', 'No Transpose', DIM1, DIM1, DIM1,
     $                   ONE, DWORK( IQLORI ), SDIM, DWORK( ITMP3 ),
     $                   DIM1, ONE, B( IR, IR ), LDB )
C
C           Update F by transformations from the left.
C
            CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ZERO,
     $                   ONE, DWORK( ITMP1 ), DIM1, DWORK( IQLORI ),
     $                   SDIM, F( IR, IR ), LDF, INFO )
            CALL MB01RX( 'Left', 'Upper', 'Transpose', DIM1, DIM1, ONE,
     $                   ONE, DWORK( ITMP1 ), DIM1, DWORK( IQUPRI ),
     $                   SDIM, DWORK( ITMP2 ), DIM1, INFO )
            CALL DLACPY( 'Upper', DIM1, DIM1, DWORK( ITMP1 ), DIM1,
     $                   F( IR, IR ), LDF )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C              Workspace: IWRK4 + 2*N - 1.
C
               CALL DLACPY( 'Full', N, DIM1, Q( 1, IR ), LDQ,
     $                      DWORK( IWRK4 ), N )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, DWORK( IWRK4 ), N,
     $                      DWORK( IQUPLE ), SDIM, ZERO, Q( 1, IR ),
     $                      LDQ )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, Q( 1, M+IR ), LDQ,
     $                      DWORK( IQLOLE ), SDIM, ONE, Q( 1, IR ),
     $                      LDQ )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, DWORK( IWRK4 ), N,
     $                      DWORK( IQUPRI ), SDIM, ZERO, DWORK( IWRK3 ),
     $                      N )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, DIM1,
     $                      DIM1, ONE, Q( 1, M+IR ), LDQ,
     $                      DWORK( IQLORI ), SDIM, ONE, DWORK( IWRK3 ),
     $                      N )
               CALL DLACPY( 'Full', N, DIM1, DWORK( IWRK3 ), N,
     $                      Q( 1, M+IR ), LDQ )
            END IF
         ELSE
            Q11 = DWORK( IQUPLE )
            Q21 = DWORK( IQLOLE )
            Q12 = DWORK( IQUPRI )
            Q22 = DWORK( IQLORI )
C
C           Update A by transformations from the right.
C
            CALL DCOPY( M-1, A( 1, IR ), 1, DWORK( IWRK3 ), 1 )
            CALL DSCAL( M-1, Q11, A( 1, IR ), 1 )
            CALL DAXPY( M-1, Q21, D( 1, IR ), 1, A( 1, IR ), 1 )
C
C           Update D by transformations from the right.
C
            CALL DSCAL( M-1, Q22, D( 1, IR ), 1 )
            CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, D( 1, IR ), 1 )
C
C           Update B by transformations from the right.
C
            CALL DCOPY( M-1, B( 1, IR ), 1, DWORK( IWRK3 ), 1 )
            CALL DSCAL( M-1, Q11, B( 1, IR ), 1 )
            CALL DAXPY( M-1, Q21, F( 1, IR ), 1, B( 1, IR ), 1 )
C
C           Update F by transformations from the right.
C
            CALL DSCAL( M-1, Q22, F( 1, IR ), 1 )
            CALL DAXPY( M-1, Q12, DWORK( IWRK3 ), 1, F( 1, IR ), 1 )
C
C           Update B by transformations from the left.
C
            B( M, M ) = -B( M, M )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C
               CALL DCOPY( N, Q( 1, IR ), 1, DWORK( IWRK4 ), 1 )
               CALL DSCAL( N, Q11, Q( 1, IR ), 1 )
               CALL DAXPY( N, Q21, Q( 1, IR+M ), 1, Q( 1, IR ), 1 )
               CALL DSCAL( N, Q22, Q( 1, IR+M ), 1 )
               CALL DAXPY( N, Q12, DWORK( IWRK4 ), 1, Q( 1, IR+M ), 1 )
            END IF
C
         END IF
C
         MM = MM + 1
         DO 60 J = R - 1, MM, -1
            IB1  = IWORK( J )
            IB2  = IWORK( J+1 )
            IB3  = IWORK( J+2 )
            DIM1 = IB2  - IB1
            DIM2 = IB3  - IB2
            SDIM = DIM1 + DIM2
C
C           Copy the relevant part of A(ib1:ib3-1,ib1:ib3-1) and
C           B(ib1:ib3-1,ib1:ib3-1) to DWORK as inputs for MB03DD.
C           Also, set the additional zero elements.
C
            CALL DLACPY( 'Upper', SDIM, SDIM, A( IB1, IB1 ), LDA,
     $                   DWORK( IA ), SDIM )
            CALL DLASET( 'Lower', SDIM-1, SDIM-1, ZERO, ZERO,
     $                   DWORK( IA+1 ), SDIM )
            CALL DLACPY( 'Upper', SDIM, SDIM, B( IB1, IB1 ), LDB,
     $                   DWORK( IB ), SDIM )
            CALL DCOPY(  SDIM-1, B( IB1+1, IB1 ), LDB+1, DWORK( IB+1 ),
     $                   SDIM+1 )
            CALL DLASET( 'Lower', SDIM-2, SDIM-2, ZERO, ZERO,
     $                   DWORK( IB+2 ), SDIM )
C
C           Perform eigenvalue/matrix block exchange.
C
            CALL MB03DD( 'Triangular', DIM1, DIM2, PREC, DWORK( IB ),
     $                   SDIM, DWORK( IA ), SDIM, DWORK( IQ1 ), SDIM,
     $                   DWORK( IQ2 ), SDIM, DWORK( IWRK1 ),
     $                   LDWORK-IWRK1+1, INFO )
            IF( INFO.GT.0 ) THEN
               INFO = 1
               RETURN
            END IF
C
C           Copy the transformed diagonal blocks, if sdim > 2.
C
            NROWS = IB1 - 1
            NCOLS = M - IB3 + 1
            ICS   = IB3
            IF( SDIM.GT.2 ) THEN
               CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IA ), SDIM,
     $                      A( IB1, IB1 ), LDA )
               CALL DLACPY( 'Upper', SDIM, SDIM, DWORK( IB ), SDIM,
     $                      B( IB1, IB1 ), LDB )
               CALL DCOPY(  SDIM-1, DWORK( IB+1 ), SDIM+1,
     $                      B( IB1+1, IB1 ), LDB+1 )
               NROW = NROWS
               NCOL = NCOLS
               IC   = ICS
               LDW  = MAX( 1, NROW )
            ELSE
               TMP = A( IB1+1, IB1 )
               A( IB1+1, IB1 ) = ZERO
               NROW = IB3 - 1
               NCOL = M - IB1 + 1
               IC   = IB1
               LDW  = NROW
            END IF
C
C           Update A.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                   SDIM, ONE, A( 1, IB1 ), LDA, DWORK( IQ1 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                   A( 1, IB1 ), LDA )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                   SDIM, ONE, DWORK( IQ2 ), SDIM, A( IB1, IC ),
     $                   LDA, ZERO, DWORK( IWRK2 ), SDIM )
            CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                   A( IB1, IC ), LDA )
            IF( SDIM.EQ.2 )
     $         A( IB1+1, IB1 ) = TMP
C
C           Update D.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                   SDIM, ONE, D( 1, IB1 ), LDD, DWORK( IQ2 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                   D( 1, IB1 ), LDD )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                   SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                   D( IB1, ICS ), LDD, ZERO, DWORK( IWRK2 ),
     $                   SDIM )
            CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                   D( IB1, ICS ), LDD )
            CALL MB01LD( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                   D( IB1, IB1 ), LDD, DWORK( IQ2 ), SDIM,
     $                   D( IB1, IB1 ), LDD, DWORK( IWRK2 ),
     $                   LDWORK-IWRK2+1, INFO )
C
C           Update B.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROW, SDIM,
     $                   SDIM, ONE, B( 1, IB1 ), LDB, DWORK( IQ1 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROW, SDIM, DWORK( IWRK2 ), LDW,
     $                   B( 1, IB1 ), LDB )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOL,
     $                   SDIM, ONE, DWORK( IQ2 ), SDIM, B( IB1, IC ),
     $                   LDB, ZERO, DWORK( IWRK2 ), SDIM )
            CALL DLACPY( 'Full', SDIM, NCOL, DWORK( IWRK2 ), SDIM,
     $                   B( IB1, IC ), LDB )
C
C           Update F.
C
            CALL DGEMM(  'No Transpose', 'No Transpose', NROWS, SDIM,
     $                   SDIM, ONE, F( 1, IB1 ), LDF, DWORK( IQ2 ),
     $                   SDIM, ZERO, DWORK( IWRK2 ), LDW )
            CALL DLACPY( 'Full', NROWS, SDIM, DWORK( IWRK2 ), LDW,
     $                   F( 1, IB1 ), LDF )
            CALL DGEMM(  'Transpose', 'No Transpose', SDIM, NCOLS,
     $                   SDIM, ONE, DWORK( IQ2 ), SDIM,
     $                   F( IB1, ICS ), LDF, ZERO, DWORK( IWRK2 ),
     $                   SDIM )
            CALL DLACPY( 'Full', SDIM, NCOLS, DWORK( IWRK2 ), SDIM,
     $                   F( IB1, ICS ), LDF )
            CALL MB01RU( 'Upper', 'Transpose', SDIM, SDIM, ZERO, ONE,
     $                   F( IB1, IB1 ), LDF, DWORK( IQ2 ), SDIM,
     $                   F( IB1, IB1 ), LDF, DWORK( IWRK2 ),
     $                   LDWORK-IWRK2+1, INFO )
            CALL DSCAL( SDIM, HALF, F( IB1, IB1 ), LDF+1 )
C
            IF( LCMPQ ) THEN
C
C              Update Q.
C              Workspace: IWRK2 + 4*N - 1.
C
               CALL DGEMM(  'No Transpose', 'No Transpose', N, SDIM,
     $                      SDIM, ONE, Q( 1, IB1 ), LDQ, DWORK( IQ1 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), N )
               CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N,
     $                      Q( 1, IB1 ), LDQ )
               CALL DGEMM(  'No Transpose', 'No Transpose', N, SDIM,
     $                      SDIM, ONE, Q( 1, M+IB1 ), LDQ, DWORK( IQ2 ),
     $                      SDIM, ZERO, DWORK( IWRK2 ), N )
               CALL DLACPY( 'Full', N, SDIM, DWORK( IWRK2 ), N,
     $                      Q( 1, M+IB1 ), LDQ )
            END IF
C
C           Update index list IWORK(1:M) if a 1-by-1 and 2-by-2 block
C           have been swapped.
C
            HLP = DIM2 - DIM1
            IF( HLP.EQ.1 ) THEN
C
C              First block was 2-by-2.
C
               IWORK( J+1 ) = IB1 + 1
C
            ELSE IF( HLP.EQ.-1 ) THEN
C
C              Second block was 2-by-2.
C
               IWORK( J+1 ) = IB1 + 2
            END IF
   60    CONTINUE
   70 CONTINUE
C
      IF( M.GT.1 ) THEN
C
C        Restore the lower triangle of the submatrix D(M-1:M,M-1:M) and
C        the elements A(M,M-1) and F(M,M-1).
C
         D( M-1, M-1 ) = D1
         D(   M, M-1 ) = D2
         D(   M,   M ) = D3
         A(   M, M-1 ) = A2
         F(   M, M-1 ) = F2
      END IF
C
      IF( MM.GT.0 ) THEN
         NEIG = IWORK( MM+1 ) - 1
      ELSE
         NEIG = 0
      END IF
C
      RETURN
C *** Last line of MB03JD ***
      END


      DOUBLE PRECISION FUNCTION PHO_DOR94FV(X,N,Ak,Bk,A,B,C,D)
C
C...FUNCTIONAL FORMS OF THE PARAMETRIZATIONS :
C
      IMPLICIT NONE
      DOUBLE PRECISION A , Ak , B , Bk , C , D , dx , N , X
      SAVE

      dx = SQRT(X)
      PHO_DOR94FV = N*X**Ak*(1.D0+A*X**Bk+X*(B+C*dx))*(1.D0-X)**D

      END FUNCTION


      subroutine qlI4DNS41(Y,musq,Ival0)
      implicit none
      include 'qlconstants.f'
c-----Implementation of Eq.~(41) of
c----- %\cite{Denner:1991qq}
c----- %\cite{Denner:1991qq}
c----- \bibitem{Denner:1991qq}
c----- A.~Denner, U.~Nierste and R.~Scharf,
c----- %``A Compact expression for the scalar one loop four point function,''
c----- Nucl.\ Phys.\  B {\bf 367}, 637 (1991).
c----- %%CITATION = NUPHA,B367,637;%%
      double complex Ival0,discr,wlog(2),cln,z(2),k(4,4),lnsum,
     . qlLi2omprod,a,b,c,d,bsq,fourac
      double precision musq,Y(4,4),iep
      integer i,j

      do i=1,4
      do j=1,4
      k(i,j)=dcmplx(2d0*Y(i,j)/musq)
      enddo
      enddo

      a=k(2,4)*k(3,4)
      b=k(1,3)*k(2,4)+k(1,2)*k(3,4)-k(1,4)*k(2,3)
      c=k(1,2)*k(1,3)
      d=k(2,3)
      bsq=b**2
      fourac=4d0*a*c
      discr=sqrt(bsq-fourac)

      if (abs(discr) .lt. 1d-10*max(dble(bsq),dble(fourac))) then
      z(1)=0.5d0*b/a
      wlog(1)=dcmplx(dreal(cln(z(1),+1d0)))
      Ival0=
     . +k(3,4)*(cln(k(3,4),-1d0)+wlog(1)-cln(k(1,3),-1d0))
     . /(k(3,4)*z(1)-k(1,3))
     . +k(2,4)*(cln(k(2,4),-1d0)+wlog(1)-cln(k(1,2),-1d0))
     . /(k(2,4)*z(1)-k(1,2))
     . -(wlog(1)
     . +cln(k(2,3),-1d0)+cln(k(1,4),-1d0)
     . -cln(k(1,3),-1d0)-cln(k(1,2),-1d0))/z(1)

      Ival0=Ival0/(musq**2*a)
      return
      else
C----wlogi=log(-xi),zi=-xi
      z(1)=0.5d0*(b-discr)/a
      z(2)=0.5d0*(b+discr)/a
      iep=sign(1d0,dreal(d))
C-----z(1) comes with + i*ep*d
C-----z(2) comes with - i*ep*d
      wlog(1)=cln(z(1),+iep)
      wlog(2)=cln(z(2),-iep)
      lnsum=+cln(k(1,2),-1d0)+cln(k(1,3),-1d0)
     .      -cln(k(1,4),-1d0)-cln(k(2,3),-1d0)
      Ival0=czip
      do j=1,2
      iep=-dfloat(2*j-3)*iep
      Ival0=Ival0+dfloat(2*j-3)*(
     . -0.5d0*wlog(j)**2+wlog(j)*lnsum
     . -qlLi2omprod(dble(k(3,4)),dble(k(1,3)),z(j),iep)
     . -qlLi2omprod(dble(k(2,4)),dble(k(1,2)),z(j),iep))

      enddo

      Ival0=Ival0/(musq**2*discr)
      endif
      return
      end


module crypto
use types, only : i1, i4, i8
implicit none
private
public sbox

contains

subroutine key_mix(input, subkey, output)
    !
    ! Mix 128 bits of input_data (input as four 32 bit words) with a 128 bit sub-key
    ! (also input as four 32 bit words)
    !
    integer(kind=i8), dimension(4), intent(in)  :: input
    integer(kind=i8), dimension(4), intent(in)  :: subkey
    integer(kind=i8), dimension(4), intent(out) :: output

    integer(kind=i4)                            :: word

    do word = 1, 4
        output(word) = ieor(input(word), subkey(word))
    end do

end subroutine

subroutine sbox(n, input, output)
    !
    ! Serpent uses eight S-Boxes (n=0, ... 8). Each S-Box takes a four bit input and
    ! outputs a four bit number. Each round of serpent applies an S-Box to 128 bits
    ! which are input and output as four 32 bit words.
    !
    ! This code is not optimised.
    !
    integer(kind=i4), intent(in)                :: n
    integer(kind=i8), dimension(4), intent(in)  :: input
    integer(kind=i8), dimension(4), intent(out) :: output

    integer(kind=i1), dimension(0:15, 0:7)      :: svals
    integer(kind=i4)                            :: word, bit

    svals = reshape((/   3,  8, 15,  1, 10,  6,  5, 11, 14, 13,  4,  2,  7,  0,  9, 12, &
                        15, 12,  2,  7,  9,  0,  5, 10,  1, 11, 14,  8,  6, 13,  3, 4,  &
                         8,  6,  7,  9,  3, 12, 10, 15, 13,  1, 14,  4,  0, 11,  5, 2,  &
                         0, 15, 11,  8, 12,  9,  6,  3, 13,  1,  2,  4, 10,  7,  5, 14, &
                         1, 15,  8,  3, 12,  0, 11,  6,  2,  5,  4, 10,  9, 14,  7, 13, &
                        15,  5,  2, 11,  4, 10,  9, 12,  0,  3, 14,  8, 13,  6,  7, 1,  &
                         7,  2, 12,  5,  8,  4,  6, 11, 14,  9,  1, 15, 13,  3, 10, 0,  &
                         1, 13, 15,  0, 14,  8,  2, 11,  7,  4, 12, 10,  9,  3,  5, 6 /), &
                        shape(svals))

    output = 0_i8

    do word = 1, 4
        do bit = 0, 28, 4
            output(word) = ior(output(word), ishft(svals(ibits(input(word), bit, 4), n), bit))
        end do
    end do

end subroutine

subroutine linear_transfor(input)
    !
    ! Linearly transform the output from the S-Boxes.
    !
    integer(kind=i8), dimension(0:3), intent(inout)   :: input

    input(0) = ishftc(input(0), 13, 32)
    input(2) = ishftc(input(2), 3, 32)
    input(1) = ieor(ieor(input(1), input(0)), input(2))
    input(3) = ieor(ieor(input(3), input(2)), ishft(input(0), 3))
    input(1) = ishftc(input(1), 1, 32)
    input(3) = ishftc(input(3), 7, 32)
    input(0) = ieor(ieor(input(0), input(1)), input(3))
    input(2) = ieor(ieor(input(2), input(3)), ishft(input(1), 7))
    input(0) = ishftc(input(0), 5, 32)
    input(2) = ishftc(input(2), 22, 32)

end subroutine

subroutine expand_key(user_key, round_key)
    integer(kind=i8), dimension(0:7), intent(in)    :: user_key     ! 256 bit user key.
    integer(kind=i8), dimension(0:131), intent(out) :: round_key    ! Round keys.

    integer(kind=i8), dimension(-8:131)             :: inter_key    ! Intermediate key.
    integer(kind=i8)                                :: i

    inter_key(-8:-1) = user_key(0:7)

    do i = 0, 131
        inter_key(i) = ieor(inter_key(i-8), inter_key(i-5))
        inter_key(i) = ieor(inter_key(i), inter_key(i-3))
        inter_key(i) = ieor(inter_key(i), inter_key(i-1))
        inter_key(i) = ieor(inter_key(i), z'9E3779B9')
        inter_key(i) = ieor(inter_key(i), i)
    end do

    do i = 0, 128, 4
        call sbox(n, inter_key(i:i+3), round_key(i:i+3))
    end do

end subroutine

subroutine pad_key(key)
    !
    ! Pad the key out to 256 bits, if necessary.
    !
end subroutine

end module


program problem86
  implicit none
  integer, parameter :: goal=1000000
  integer            :: m,count

  count=0
  m=0
  do while (count<goal .and. m<2000)
     m=m+1
     count=count+score(m)
  end do

  print *, m, count

contains

  pure function score(m)
    implicit none
    integer, intent(in) :: m
    integer             :: a,b,c,score

    score=0
    ! do a=m,m
    a=m
    do b=1,a
       do c=1,b
          if (predicate(a,b,c)) score=score+1
       end do
    end do
    ! end do

  end function score

  pure function predicate(a,b,c)
    implicit none
    integer, intent(in) :: a,b,c
    real*16             :: path1,path2,path3,best_path
    logical             :: predicate

    path1=sqrt(dble((a+b)**2 + c**2))
    path2=sqrt(dble((a+c)**2 + b**2))
    path3=sqrt(dble((b+c)**2 + a**2))
    best_path=min(path1,min(path2,path3))

    predicate=(mod(best_path,1.0)==0.0)

  end function predicate

end program problem86


MODULE ZTOOLS_MOD
implicit none

real, allocatable, dimension(:) :: dx
real                            :: dy

contains

!################################################################

subroutine to_mass_grid( xi, xo )

real, intent(in),  dimension(:,:) :: xi
real, intent(out), dimension(:,:) :: xo

integer :: ixi, jxi, ixo, jxo

ixi = SIZE( xi, 1 )
jxi = SIZE( xi, 2 )
ixo = SIZE( xo, 1 )
jxo = SIZE( xo, 2 )

if( ixi == (ixo+1) ) then
  xo(:,:) =  0.5*( xi(1:ixi-1,:) + xi(2:ixi,:) )
else if( jxi == (jxo+1) ) then
  xo(:,:) =  0.5*( xi(:,1:jxi-1) + xi(:,2:jxi) )
else
  print *, ' *** ERROR IN TRANSFORMATION TO MASS GRID'
  STOP
endif

end subroutine to_mass_grid

!################################################################

subroutine set_dx_dy( rlat, rlon )

real, intent(in),  dimension(:) :: rlat, rlon

 real, parameter :: radius = 6371.0e3
 real            :: PI, RADIAN
 real            :: dlat, dlon
 integer         :: j
 integer         :: jmx

 jmx = size(rlat)

ALLOCATE( dx(jmx) )

PI     = 4.0*ATAN(1.0)
RADIAN = 180.0/PI

dlat = ABS( rlat(2) - rlat(1) ) / RADIAN
dlon =    ( rlon(2) - rlon(1) ) / RADIAN

do j = 1,jmx
  dx(j) = radius * cos( rlat(j) / RADIAN ) * dlon
end do
  dy    = radius * dlat

end subroutine set_dx_dy

!################################################################

subroutine comp_vort( uu, vv, vort )

real, intent(in),  dimension(:,:) :: uu, vv
real, intent(out), dimension(:,:) :: vort
integer                           :: i,   j
integer                           :: imx, jmx

imx = SIZE( uu, 1 )
jmx = SIZE( uu, 2 )

vort(:,:) = 0.0

do j = 2,jmx-1
do i = 2,imx-1
!vort(i,j) = ( vv(i+1,j) - vv(i-1,j) ) / ( 2.0*dx(j) ) &
!          - ( uu(i,j+1) - uu(i,j-1) ) / ( 2.0*dy    )
vort(i,j) = ( vv(i+1,j) - vv(i-1,j) ) / ( 2.0*dx(j) ) &
          - ( uu(i,j+1) - uu(i,j-1) ) / ( 2.0*dy )
end do
end do

end subroutine comp_vort

!################################################################

subroutine comp_wind( uu, vv, wind )

real, intent(in),  dimension(:,:) :: uu, vv
real, intent(out), dimension(:,:) :: wind

wind(:,:) = uu(:,:)*uu(:,:) + vv(:,:)*vv(:,:)
wind(:,:) = SQRT( wind(:,:) )

end subroutine comp_wind

!################################################################

subroutine comp_psl( psfc, tsfc, zsfc, psl )

 real, parameter :: rgas   = 0.2870e3
 real, parameter :: grav   = 9.806
 real, parameter :: grexp  = grav / rgas

real, intent(in),  dimension(:,:) :: psfc, tsfc, zsfc
real, intent(out), dimension(:,:) :: psl

 psl(:,:) = psfc(:,:) * exp( grexp * zsfc(:,:) / tsfc(:,:) )

end subroutine comp_psl

!################################################################
end MODULE ZTOOLS_MOD