!********************************************************************************
!   FORWERR_MULTI: Compare the forward error of FPML, FPML-Quad, and FPML-Comp
!   Author: Thomas R. Cameron, Penn State Erie The Behrend College
!   Last Modified: 31 July 2020
!********************************************************************************
program forwerr_multi
    use fpml, only : main
	use fpml_comp, only: main_comp
	use fpml_quad, only: qp, main_quad
    use mproutines
	implicit none
    ! testing variables
    integer                                     :: deg, j, poly_num
    complex(kind=dp), dimension(:), allocatable :: exact_roots
    ! FPML variables
    integer, parameter                          :: itmax = 30
    integer, allocatable                        :: conv(:)
    real(kind=dp), allocatable                  :: berr(:), cond(:)
	real(kind=qp), allocatable					:: berr_quad(:), cond_quad(:)
    complex(kind=dp), allocatable               :: p(:), roots(:)
	complex(kind=qp), allocatable				:: p_quad(:), roots_quad(:)

    ! Testing: polynomials with multiple and near multiple roots
    open(unit=1,file="data_files/forwerr_multi.dat")
    write(1,'(A)') 'Poly No., FPML, FPML-Quad, FPML-Comp'
    do poly_num=1,7
        write(1, '(I10,A)', advance='no') poly_num, ', '
        ! make polynomial
        call make_poly(poly_num, deg, exact_roots, p)
		! allocate
        allocate(roots(deg), berr(deg), cond(deg), conv(deg))
		allocate(p_quad(deg+1), roots_quad(deg), berr_quad(deg), cond_quad(deg))
        ! FPML
        call main(p, deg, roots, berr, cond, conv, itmax)
        write(1, '(ES15.2, A)', advance='no') max_rel_err(roots,exact_roots,deg), ', '
        ! FPML-Quad
		p_quad = p
        call main_quad(p_quad, deg, roots_quad, berr_quad, cond_quad, conv, itmax)
		roots = roots_quad
        write(1, '(ES15.2, A)', advance='no') max_rel_err(roots,exact_roots,deg), ', '
        ! FPML-Comp
        call main_comp(p, deg, roots, itmax)
        write(1, '(ES15.2, A)') max_rel_err(roots,exact_roots,deg)
        ! deallocate
        deallocate(p, exact_roots, roots, berr, cond, conv)
		deallocate(p_quad, roots_quad, berr_quad, cond_quad)
    end do
    ! close file
    close(1)

contains

		!************************************************
	    !                       make_poly               *
	    !************************************************
	    ! Make special polynomial corresponding to
	    ! poly_num and deg > 1.
	    !************************************************
	    subroutine make_poly(poly_num, deg, exact_roots, p)
	        implicit none
	        ! argument variables
	        integer, intent(in)                         :: poly_num
	        integer, intent(out)                        :: deg
	        complex(kind=dp), allocatable, intent(out)  :: exact_roots(:), p(:)
	        ! local variables
	        integer                                     :: j

	        select case (poly_num)
	            ! case 1
	            case(1)
	            ! Mandelbrot Polynomial, theoretical limiting accuracy 2.53E-5
	            deg = 63
	            allocate(exact_roots(deg), p(deg+1))
	            ! roots
	            exact_roots(1) = cmplx(-0.199909568232701847321062999922E1_dp,0E0_dp,kind=dp)
	            exact_roots(2) = cmplx(-0.199181417254912221573256094986E1_dp,0E0_dp,kind=dp)
	            exact_roots(3) = cmplx(-0.197717958700625738734608852066E1_dp,0E0_dp,kind=dp)
	            exact_roots(4) = cmplx(-0.195370589428439624542762219901E1_dp,0E0_dp,kind=dp)
	            exact_roots(5) = cmplx(-0.192714770936395026246006818895E1_dp,0E0_dp,kind=dp)
	            exact_roots(6) = cmplx(-0.188480357158668179232947809292E1_dp,0E0_dp,kind=dp)
	            exact_roots(7) = cmplx(-0.183231520275122919208489752604E1_dp,0E0_dp,kind=dp)
	            exact_roots(8) = cmplx(-0.176926167027683114607548022864E1_dp,-0.5691950039560031530490018730E-1_dp,kind=dp)
	            exact_roots(9) = cmplx(-0.176926167027683114607548022864E1_dp,0.5691950039560031530490018730E-1_dp,kind=dp)
	            exact_roots(10) = cmplx(-0.167406609147478797156529602917E1_dp,0E0_dp,kind=dp)
	            exact_roots(11) = cmplx(-0.157488913975230096981996555250E1_dp,0E0_dp,kind=dp)
	            exact_roots(12) = cmplx(-0.140844648574007265491757700881E1_dp,-0.13617199730465991568470779361E0_dp,kind=dp)
	            exact_roots(13) = cmplx(-0.140844648574007265491757700881E1_dp,0.13617199730465991568470779361E0_dp,kind=dp)
	            exact_roots(14) = cmplx(-0.1292558061033522087164184706361E1_dp,-0.438198816086631837129737124327E0_dp,kind=dp)
	            exact_roots(15) = cmplx(-0.1292558061033522087164184706361E1_dp,0.438198816086631837129737124327E0_dp,kind=dp)
	            exact_roots(16) = cmplx(-0.1262287281438472543010111941208E1_dp,-0.408104324112690383290160657426E0_dp,kind=dp)
	            exact_roots(17) = cmplx(-0.1262287281438472543010111941208E1_dp,0.408104324112690383290160657426E0_dp,kind=dp)
	            exact_roots(18) = cmplx(-0.1252735884012037946295811002564E1_dp,-0.342470647889750893861875786871E0_dp,kind=dp)
	            exact_roots(19) = cmplx(-0.1252735884012037946295811002564E1_dp,0.342470647889750893861875786871E0_dp,kind=dp)
	            exact_roots(20) = cmplx(-0.1028193852454817599302497455967E1_dp,-0.361376517118561592479460832998E0_dp,kind=dp)
	            exact_roots(21) = cmplx(-0.1028193852454817599302497455967E1_dp,0.361376517118561592479460832998E0_dp,kind=dp)
	            exact_roots(22) = cmplx(-0.623532485956252757990016587001E0_dp,-0.681064414225239608090835812687E0_dp,kind=dp)
	            exact_roots(23) = cmplx(-0.623532485956252757990016587001E0_dp,0.681064414225239608090835812687E0_dp,kind=dp)
	            exact_roots(24) = cmplx(-0.622436295041293587960163506947E0_dp,-0.424878436475629184311574438805E0_dp,kind=dp)
	            exact_roots(25) = cmplx(-0.622436295041293587960163506947E0_dp,0.424878436475629184311574438805E0_dp,kind=dp)
	            exact_roots(26) = cmplx(-0.530827804859942728921477297120E0_dp,-0.668288725559205771444092465565E0_dp,kind=dp)
	            exact_roots(27) = cmplx(-0.530827804859942728921477297120E0_dp,0.668288725559205771444092465565E0_dp,kind=dp)
	            exact_roots(28) = cmplx(-0.272102461488938894219383324518E0_dp,-0.842364690294128145503155708243E0_dp,kind=dp)
	            exact_roots(29) = cmplx(-0.272102461488938894219383324518E0_dp,0.842364690294128145503155708243E0_dp,kind=dp)
	            exact_roots(30) = cmplx(-0.224915951286740054685326255204E0_dp,-0.1116260157454991835001268254245E1_dp,kind=dp)
	            exact_roots(31) = cmplx(-0.224915951286740054685326255204E0_dp,0.1116260157454991835001268254245E1_dp,kind=dp)
	            exact_roots(32) = cmplx(-0.207283835455666412824133850187E0_dp,-0.1117480772494962911373775673122E1_dp,kind=dp)
	            exact_roots(33) = cmplx(-0.207283835455666412824133850187E0_dp,0.1117480772494962911373775673122E1_dp,kind=dp)
	            exact_roots(34) = cmplx(-0.174578221135716969451566432662E0_dp,-0.1071427671454031189229646310220E1_dp,kind=dp)
	            exact_roots(35) = cmplx(-0.174578221135716969451566432662E0_dp,0.1071427671454031189229646310220E1_dp,kind=dp)
	            exact_roots(36) = cmplx(-0.157516053475965356164335109645E0_dp,-0.1109006514113607177971751986155E1_dp,kind=dp)
	            exact_roots(37) = cmplx(-0.157516053475965356164335109645E0_dp,0.1109006514113607177971751986155E1_dp,kind=dp)
	            exact_roots(38) = cmplx(-0.127499973546363000199539565346E0_dp,-0.987460909489456792207407680793E0_dp,kind=dp)
	            exact_roots(39) = cmplx(-0.127499973546363000199539565346E0_dp,0.987460909489456792207407680793E0_dp,kind=dp)
	            exact_roots(40) = cmplx(-0.14233481920354066767761845314E-1_dp,-0.1032914775213644109395013402655E1_dp,kind=dp)
	            exact_roots(41) = cmplx(-0.14233481920354066767761845314E-1_dp,0.1032914775213644109395013402655E1_dp,kind=dp)
	            exact_roots(42) = cmplx(-0.6983568496261391817966491075E-2_dp,-0.1003603862288289548530704966951E1_dp,kind=dp)
	            exact_roots(43) = cmplx(-0.6983568496261391817966491075E-2_dp,0.1003603862288289548530704966951E1_dp,kind=dp)
	            exact_roots(44) = cmplx(0.14895466603687646529815779209E-1_dp,-0.848148761908416527719331111783E0_dp,kind=dp)
	            exact_roots(45) = cmplx(0.14895466603687646529815779209E-1_dp,0.848148761908416527719331111783E0_dp,kind=dp)
	            exact_roots(46) = cmplx(0.121192786105906486314704443411E0_dp,-0.610611692210754211675387244150E0_dp,kind=dp)
	            exact_roots(47) = cmplx(0.121192786105906486314704443411E0_dp,0.610611692210754211675387244150E0_dp,kind=dp)
	            exact_roots(48) = cmplx(0.352482539722363278193253964052E0_dp,-0.698337239583330331258141954760E0_dp,kind=dp)
	            exact_roots(49) = cmplx(0.352482539722363278193253964052E0_dp,0.698337239583330331258141954760E0_dp,kind=dp)
	            exact_roots(50) = cmplx(0.376008681846767559704804317729E0_dp,-0.144749371321632864747110182013E0_dp,kind=dp)
	            exact_roots(51) = cmplx(0.376008681846767559704804317729E0_dp,0.144749371321632864747110182013E0_dp,kind=dp)
	            exact_roots(52) = cmplx(0.376893240379311323690004017969E0_dp,-0.678568693190448141957540792997E0_dp,kind=dp)
	            exact_roots(53) = cmplx(0.376893240379311323690004017969E0_dp,0.678568693190448141957540792997E0_dp,kind=dp)
	            exact_roots(54) = cmplx(0.386539176596158026508293086904E0_dp,-0.569324711303102903213792357135E0_dp,kind=dp)
	            exact_roots(55) = cmplx(0.386539176596158026508293086904E0_dp,0.569324711303102903213792357135E0_dp,kind=dp)
	            exact_roots(56) = cmplx(0.412916024722700479197334566383E0_dp,-0.614806760143385694954549720401E0_dp,kind=dp)
	            exact_roots(57) = cmplx(0.412916024722700479197334566383E0_dp,0.614806760143385694954549720401E0_dp,kind=dp)
	            exact_roots(58) = cmplx(0.432376192641994507824669648087E0_dp,-0.226759904435348618697876559972E0_dp,kind=dp)
	            exact_roots(59) = cmplx(0.432376192641994507824669648087E0_dp,0.226759904435348618697876559972E0_dp,kind=dp)
	            exact_roots(60) = cmplx(0.452774498724915493508803077733E0_dp,-0.396170128033165002412596877271E0_dp,kind=dp)
	            exact_roots(61) = cmplx(0.452774498724915493508803077733E0_dp,0.396170128033165002412596877271E0_dp,kind=dp)
	            exact_roots(62) = cmplx(0.456823285823316651283953236253E0_dp,-0.347758700883481983632188723200E0_dp,kind=dp)
	            exact_roots(63) = cmplx(0.456823285823316651283953236253E0_dp,0.347758700883481983632188723200E0_dp,kind=dp)
	            ! polynomial
	            p(1) = cmplx(1E0_dp,0E0_dp,kind=dp)
	            p(2) = cmplx(1E0_dp,0E0_dp,kind=dp)
	            p(3) = cmplx(2E0_dp,0E0_dp,kind=dp)
	            p(4) = cmplx(5E0_dp,0E0_dp,kind=dp)
	            p(5) = cmplx(14E0_dp,0E0_dp,kind=dp)
	            p(6) = cmplx(42E0_dp,0E0_dp,kind=dp)
	            p(7) = cmplx(132E0_dp,0E0_dp,kind=dp)
	            p(8) = cmplx(365E0_dp,0E0_dp,kind=dp)
	            p(9) = cmplx(950E0_dp,0E0_dp,kind=dp)
	            p(10) = cmplx(2398E0_dp,0E0_dp,kind=dp)
	            p(11) = cmplx(5916E0_dp,0E0_dp,kind=dp)
	            p(12) = cmplx(14290E0_dp,0E0_dp,kind=dp)
	            p(13) = cmplx(33708E0_dp,0E0_dp,kind=dp)
	            p(14) = cmplx(77684E0_dp,0E0_dp,kind=dp)
	            p(15) = cmplx(175048E0_dp,0E0_dp,kind=dp)
	            p(16) = cmplx(385741E0_dp,0E0_dp,kind=dp)
	            p(17) = cmplx(831014E0_dp,0E0_dp,kind=dp)
	            p(18) = cmplx(1749654E0_dp,0E0_dp,kind=dp)
	            p(19) = cmplx(3598964E0_dp,0E0_dp,kind=dp)
	            p(20) = cmplx(7228014E0_dp,0E0_dp,kind=dp)
	            p(21) = cmplx(14162220E0_dp,0E0_dp,kind=dp)
	            p(22) = cmplx(27049196E0_dp,0E0_dp,kind=dp)
	            p(23) = cmplx(50323496E0_dp,0E0_dp,kind=dp)
	            p(24) = cmplx(91143114E0_dp,0E0_dp,kind=dp)
	            p(25) = cmplx(160617860E0_dp,0E0_dp,kind=dp)
	            p(26) = cmplx(275276716E0_dp,0E0_dp,kind=dp)
	            p(27) = cmplx(458591432E0_dp,0E0_dp,kind=dp)
	            p(28) = cmplx(742179284E0_dp,0E0_dp,kind=dp)
	            p(29) = cmplx(1166067016E0_dp,0E0_dp,kind=dp)
	            p(30) = cmplx(1777171560E0_dp,0E0_dp,kind=dp)
	            p(31) = cmplx(2625062128E0_dp,0E0_dp,kind=dp)
	            p(32) = cmplx(3754272037E0_dp,0E0_dp,kind=dp)
	            p(33) = cmplx(5193067630E0_dp,0E0_dp,kind=dp)
	            p(34) = cmplx(6939692682E0_dp,0E0_dp,kind=dp)
	            p(35) = cmplx(8948546308E0_dp,0E0_dp,kind=dp)
	            p(36) = cmplx(11120136162E0_dp,0E0_dp,kind=dp)
	            p(37) = cmplx(13299362332E0_dp,0E0_dp,kind=dp)
	            p(38) = cmplx(15286065700E0_dp,0E0_dp,kind=dp)
	            p(39) = cmplx(16859410792E0_dp,0E0_dp,kind=dp)
	            p(40) = cmplx(17813777994E0_dp,0E0_dp,kind=dp)
	            p(41) = cmplx(17999433372E0_dp,0E0_dp,kind=dp)
	            p(42) = cmplx(17357937708E0_dp,0E0_dp,kind=dp)
	            p(43) = cmplx(15941684776E0_dp,0E0_dp,kind=dp)
	            p(44) = cmplx(13910043524E0_dp,0E0_dp,kind=dp)
	            p(45) = cmplx(11500901864E0_dp,0E0_dp,kind=dp)
	            p(46) = cmplx(8984070856E0_dp,0E0_dp,kind=dp)
	            p(47) = cmplx(6609143792E0_dp,0E0_dp,kind=dp)
	            p(48) = cmplx(4562339774E0_dp,0E0_dp,kind=dp)
	            p(49) = cmplx(2943492972E0_dp,0E0_dp,kind=dp)
	            p(50) = cmplx(1766948340E0_dp,0E0_dp,kind=dp)
	            p(51) = cmplx(981900168E0_dp,0E0_dp,kind=dp)
	            p(52) = cmplx(502196500E0_dp,0E0_dp,kind=dp)
	            p(53) = cmplx(234813592E0_dp,0E0_dp,kind=dp)
	            p(54) = cmplx(99582920E0_dp,0E0_dp,kind=dp)
	            p(55) = cmplx(37945904E0_dp,0E0_dp,kind=dp)
	            p(56) = cmplx(12843980E0_dp,0E0_dp,kind=dp)
	            p(57) = cmplx(3807704E0_dp,0E0_dp,kind=dp)
	            p(58) = cmplx(971272E0_dp,0E0_dp,kind=dp)
	            p(59) = cmplx(208336E0_dp,0E0_dp,kind=dp)
	            p(60) = cmplx(36440E0_dp,0E0_dp,kind=dp)
	            p(61) = cmplx(4976E0_dp,0E0_dp,kind=dp)
	            p(62) = cmplx(496E0_dp,0E0_dp,kind=dp)
	            p(63) = cmplx(32E0_dp,0E0_dp,kind=dp)
	            p(64) = cmplx(1E0_dp,0E0_dp,kind=dp)
	            ! case 2
	            case(2)
	            ! Kameny Polynomial c=10, theoretical limiting accuracy 1.11E-16
	            deg = 9
	            allocate(exact_roots(deg), p(deg+1))
	            ! roots
	            exact_roots(1) = cmplx(-0.250708394126194522431084083966E1_dp,0E0_dp,kind=dp)
	            exact_roots(2) = cmplx(-0.77475933255040504312683246509E0_dp,-0.239347474286129783412456829950E1_dp,kind=dp)
	            exact_roots(3) = cmplx(-0.77475933255040504312683246509E0_dp,0.239347474286129783412456829950E1_dp,kind=dp)
	            exact_roots(4) = cmplx(-0.173313478195944654943157024747E0_dp,0E0_dp,kind=dp)
	            exact_roots(5) = cmplx(-0.173097223325097844852013748504E0_dp,0E0_dp,kind=dp)
	            exact_roots(6) = cmplx(0.173204810760521109164135307321E0_dp,-0.108125591879847889809932772E-3_dp,kind=dp)
	            exact_roots(7) = cmplx(0.173204810760521109164135307321E0_dp,0.108125591879847889809932772E-3_dp,kind=dp)
	            exact_roots(8) = cmplx(0.202830184318137779601570296422E1_dp,-0.147928157900441456648083759833E1_dp,kind=dp)
	            exact_roots(9) = cmplx(0.202830184318137779601570296422E1_dp,0.147928157900441456648083759833E1_dp,kind=dp)
	            ! polynomial
	            p(1) = cmplx(9E0_dp,0E0_dp,kind=dp)
	            p(2) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(3) = cmplx(-600E0_dp,0E0_dp,kind=dp)
	            p(4) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(5) = cmplx(10000E0_dp,0E0_dp,kind=dp)
	            p(6) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(7) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(8) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(9) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(10) = cmplx(100E0_dp,0E0_dp,kind=dp)
	            ! case 3
	            case(3)
	            ! Kameny Polynomial c=10^3, theoretical limiting accuracy 1.11E-16
	            deg = 9
	            allocate(exact_roots(deg), p(deg+1))
	            ! roots
	            exact_roots(1) = cmplx(-0.158489318488962525196907753240E2_dp,0E0_dp,kind=dp)
	            exact_roots(2) = cmplx(-0.48975892839992994551324676957E1_dp,-0.150732300552288401309352587876E2_dp,kind=dp)
	            exact_roots(3) = cmplx(-0.48975892839992994551324676957E1_dp,0.150732300552288401309352587876E2_dp,kind=dp)
	            exact_roots(4) = cmplx(-0.173205080767700380719051028416E-2_dp,0E0_dp,kind=dp)
	            exact_roots(5) = cmplx(-0.173205080746075077991838239885E-2_dp,0E0_dp,kind=dp)
	            exact_roots(6) = cmplx(0.173205080756887729350044634151E-2_dp,-0.10812651363606394264E-12_dp,kind=dp)
	            exact_roots(7) = cmplx(0.173205080756887729350044634151E-2_dp,0.10812651363606394264E-12_dp,kind=dp)
	            exact_roots(8) = cmplx(0.128220552084474257149779093577E2_dp,-0.93157684943778791903260859371E1_dp,kind=dp)
	            exact_roots(9) = cmplx(0.128220552084474257149779093577E2_dp,0.93157684943778791903260859371E1_dp,kind=dp)
	            ! polynomial
	            p(1) = cmplx(9E0_dp,0E0_dp,kind=dp)
	            p(2) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(3) = cmplx(-6000000E0_dp,0E0_dp,kind=dp)
	            p(4) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(5) = cmplx(1000000000000E0_dp,0E0_dp,kind=dp)
	            p(6) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(7) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(8) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(9) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(10) = cmplx(1000000E0_dp,0E0_dp,kind=dp)
	            ! case 4
	            case(4)
	            ! Kameny Polynomial c=10^6, theoretical limiting accuracy 8.09E-9
	            deg = 9
	            allocate(exact_roots(deg), p(deg+1))
	            ! roots
	            exact_roots(1) = cmplx(-0.251188643150958006331217160138E3_dp,0E0_dp,kind=dp)
	            exact_roots(2) = cmplx(-0.77621559527630266049907587459E2_dp,-0.238894595888056617951698213041E3_dp,kind=dp)
	            exact_roots(3) = cmplx(-0.77621559527630266049907587459E2_dp,0.238894595888056617951698213041E3_dp,kind=dp)
	            exact_roots(4) = cmplx(-0.173205080756887729353086560209E-5_dp,0E0_dp,kind=dp)
	            exact_roots(5) = cmplx(-0.173205080756887729352402708092E-5_dp,0E0_dp,kind=dp)
	            exact_roots(6) = cmplx(0.173205080756887729352744634151E-5_dp,-0.341926059E-26_dp,kind=dp)
	            exact_roots(7) = cmplx(0.173205080756887729352744634151E-5_dp,0.341926059E-26_dp,kind=dp)
	            exact_roots(8) = cmplx(0.203215881103109269215516167528E3_dp,-0.147644979987489859882850769633E3_dp,kind=dp)
	            exact_roots(9) = cmplx(0.203215881103109269215516167528E3_dp,0.147644979987489859882850769633E3_dp,kind=dp)
	            ! polynomial
	            p(1) = cmplx(9E0_dp,0E0_dp,kind=dp)
	            p(2) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(3) = cmplx(-6000000000000E0_dp,0E0_dp,kind=dp)
	            p(4) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(5) = cmplx(1000000000000000000000000E0_dp,0E0_dp,kind=dp)
	            p(6) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(7) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(8) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(9) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(10) = cmplx(1000000000000E0_dp,0E0_dp,kind=dp)
	            ! case 5
	            case(5)
	            ! Multiplicity I
	            deg = 55
	            allocate(exact_roots(deg), p(deg+1))
	            ! roots
	            exact_roots(1) = cmplx(-0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(2) = cmplx(-0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(3) = cmplx(-0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(4) = cmplx(-0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(5) = cmplx(-0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(6) = cmplx(-0.951677511788434760780566076462E0_dp,-0.156577036126765257092467586019E0_dp,kind=dp)
	            exact_roots(7) = cmplx(-0.951677511788434760780566076462E0_dp,0.156577036126765257092467586019E0_dp,kind=dp)
	            exact_roots(8) = cmplx(-0.947111794804360643443628545664E0_dp,-0.45987543603302557306898551016E-1_dp,kind=dp)
	            exact_roots(9) = cmplx(-0.947111794804360643443628545664E0_dp,0.45987543603302557306898551016E-1_dp,kind=dp)
	            exact_roots(10) = cmplx(-0.935147084823051581325738268702E0_dp,-0.276366395363089095701385358741E0_dp,kind=dp)
	            exact_roots(11) = cmplx(-0.935147084823051581325738268702E0_dp,0.276366395363089095701385358741E0_dp,kind=dp)
	            exact_roots(12) = cmplx(-0.899451950794801943937381293773E0_dp,-0.394568367012592113985865567971E0_dp,kind=dp)
	            exact_roots(13) = cmplx(-0.899451950794801943937381293773E0_dp,0.394568367012592113985865567971E0_dp,kind=dp)
	            exact_roots(14) = cmplx(-0.846928410223891427281972003960E0_dp,-0.507591758019284469647521636947E0_dp,kind=dp)
	            exact_roots(15) = cmplx(-0.846928410223891427281972003960E0_dp,0.507591758019284469647521636947E0_dp,kind=dp)
	            exact_roots(16) = cmplx(-0.779195724062158658036386916327E0_dp,-0.613081457400403535591975580892E0_dp,kind=dp)
	            exact_roots(17) = cmplx(-0.779195724062158658036386916327E0_dp,0.613081457400403535591975580892E0_dp,kind=dp)
	            exact_roots(18) = cmplx(-0.697743392981121831801589116937E0_dp,-0.709081007070975090262670227767E0_dp,kind=dp)
	            exact_roots(19) = cmplx(-0.697743392981121831801589116937E0_dp,0.709081007070975090262670227767E0_dp,kind=dp)
	            exact_roots(20) = cmplx(-0.604121886825094827201080735988E0_dp,-0.793887314714735149770017023538E0_dp,kind=dp)
	            exact_roots(21) = cmplx(-0.604121886825094827201080735988E0_dp,0.793887314714735149770017023538E0_dp,kind=dp)
	            exact_roots(22) = cmplx(-0.500000000000000000000000000000E0_dp,-0.866025403784438646763723170753E0_dp,kind=dp)
	            exact_roots(23) = cmplx(-0.500000000000000000000000000000E0_dp,0.866025403784438646763723170753E0_dp,kind=dp)
	            exact_roots(24) = cmplx(-0.387174132037879582862879778205E0_dp,-0.924251993602053902039550620488E0_dp,kind=dp)
	            exact_roots(25) = cmplx(-0.387174132037879582862879778205E0_dp,0.924251993602053902039550620488E0_dp,kind=dp)
	            exact_roots(26) = cmplx(-0.267556959428167474972897159502E0_dp,-0.967566373494130224905327435791E0_dp,kind=dp)
	            exact_roots(27) = cmplx(-0.267556959428167474972897159502E0_dp,0.967566373494130224905327435791E0_dp,kind=dp)
	            exact_roots(28) = cmplx(-0.143155839532593341810009310219E0_dp,-0.995221832724034632237407792227E0_dp,kind=dp)
	            exact_roots(29) = cmplx(-0.143155839532593341810009310219E0_dp,0.995221832724034632237407792227E0_dp,kind=dp)
	            exact_roots(30) = cmplx(-0.16045517947534302681825863292E-1_dp,-0.1006735041626386010701028433184E1_dp,kind=dp)
	            exact_roots(31) = cmplx(-0.16045517947534302681825863292E-1_dp,0.1006735041626386010701028433184E1_dp,kind=dp)
	            exact_roots(32) = cmplx(0.111662481142841735790134563805E0_dp,-0.1001892206008032435299692737060E1_dp,kind=dp)
	            exact_roots(33) = cmplx(0.111662481142841735790134563805E0_dp,0.1001892206008032435299692737060E1_dp,kind=dp)
	            exact_roots(34) = cmplx(0.237852321567861477202899799722E0_dp,-0.980751410679651646035316169672E0_dp,kind=dp)
	            exact_roots(35) = cmplx(0.237852321567861477202899799722E0_dp,0.980751410679651646035316169672E0_dp,kind=dp)
	            exact_roots(36) = cmplx(0.360437139274099643543556447604E0_dp,-0.943640865401314173256925688139E0_dp,kind=dp)
	            exact_roots(37) = cmplx(0.360437139274099643543556447604E0_dp,0.943640865401314173256925688139E0_dp,kind=dp)
	            exact_roots(38) = cmplx(0.477392314844102847110474634171E0_dp,-0.891152945345826129924640822366E0_dp,kind=dp)
	            exact_roots(39) = cmplx(0.477392314844102847110474634171E0_dp,0.891152945345826129924640822366E0_dp,kind=dp)
	            exact_roots(40) = cmplx(0.586788023132224235580014756671E0_dp,-0.824134044230047196220784957068E0_dp,kind=dp)
	            exact_roots(41) = cmplx(0.586788023132224235580014756671E0_dp,0.824134044230047196220784957068E0_dp,kind=dp)
	            exact_roots(42) = cmplx(0.686820425487486753027867016412E0_dp,-0.743670357958749198637378689329E0_dp,kind=dp)
	            exact_roots(43) = cmplx(0.686820425487486753027867016412E0_dp,0.743670357958749198637378689329E0_dp,kind=dp)
	            exact_roots(44) = cmplx(0.775840929682842739762490529077E0_dp,-0.651069801113127816898897251309E0_dp,kind=dp)
	            exact_roots(45) = cmplx(0.775840929682842739762490529077E0_dp,0.651069801113127816898897251309E0_dp,kind=dp)
	            exact_roots(46) = cmplx(0.852382996720766159190958138062E0_dp,-0.547840332639938504859225568105E0_dp,kind=dp)
	            exact_roots(47) = cmplx(0.852382996720766159190958138062E0_dp,0.547840332639938504859225568105E0_dp,kind=dp)
	            exact_roots(48) = cmplx(0.915186027756796108167454007547E0_dp,-0.435665032553729539118325217757E0_dp,kind=dp)
	            exact_roots(49) = cmplx(0.915186027756796108167454007547E0_dp,0.435665032553729539118325217757E0_dp,kind=dp)
	            exact_roots(50) = cmplx(0.963215921119370289466626861950E0_dp,-0.316374328936911136376493374596E0_dp,kind=dp)
	            exact_roots(51) = cmplx(0.963215921119370289466626861950E0_dp,0.316374328936911136376493374596E0_dp,kind=dp)
	            exact_roots(52) = cmplx(0.995681949864471509895340077408E0_dp,-0.191915823987060561907739223463E0_dp,kind=dp)
	            exact_roots(53) = cmplx(0.995681949864471509895340077408E0_dp,0.191915823987060561907739223463E0_dp,kind=dp)
	            exact_roots(54) = cmplx(0.1012049674656226877398138236602E1_dp,-0.64322209034046437066803422584E-1_dp,kind=dp)
	            exact_roots(55) = cmplx(0.1012049674656226877398138236602E1_dp,0.64322209034046437066803422584E-1_dp,kind=dp)
	            ! polynomial
	            p(1) = cmplx(1E0_dp,0E0_dp,kind=dp)
	            p(2) = cmplx(6E0_dp,0E0_dp,kind=dp)
	            p(3) = cmplx(15E0_dp,0E0_dp,kind=dp)
	            p(4) = cmplx(20E0_dp,0E0_dp,kind=dp)
	            p(5) = cmplx(15E0_dp,0E0_dp,kind=dp)
	            p(6) = cmplx(6E0_dp,0E0_dp,kind=dp)
	            p(7) = cmplx(1E0_dp,0E0_dp,kind=dp)
	            p(8) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(9) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(10) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(11) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(12) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(13) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(14) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(15) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(16) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(17) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(18) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(19) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(20) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(21) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(22) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(23) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(24) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(25) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(26) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(27) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(28) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(29) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(30) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(31) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(32) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(33) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(34) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(35) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(36) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(37) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(38) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(39) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(40) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(41) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(42) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(43) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(44) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(45) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(46) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(47) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(48) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(49) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(50) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(51) = cmplx(1E0_dp,0E0_dp,kind=dp)
	            p(52) = cmplx(5E0_dp,0E0_dp,kind=dp)
	            p(53) = cmplx(10E0_dp,0E0_dp,kind=dp)
	            p(54) = cmplx(10E0_dp,0E0_dp,kind=dp)
	            p(55) = cmplx(5E0_dp,0E0_dp,kind=dp)
	            p(56) = cmplx(1E0_dp,0E0_dp,kind=dp)
	            ! case 6
	            case(6)
	            ! Multiplicity II
	            deg = 62
	            allocate(exact_roots(deg), p(deg+1))
	            ! roots
	            exact_roots(1) = cmplx(-0.998026728428271561952336806863E0_dp,-0.62790519529313376076178224566E-1_dp,kind=dp)
	            exact_roots(2) = cmplx(-0.998026728428271561952336806863E0_dp,0.62790519529313376076178224566E-1_dp,kind=dp)
	            exact_roots(3) = cmplx(-0.982287250728688681085641742865E0_dp,-0.187381314585724630542550734447E0_dp,kind=dp)
	            exact_roots(4) = cmplx(-0.982287250728688681085641742865E0_dp,0.187381314585724630542550734447E0_dp,kind=dp)
	            exact_roots(5) = cmplx(-0.951056516295153572116439333379E0_dp,-0.309016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(6) = cmplx(-0.951056516295153572116439333379E0_dp,0.309016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(7) = cmplx(-0.904827052466019527713668647933E0_dp,-0.425779291565072648862502445744E0_dp,kind=dp)
	            exact_roots(8) = cmplx(-0.904827052466019527713668647933E0_dp,0.425779291565072648862502445744E0_dp,kind=dp)
	            exact_roots(9) = cmplx(-0.844327925502015078548558063967E0_dp,-0.535826794978996618271308767868E0_dp,kind=dp)
	            exact_roots(10) = cmplx(-0.844327925502015078548558063967E0_dp,0.535826794978996618271308767868E0_dp,kind=dp)
	            exact_roots(11) = cmplx(-0.770513242775789230803009636396E0_dp,-0.637423989748689710176712811676E0_dp,kind=dp)
	            exact_roots(12) = cmplx(-0.770513242775789230803009636396E0_dp,0.637423989748689710176712811676E0_dp,kind=dp)
	            exact_roots(13) = cmplx(-0.684547105928688673732283357621E0_dp,-0.728968627421411523146730319055E0_dp,kind=dp)
	            exact_roots(14) = cmplx(-0.684547105928688673732283357621E0_dp,0.728968627421411523146730319055E0_dp,kind=dp)
	            exact_roots(15) = cmplx(-0.587785252292473129168705954639E0_dp,-0.809016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(16) = cmplx(-0.587785252292473129168705954639E0_dp,0.809016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(17) = cmplx(-0.50000000000000000000000000000E0_dp,-0.217944947177033677611849099193E1_dp,kind=dp)
	            exact_roots(18) = cmplx(-0.50000000000000000000000000000E0_dp,-0.217944947177033677611849099193E1_dp,kind=dp)
	            exact_roots(19) = cmplx(-0.50000000000000000000000000000E0_dp,-0.217944947177033677611849099193E1_dp,kind=dp)
	            exact_roots(20) = cmplx(-0.50000000000000000000000000000E0_dp,0.217944947177033677611849099193E1_dp,kind=dp)
	            exact_roots(21) = cmplx(-0.50000000000000000000000000000E0_dp,0.217944947177033677611849099193E1_dp,kind=dp)
	            exact_roots(22) = cmplx(-0.50000000000000000000000000000E0_dp,0.217944947177033677611849099193E1_dp,kind=dp)
	            exact_roots(23) = cmplx(-0.481753674101715274987191502872E0_dp,-0.876306680043863587308115903922E0_dp,kind=dp)
	            exact_roots(24) = cmplx(-0.481753674101715274987191502872E0_dp,0.876306680043863587308115903922E0_dp,kind=dp)
	            exact_roots(25) = cmplx(-0.368124552684677959156947147493E0_dp,-0.929776485888251403660942556222E0_dp,kind=dp)
	            exact_roots(26) = cmplx(-0.368124552684677959156947147493E0_dp,0.929776485888251403660942556222E0_dp,kind=dp)
	            exact_roots(27) = cmplx(-0.248689887164854788242283746006E0_dp,-0.968583161128631119490168375465E0_dp,kind=dp)
	            exact_roots(28) = cmplx(-0.248689887164854788242283746006E0_dp,0.968583161128631119490168375465E0_dp,kind=dp)
	            exact_roots(29) = cmplx(-0.125333233564304245373118759817E0_dp,-0.992114701314477831049793042786E0_dp,kind=dp)
	            exact_roots(30) = cmplx(-0.125333233564304245373118759817E0_dp,0.992114701314477831049793042786E0_dp,kind=dp)
	            exact_roots(31) = cmplx(0E0_dp,-0.100000000000000000000000000000E1_dp,kind=dp)
	            exact_roots(32) = cmplx(0E0_dp,0.100000000000000000000000000000E1_dp,kind=dp)
	            exact_roots(33) = cmplx(0.125333233564304245373118759817E0_dp,-0.992114701314477831049793042786E0_dp,kind=dp)
	            exact_roots(34) = cmplx(0.125333233564304245373118759817E0_dp,0.992114701314477831049793042786E0_dp,kind=dp)
	            exact_roots(35) = cmplx(0.248689887164854788242283746006E0_dp,-0.968583161128631119490168375465E0_dp,kind=dp)
	            exact_roots(36) = cmplx(0.248689887164854788242283746006E0_dp,0.968583161128631119490168375465E0_dp,kind=dp)
	            exact_roots(37) = cmplx(0.333333333333333333333333333333E0_dp,0E0_dp,kind=dp)
	            exact_roots(38) = cmplx(0.333333333333333333333333333333E0_dp,0E0_dp,kind=dp)
	            exact_roots(39) = cmplx(0.368124552684677959156947147493E0_dp,-0.929776485888251403660942556222E0_dp,kind=dp)
	            exact_roots(40) = cmplx(0.368124552684677959156947147493E0_dp,0.929776485888251403660942556222E0_dp,kind=dp)
	            exact_roots(41) = cmplx(0.481753674101715274987191502872E0_dp,-0.876306680043863587308115903922E0_dp,kind=dp)
	            exact_roots(42) = cmplx(0.481753674101715274987191502872E0_dp,0.876306680043863587308115903922E0_dp,kind=dp)
	            exact_roots(43) = cmplx(0.587785252292473129168705954639E0_dp,-0.809016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(44) = cmplx(0.587785252292473129168705954639E0_dp,0.809016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(45) = cmplx(0.684547105928688673732283357621E0_dp,-0.728968627421411523146730319055E0_dp,kind=dp)
	            exact_roots(46) = cmplx(0.684547105928688673732283357621E0_dp,0.728968627421411523146730319055E0_dp,kind=dp)
	            exact_roots(47) = cmplx(0.770513242775789230803009636396E0_dp,-0.637423989748689710176712811676E0_dp,kind=dp)
	            exact_roots(48) = cmplx(0.770513242775789230803009636396E0_dp,0.637423989748689710176712811676E0_dp,kind=dp)
	            exact_roots(49) = cmplx(0.844327925502015078548558063967E0_dp,-0.535826794978996618271308767868E0_dp,kind=dp)
	            exact_roots(50) = cmplx(0.844327925502015078548558063967E0_dp,0.535826794978996618271308767868E0_dp,kind=dp)
	            exact_roots(51) = cmplx(0.904827052466019527713668647933E0_dp,-0.425779291565072648862502445744E0_dp,kind=dp)
	            exact_roots(52) = cmplx(0.904827052466019527713668647933E0_dp,0.425779291565072648862502445744E0_dp,kind=dp)
	            exact_roots(53) = cmplx(0.951056516295153572116439333379E0_dp,-0.309016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(54) = cmplx(0.951056516295153572116439333379E0_dp,0.309016994374947424102293417183E0_dp,kind=dp)
	            exact_roots(55) = cmplx(0.982287250728688681085641742865E0_dp,-0.187381314585724630542550734447E0_dp,kind=dp)
	            exact_roots(56) = cmplx(0.982287250728688681085641742865E0_dp,0.187381314585724630542550734447E0_dp,kind=dp)
	            exact_roots(57) = cmplx(0.998026728428271561952336806863E0_dp,-0.62790519529313376076178224566E-1_dp,kind=dp)
	            exact_roots(58) = cmplx(0.998026728428271561952336806863E0_dp,0.62790519529313376076178224566E-1_dp,kind=dp)
	            exact_roots(59) = cmplx(0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(60) = cmplx(0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(61) = cmplx(0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(62) = cmplx(0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            ! polynomial
	            p(1) = cmplx(125E0_dp,0E0_dp,kind=dp)
	            p(2) = cmplx(-1175E0_dp,0E0_dp,kind=dp)
	            p(3) = cmplx(4215E0_dp,0E0_dp,kind=dp)
	            p(4) = cmplx(-7444E0_dp,0E0_dp,kind=dp)
	            p(5) = cmplx(7393E0_dp,0E0_dp,kind=dp)
	            p(6) = cmplx(-5133E0_dp,0E0_dp,kind=dp)
	            p(7) = cmplx(3402E0_dp,0E0_dp,kind=dp)
	            p(8) = cmplx(-1917E0_dp,0E0_dp,kind=dp)
	            p(9) = cmplx(741E0_dp,0E0_dp,kind=dp)
	            p(10) = cmplx(-316E0_dp,0E0_dp,kind=dp)
	            p(11) = cmplx(115E0_dp,0E0_dp,kind=dp)
	            p(12) = cmplx(-15E0_dp,0E0_dp,kind=dp)
	            p(13) = cmplx(9E0_dp,0E0_dp,kind=dp)
	            p(14) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(15) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(16) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(17) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(18) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(19) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(20) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(21) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(22) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(23) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(24) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(25) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(26) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(27) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(28) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(29) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(30) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(31) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(32) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(33) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(34) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(35) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(36) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(37) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(38) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(39) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(40) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(41) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(42) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(43) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(44) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(45) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(46) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(47) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(48) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(49) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(50) = cmplx(0E0_dp,0E0_dp,kind=dp)
	            p(51) = cmplx(125E0_dp,0E0_dp,kind=dp)
	            p(52) = cmplx(-1175E0_dp,0E0_dp,kind=dp)
	            p(53) = cmplx(4215E0_dp,0E0_dp,kind=dp)
	            p(54) = cmplx(-7444E0_dp,0E0_dp,kind=dp)
	            p(55) = cmplx(7393E0_dp,0E0_dp,kind=dp)
	            p(56) = cmplx(-5133E0_dp,0E0_dp,kind=dp)
	            p(57) = cmplx(3402E0_dp,0E0_dp,kind=dp)
	            p(58) = cmplx(-1917E0_dp,0E0_dp,kind=dp)
	            p(59) = cmplx(741E0_dp,0E0_dp,kind=dp)
	            p(60) = cmplx(-316E0_dp,0E0_dp,kind=dp)
	            p(61) = cmplx(115E0_dp,0E0_dp,kind=dp)
	            p(62) = cmplx(-15E0_dp,0E0_dp,kind=dp)
	            p(63) = cmplx(9E0_dp,0E0_dp,kind=dp)
	            ! case 7
	            case(7)
	            ! Multiplicity III
	            deg = 17
	            allocate(exact_roots(deg), p(deg+1))
	            ! roots
	            exact_roots(1) = cmplx(0.100000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(2) = cmplx(0.200000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(3) = cmplx(0.300000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(4) = cmplx(0.400000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(5) = cmplx(0.500000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(6) = cmplx(0.600000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(7) = cmplx(0.700000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(8) = cmplx(0.800000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(9) = cmplx(0.900000000000000000000000000000E1_dp,0E0_dp,kind=dp)
	            exact_roots(10) = cmplx(0.100000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            exact_roots(11) = cmplx(0.110000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            exact_roots(12) = cmplx(0.120000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            exact_roots(13) = cmplx(0.130000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            exact_roots(14) = cmplx(0.140000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            exact_roots(15) = cmplx(0.150000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            exact_roots(16) = cmplx(0.150000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            exact_roots(17) = cmplx(0.150000000000000000000000000000E2_dp,0E0_dp,kind=dp)
	            ! polynomial
	            p(1) = cmplx(-294226732800000E0_dp,0E0_dp,kind=dp)
	            p(2) = cmplx(1015541906400000E0_dp,0E0_dp,kind=dp)
	            p(3) = cmplx(-1518791527728000E0_dp,0E0_dp,kind=dp)
	            p(4) = cmplx(1327137724803600E0_dp,0E0_dp,kind=dp)
	            p(5) = cmplx(-766908691489440E0_dp,0E0_dp,kind=dp)
	            p(6) = cmplx(313437620164824E0_dp,0E0_dp,kind=dp)
	            p(7) = cmplx(-94377698961000E0_dp,0E0_dp,kind=dp)
	            p(8) = cmplx(21485772576905E0_dp,0E0_dp,kind=dp)
	            p(9) = cmplx(-3758453397270E0_dp,0E0_dp,kind=dp)
	            p(10) = cmplx(509681511053E0_dp,0E0_dp,kind=dp)
	            p(11) = cmplx(-53726158200E0_dp,0E0_dp,kind=dp)
	            p(12) = cmplx(4387265090E0_dp,0E0_dp,kind=dp)
	            p(13) = cmplx(-274687140E0_dp,0E0_dp,kind=dp)
	            p(14) = cmplx(12932122E0_dp,0E0_dp,kind=dp)
	            p(15) = cmplx(-442800E0_dp,0E0_dp,kind=dp)
	            p(16) = cmplx(10405E0_dp,0E0_dp,kind=dp)
	            p(17) = cmplx(-150E0_dp,0E0_dp,kind=dp)
	            p(18) = cmplx(1E0_dp,0E0_dp,kind=dp)
	        end select
	    end subroutine make_poly
	    !************************************************
	    !                       max_rel_err             *
	    !************************************************
	    ! Compute maximum relative error between roots
	    ! and exact roots.
	    !************************************************
	    function max_rel_err(roots, exact_roots, deg) result(res)
	        implicit none
	        ! argument variables
	        integer, intent(in)             :: deg
	        complex(kind=dp), intent(in)    :: exact_roots(:), roots(:)
	        ! local variables
	        logical                         :: m(deg)
	        integer                         :: i, j, k
	        real(kind=dp)                   :: delta, err, res, relerr, rmax
	        ! intrinsic procedures
	        intrinsic                       :: abs, max, huge

	        ! initialize
	        m = .True.
	        rmax = huge(1.0_dp)
	        res = mu
	        ! main loop
	        do i=1,deg
	            ! find corresponding exact root (yet to be matched)
	            err = rmax
	            do j=1,deg
	                if(m(j)) then
	                    delta = abs(exact_roots(j) - roots(i))
	                    if(delta < err) then
	                        err = delta
	                        k = j
	                    end if
	                end if
	            end do
	            ! mark corresponding root as matched
	            m(k) = .False.
	            ! calculate relative error on this root and update max
	            ! zero roots give unhelpful relative errors, so revert to absolute error
	            if(abs(roots(i))<mu .or. abs(exact_roots(k))<mu) then
	                relerr = err
	            else
	                relerr = err/abs(exact_roots(k))
	            end if
	            res = max(relerr, res)
	        end do
	        res = max(res,mu)
	    end function max_rel_err
end program forwerr_multi


c---------------------------------------------------------------------
c compute the roots-of-unity array that will be used for subsequent FFTs.
c---------------------------------------------------------------------
      subroutine CompExp (n, exponent)

      implicit none
      integer n
      double complex exponent(n)
      integer ilog2
      external ilog2

      integer m,nu,ku,i,j,ln
      double precision t, ti, pi
      data pi /3.141592653589793238d0/

      nu = n
      m = ilog2(n)
      exponent(1) = m
      ku = 2
      ln = 1
      do j = 1, m
         t = pi / ln
         do i = 0, ln - 1
            ti = i * t
            exponent(i+ku) = dcmplx(cos(ti),sin(ti))
         enddo
         ku = ku + ln
         ln = 2 * ln
      enddo

      return
      end

c---------------------------------------------------------------------
c---------------------------------------------------------------------
c---------------------------------------------------------------------
      integer function ilog2(n)
      implicit none
      integer n
c---------------------------------------------------------------------
c---------------------------------------------------------------------
      integer nn, lg
      if (n .eq. 1) then
         ilog2=0
         return
      endif
      lg = 1
      nn = 2
      do while (nn .lt. n)
         nn = nn*2
         lg = lg+1
      end do
      ilog2 = lg
      return
      end
c---------------------------------------------------------------------
c---------------------------------------------------------------------

      subroutine ipow46(a, exponent, result)
c---------------------------------------------------------------------
c compute a^exponent mod 2^46
c---------------------------------------------------------------------

      implicit none
      double precision a, result, dummy, q, r
      integer exponent, n, n2
      external randlc
      double precision randlc
c---------------------------------------------------------------------
c Use
c   a^n = a^(n/2)*a^(n/2) if n even else
c   a^n = a*a^(n-1)       if n odd
c---------------------------------------------------------------------
      result = 1
      if (exponent .eq. 0) return
      q = a
      r = 1
      n = exponent

      do while (n .gt. 1)
         n2 = n/2
         if (n2 * 2 .eq. n) then
            dummy = randlc(q, q)
            n = n2
         else
            dummy = randlc(r, q)
            n = n-1
         endif
      end do
      dummy = randlc(r, q)
      result = r
      return
      end
c---------------------------------------------------------------------
      subroutine CalculateChecksum(csum,iterN,u,d1,d2,d3)
        implicit none
        integer iterN
        integer d1,d2,d3
        double complex csum
        double complex u(d1+1,d2,d3)
        integer i, i1, ii, ji, ki
        csum = dcmplx (0.0, 0.0)
        do i = 1, 1024
          i1 = i
          ii = mod (i1, d1) + 1
          ji = mod (3 * i1, d2) + 1
          ki = mod (5 * i1, d3) + 1
          csum = csum + u(ii,ji,ki)
        end do
        csum = csum/dble(d1*d2*d3)
        write(*,30) iterN, csum
 30     format (' T =',I5,5X,'Checksum =',1P2D22.12)
      return
      end
c---------------------------------------------------------------------
c---------------------------------------------------------------------
      subroutine compute_initial_conditions(u0,d1,d2,d3)

      implicit none
      include 'npbparams.h'
      integer d1,d2,d3
      double complex u0(d1+1,d2,d3), tmp(maxdim)
      double precision x0, start, an, dummy
      double precision RanStarts(maxdim)

      integer i,j,k
      double precision seed, a
      parameter (seed = 314159265.d0, a = 1220703125.d0)
      external randlc
      double precision randlc

      start = seed
c---------------------------------------------------------------------
c Jump to the starting element for our first plane.
c---------------------------------------------------------------------
      call ipow46(a, 0, an)
      dummy = randlc(start, an)
      call ipow46(a, 2*d1*d2, an)
c---------------------------------------------------------------------
c Go through by z planes filling in one square at a time.
c---------------------------------------------------------------------
      RanStarts(1) = start
      do k = 2, d3
         dummy = randlc(start, an)
         RanStarts(k) = start
      end do

      do k = 1, d3
         x0 = RanStarts(k)
         do j = 1, d2
           call vranlc(2*d1, x0, a, tmp)
           do i = 1, d1
             u0(i,j,k)=tmp(i)
           end do
         end do
      end do

      return
      end
c---------------------------------------------------------------------
c---------------------------------------------------------------------
      subroutine evolve(x,y,twiddle,nx,ny,nz)
      double complex x(nx+1,ny,nz),y(nx+1,ny,nz)
      real*8 twiddle(nx+1,ny,nz)
      integer nx,ny,nz
      integer i,j,k
           do i = 1, nz
             do k = 1, ny
               do j = 1, nx
                   y(j,k,i)=y(j,k,i)*twiddle(j,k,i)
                   x(j,k,i)=y(j,k,i)
                 end do
              end do
           end do

      return
      end
c---------------------------------------------------------------------
c---------------------------------------------------------------------


      SUBROUTINE SB10VD( N, M, NP, NCON, NMEAS, A, LDA, B, LDB, C, LDC,
     $                   F, LDF, H, LDH, X, LDX, Y, LDY, XYCOND, IWORK,
     $                   DWORK, LDWORK, BWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute the state feedback and the output injection
C     matrices for an H2 optimal n-state controller for the system
C
C                   | A  | B1  B2  |   | A | B |
C               P = |----|---------| = |---|---|
C                   | C1 |  0  D12 |   | C | D |
C                   | C2 | D21 D22 |
C
C     where B2 has as column size the number of control inputs (NCON)
C     and C2 has as row size the number of measurements (NMEAS) being
C     provided to the controller.
C
C     It is assumed that
C
C     (A1) (A,B2) is stabilizable and (C2,A) is detectable,
C
C     (A2) D12 is full column rank with D12 = | 0 | and D21 is
C                                             | I |
C          full row rank with D21 = | 0 I | as obtained by the
C          SLICOT Library routine SB10UD. Matrix D is not used
C          explicitly.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the system.  N >= 0.
C
C     M       (input) INTEGER
C             The column size of the matrix B.  M >= 0.
C
C     NP      (input) INTEGER
C             The row size of the matrix C.  NP >= 0.
C
C     NCON    (input) INTEGER
C             The number of control inputs (M2).  M >= NCON >= 0,
C             NP-NMEAS >= NCON.
C
C     NMEAS   (input) INTEGER
C             The number of measurements (NP2).  NP >= NMEAS >= 0,
C             M-NCON >= NMEAS.
C
C     A       (input) DOUBLE PRECISION array, dimension (LDA,N)
C             The leading N-by-N part of this array must contain the
C             system state matrix A.
C
C     LDA     INTEGER
C             The leading dimension of the array A.  LDA >= max(1,N).
C
C     B       (input) DOUBLE PRECISION array, dimension (LDB,M)
C             The leading N-by-M part of this array must contain the
C             system input matrix B.
C
C     LDB     INTEGER
C             The leading dimension of the array B.  LDB >= max(1,N).
C
C     C       (input) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading NP-by-N part of this array must contain the
C             system output matrix C.
C
C     LDC     INTEGER
C             The leading dimension of the array C.  LDC >= max(1,NP).
C
C     F       (output) DOUBLE PRECISION array, dimension (LDF,N)
C             The leading NCON-by-N part of this array contains the
C             state feedback matrix F.
C
C     LDF     INTEGER
C             The leading dimension of the array F.  LDF >= max(1,NCON).
C
C     H       (output) DOUBLE PRECISION array, dimension (LDH,NMEAS)
C             The leading N-by-NMEAS part of this array contains the
C             output injection matrix H.
C
C     LDH     INTEGER
C             The leading dimension of the array H.  LDH >= max(1,N).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,N)
C             The leading N-by-N part of this array contains the matrix
C             X, solution of the X-Riccati equation.
C
C     LDX     INTEGER
C             The leading dimension of the array X.  LDX >= max(1,N).
C
C     Y       (output) DOUBLE PRECISION array, dimension (LDY,N)
C             The leading N-by-N part of this array contains the matrix
C             Y, solution of the Y-Riccati equation.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= max(1,N).
C
C     XYCOND  (output) DOUBLE PRECISION array, dimension (2)
C             XYCOND(1) contains an estimate of the reciprocal condition
C                       number of the X-Riccati equation;
C             XYCOND(2) contains an estimate of the reciprocal condition
C                       number of the Y-Riccati equation.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (max(2*N,N*N))
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) contains the optimal
C             LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of the array DWORK.
C             LDWORK >= 13*N*N + 12*N + 5.
C             For good performance, LDWORK must generally be larger.
C
C     BWORK   LOGICAL array, dimension (2*N)
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 X-Riccati equation was not solved
C                   successfully;
C             = 2:  if the Y-Riccati equation was not solved
C                   successfully.
C
C     METHOD
C
C     The routine implements the formulas given in [1], [2]. The X-
C     and Y-Riccati equations are solved with condition and accuracy
C     estimates [3].
C
C     REFERENCES
C
C     [1] Zhou, K., Doyle, J.C., and Glover, K.
C         Robust and Optimal Control.
C         Prentice-Hall, Upper Saddle River, NJ, 1996.
C
C     [2] Balas, G.J., Doyle, J.C., Glover, K., Packard, A., and
C         Smith, R.
C         mu-Analysis and Synthesis Toolbox.
C         The MathWorks Inc., Natick, Mass., 1995.
C
C     [3] Petkov, P.Hr., Konstantinov, M.M., and Mehrmann, V.
C         DGRSVX and DMSRIC: Fortan 77 subroutines for solving
C         continuous-time matrix algebraic Riccati equations with
C         condition and accuracy estimates.
C         Preprint SFB393/98-16, Fak. f. Mathematik, Tech. Univ.
C         Chemnitz, May 1998.
C
C     NUMERICAL ASPECTS
C
C     The precision of the solution of the matrix Riccati equations
C     can be controlled by the values of the condition numbers
C     XYCOND(1) and XYCOND(2) of these equations.
C
C     FURTHER COMMENTS
C
C     The Riccati equations are solved by the Schur approach
C     implementing condition and accuracy estimates.
C
C     CONTRIBUTORS
C
C     P.Hr. Petkov, D.W. Gu and M.M. Konstantinov, October 1998.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, May 1999.
C
C     KEYWORDS
C
C     Algebraic Riccati equation, H2 optimal control, LQG, LQR, optimal
C     regulator, robust control.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D+0, ONE = 1.0D+0 )
C     ..
C     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, LDC, LDF, LDH, LDWORK, LDX,
     $                   LDY, M, N, NCON, NMEAS, NP
C     ..
C     .. Array Arguments ..
      LOGICAL            BWORK( * )
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  F( LDF, * ), H( LDH, * ),
     $                   X( LDX, * ), XYCOND( 2 ), Y( LDY, * )
C     ..
C     .. Local Scalars ..
      INTEGER            INFO2, IWG, IWI, IWQ, IWR, IWRK, IWS, IWT, IWV,
     $                   LWAMAX, M1, M2, MINWRK, N2, ND1, ND2, NP1, NP2
      DOUBLE PRECISION   FERR, SEP
C     ..
C     .. External Functions ..
C
      DOUBLE PRECISION   DLANSY
      EXTERNAL           DLANSY
C     ..
C     .. External Subroutines ..
      EXTERNAL           DGEMM, DLACPY, DLASET, DSYRK, SB02RD, XERBLA
C     ..
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX
C     ..
C     .. Executable Statements ..
C
C     Decode and Test input parameters.
C
      M1  = M - NCON
      M2  = NCON
      NP1 = NP - NMEAS
      NP2 = NMEAS
C
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( NP.LT.0 ) THEN
         INFO = -3
      ELSE IF( NCON.LT.0 .OR. M1.LT.0 .OR. M2.GT.NP1 ) THEN
         INFO = -4
      ELSE IF( NMEAS.LT.0 .OR. NP1.LT.0 .OR. NP2.GT.M1 ) THEN
         INFO = -5
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, NP ) ) THEN
         INFO = -11
      ELSE IF( LDF.LT.MAX( 1, NCON ) ) THEN
         INFO = -13
      ELSE IF( LDH.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -17
      ELSE IF( LDY.LT.MAX( 1, N ) ) THEN
         INFO = -19
      ELSE
C
C        Compute workspace.
C
         MINWRK = 13*N*N + 12*N + 5
         IF( LDWORK.LT.MINWRK )
     $      INFO = -23
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'SB10VD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 .OR. M.EQ.0 .OR. NP.EQ.0 .OR. M1.EQ.0 .OR. M2.EQ.0
     $    .OR. NP1.EQ.0 .OR. NP2.EQ.0 ) THEN
         DWORK( 1 )  = ONE
         XYCOND( 1 ) = ONE
         XYCOND( 2 ) = ONE
         RETURN
      END IF
C
      ND1 = NP1 - M2
      ND2 = M1 - NP2
      N2  = 2*N
C
C     Workspace usage.
C
      IWQ  = N*N + 1
      IWG  = IWQ + N*N
      IWT  = IWG + N*N
      IWV  = IWT + N*N
      IWR  = IWV + N*N
      IWI  = IWR + N2
      IWS  = IWI + N2
      IWRK = IWS + 4*N*N
C
C     Compute Ax = A - B2*D12'*C1 .
C
      CALL DLACPY ('Full', N, N, A, LDA, DWORK, N )
      CALL DGEMM( 'N', 'N', N, N, M2, -ONE, B( 1, M1+1 ), LDB,
     $            C( ND1+1, 1), LDC, ONE, DWORK, N )
C
C     Compute Cx = C1'*C1 - C1'*D12*D12'*C1 .
C
      IF( ND1.GT.0 ) THEN
         CALL DSYRK( 'L', 'T', N, ND1, ONE, C, LDC, ZERO, DWORK( IWQ ),
     $               N )
      ELSE
         CALL DLASET( 'L', N, N, ZERO, ZERO, DWORK( IWQ ), N )
      END IF
C
C     Compute Dx = B2*B2' .
C
      CALL DSYRK( 'L', 'N', N, M2, ONE, B( 1, M1+1 ), LDB, ZERO,
     $            DWORK( IWG ), N )
C
C     Solution of the Riccati equation Ax'*X + X*Ax + Cx - X*Dx*X = 0 .
C     Workspace:  need   13*N*N + 12*N + 5;
C                 prefer larger.
C
      CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'NoTranspose',
     $             'Lower', 'GeneralScaling', 'Stable', 'NotFactored',
     $             'Original', N, DWORK, N, DWORK( IWT ), N,
     $             DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N,
     $             X, LDX, SEP, XYCOND( 1 ), FERR, DWORK( IWR ),
     $             DWORK( IWI ), DWORK( IWS ), N2, IWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 1
         RETURN
      END IF
C
      LWAMAX = INT( DWORK( IWRK ) ) + IWRK - 1
C
C     Compute F = -D12'*C1 - B2'*X .
C
      CALL DLACPY( 'Full', M2, N, C( ND1+1, 1 ), LDC, F, LDF )
      CALL DGEMM( 'T', 'N', M2, N, N, -ONE, B( 1, M1+1 ), LDB, X, LDX,
     $            -ONE, F, LDF )
C
C     Compute Ay = A - B1*D21'*C2 .
C
      CALL DLACPY( 'Full', N, N, A, LDA, DWORK, N )
      CALL DGEMM( 'N', 'N', N, N, NP2, -ONE, B( 1, ND2+1 ), LDB,
     $            C( NP1+1, 1 ), LDC, ONE, DWORK, N )
C
C     Compute Cy = B1*B1' - B1*D21'*D21*B1' .
C
      IF( ND2.GT.0 ) THEN
         CALL DSYRK( 'U', 'N', N, ND2, ONE, B, LDB, ZERO, DWORK( IWQ ),
     $               N )
      ELSE
         CALL DLASET( 'U', N, N, ZERO, ZERO, DWORK( IWQ ), N )
      END IF
C
C     Compute Dy = C2'*C2 .
C
      CALL DSYRK( 'U', 'T', N, NP2, ONE, C( NP1+1, 1 ), LDC, ZERO,
     $            DWORK( IWG ), N )
C
C     Solution of the Riccati equation Ay*Y + Y*Ay' + Cy - Y*Dy*Y = 0 .
C     Workspace:  need   13*N*N + 12*N + 5;
C                 prefer larger.
C
      CALL SB02RD( 'All', 'Continuous', 'NotUsed', 'Transpose',
     $             'Upper', 'GeneralScaling', 'Stable', 'NotFactored',
     $             'Original', N, DWORK, N, DWORK( IWT ), N,
     $             DWORK( IWV ), N, DWORK( IWG ), N, DWORK( IWQ ), N,
     $             Y, LDY, SEP, XYCOND( 2 ), FERR, DWORK( IWR ),
     $             DWORK( IWI ), DWORK( IWS ), N2, IWORK,
     $             DWORK( IWRK ), LDWORK-IWRK+1, BWORK, INFO2 )
      IF( INFO2.GT.0 ) THEN
         INFO = 2
         RETURN
      END IF
C
      LWAMAX = MAX( INT( DWORK( IWRK ) ) + IWRK - 1, LWAMAX )
C
C     Compute H = -B1*D21' - Y*C2' .
C
      CALL DLACPY( 'Full', N, NP2, B( 1, ND2+1 ), LDB, H, LDH )
      CALL DGEMM( 'N', 'T', N, NP2, N, -ONE, Y, LDY, C( NP1+1, 1 ), LDC,
     $            -ONE, H, LDH )
C
      DWORK( 1 ) = DBLE( LWAMAX )
      RETURN
C *** Last line of SB10VD ***
      END


c Compute Euclidean norm of float vector, and normalize vector if norm != 0.
c (Required by subroutine lsqr.)

	subroutine normlz(n, x, beta)

	implicit none

c	Parameters:
	integer	n
	real	x(n)
	real	beta	! Euclidean norm of x	(output)

c	Local variables:
	real	one
	real	snrm2	! BLAS function
	real	zero

      zero = 0.0
      one  = 1.0
      beta = snrm2(n, x, 1)
      if (beta .gt. zero) call sscal(n, (one/beta), x, 1)
      return

c     end of normlz
      end


 SUBROUTINE SGTSV_F95( DL, D, DU, B, INFO )
!
!  -- LAPACK95 interface driver routine (version 3.0) --
!     UNI-C, Denmark; Univ. of Tennessee, USA; NAG Ltd., UK
!     September, 2000
!
!   .. USE STATEMENTS ..
    USE LA_PRECISION, ONLY: WP => SP
    USE LA_AUXMOD, ONLY: ERINFO
    USE F77_LAPACK, ONLY: GTSV_F77 => LA_GTSV
!   .. IMPLICIT STATEMENT ..
    IMPLICIT NONE
!   .. SCALAR ARGUMENTS ..
    INTEGER, INTENT(OUT), OPTIONAL :: INFO
!   .. ARRAY ARGUMENTS ..
    REAL(WP), INTENT(INOUT) :: DL(:), D(:), DU(:), B(:,:)
!----------------------------------------------------------------------
!
! Purpose
! =======
!
!    LA_GTSV computes the solution to a real or complex linear system of
! equations A*X = B, where A is a square tridiagonal matrix and X and B
! are rectangular matrices or vectors. The LU decomposition is used to
! factor the matrix A as A = L*U , where L is a product of permutation
! and unit lower bidiagonal matrices and U is upper triangular with
! nonzeros in only the main diagonal and first two superdiagonals.
! The factored form of A is then used to solve the above system.
!
! Note: The system A^T*X = B may be solved by interchanging the order of
! the arguments DU and DL.
!
! =========
!
!       SUBROUTINE LA_GTSV( DL, D, DU, B, INFO=info )
!           <type>(<wp>), INTENT(INOUT) :: DL(:), D(:), DU(:), <rhs>
!           INTEGER, INTENT(OUT), OPTIONAL :: INFO
!       where
!           <type> ::= REAL | COMPLEX
!           <wp> ::= KIND(1.0) | KIND(1.0D0)
!           <rhs> ::= B(:,:) | B(:)
!
! Arguments
! =========
!
! DL    (input/output) REAL or COMPLEX array, shape (:) with
!       size(DL) = n-1, where n is the order of A.
!       On entry, the subdiagonal of A.
!       On exit, the n-2 elements of the second superdiagonal of U in
!       DL(1),..., DL(n-2).
! D     (input/output) REAL or COMPLEX array, shape (:) with size(D) = n.
!       On entry, the diagonal of A.
!       On exit, the diagonal of U .
! DU    (input/output) REAL or COMPLEX array, shape (:) with
!       size(DL) = n-1.
!       On entry, the superdiagonal of A.
!       On exit, the first superdiagonal of U .
! B     (input/output) REAL or COMPLEX array, shape (:,:) with
!       size(B,1) = n or shape (:) with size(B) = n.
!       On entry, the matrix B.
!       On exit, the solution matrix X .
! INFO  Optional (output) INTEGER
!       = 0: successful exit.
!       < 0: if INFO = -i, the i-th argument had an illegal value.
!       > 0: if INFO = i, then U(i,i) = 0. The factorization has not been
!       completed unless i = n. The factor U is singular, so the solution
!       could not be computed.
!       If INFO is not present and an error occurs, then the program is
!       terminated with an error message.
!----------------------------------------------------------------------
!   .. PARAMETERS ..
    CHARACTER(LEN=7), PARAMETER :: SRNAME = 'LA_GTSV'
!   .. LOCAL SCALARS ..
    INTEGER :: LINFO, N, NRHS
!   .. INTRINSIC FUNCTIONS ..
    INTRINSIC SIZE
!   .. EXECUTABLE STATEMENTS ..
    LINFO = 0
    N = SIZE(D); NRHS = SIZE(B,2)
!   .. TEST THE ARGUMENTS
    IF( SIZE( DL ) /= N-1 .AND. N /= 0 ) THEN; LINFO = -1
    ELSE IF( N < 0 ) THEN; LINFO = -2
    ELSE IF( SIZE( DU ) /= N-1 .AND. N/=0 ) THEN; LINFO = -3
    ELSE IF( SIZE( B, 1 ) /= N .OR. NRHS < 0 ) THEN; LINFO = -4
    ELSE IF ( N > 0 ) THEN
       CALL GTSV_F77( N, NRHS, DL, D, DU, B, N, LINFO )
    END IF
    CALL ERINFO( LINFO, SRNAME, INFO )
 END SUBROUTINE SGTSV_F95


SUBROUTINE clawpack5_b4step2(mbc,mx,my,meqn,q, &
    xlower,ylower,dx,dy,time,dt,maux,aux)
    IMPLICIT NONE

    INTEGER mbc,mx,my,maux,meqn
    DOUBLE PRECISION xlower,ylower,dx,dy,time,dt

    DOUBLE PRECISION q(meqn,1-mbc:mx+mbc,1-mbc:my+mbc)
    DOUBLE PRECISION aux(maux,1-mbc:mx+mbc,1-mbc:my+mbc)

    DOUBLE PRECISION tperiod, pi2
    COMMON /comvt/ tperiod,pi2

    INTEGER i,j
    DOUBLE PRECISION xll,yll, psi, vt

    IF (tperiod .EQ. 0.d0) THEN
        !! # special case --- indication that velocities specified in
        !! # setaux should be used for all time.
        RETURN
    ENDIF

    vt = dcos(pi2*(time+dt/2.d0)/tperiod)

    DO  j=1-mbc,my+mbc
        DO i=1-mbc,mx+mbc
            !! # coordinates of lower left corner of grid cell:
            xll = xlower + (i-1)*dx
            yll = ylower + (j-1)*dy

            !! # difference stream function psi to get normal velocities:
            aux(1,i,j) = -(psi(xll, yll+dy) - psi(xll,yll)) / dy
            aux(2,i,j) =  (psi(xll+dx, yll) - psi(xll,yll)) / dx

            !! # multiply by time-factor:
            aux(1,i,j) = vt * aux(1,i,j)
            aux(2,i,j) = vt * aux(2,i,j)
        ENDDO
    ENDDO
RETURN
END SUBROUTINE clawpack5_b4step2


! Copyright (c) 2021, University of Colorado Denver. All rights reserved.
!
! This file is part of <T>LAPACK.
! <T>LAPACK is free software: you can redistribute it and/or modify it under
! the terms of the BSD 3-Clause license. See the accompanying LICENSE file.

program example_fortranWrapper_ssymm
use constants
implicit none

    ! Constants
    character, parameter :: layout = 'C', side = 'L', uplo = 'U'
    integer(blas_size), parameter :: m = 100, n = 200, incx = 1e0
    integer(blas_size), parameter :: lda = m, ldb = m, ldc = m

    ! Arrays with zeros
    real(sp) :: A(m,m), B(m,n), C(m,n)

    ! Local variables
    integer(blas_size) :: i, j

    ! Error measurements
    real(sp) :: errorF

    ! External functions
    external :: ssymm
    real(sp), external :: snrm2
    intrinsic :: random_number, min

    ! Initialize A with random numbers
    call random_number( A )

    ! Put junk in the lower part of A
    do j = 1, m
        do i = j+1, m
            A(i,j) = -6.2598534e+18
        end do
    end do

    ! Set C using A
    do j = 1, min(m,n)
        do i = 1, j-1
            C(i,j) = A(i,j)
            C(j,i) = C(i,j)
        end do
        C(j,j) = A(j,j)
    end do

    ! Set the main diagonal of B with ones
    do i = 1, min(m,n)
        B(i,i) = 1.e0
    end do

    ! Call ssymm
    call ssymm( &
        layout, side, uplo, m, n, -1.e0, &
        A, lda, B, ldb, 1.e0, C, ldc )

    ! Call snrm2
    errorF = snrm2( m*n, C, incx )

    ! Output
    print *, "||C-AB||_F = ", errorF

end program


*DECK DCOSDG
      DOUBLE PRECISION FUNCTION DCOSDG (X)
C***BEGIN PROLOGUE  DCOSDG
C***PURPOSE  Compute the cosine of an argument in degrees.
C***LIBRARY   SLATEC (FNLIB)
C***CATEGORY  C4A
C***TYPE      DOUBLE PRECISION (COSDG-S, DCOSDG-D)
C***KEYWORDS  COSINE, DEGREES, ELEMENTARY FUNCTIONS, FNLIB,
C             TRIGONOMETRIC
C***AUTHOR  Fullerton, W., (LANL)
C***DESCRIPTION
C
C DCOSDG(X) calculates the double precision trigonometric cosine
C for double precision argument X in units of degrees.
C
C***REFERENCES  (NONE)
C***ROUTINES CALLED  (NONE)
C***REVISION HISTORY  (YYMMDD)
C   770601  DATE WRITTEN
C   890531  Changed all specific intrinsics to generic.  (WRB)
C   890531  REVISION DATE from Version 3.2
C   891214  Prologue converted to Version 4.0 format.  (BAB)
C***END PROLOGUE  DCOSDG
      DOUBLE PRECISION X, RADDEG
      SAVE RADDEG
      DATA RADDEG / 0.0174532925 1994329576 9236907684 886 D0 /
C***FIRST EXECUTABLE STATEMENT  DCOSDG
      DCOSDG = COS (RADDEG*X)
C
      IF (MOD(X,90.D0).NE.0.D0) RETURN
      N = ABS(X)/90.D0 + 0.5D0
      N = MOD (N, 2)
      IF (N.EQ.0) DCOSDG = SIGN (1.0D0, DCOSDG)
      IF (N.EQ.1) DCOSDG = 0.0D0
C
      RETURN
      END


! { dg-do compile }
! This is the list of intrinsics allowed as actual arguments
 intrinsic abs,acos,acosh,aimag,aint,alog,alog10,amod,anint,asin,asinh,atan,&
 atan2,atanh,cabs,ccos,cexp,clog,conjg,cos,cosh,csin,csqrt,dabs,dacos,&
 dacosh,dasin,dasinh,datan,datan2,datanh,dconjg,dcos,dcosh,ddim,dexp,dim,&
 dimag,dint,dlog,dlog10,dmod,dnint,dprod,dsign,dsin,dsinh,dsqrt,dtan,dtanh,&
 exp,iabs,idim,idnint,index,isign,len,mod,nint,sign,sin,sinh,sqrt,tan,&
 tanh,zabs,zcos,zexp,zlog,zsin,zsqrt

  call foo(abs)
  call foo(acos)
  call foo(acosh)
  call foo(aimag)
  call foo(aint)
  call foo(alog)
  call foo(alog10)
  call foo(amod)
  call foo(anint)
  call foo(asin)
  call foo(asinh)
  call foo(atan)
  call foo(atan2)
  call foo(atanh)
  call foo(cabs)
  call foo(ccos)
  call foo(cexp)
  call foo(clog)
  call foo(conjg)
  call foo(cos)
  call foo(cosh)
  call foo(csin)
  call foo(csqrt)
  call foo(dabs)
  call foo(dacos)
  call foo(dacosh)
  call foo(dasin)
  call foo(dasinh)
  call foo(datan)
  call foo(datan2)
  call foo(datanh)
  call foo(dconjg)
  call foo(dcos)
  call foo(dcosh)
  call foo(ddim)
  call foo(dexp)
  call foo(dim)
  call foo(dimag)
  call foo(dint)
  call foo(dlog)
  call foo(dlog10)
  call foo(dmod)
  call foo(dnint)
  call foo(dprod)
  call foo(dsign)
  call foo(dsin)
  call foo(dsinh)
  call foo(dsqrt)
  call foo(dtan)
  call foo(dtanh)
  call foo(exp)
  call foo(iabs)
  call foo(idim)
  call foo(idnint)
  call foo(index)
  call foo(isign)
  call foo(len)
  call foo(mod)
  call foo(nint)
  call foo(sign)
  call foo(sin)
  call foo(sinh)
  call foo(sqrt)
  call foo(tan)
  call foo(tanh)
  call foo(zabs)
  call foo(zcos)
  call foo(zexp)
  call foo(zlog)
  call foo(zsin)
  call foo(zsqrt)
  end


! https://stackoverflow.com/questions/8155160/metis-with-fortran
! http://glaros.dtc.umn.edu/gkhome/node/799

program test_PartGraphRecursive1

    use metis_interface, only: idx_t, METIS_PartGraphRecursive, METIS_OK
    implicit none

    integer(idx_t), parameter :: nvtxs = 15     ! number of vertices
    integer(idx_t), parameter :: nedgs = 22     ! number of edges

    integer(idx_t) :: xadj(nvtxs+1),adjncy(2*nedgs) ! adjacency arrays
    integer(idx_t) :: part(nvtxs)                   ! partition vector
    integer(idx_t) :: objval, ios, ncon, nparts

    write(*,'(A)') "TEST METIS_PartGraphRecursive 1"

    !  0---1---2---3---4
    !  |   |   |   |   |
    !  5---6---7---8---9
    !  |   |   |   |   |
    ! 10--11--12--13--14

    ! Note that we are using C-style numbering!

    xadj = [0,2,5,8,11,13,16,20,24,28,31,33,36,39,42,44]
    adjncy = [1,5,0,2,6,1,3,7,2,4,8,3,9,0,6,10,1,5,7,11,2,6,8,12,3,7,9,13,4,8,14,5,11,6,10,12,7,11,13,8,12,14,9,13]

    ncon = 1
    nparts = 2
    ios = METIS_PartGraphRecursive(nvtxs,ncon,xadj=xadj,adjncy=adjncy,nparts=nparts,objval=objval,part=part)
    if (ios /= METIS_OK) then
        write(*,*) "METIS_PartGraphRecursive failed with error: ", ios
        error stop 1
    end if

    write(*,'(A,I0)') "objval = ", objval
    write(*,'(A,*(I1,:,1X))') "part = ", part

end program


      program DRSNML
c>> 2001-05-25 DRSCDNML Krogh Added comma to format.
c>> 1996-05-28 DRSCDNML Krogh  Changes to use M77CON
c>> 1994-07-06 DRSCDNML WV Snyder JPL set up for CHGTYP
c>> 1994-04-12 DRSCDNML WV Snyder JPL repair format to display sign
c
c     Evaluate the Cumulative Normal Distribution using SCDNML.
c
c--S replaces "?": DR?NML, DR?CDNML, ?CDNML, ?PPNML
      real             SCDNML, SPPNML
      external SCDNML, SPPNML
      real             X, C, P, MU, SIGMA
c
10    format ('        X       C=SCDNML(X)     SPPNML(C)')
20    format (1x,1p,2g14.7,2x,g14.7)
      x = -4.0e0
      mu = 0.0e0
      sigma = 1.0e0
      print 10
30    if (x .le. 4.0e0) then
         c = scdnml(x,mu,sigma)
         p = sppnml(c,mu,sigma)
         print 20, x, c, p
         x = x + 0.5e0
         go to 30
      end if
      stop
      end


module LseSolvers
    use omp_lib
    use Const
    use Utils
    use IO_array
    implicit none

contains
 ! для нормировки строки, одна и та же в методе Гаусса и Жордана.
     subroutine norm_line(arr)
         real(mpc), intent(inout), dimension(:) :: arr
         if (abs(arr(1)) < eps) write (stderr, *) arr(1), "Division may produce incorrect result"
         arr = arr / arr(1)
     end subroutine norm_line

 ! общая функция для вычитания строки (для диагонализации)
     subroutine substract(a)
         real(mpc), intent(inout), dimension(:, :) :: a
         integer :: i, n, m
         n = size(a, 1); m = size(a, 2)
         !$omp parallel
         !$omp workshare
         forall (i = 2:n)
             a(i,:) = a(i,:) - a(1,:) * a(i, 1)
         end forall
         !$omp end workshare
         !$omp end parallel
     end subroutine substract

     subroutine remove_sing(a, k, permt)
         real(mpc), intent(inout), dimension(:, :) :: a
         integer, dimension(size(a, 1)), intent(inout) :: permt
         integer :: k, n, pos(2)
         intent(in) :: k
         n = size(a,1)
         pos = maxloc(abs(a(k:n, k:n))) + (/ k-1, k-1 /)
         permt(k) = pos(2) ! номер столбца (ну то есть строки,
                           ! но оно всё транспонированное хранится)
         call swap(a, k, pos(1), a_cols=.TRUE.)
         call swap(a, k, pos(2))
     end subroutine remove_sing

     function gauss_solve(a, is_mod) result(x)
         real(mpc), intent(in), dimension(:, :) :: a
         real(mpc), dimension(size(a, 1), size(a, 2)) :: a1 ! портить матрицу некультурно
         real(mpc), dimension(size(a, 1)) :: x
         real(mpc) :: tmp
         logical, intent(in), optional :: is_mod
         logical :: c_is_mod
         integer :: k, n, permt(size(a, 1))
         n = size(a, 1)
         a1 = a
         if (.not. present(is_mod)) c_is_mod = .TRUE.

         ! тут похоже нигде не распараллелить, проход последовательный
         do k = 1, n
             if (c_is_mod) call remove_sing(a1, k, permt)
             call norm_line(a1(k, k:n+1))
             call substract(a1(k:n, k:n+1))
         end do

         ! и здесь тоже..
         do k = n,1,-1
             x(k) = a1(k, n+1) - dot_product(a1(k, k+1:n), x(k+1:n))
         end do
         if (c_is_mod) then
         do k = n, 1, -1
             tmp = x(k)
             x(k) = x(permt(k))
             x(permt(k)) = tmp
         end do
         end if
     end function gauss_solve

     function jordan_solve(a) result(x)
         real(mpc), intent(in), dimension(:, :) :: a
         real(mpc), dimension(size(a, 1), size(a, 2)) :: a1
         real(mpc), dimension(size(a, 1)) :: x
         integer :: k, n
         n = size(a, 1)
         a1 = a
         do k = 1, n
             call norm_line(a1(k, k:n+1))
             call substract(a1(k:n, k:n+1))
             call reverse_cols(a1(1:k, k:n+1))
             call substract(a1(1:k, k:n+1))
             call reverse_cols(a1(1:k, k:n+1))
         end do
         x = a1(:, n+1)
     end function jordan_solve

end module LseSolvers


program main
    use global_variables
    use input
    use derived_parameters
    use rhs
    use DVODE_F90_M
    use calculations
    implicit none

    double precision, allocatable :: ATOL(:), Y(:)
    double precision :: RTOL, T, TOUT, RSTATS
    integer :: NEQ, ITASK, ISTATE, ISTATS, IOUT, IERROR, R, kk, STEPS
    DIMENSION :: RSTATS(22), ISTATS(31)
    TYPE(VODE_OPTS) :: OPTIONS
    OPEN(UNIT=6, FILE = 'results_raw.dat')

    call read_inputfile()
    call derived_param()

    NEQ = (N_modes*2)+1

    allocate(Y(NEQ))
    allocate(ATOL(NEQ))

    n10 = p10/(kB*Temp);
    Y(NEQ) = n10;
    do kk = 1, N_modes
        Y(2*kk-1) = N_init(kk);
		Y(2*kk-0) = v_init(kk)*Y(2*kk-1);
    end do

	! Error Tolerances
    do kk = 2, N_modes
        ATOL(2*kk-1) = (1D-20)
        ATOL(2*kk-0) = (1D-30)
    end do
    ATOL(NEQ) = (1D-10)
    RTOL = 1D-6

    T = 0
    TOUT = dt
    STEPS = t_final/dt
    ITASK = 1
    ISTATE = 1
    OPTIONS = SET_OPTS(RELERR=RTOL,ABSERR_VECTOR=ATOL)

	WRITE(6,63)T,Y
	time(1) = T
	nlines = 1
    do IOUT = 1,STEPS
        call DVODE_F90(FEX,NEQ,Y,T,TOUT,ITASK,ISTATE,OPTIONS)
        CALL GET_STATS(RSTATS,ISTATS)
        WRITE(6,63)T,Y
       TOUT = TOUT + dt
       time(IOUT+1) = T
	   nlines = nlines + 1
    end do

63  FORMAT(100E14.6)
call calc()
end program main


      PROGRAM FFT

!***********************************************************************
!* Computes the DFT Magnitude and Phase of a UDS Y-Series File.
!*
!* Language: Fortran
!*
!* Author: Stuart G. Mentzer
!*
!* Date: 2003/07/18
!***********************************************************************

      ! Headers
      INCLUDE 'uds_str.fi'
      INCLUDE 'uds_fxn.fi'
      INCLUDE 'file.fi'

      ! Variables ______________________________________________________

      RECORD /UDS_Y/  U
      RECORD /UDS_CONTROL/  C
      RECORD /FILE/  HIT, REPORT, OUTPUT_LIST

      LOGICAL ALL_BATCH, NO_BATCH, NO_INCR, ONE_PASS, NEW_HIT, EOF,
     & BATCH, GROUP, NEW_GROUP

      INTEGER NUM_ARGS, MAX_ARGS, IOS, I, M_MIN, M_MAX

      PARAMETER ( MAX_ARGS = 12 )

      REAL Y_PHS(0:NLP_U), PAD_FAC

      COMPLEX Y_DFT(0:NLP_2)

      EQUIVALENCE ( Y_PHS, Y_DFT ) ! Space saving - DFT not used

      CHARACTER CL_ARG(0:MAX_ARGS)*255, PROG_NAME*8,
     & TEMPLATE_STR*255, DIR_OUT*255,
     & FILE_NAME*255, OUT_FILE*255, DEF_FILE*255,
     & PROMPT*79,
     & OUTPUTS*2, MAG_OUT, PHS_OUT

      ! Initializations
      PROG_NAME = 'FFT'
      CALL FILE_INIT( HIT )
      CALL GET_CL( CL_ARG, NUM_ARGS, MAX_ARGS )
      CALL FFT_CL( CL_ARG, NUM_ARGS, PROG_NAME, OUTPUTS )
      CALL PROC_CL( CL_ARG, NUM_ARGS, PROG_NAME, TEMPLATE_STR,
     & ALL_BATCH, NO_BATCH, NO_INCR, REPORT, OUTPUT_LIST, DIR_OUT,
     & ONE_PASS, .TRUE., .TRUE. )
      PROMPT = 'UDS file name/template/hitlist?'
      PROMPT(74:) = '[done]'
      CALL UDS_CONTROL_INIT( C )
      C.CHANFORM = 'Y' ! Only accept Y-series file input
      M_MAX = INT( ( LOG( REAL( NLP_2 ) ) / LOG( 2. ) ) *
     & ( 1. + 2.E-7 ) )

      WRITE( *, '(//17X,A//)' )
     & '**  Discrete Fourier Transform Computation  **'

      ! Read the file name/template/hitlist
  100 CALL FILE_PROMPT( TEMPLATE_STR, PROMPT, DIR_OUT,
     & ONE_PASS, HIT, NEW_HIT, FILE_NAME, EOF )
      IF ( ( FILE_NAME .EQ. ' ' ) .OR. ( EOF ) ) GO TO 199 ! Done

      ! Batch setup
      CALL BAT_SET( ALL_BATCH, NO_BATCH, NEW_HIT, HIT, BATCH )
      CALL GROUP_SET( HIT, NEW_HIT, BATCH, 2, GROUP, NEW_GROUP )

      ! Group prompts
      IF ( NEW_GROUP ) THEN

        ! DFT magnitude files
  101   IF ( OUTPUTS(1:1) .NE. ' ' ) THEN
          MAG_OUT = 'Y'
        ELSE IF ( OUTPUTS .NE. ' ' ) THEN
          MAG_OUT = 'N'
        ELSE
          WRITE( *, '(/A,46X,A/'' >> '',$)' )
     &     ' DFT magnitude files?   (Y/N)', '[Yes]'
          READ( *, '(A)', IOSTAT=IOS ) MAG_OUT
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          CALL STR_UP( MAG_OUT )
          IF ( .NOT. ANY_CHARS( MAG_OUT, ' YN' ) ) THEN
            WRITE( *, * ) '*** Invalid response'
            GO TO 101
          END IF
        END IF

        ! DFT phase files
  102   IF ( OUTPUTS(2:2) .NE. ' ' ) THEN
          PHS_OUT = 'Y'
        ELSE IF ( OUTPUTS .NE. ' ' ) THEN
          PHS_OUT = 'N'
        ELSE
          WRITE( *, '(/A,50X,A/'' >> '',$)' )
     &     ' DFT phase files?   (Y/N)', '[Yes]'
          READ( *, '(A)', IOSTAT=IOS ) PHS_OUT
          IF ( IOS .NE. 0 ) THEN
            CALL MSG_WRITE( '*** Operation skipped', REPORT )
            CALL FILE_DEL( HIT )
            GO TO 190
          END IF
          CALL STR_UP( PHS_OUT )
          IF ( .NOT. ANY_CHARS( PHS_OUT, ' YN' ) ) THEN
            WRITE( *, * ) '*** Invalid response'
            GO TO 102
          END IF
        END IF

      END IF

      ! Read UDS file
      CALL REP_COLS( REPORT )
      CALL UDS_GET( FILE_NAME, U, C, REPORT, IOS )
      IF ( IOS .NE. 0 ) GO TO 190

      ! Check file fields
      IF ( ( U.CURTYP .NE. 'TIME SERIES' ) .OR.
     & ( U.XTYP .NE. 'TIME' ) .OR.
     & ( U.XUNITS .NE. 'SECONDS' ) )
     & CALL MSG_WRITE( '*** WARNING - Not a time series file',
     & REPORT )
      IF ( U.NFP .GT. 0 ) THEN
        CALL MSG_WRITE( '*** Zero-filling initial portion of signal',
     &   REPORT )
        DO I = 0, U.NFP-1
          U.Y(I) = 0.
        END DO
      END IF
      IF ( U.NLP .LE. 0 ) THEN
        CALL MSG_WRITE( '*** ERROR - Final index <= 0', REPORT )
        GO TO 190
      END IF
      IF ( U.DEL .LE. 0. ) THEN
        CALL MSG_WRITE( '*** ERROR - Nonpositive x-axis step',
     &   REPORT )
        GO TO 190
      END IF

      ! Prepare output fields
      U.XTYP = 'FREQUENCY'
      IF ( U.XUNITS .EQ. 'SECONDS' ) THEN
        U.XUNITS = 'HZ'
      ELSE
        U.XUNITS = ' '
      END IF
      U.NFP = 0
      U.FSTP = 1. / ( 2. * U.DEL )
      U.FCOR = U.FSTP
      U.FCUT = U.FSTP
      U.STATUS = 'COMPUTED'

      ! Compute DFT with FFT algorithm
      PAD_FAC = 2.5 ! Length padding factor
      M_MIN = 6 ! Minimum power of 2 to use for length
      CALL FFT_S( U.Y(0), U.Y(0), Y_PHS, NLP_U, U.NLP, Y_DFT, NLP_2,
     & U.DEL, PAD_FAC, M_MIN, IOS )
      IF ( IOS .NE. 0 ) THEN
        CALL MSG_WRITE( '*** ERROR - FFT computation failed', REPORT )
        GO TO 190
      END IF

      ! Set default magnitude file name
      OUT_FILE = FILE_NAME
      CALL FN_EXTRACT( OUT_FILE )
      CALL FN_FLAG( OUT_FILE, 'dm', 2, I )
      CALL ADD_PATH( DIR_OUT, OUT_FILE )
      IF ( .NOT. NO_INCR ) CALL FN_INCR( OUT_FILE )
      CALL FN_NAME_EXTRACT( OUT_FILE )
      DEF_FILE = OUT_FILE

      ! Get the magnitude UDS file name
      IF ( .NOT. BATCH ) THEN
  120   IF ( ( OUTPUTS .EQ. ' ' ) .OR.
     &   ( OUTPUTS(1:1) .NE. ' ' ) ) THEN
          WRITE( *, '(/A/3A/'' >> '',$)' )
     &     ' DFT magnitude file name?   ( N - None )',
     &     ' [', DEF_FILE(:L_TRIM(DEF_FILE)), ']'
          READ( *, '(A)', END=190 ) OUT_FILE
          IF ( OUT_FILE .EQ. ' ' ) THEN ! Use default file name
            OUT_FILE = DEF_FILE
          ELSE IF ( ( OUT_FILE .EQ. 'N' ) .OR.
     &     ( OUT_FILE .EQ. 'n' ) ) THEN ! No output file
            OUT_FILE(1:1) = 'N'
          ELSE ! Check file name validity
            CALL ADD_PATH( DIR_OUT, OUT_FILE )
            IF ( .NOT. FN_VALID( OUT_FILE ) ) THEN
              WRITE( *, * ) '*** Invalid file name'
              GO TO 120
            END IF
          END IF
        ELSE
          OUT_FILE = 'N'
        END IF
      ELSE ! Batch
        IF ( MAG_OUT .EQ. 'N' ) THEN
          OUT_FILE = 'N'
        ELSE
          OUT_FILE = DEF_FILE
        END IF
      END IF

      ! Write the magnitude UDS file
      IF ( OUT_FILE .NE. 'N' ) THEN
        ! Prepare magnitude output fields
        U.CURTYP = 'DFT MAG.'
        WRITE ( U.CURDSC, '(A)', IOSTAT=IOS )
     &   'Discrete Fourier Transform Magnitude'

        CALL UDS_PUT( OUT_FILE, U, C, REPORT, OUTPUT_LIST,
     &   DIR_OUT, .TRUE., IOS )
        IF ( IOS .NE. 0 ) GO TO 190
      END IF

      ! Construct default phase UDS file name
      OUT_FILE = FILE_NAME
      CALL FN_EXTRACT( OUT_FILE )
      CALL FN_FLAG( OUT_FILE, 'dp', 2, I )
      CALL ADD_PATH( DIR_OUT, OUT_FILE )
      IF ( .NOT. NO_INCR ) CALL FN_INCR( OUT_FILE )
      CALL FN_NAME_EXTRACT( OUT_FILE )
      DEF_FILE = OUT_FILE

      ! Get the phase UDS file name
      IF ( .NOT. BATCH ) THEN
  130   IF ( ( OUTPUTS .EQ. ' ' ) .OR.
     &   ( OUTPUTS(2:2) .NE. ' ' ) ) THEN
          WRITE( *, '(/A/3A/'' >> '',$)' )
     &     ' DFT phase file name?   ( N - None )',
     &     ' [', DEF_FILE(:L_TRIM(DEF_FILE)), ']'
          READ( *, '(A)', END=190 ) OUT_FILE
          IF ( OUT_FILE .EQ. ' ' ) THEN ! Use default file name
            OUT_FILE = DEF_FILE
          ELSE IF ( ( OUT_FILE .EQ. 'N' ) .OR.
     &     ( OUT_FILE .EQ. 'n' ) ) THEN ! No output file
            OUT_FILE(1:1) = 'N'
          ELSE ! Check file name validity
            CALL ADD_PATH( DIR_OUT, OUT_FILE )
            IF ( .NOT. FN_VALID( OUT_FILE ) ) THEN
              WRITE( *, * ) '*** Invalid file name'
              GO TO 130
            END IF
          END IF
        ELSE
          OUT_FILE = 'N'
        END IF
      ELSE ! Batch
        IF ( PHS_OUT .EQ. 'N' ) THEN
          OUT_FILE = 'N'
        ELSE
          OUT_FILE = DEF_FILE
        END IF
      END IF

      ! Write the phase UDS file
      IF ( OUT_FILE .NE. 'N' ) THEN
        ! Assign phase
        DO I = 0, U.NLP
          U.Y(I) = Y_PHS(I)
        END DO

        ! Prepare phase output fields
        U.YTYP = 'PHASE ANGLE'
        U.YUNITS = 'DEGREES'
        U.CURTYP = 'DFT PHASE'
        WRITE ( U.CURDSC, '(A)', IOSTAT=IOS )
     &   'Discrete Fourier Transform Phase Angle'

        CALL UDS_PUT( OUT_FILE, U, C, REPORT, OUTPUT_LIST,
     &   DIR_OUT, .TRUE., IOS )
      END IF

      ! Loop for next file
  190 WRITE( *, '(80(''_''))' )
      GO TO 100

      ! Clean up and stop
  199 CALL CLEAN_UP( HIT, REPORT, OUTPUT_LIST, DIR_OUT )

      END

      SUBROUTINE FFT_CL( CL_ARG, NUM_ARGS, PROG_NAME, OUTPUTS )

!***********************************************************************
!* Processes the Program-Specific Command Line Arguments
!***********************************************************************

      ! Arguments ______________________________________________________

      CHARACTER*(*) CL_ARG(0:*) ! Command line argument array

      INTEGER NUM_ARGS ! Number of arguments

      CHARACTER*(*) PROG_NAME ! Program name

      CHARACTER*(*) OUTPUTS ! Indicates magnitude &/or phase outputs

      ! Variables ______________________________________________________

      INTEGER I, NS

      CHARACTER ARG*255, C

      ! Process command line arguments
      OUTPUTS = ' '
      DO I = 1, NUM_ARGS
        CALL STR_UPCASE( ARG, CL_ARG(I) )
        C = ARG(1:1)
        IF ( ( C .EQ. '-' ) .OR. ( C .EQ. '/' ) ) THEN
          NS = 2
        ELSE
          NS = 1
        END IF
        IF ( ( ARG(NS:) .EQ. '?' ) .OR.
     &   ( ARG(NS:) .EQ. '??' ) .OR.
     &   ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line syntax
          CALL SYNTAX_CL( PROG_NAME )
          WRITE( *, '(10X,A)' ) '[MAG|PHASE|BOTH]'
          IF ( ( ARG(NS:) .EQ. '??' ) .OR.
     &     ( ARG(NS:) .EQ. 'HELP' ) ) THEN ! Show command line help
            CALL HELP_CL( PROG_NAME )
            WRITE( *, '(2(10X,A/),10X,A)' )
     &       'MAG :  Magnitude output only',
     &       'PHASE :  Phase output only',
     &       'BOTH :  Magnitude and phase outputs'
          END IF
          STOP ' '
        ELSE IF ( ARG(NS:) .EQ. 'MAG' ) THEN
          OUTPUTS = 'X '
          CL_ARG(I) = ' '
        ELSE IF ( ARG(NS:) .EQ. 'PHASE' ) THEN
          OUTPUTS = ' X'
          CL_ARG(I) = ' '
        ELSE IF ( ARG(NS:) .EQ. 'BOTH' ) THEN
          OUTPUTS = 'XX'
          CL_ARG(I) = ' '
        END IF
      END DO

      RETURN
      END


program random_numbers
    use, intrinsic :: iso_fortran_env, only : error_unit
    implicit none
    integer, parameter :: nr_vals = 3
    integer :: seed_size, istat, i
    integer, dimension(:), allocatable :: seed_vals, new_seed_vals
    real :: r

    ! check how many integers are required to seed the RNG
    call random_seed(size=seed_size)
    print '(A, I0)', 'number of seeds: ', seed_size

    ! allocate the array to hold the seeds
    allocate (seed_vals(seed_size), new_seed_vals(seed_size), stat=istat)
    if (istat /= 0) then
        write (unit=error_unit, fmt='(A)') 'error: can not allocate seed'
        stop 1
    end if

    ! get the current seed values
    call random_seed(get=seed_vals)
    print '(A, *(I12))', 'seeds: ', seed_vals

    ! print some random numbers
    print '(A)', 'values:'
    do i = 1, nr_vals
        call random_number(r)
        print '(F10.7)', r
    end do

    ! get current seed
    call random_seed(get=new_seed_vals)
    print '(A, *(I12))', 'current seeds: ', new_seed_vals

    ! reseed
    call random_seed(put=seed_vals)
    print '(A)', 'values after reseed:'
    do i = 1, nr_vals
        call random_number(r)
        print '(F10.7)', r
    end do

    ! clean up
    deallocate(seed_vals)
end program random_numbers