subroutine airy_ai_values ( n_data, x, ai ) !*****************************************************************************80 ! !! airy_ai_values() returns some values of the Airy Ai(x) function. ! ! Discussion: ! ! The Airy functions Ai(X) and Bi(X) are a pair of linearly independent ! solutions of the differential equation: ! ! W'' - X * W = 0 ! ! In Mathematica, the function can be evaluated by: ! ! AiryAi[x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) AI, the value of the Airy AI function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 11 real ( kind = rk ) ai real ( kind = rk ), save, dimension ( n_max ) :: ai_vec = (/ & 0.3550280538878172D+00, & 0.3292031299435381D+00, & 0.3037031542863820D+00, & 0.2788064819550049D+00, & 0.2547423542956763D+00, & 0.2316936064808335D+00, & 0.2098000616663795D+00, & 0.1891624003981501D+00, & 0.1698463174443649D+00, & 0.1518868036405444D+00, & 0.1352924163128814D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.0D+00, & 0.1D+00, & 0.2D+00, & 0.3D+00, & 0.4D+00, & 0.5D+00, & 0.6D+00, & 0.7D+00, & 0.8D+00, & 0.9D+00, & 1.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 ai = 0.0D+00 else x = x_vec(n_data) ai = ai_vec(n_data) end if return end subroutine airy_ai_prime_values ( n_data, x, aip ) !*****************************************************************************80 ! !! airy_ai_prime_values() returns some values of the Airy function Ai'(x). ! ! Discussion: ! ! The Airy functions Ai(X) and Bi(X) are a pair of linearly independent ! solutions of the differential equation: ! ! W'' - X * W = 0 ! ! In Mathematica, the function can be evaluated by: ! ! AiryAiPrime[x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) AIP, the derivative of the Airy AI function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 11 real ( kind = rk ) aip real ( kind = rk ), save, dimension ( n_max ) :: aip_vec = (/ & -0.2588194037928068D+00, & -0.2571304219075862D+00, & -0.2524054702856195D+00, & -0.2451463642190548D+00, & -0.2358320344192082D+00, & -0.2249105326646839D+00, & -0.2127932593891585D+00, & -0.1998511915822805D+00, & -0.1864128638072717D+00, & -0.1727638434616347D+00, & -0.1591474412967932D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.0D+00, & 0.1D+00, & 0.2D+00, & 0.3D+00, & 0.4D+00, & 0.5D+00, & 0.6D+00, & 0.7D+00, & 0.8D+00, & 0.9D+00, & 1.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 aip = 0.0D+00 else x = x_vec(n_data) aip = aip_vec(n_data) end if return end subroutine airy_bi_values ( n_data, x, bi ) !*****************************************************************************80 ! !! airy_bi_values() returns some values of the Airy Bi(x) function. ! ! Discussion: ! ! The Airy functions Ai(X) and Bi(X) are a pair of linearly independent ! solutions of the differential equation: ! ! W'' - X * W = 0 ! ! In Mathematica, the function can be evaluated by: ! ! AiryBi[x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) BI, the value of the Airy BI function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 11 real ( kind = rk ) bi real ( kind = rk ), save, dimension ( n_max ) :: bi_vec = (/ & 0.6149266274460007D+00, & 0.6598616901941892D+00, & 0.7054642029186612D+00, & 0.7524855850873156D+00, & 0.8017730000135972D+00, & 0.8542770431031555D+00, & 0.9110633416949405D+00, & 0.9733286558781659D+00, & 0.1042422171231561D+01, & 0.1119872813134447D+01, & 0.1207423594952871D+01 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.0D+00, & 0.1D+00, & 0.2D+00, & 0.3D+00, & 0.4D+00, & 0.5D+00, & 0.6D+00, & 0.7D+00, & 0.8D+00, & 0.9D+00, & 1.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 bi = 0.0D+00 else x = x_vec(n_data) bi = bi_vec(n_data) end if return end subroutine airy_bi_prime_values ( n_data, x, bip ) !*****************************************************************************80 ! !! airy_bi_prime_values() returns some values of the Airy function Bi'(x). ! ! Discussion: ! ! The Airy functions Ai(X) and Bi(X) are a pair of linearly independent ! solutions of the differential equation: ! ! W'' - X * W = 0 ! ! In Mathematica, the function can be evaluated by: ! ! AiryBiPrime[x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) BIP, the derivative of the Airy BI function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 11 real ( kind = rk ) bip real ( kind = rk ), save, dimension ( n_max ) :: bip_vec = (/ & 0.4482883573538264D+00, & 0.4515126311496465D+00, & 0.4617892843621509D+00, & 0.4800490287524480D+00, & 0.5072816760506224D+00, & 0.5445725641405923D+00, & 0.5931444786342857D+00, & 0.6544059191721400D+00, & 0.7300069016152518D+00, & 0.8219038903072090D+00, & 0.9324359333927756D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.0D+00, & 0.1D+00, & 0.2D+00, & 0.3D+00, & 0.4D+00, & 0.5D+00, & 0.6D+00, & 0.7D+00, & 0.8D+00, & 0.9D+00, & 1.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 bip = 0.0D+00 else x = x_vec(n_data) bip = bip_vec(n_data) end if return end function alngam ( x ) !*****************************************************************************80 ! !! alngam() computes the log of the absolute value of the Gamma function. ! ! Discussion: ! ! The Gamma function is defined as ! ! GAMMA(Z) = INTEGRAL ( 0 <= T < +oo ) T^(Z-1) EXP ( -T ) DT ! ! If Z is a positive integer, GAMMA(Z) = (Z-1)!, the factorial. ! ! There is a special value: ! ! GAMMA(0.5) = SQRT ( PI ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 31 May 2000 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of the gamma function. ! ! Output, real ( kind = rk ) ALNGAM, the logarithm of the absolute ! value of GAMMA(X). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) alngam real ( kind = rk ) d9lgmc real ( kind = rk ), save :: dxrel = 0.0D+00 real ( kind = rk ) gamma real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) sinpiy real ( kind = rk ), parameter :: sq2pil = 0.91893853320467274D+00 real ( kind = rk ), parameter :: sqpi2l = 0.22579135264472743D+00 real ( kind = rk ) x real ( kind = rk ), save :: xmax = 0.0D+00 real ( kind = rk ) y if ( xmax == 0.0D+00 ) then xmax = huge ( xmax ) / log ( huge ( xmax ) ) dxrel = sqrt ( epsilon ( dxrel ) ) end if y = abs ( x ) if ( y <= 10.0D+00 ) then alngam = log ( abs ( gamma ( x ) ) ) return end if if ( xmax < y ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ALNGAM - Fatal error!' write ( *, '(a)' ) ' |X| is so big that ALNGAM will overflow.' stop end if if ( 0.0D+00 < x ) then alngam = sq2pil + ( x - 0.5D+00 ) * log ( x ) - x + d9lgmc ( y ) return end if sinpiy = abs ( sin ( pi * y ) ) if ( sinpiy == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ALNGAM - Fatal error!' write ( *, '(a)' ) ' X is a negative integer.' stop end if if ( abs ( ( x - real ( int ( x - 0.5D+00 ), kind = rk ) ) / x ) < dxrel ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ALNGAM - Warning:' write ( *, '(a)' ) ' Answer has less than half usual precision.' write ( *, '(a)' ) ' X is very near a negative integer.' end if alngam = sqpi2l + ( x - 0.5D+00 ) * log ( y ) - x - log ( sinpiy ) & - d9lgmc ( y ) return end subroutine asyjy ( funjy, x, fnu, flgjy, in, y, wk, iflw ) !*****************************************************************************80 ! !! asyjy() computes high order Bessel functions J and Y. ! ! Discussion: ! ! ASYJY implements the uniform asymptotic expansion of ! the J and Y Bessel functions for 35 <= FNU and 0.0 < X. ! ! The forms are identical except for a change ! in sign of some of the terms. This change in sign is ! accomplished by means of the flag FLGJY = 1 or -1. ! ! On FLGJY = 1 the Airy functions AI(X) and DAI(X) are ! supplied by the external function JAIRY, and on ! FLGJY = -1 the Airy functions BI(X) and DBI(X) are ! supplied by the external funtion YAIRY. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 August 2001 ! ! Author: ! ! Donald Amos ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, external FUNJY, is the function JAIRY or YAIRY. ! ! Input, real ( kind = rk ) X, the argument, which must be greater than 0. ! ! Input, real ( kind = rk ) FNU, the order of the first Bessel function. ! FNU is generally at least 35. ! ! Input, real ( kind = rk ) FLGJY, a selection flag ! 1.0D+00 gives the J function ! -1.0D+00 gives the Y function ! ! Input, integer IN, the number of functions desired, which ! should be 1 or 2. ! ! Output, real ( kind = rk ) Y(IN), contains the desired function values. ! ! Output, integer IFLW, a flag indicating underflow or overflow ! return variables for BESJ only. ! ! Output, real ( kind = rk ) WK(7), contains the following values: ! ! wk(1) = 1 - (x/fnu)^2 = w^2 ! wk(2) = sqrt ( abs ( wk(1) ) ) ! wk(3) = abs ( wk(2) - atan ( wk(2) ) ) or ! abs ( ln((1 + wk(2) )/ ( x / fnu ) ) - wk(2)) ! = abs ( (2/3)*zeta^(3/2)) ! wk(4) = fnu*wk(3) ! wk(5) = (1.5*wk(3) * fnu)^(1/3) = sqrt ( zeta ) * fnu^(1/3) ! wk(6) = sign ( 1.0, w^2 ) * wk(5)^2 ! = sign ( 1.0, w^2 ) * zeta * fnu^(2/3) ! wk(7) = fnu**(1/3) ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) abw2 real ( kind = rk ) akm real ( kind = rk ) alfa(26,4) real ( kind = rk ) alfa1(26,2) real ( kind = rk ) alfa2(26,2) real ( kind = rk ) ap real ( kind = rk ), parameter, dimension ( 8 ) :: ar = (/ & 8.35503472222222D-02, 1.28226574556327D-01, & 2.91849026464140D-01, 8.81627267443758D-01, 3.32140828186277D+00, & 1.49957629868626D+01, 7.89230130115865D+01, 4.74451538868264D+02 /) real ( kind = rk ) asum real ( kind = rk ) az real ( kind = rk ) beta(26,5) real ( kind = rk ) beta1(26,2) real ( kind = rk ) beta2(26,2) real ( kind = rk ) beta3(26,1) real ( kind = rk ) br(10) real ( kind = rk ) bsum real ( kind = rk ) c(65) real ( kind = rk ), parameter :: con1 = 6.66666666666667D-01 real ( kind = rk ), parameter :: con2 = 3.33333333333333D-01 real ( kind = rk ), parameter :: con548 = 1.04166666666667D-01 real ( kind = rk ) cr(10) real ( kind = rk ) crz32 real ( kind = rk ) d1mach real ( kind = rk ) dfi real ( kind = rk ) elim real ( kind = rk ) dr(10) real ( kind = rk ) fi real ( kind = rk ) flgjy real ( kind = rk ) fn real ( kind = rk ) fnu real ( kind = rk ) fn2 external funjy real ( kind = rk ) gama(26) integer i integer i1mach integer iflw integer in integer j integer jn integer jr integer ju integer k integer kb integer klast integer kmax(5) integer kp1 integer ks integer ksp1 integer kstemp integer l integer lr integer lrp1 real ( kind = rk ) phi real ( kind = rk ) rcz real ( kind = rk ) rden real ( kind = rk ) relb real ( kind = rk ) rfn2 real ( kind = rk ) rtz real ( kind = rk ) rzden real ( kind = rk ) sa real ( kind = rk ) sb real ( kind = rk ) suma real ( kind = rk ) sumb real ( kind = rk ) s1 real ( kind = rk ) ta real ( kind = rk ) tau real ( kind = rk ) tb real ( kind = rk ) tfn real ( kind = rk ) tol real ( kind = rk ), save :: tols = -6.90775527898214D+00 real ( kind = rk ) t2 real ( kind = rk ) upol(10) real ( kind = rk ) wk(*) real ( kind = rk ) x real ( kind = rk ) xx real ( kind = rk ) y(*) real ( kind = rk ) z real ( kind = rk ) z32 equivalence (alfa(1,1),alfa1(1,1)) equivalence (alfa(1,3),alfa2(1,1)) equivalence (beta(1,1),beta1(1,1)) equivalence (beta(1,3),beta2(1,1)) equivalence (beta(1,5),beta3(1,1)) data br(1), br(2), br(3), br(4), br(5), br(6), br(7), br(8), br(9), br(10) & /-1.45833333333333D-01,-9.87413194444444D-02, & -1.43312053915895D-01,-3.17227202678414D-01,-9.42429147957120D-01, & -3.51120304082635D+00,-1.57272636203680D+01,-8.22814390971859D+01, & -4.92355370523671D+02,-3.31621856854797D+03/ data c(1), c(2), c(3), c(4), c(5), c(6), c(7), c(8), c(9), c(10), & c(11), c(12), c(13), c(14), c(15), c(16), c(17), c(18), & c(19), c(20), c(21), c(22), c(23), c(24)/ & -2.08333333333333D-01, 1.25000000000000D-01, & 3.34201388888889D-01, -4.01041666666667D-01, & 7.03125000000000D-02, -1.02581259645062D+00, & 1.84646267361111D+00, -8.91210937500000D-01, & 7.32421875000000D-02, 4.66958442342625D+00, & -1.12070026162230D+01, 8.78912353515625D+00, & -2.36408691406250D+00, 1.12152099609375D-01, & -2.82120725582002D+01, 8.46362176746007D+01, & -9.18182415432400D+01, 4.25349987453885D+01, & -7.36879435947963D+00, 2.27108001708984D-01, & 2.12570130039217D+02, -7.65252468141182D+02, & 1.05999045252800D+03, -6.99579627376133D+02/ data c(25), c(26), c(27), c(28), c(29), c(30), c(31), c(32), & c(33), c(34), c(35), c(36), c(37), c(38), c(39), c(40), & c(41), c(42), c(43), c(44), c(45), c(46), c(47), c(48)/ & 2.18190511744212D+02, -2.64914304869516D+01, & 5.72501420974731D-01, -1.91945766231841D+03, & 8.06172218173731D+03, -1.35865500064341D+04, & 1.16553933368645D+04, -5.30564697861340D+03, & 1.20090291321635D+03, -1.08090919788395D+02, & 1.72772750258446D+00, 2.02042913309661D+04, & -9.69805983886375D+04, 1.92547001232532D+05, & -2.03400177280416D+05, 1.22200464983017D+05, & -4.11926549688976D+04, 7.10951430248936D+03, & -4.93915304773088D+02, 6.07404200127348D+00, & -2.42919187900551D+05, 1.31176361466298D+06, & -2.99801591853811D+06, 3.76327129765640D+06/ data c(49), c(50), c(51), c(52), c(53), c(54), c(55), c(56), & c(57), c(58), c(59), c(60), c(61), c(62), c(63), c(64), & c(65)/ & -2.81356322658653D+06, 1.26836527332162D+06, & -3.31645172484564D+05, 4.52187689813627D+04, & -2.49983048181121D+03, 2.43805296995561D+01, & 3.28446985307204D+06, -1.97068191184322D+07, & 5.09526024926646D+07, -7.41051482115327D+07, & 6.63445122747290D+07, -3.75671766607634D+07, & 1.32887671664218D+07, -2.78561812808645D+06, & 3.08186404612662D+05, -1.38860897537170D+04, & 1.10017140269247D+02/ data alfa1(1,1), alfa1(2,1), alfa1(3,1), alfa1(4,1), alfa1(5,1), & alfa1(6,1), alfa1(7,1), alfa1(8,1), alfa1(9,1), alfa1(10,1), & alfa1(11,1),alfa1(12,1),alfa1(13,1),alfa1(14,1),alfa1(15,1), & alfa1(16,1),alfa1(17,1),alfa1(18,1),alfa1(19,1),alfa1(20,1), & alfa1(21,1),alfa1(22,1),alfa1(23,1),alfa1(24,1),alfa1(25,1), & alfa1(26,1) /-4.44444444444444D-03,-9.22077922077922D-04, & -8.84892884892885D-05, 1.65927687832450D-04, 2.46691372741793D-04, & 2.65995589346255D-04, 2.61824297061501D-04, 2.48730437344656D-04, & 2.32721040083232D-04, 2.16362485712365D-04, 2.00738858762752D-04, & 1.86267636637545D-04, 1.73060775917876D-04, 1.61091705929016D-04, & 1.50274774160908D-04, 1.40503497391270D-04, 1.31668816545923D-04, & 1.23667445598253D-04, 1.16405271474738D-04, 1.09798298372713D-04, & 1.03772410422993D-04, 9.82626078369363D-05, 9.32120517249503D-05, & 8.85710852478712D-05, 8.42963105715700D-05, 8.03497548407791D-05/ data alfa1(1,2), alfa1(2,2), alfa1(3,2), alfa1(4,2), alfa1(5,2), & alfa1(6,2), alfa1(7,2), alfa1(8,2), alfa1(9,2), alfa1(10,2), & alfa1(11,2),alfa1(12,2),alfa1(13,2),alfa1(14,2),alfa1(15,2), & alfa1(16,2),alfa1(17,2),alfa1(18,2),alfa1(19,2),alfa1(20,2), & alfa1(21,2),alfa1(22,2),alfa1(23,2),alfa1(24,2),alfa1(25,2), & alfa1(26,2) / 6.93735541354589D-04, 2.32241745182922D-04, & -1.41986273556691D-05,-1.16444931672049D-04,-1.50803558053049D-04,& -1.55121924918096D-04,-1.46809756646466D-04,-1.33815503867491D-04, & -1.19744975684254D-04,-1.06184319207974D-04,-9.37699549891194D-05, & -8.26923045588193D-05,-7.29374348155221D-05,-6.44042357721016D-05, & -5.69611566009369D-05,-5.04731044303562D-05,-4.48134868008883D-05, & -3.98688727717599D-05,-3.55400532972042D-05,-3.17414256609022D-05, & -2.83996793904175D-05,-2.54522720634871D-05,-2.28459297164725D-05, & -2.05352753106481D-05,-1.84816217627666D-05,-1.66519330021394D-05/ data alfa2(1,1), alfa2(2,1), alfa2(3,1), alfa2(4,1), alfa2(5,1), & alfa2(6,1), alfa2(7,1), alfa2(8,1), alfa2(9,1), alfa2(10,1), & alfa2(11,1),alfa2(12,1),alfa2(13,1),alfa2(14,1),alfa2(15,1), & alfa2(16,1),alfa2(17,1),alfa2(18,1),alfa2(19,1),alfa2(20,1), & alfa2(21,1),alfa2(22,1),alfa2(23,1),alfa2(24,1),alfa2(25,1), & alfa2(26,1) /-3.54211971457744D-04,-1.56161263945159D-04, & 3.04465503594936D-05, 1.30198655773243D-04, 1.67471106699712D-04, & 1.70222587683593D-04, 1.56501427608595D-04, 1.36339170977445D-04, & 1.14886692029825D-04, 9.45869093034688D-05, 7.64498419250898D-05, & 6.07570334965197D-05, 4.74394299290509D-05, 3.62757512005344D-05, & 2.69939714979225D-05, 1.93210938247939D-05, 1.30056674793963D-05, & 7.82620866744497D-06, 3.59257485819352D-06, 1.44040049814252D-07, & -2.65396769697939D-06,-4.91346867098486D-06,-6.72739296091248D-06, & -8.17269379678658D-06,-9.31304715093561D-06,-1.02011418798016D-05/ data alfa2(1,2), alfa2(2,2), alfa2(3,2), alfa2(4,2), alfa2(5,2), & alfa2(6,2), alfa2(7,2), alfa2(8,2), alfa2(9,2), alfa2(10,2), & alfa2(11,2),alfa2(12,2),alfa2(13,2),alfa2(14,2),alfa2(15,2), & alfa2(16,2),alfa2(17,2),alfa2(18,2),alfa2(19,2),alfa2(20,2), & alfa2(21,2),alfa2(22,2),alfa2(23,2),alfa2(24,2),alfa2(25,2), & alfa2(26,2) / 3.78194199201773D-04, 2.02471952761816D-04, & -6.37938506318862D-05,-2.38598230603006D-04,-3.10916256027362D-04, & -3.13680115247576D-04,-2.78950273791323D-04,-2.28564082619141D-04, & -1.75245280340847D-04,-1.25544063060690D-04,-8.22982872820208D-05, & -4.62860730588116D-05,-1.72334302366962D-05, 5.60690482304602D-06, & 2.31395443148287D-05, 3.62642745856794D-05, 4.58006124490189D-05, & 5.24595294959114D-05, 5.68396208545815D-05, 5.94349820393104D-05, & 6.06478527578422D-05, 6.08023907788436D-05, 6.01577894539460D-05, & 5.89199657344698D-05, 5.72515823777593D-05, 5.52804375585853D-05/ data beta1(1,1), beta1(2,1), beta1(3,1), beta1(4,1), beta1(5,1), & beta1(6,1), beta1(7,1), beta1(8,1), beta1(9,1), beta1(10,1), & beta1(11,1),beta1(12,1),beta1(13,1),beta1(14,1),beta1(15,1), & beta1(16,1),beta1(17,1),beta1(18,1),beta1(19,1),beta1(20,1), & beta1(21,1),beta1(22,1),beta1(23,1),beta1(24,1),beta1(25,1), & beta1(26,1) / 1.79988721413553D-02, 5.59964911064388D-03, & 2.88501402231133D-03, 1.80096606761054D-03, 1.24753110589199D-03, & 9.22878876572938D-04, 7.14430421727287D-04, 5.71787281789705D-04, & 4.69431007606482D-04, 3.93232835462917D-04, 3.34818889318298D-04, & 2.88952148495752D-04, 2.52211615549573D-04, 2.22280580798883D-04, & 1.97541838033063D-04, 1.76836855019718D-04, 1.59316899661821D-04, & 1.44347930197334D-04, 1.31448068119965D-04, 1.20245444949303D-04, & 1.10449144504599D-04, 1.01828770740567D-04, 9.41998224204238D-05, & 8.74130545753834D-05, 8.13466262162801D-05, 7.59002269646219D-05/ data beta1(1,2), beta1(2,2), beta1(3,2), beta1(4,2), beta1(5,2), & beta1(6,2), beta1(7,2), beta1(8,2), beta1(9,2), beta1(10,2), & beta1(11,2),beta1(12,2),beta1(13,2),beta1(14,2),beta1(15,2), & beta1(16,2),beta1(17,2),beta1(18,2),beta1(19,2),beta1(20,2), & beta1(21,2),beta1(22,2),beta1(23,2),beta1(24,2),beta1(25,2), & beta1(26,2) /-1.49282953213429D-03,-8.78204709546389D-04, & -5.02916549572035D-04,-2.94822138512746D-04,-1.75463996970783D-04, & -1.04008550460816D-04,-5.96141953046458D-05,-3.12038929076098D-05, & -1.26089735980230D-05,-2.42892608575730D-07, 8.05996165414274D-06, & 1.36507009262147D-05, 1.73964125472926D-05, 1.98672978842134D-05, & 2.14463263790823D-05, 2.23954659232457D-05, 2.28967783814713D-05, & 2.30785389811178D-05, 2.30321976080909D-05, 2.28236073720349D-05, & 2.25005881105292D-05, 2.20981015361991D-05, 2.16418427448104D-05, & 2.11507649256221D-05, 2.06388749782171D-05, 2.01165241997082D-05/ data beta2(1,1), beta2(2,1), beta2(3,1), beta2(4,1), beta2(5,1), & beta2(6,1), beta2(7,1), beta2(8,1), beta2(9,1), beta2(10,1), & beta2(11,1),beta2(12,1),beta2(13,1),beta2(14,1),beta2(15,1), & beta2(16,1),beta2(17,1),beta2(18,1),beta2(19,1),beta2(20,1), & beta2(21,1),beta2(22,1),beta2(23,1),beta2(24,1),beta2(25,1), & beta2(26,1) / 5.52213076721293D-04, 4.47932581552385D-04, & 2.79520653992021D-04, 1.52468156198447D-04, 6.93271105657044D-05, & 1.76258683069991D-05,-1.35744996343269D-05,-3.17972413350427D-05, & -4.18861861696693D-05,-4.69004889379141D-05,-4.87665447413787D-05, & -4.87010031186735D-05,-4.74755620890087D-05,-4.55813058138628D-05, & -4.33309644511266D-05,-4.09230193157750D-05,-3.84822638603221D-05, & -3.60857167535411D-05,-3.37793306123367D-05,-3.15888560772110D-05, & -2.95269561750807D-05,-2.75978914828336D-05,-2.58006174666884D-05, & -2.41308356761280D-05,-2.25823509518346D-05,-2.11479656768913D-05/ data beta2(1,2), beta2(2,2), beta2(3,2), beta2(4,2), beta2(5,2), & beta2(6,2), beta2(7,2), beta2(8,2), beta2(9,2), beta2(10,2), & beta2(11,2),beta2(12,2),beta2(13,2),beta2(14,2),beta2(15,2), & beta2(16,2),beta2(17,2),beta2(18,2),beta2(19,2),beta2(20,2), & beta2(21,2),beta2(22,2),beta2(23,2),beta2(24,2),beta2(25,2), & beta2(26,2) /-4.74617796559960D-04,-4.77864567147321D-04, & -3.20390228067038D-04,-1.61105016119962D-04,-4.25778101285435D-05, & 3.44571294294968D-05, 7.97092684075675D-05, 1.03138236708272D-04, & 1.12466775262204D-04, 1.13103642108481D-04, 1.08651634848774D-04, & 1.01437951597662D-04, 9.29298396593364D-05, 8.40293133016090D-05, & 7.52727991349134D-05, 6.69632521975731D-05, 5.92564547323195D-05, & 5.22169308826976D-05, 4.58539485165361D-05, 4.01445513891487D-05, & 3.50481730031328D-05, 3.05157995034347D-05, 2.64956119950516D-05, & 2.29363633690998D-05, 1.97893056664022D-05, 1.70091984636413D-05/ data beta3(1,1), beta3(2,1), beta3(3,1), beta3(4,1), beta3(5,1), & beta3(6,1), beta3(7,1), beta3(8,1), beta3(9,1), beta3(10,1), & beta3(11,1),beta3(12,1),beta3(13,1),beta3(14,1),beta3(15,1), & beta3(16,1),beta3(17,1),beta3(18,1),beta3(19,1),beta3(20,1), & beta3(21,1),beta3(22,1),beta3(23,1),beta3(24,1),beta3(25,1), & beta3(26,1) / 7.36465810572578D-04, 8.72790805146194D-04, & 6.22614862573135D-04, 2.85998154194304D-04, 3.84737672879366D-06, & -1.87906003636972D-04,-2.97603646594555D-04,-3.45998126832656D-04, & -3.53382470916038D-04,-3.35715635775049D-04,-3.04321124789040D-04, & -2.66722723047613D-04,-2.27654214122820D-04,-1.89922611854562D-04, & -1.55058918599094D-04,-1.23778240761874D-04,-9.62926147717644D-05, & -7.25178327714425D-05,-5.22070028895634D-05,-3.50347750511901D-05, & -2.06489761035552D-05,-8.70106096849767D-06, 1.13698686675100D-06, & 9.16426474122779D-06, 1.56477785428873D-05, 2.08223629482467D-05/ data gama(1), gama(2), gama(3), gama(4), gama(5), & gama(6), gama(7), gama(8), gama(9), gama(10), & gama(11), gama(12), gama(13), gama(14), gama(15), & gama(16), gama(17), gama(18), gama(19), gama(20), & gama(21), gama(22), gama(23), gama(24), gama(25), & gama(26) / 6.29960524947437D-01, 2.51984209978975D-01, & 1.54790300415656D-01, 1.10713062416159D-01, 8.57309395527395D-02, & 6.97161316958684D-02, 5.86085671893714D-02, 5.04698873536311D-02, & 4.42600580689155D-02, 3.93720661543510D-02, 3.54283195924455D-02, & 3.21818857502098D-02, 2.94646240791158D-02, 2.71581677112934D-02, & 2.51768272973862D-02, 2.34570755306079D-02, 2.19508390134907D-02, & 2.06210828235646D-02, 1.94388240897881D-02, 1.83810633800683D-02, & 1.74293213231963D-02, 1.65685837786612D-02, 1.57865285987918D-02, & 1.50729501494096D-02, 1.44193250839955D-02, 1.38184805735342D-02/ ! ! I1MACH(14) replaces I1MACH(11) in a double precision code ! I1MACH(15) replaces I1MACH(12) in a double precision code ! ta = epsilon ( ta ) tol = max ( ta, 1.0D-15 ) tb = d1mach(5) ju = i1mach(15) if ( flgjy /= 1.0D+00 ) then jr = i1mach(14) elim = 2.303D+00 * tb * ( real ( - ju ) - real ( jr ) ) else elim = 2.303D+00 * ( tb * real ( - ju ) - 3.0D+00 ) end if fn = fnu iflw = 0 do jn = 1, in xx = x / fn wk(1) = 1.0D+00 - xx * xx abw2 = abs ( wk(1) ) wk(2) = sqrt ( abw2 ) wk(7) = fn**con2 if ( 0.27750D+00 < abw2 ) then go to 80 end if ! ! Asymptotic expansion. ! ! Cases near x=fn, abs ( 1-(x/fn)^2 ) <= 0.2775 ! coefficients of asymptotic expansion by series ! ! ZETA and truncation for a(zeta) and b(zeta) series ! ! KMAX is the truncation index for a(zeta) and b(zeta) series = max ( 2, sa ) ! if ( abw2 == 0.0D+00 ) then sa = 0.0D+00 else sa = tols / log ( abw2 ) end if sb = sa do i = 1, 5 akm = max ( sa, 2.0D+00 ) kmax(i) = int ( akm ) sa = sa + sb end do kb = kmax(5) klast = kb - 1 sa = gama(kb) do k = 1, klast kb = kb - 1 sa = sa * wk(1) + gama(kb) end do z = wk(1) * sa az = abs ( z ) rtz = sqrt ( az ) wk(3) = con1 * az * rtz wk(4) = wk(3) * fn wk(5) = rtz * wk(7) wk(6) = - wk(5) * wk(5) if ( 0.0D+00 < z ) then if ( elim < wk(4) ) then iflw = 1 return end if wk(6) = -wk(6) end if phi = sqrt ( sqrt ( sa + sa + sa + sa ) ) ! ! b(zeta) for s=0 ! kb = kmax(5) klast = kb - 1 sb = beta(kb,1) do k = 1, klast kb = kb - 1 sb = sb * wk(1) + beta(kb,1) end do ksp1 = 1 fn2 = fn * fn rfn2 = 1.0D+00 / fn2 rden = 1.0D+00 asum = 1.0D+00 relb = tol * abs ( sb ) bsum = sb do ks = 1, 4 ksp1 = ksp1 + 1 rden = rden * rfn2 ! ! a(zeta) and b(zeta) for s=1,2,3,4 ! kstemp = 5 - ks kb = kmax(kstemp) klast = kb - 1 sa = alfa(kb,ks) sb = beta(kb,ksp1) do k = 1, klast kb = kb - 1 sa = sa * wk(1) + alfa(kb,ks) sb = sb * wk(1) + beta(kb,ksp1) end do ta = sa * rden tb = sb * rden asum = asum + ta bsum = bsum + tb if ( abs ( ta ) <= tol .and. abs ( tb ) <= relb ) then exit end if end do bsum = bsum / ( fn * wk(7) ) go to 160 80 continue upol(1) = 1.0D+00 tau = 1.0D+00 / wk(2) t2 = 1.0D+00 / wk(1) ! ! Cases for sqrt ( 1.2775 ) < (x/fn). ! if ( wk(1) < 0.0D+00 ) then wk(3) = abs ( wk(2) - atan ( wk(2) ) ) wk(4) = wk(3) * fn rcz = -con1 / wk(4) z32 = 1.5D+00 * wk(3) rtz = z32**con2 wk(5) = rtz * wk(7) wk(6) = -wk(5) * wk(5) ! ! Cases for (x/fn) < sqrt ( 0.7225 ) ! else wk(3) = abs ( log ( ( 1.0D+00 + wk(2) ) / xx ) - wk(2) ) wk(4) = wk(3) * fn rcz = con1 / wk(4) if ( elim < wk(4) ) then iflw = 1 return end if z32 = 1.5D+00 * wk(3) rtz = z32**con2 wk(7) = fn**con2 wk(5) = rtz * wk(7) wk(6) = wk(5) * wk(5) end if phi = sqrt ( ( rtz + rtz ) * tau ) tb = 1.0D+00 asum = 1.0D+00 tfn = tau / fn upol(2) = ( c(1) * t2 + c(2) ) * tfn crz32 = con548 * rcz bsum = upol(2) + crz32 relb = tol * abs ( bsum ) ap = tfn ks = 0 kp1 = 2 rzden = rcz l = 2 do lr = 2, 8, 2 ! ! Compute two U polynomials for next a(zeta) and b(zeta) ! lrp1 = lr + 1 do k = lr, lrp1 ks = ks + 1 kp1 = kp1 + 1 l = l + 1 s1 = c(l) do j = 2, kp1 l = l + 1 s1 = s1 * t2 + c(l) end do ap = ap * tfn upol(kp1) = ap * s1 cr(ks) = br(ks) * rzden rzden = rzden * rcz dr(ks) = ar(ks) * rzden end do suma = upol(lrp1) sumb = upol(lr+2) + upol(lrp1) * crz32 ju = lrp1 do jr = 1, lr ju = ju - 1 suma = suma + cr(jr) * upol(ju) sumb = sumb + dr(jr) * upol(ju) end do tb = -tb if ( 0.0D+00 < wk(1) ) then tb = abs ( tb ) end if asum = asum + suma * tb bsum = bsum + sumb * tb if ( abs ( suma ) <= tol .and. abs ( sumb ) <= relb ) then exit end if end do tb = wk(5) if ( 0.0D+00 < wk(1) ) then tb = -tb end if bsum = bsum / tb 160 continue call funjy ( wk(6), wk(5), wk(4), fi, dfi ) y(jn) = flgjy * phi * ( fi * asum + dfi * bsum ) / wk(7) fn = fn - flgjy end do return end subroutine bakslv ( nr, n, a, x, b ) !*****************************************************************************80 ! !! bakslv() solves A'*x=b where A is a lower triangular matrix. ! ! Discussion: ! ! BAKSLV solves the linear equations A'*X=B, where A is a ! lower triangular matrix and A' is the transpose of A. ! ! This routine is required by the UNCMIN minimization program. ! ! If B is no longer required by calling routine, then vectors B and ! X may share the same storage, and the output value of X will ! overwrite the input value of B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! John Dennis, Robert Schnabel, ! Numerical Methods for Unconstrained Optimization ! and Nonlinear Equations, ! SIAM, 1996, ! ISBN13: 978-0-898713-64-0, ! LC: QA402.5.D44. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer NR, the leading dimension of A. ! ! Input, integer N, the number of rows and columns in A. ! ! Input, real ( kind = rk ) A(NR,N), the N by N matrix, containing the lower ! triangular matrix. A is not altered by this routine. ! ! Output, real ( kind = rk ) X(N), the solution vector. ! ! Input, real ( kind = rk ) B(N), the right hand side vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) b(n) integer i integer ip1 real ( kind = rk ) x(n) ! ! Solve L' * x = b. ! i = n x(i) = b(i) / a(i,i) if ( n == 1 ) then return end if do ip1 = i i = i - 1 x(i) = ( b(i) - dot_product ( x(ip1:n), a(ip1:n,i) ) ) / a(i,i) if ( i == 1 ) then exit end if end do return end subroutine bernstein_poly_values ( n_data, n, k, x, b ) !*****************************************************************************80 ! !! bernstein_poly_values() returns some values of the Bernstein polynomials. ! ! Discussion: ! ! The Bernstein polynomials are assumed to be based on [0,1]. ! ! The formula for the Bernstein polynomials is ! ! B(N,I)(X) = [N!/(I!*(N-I)!)] * (1-X)**(N-I) * X**I ! ! In Mathematica, the function can be evaluated by: ! ! Binomial[n,i] * (1-x)^(n-i) * x^i ! ! First values: ! ! B(0,0)(X) = 1 ! ! B(1,0)(X) = 1-X ! B(1,1)(X) = X ! ! B(2,0)(X) = (1-X)^2 ! B(2,1)(X) = 2 * (1-X) * X ! B(2,2)(X) = X^2 ! ! B(3,0)(X) = (1-X)^3 ! B(3,1)(X) = 3 * (1-X)^2 * X ! B(3,2)(X) = 3 * (1-X) * X^2 ! B(3,3)(X) = X^3 ! ! B(4,0)(X) = (1-X)^4 ! B(4,1)(X) = 4 * (1-X)^3 * X ! B(4,2)(X) = 6 * (1-X)^2 * X^2 ! B(4,3)(X) = 4 * (1-X) * X^3 ! B(4,4)(X) = X^4 ! ! Special values: ! ! B(N,I)(X) has a unique maximum value at X = I/N. ! ! B(N,I)(X) has an I-fold zero at 0 and and N-I fold zero at 1. ! ! B(N,I)(1/2) = C(N,K) / 2^N ! ! For a fixed X and N, the polynomials add up to 1: ! ! Sum ( 0 <= I <= N ) B(N,I)(X) = 1 ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 19 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer N, the degree of the polynomial. ! ! Output, integer K, the index of the polynomial. ! ! Output, real ( kind = rk ) X, the argument of the polynomial. ! ! Output, real ( kind = rk ) B, the value of the polynomial B(N,K)(X). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 15 real ( kind = rk ) b real ( kind = rk ), save, dimension ( n_max ) :: b_vec = (/ & 0.1000000000000000D+01, & 0.7500000000000000D+00, & 0.2500000000000000D+00, & 0.5625000000000000D+00, & 0.3750000000000000D+00, & 0.6250000000000000D-01, & 0.4218750000000000D+00, & 0.4218750000000000D+00, & 0.1406250000000000D+00, & 0.1562500000000000D-01, & 0.3164062500000000D+00, & 0.4218750000000000D+00, & 0.2109375000000000D+00, & 0.4687500000000000D-01, & 0.3906250000000000D-02 /) integer k integer, save, dimension ( n_max ) :: k_vec = (/ & 0, & 0, 1, & 0, 1, 2, & 0, 1, 2, 3, & 0, 1, 2, 3, 4 /) integer n integer n_data integer, save, dimension ( n_max ) :: n_vec = (/ & 0, & 1, 1, & 2, 2, 2, & 3, 3, 3, 3, & 4, 4, 4, 4, 4 /) real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00, & 0.25D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 n = 0 k = 0 x = 0.0D+00 b = 0.0D+00 else n = n_vec(n_data) k = k_vec(n_data) x = x_vec(n_data) b = b_vec(n_data) end if return end function besi0 ( x ) !*****************************************************************************80 ! !! besi0() computes the hyperbolic Bessel function of the first kind, order zero. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 25 August 2001 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of the Bessel function. ! ! Output, real ( kind = rk ) BESI0, the value of the Bessel function at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) besi0 real ( kind = rk ) besi0e real ( kind = rk ), parameter, dimension ( 12 ) :: bi0cs = (/ & -0.07660547252839144951D+00, 1.927337953993808270D+00, & 0.2282644586920301339D+00, 0.01304891466707290428D+00, & 0.00043442709008164874D+00, 0.00000942265768600193D+00, & 0.00000014340062895106D+00, 0.00000000161384906966D+00, & 0.00000000001396650044D+00, 0.00000000000009579451D+00, & 0.00000000000000053339D+00, 0.00000000000000000245D+00 /) real ( kind = rk ) csevl integer inits integer, save :: nti0 = 0 real ( kind = rk ) x real ( kind = rk ), save :: xmax = 0.0D+00 real ( kind = rk ), save :: xsml = 0.0D+00 real ( kind = rk ) y if ( nti0 == 0 ) then nti0 = inits ( bi0cs, 12, 0.1D+00 * epsilon ( bi0cs ) ) xsml = 2.0D+00 * sqrt ( epsilon ( xsml ) ) xmax = log ( huge ( xmax ) ) end if y = abs ( x ) if ( y <= 3.0D+00 ) then if ( xsml < y ) then besi0 = 2.75D+00 + csevl ( y * y / 4.5D+00 - 1.0D+00, bi0cs, nti0 ) else besi0 = 1.0D+00 end if return end if if ( xmax < y ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BESI0 - Fatal error!' write ( *, '(a)' ) ' |X| is so big that BESI0 will overflow.' stop end if besi0 = exp ( y ) * besi0e ( x ) return end function besi0e ( x ) !*****************************************************************************80 ! !! besi0e() computes the scaled hyperbolic Bessel function I0(X). ! ! Discussion: ! ! BESI0E calculates the exponentially scaled modified hyperbolic ! Bessel function of the first kind of order zero for real argument X. ! ! besi0e(x) = exp ( - abs ( x ) ) * i0 ( x ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of the Bessel function. ! ! Output, real ( kind = rk ) BESI0E, the value of the Bessel function at X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ai02cs(22) real ( kind = rk ) ai0cs(21) real ( kind = rk ) besi0e real ( kind = rk ) bi0cs(12) real ( kind = rk ) csevl integer inits integer, save :: ntai0 = 0 integer, save :: ntai02 = 0 integer, save :: nti0 = 0 real ( kind = rk ) x real ( kind = rk ), save :: xsml = 0.0D+00 real ( kind = rk ) y data bi0cs( 1) / -0.07660547252839144951D+00 / data bi0cs( 2) / 1.927337953993808270D+00 / data bi0cs( 3) / 0.2282644586920301339D+00 / data bi0cs( 4) / 0.01304891466707290428D+00 / data bi0cs( 5) / 0.00043442709008164874D+00 / data bi0cs( 6) / 0.00000942265768600193D+00 / data bi0cs( 7) / 0.00000014340062895106D+00 / data bi0cs( 8) / 0.00000000161384906966D+00 / data bi0cs( 9) / 0.00000000001396650044D+00 / data bi0cs(10) / 0.00000000000009579451D+00 / data bi0cs(11) / 0.00000000000000053339D+00 / data bi0cs(12) / 0.00000000000000000245D+00 / data ai0cs( 1) / 0.07575994494023796D+00 / data ai0cs( 2) / 0.00759138081082334D+00 / data ai0cs( 3) / 0.00041531313389237D+00 / data ai0cs( 4) / 0.00001070076463439D+00 / data ai0cs( 5) / -0.00000790117997921D+00 / data ai0cs( 6) / -0.00000078261435014D+00 / data ai0cs( 7) / 0.00000027838499429D+00 / data ai0cs( 8) / 0.00000000825247260D+00 / data ai0cs( 9) / -0.00000001204463945D+00 / data ai0cs(10) / 0.00000000155964859D+00 / data ai0cs(11) / 0.00000000022925563D+00 / data ai0cs(12) / -0.00000000011916228D+00 / data ai0cs(13) / 0.00000000001757854D+00 / data ai0cs(14) / 0.00000000000112822D+00 / data ai0cs(15) / -0.00000000000114684D+00 / data ai0cs(16) / 0.00000000000027155D+00 / data ai0cs(17) / -0.00000000000002415D+00 / data ai0cs(18) / -0.00000000000000608D+00 / data ai0cs(19) / 0.00000000000000314D+00 / data ai0cs(20) / -0.00000000000000071D+00 / data ai0cs(21) / 0.00000000000000007D+00 / data ai02cs( 1) / 0.05449041101410882D+00 / data ai02cs( 2) / 0.00336911647825569D+00 / data ai02cs( 3) / 0.00006889758346918D+00 / data ai02cs( 4) / 0.00000289137052082D+00 / data ai02cs( 5) / 0.00000020489185893D+00 / data ai02cs( 6) / 0.00000002266668991D+00 / data ai02cs( 7) / 0.00000000339623203D+00 / data ai02cs( 8) / 0.00000000049406022D+00 / data ai02cs( 9) / 0.00000000001188914D+00 / data ai02cs(10) / -0.00000000003149915D+00 / data ai02cs(11) / -0.00000000001321580D+00 / data ai02cs(12) / -0.00000000000179419D+00 / data ai02cs(13) / 0.00000000000071801D+00 / data ai02cs(14) / 0.00000000000038529D+00 / data ai02cs(15) / 0.00000000000001539D+00 / data ai02cs(16) / -0.00000000000004151D+00 / data ai02cs(17) / -0.00000000000000954D+00 / data ai02cs(18) / 0.00000000000000382D+00 / data ai02cs(19) / 0.00000000000000176D+00 / data ai02cs(20) / -0.00000000000000034D+00 / data ai02cs(21) / -0.00000000000000027D+00 / data ai02cs(22) / 0.00000000000000003D+00 / if ( nti0 == 0 ) then nti0 = inits ( bi0cs, 12, 0.1D+00 * epsilon ( bi0cs ) ) ntai0 = inits ( ai0cs, 21, 0.1D+00 * epsilon ( ai0cs ) ) ntai02 = inits ( ai02cs, 22, 0.1D+00 * epsilon ( ai02cs ) ) xsml = 2.0D+00 * sqrt ( epsilon ( xsml ) ) end if y = abs ( x ) if ( y <= xsml ) then besi0e = 1.0D+00 else if ( y <= 3.0D+00 ) then besi0e = exp ( -y ) * & ( 2.75D+00 + csevl ( y*y/4.5D+00 - 1.0D+00, bi0cs, nti0 ) ) else if ( y <= 8.0D+00 ) then besi0e = ( 0.375D+00 + & csevl ( ( 48.0D+00 / y - 11.0D+00 ) / 5.0D+00, ai0cs, ntai0 ) ) & / sqrt ( y ) else if ( 8.0D+00 < y ) then besi0e = ( 0.375D+00 + csevl ( 16.0D+00 / y - 1.0D+00, ai02cs, ntai02 ) ) & / sqrt ( y ) end if return end subroutine besj ( x, alpha, n, y, nz ) !*****************************************************************************80 ! !! besj() computes a sequence of J Bessel functions of increasing order. ! ! Discussion: ! ! BESJ computes an N member sequence of J Bessel functions ! ! J(ALPHA+K-1) (X) ! ! for K=1,..,N for non-negative order ALPHA and X. ! ! A combination of the power series, the asymptotic expansion for X ! to infinity and the uniform asymptotic expansion for NU to infinity ! are applied over subdivisions of the (NU,X) plane. For values of ! (NU,X) not covered by one of these formulae, the order is ! incremented or decremented by integer values into a region ! where one of the formulas apply. ! ! Backward recursion is applied to reduce orders by integers ! except where the entire sequence lies in the oscillatory region. ! In this case forward recursion is stable and values from the ! asymptotic expansion for X to infinity start the recursion when it ! is efficient to do so. ! ! Leading terms of the series and uniform expansion are tested for ! underflow. If a sequence is requested and the last member would ! underflow, the result is set to zero and the next lower order ! tried, until a member comes on scale or all members are set ! to zero. ! ! Overflow cannot occur. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Donald Amos, SL Daniel, MK Weston, ! CDC 6600 subroutines IBESS and JBESS for Bessel functions ! I(NU,X) and J(NU,X), X .GE. 0, NU .GE. 0 ! ACM Transactions on Mathematical Software, ! Volume 3, pages 76-92, 1977. ! ! Frank Olver, ! Tables of Bessel Functions of Moderate or Large Orders, ! NPL Mathematical Tables, Volume 6, ! Her Majesty's Stationery Office, London, 1962. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of the Bessel function. ! X must be nonnegative. ! ! Input, real ( kind = rk ) ALPHA, the order of the first member of ! the sequence. ALPHA must be at least 0.0. ! ! Input, integer N, the number of members in the sequence, ! N must be at least 1. ! ! Output, real ( kind = rk ) Y(N), a vector whose first N components contain ! values for J(ALPHA+K-1)(X), K=1,...,N ! ! Output, integer NZ, the number of components of Y set to zero ! due to underflow. ! ! NZ=0, normal return, computation completed ! ! NZ /= 0, Y(N-NZ+1) through Y(N) were set to 0. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) ak real ( kind = rk ) akm real ( kind = rk ) alngam real ( kind = rk ) alpha real ( kind = rk ) ans real ( kind = rk ) ap real ( kind = rk ) arg real ( kind = rk ) coef real ( kind = rk ) d1mach real ( kind = rk ) dalpha real ( kind = rk ) dfn real ( kind = rk ) dtm real ( kind = rk ) earg real ( kind = rk ) elim1 real ( kind = rk ) etx real ( kind = rk ) fidal real ( kind = rk ) flgjy real ( kind = rk ) fn real ( kind = rk ) fnf real ( kind = rk ) fni real ( kind = rk ) fnp1 real ( kind = rk ) fnu real ( kind = rk ), parameter, dimension ( 2 ) :: fnulim = (/ & 100.0D+00, 60.0D+00 /) real ( kind = rk ) gln integer i integer i1 integer i1mach integer i2 integer ialp integer idalp integer iflw integer in integer, parameter :: inlim = 150 integer is external jairy integer k integer kk integer km integer kt integer nn integer ns integer nz real ( kind = rk ), parameter :: pdf = 0.785398163397448D+00 real ( kind = rk ), parameter :: pidt = 1.57079632679490D+00 real ( kind = rk ), parameter, dimension ( 4 ) :: pp = (/ & 8.72909153935547D+00, 2.65693932265030D-01, & 1.24578576865586D-01, 7.70133747430388D-04 /) real ( kind = rk ) rden real ( kind = rk ) relb real ( kind = rk ), parameter :: rttp = 7.97884560802865D-01 real ( kind = rk ), parameter :: rtwo = 1.34839972492648D+00 real ( kind = rk ) rtx real ( kind = rk ) rzden real ( kind = rk ) s real ( kind = rk ) sa real ( kind = rk ) sb real ( kind = rk ) sxo2 real ( kind = rk ) s1 real ( kind = rk ) s2 real ( kind = rk ) t real ( kind = rk ) ta real ( kind = rk ) tau real ( kind = rk ) tb real ( kind = rk ) temp(3) real ( kind = rk ) tfn real ( kind = rk ) tm real ( kind = rk ) tol real ( kind = rk ) tolln real ( kind = rk ) trx real ( kind = rk ) tx real ( kind = rk ) t1 real ( kind = rk ) t2 real ( kind = rk ) wk(7) real ( kind = rk ) x real ( kind = rk ) xo2 real ( kind = rk ) xo2l real ( kind = rk ) y(n) nz = 0 kt = 1 ! ! I1MACH(14) replaces I1MACH(11) in a double precision code ! I1MACH(15) replaces I1MACH(12) in a double precision code ! ta = epsilon ( ta ) tol = max ( ta, 1.0D-15 ) i1 = i1mach(14) + 1 i2 = i1mach(15) tb = d1mach(5) elim1 = 2.303D+00 * ( real ( -i2, kind = rk ) * tb - 3.0D+00 ) ! ! TOLLN = -ln(tol) ! tolln = 2.303D+00 * tb * real ( i1, kind = rk ) tolln = min ( tolln, 34.5388D+00 ) if ( n < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BESJ - Fatal error!' write ( *, '(a)' ) ' N is less than 1.' return end if if ( n == 1 ) then kt = 2 end if nn = n if ( x < 0.0D+00 ) then call xerror ( 'BESJ - X less than zero.', 2, 1 ) return end if if ( x == 0.0D+00 ) then if ( alpha < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BESJ - Fatal error!' write ( *, '(a)' ) ' ALPHA less than zero.' return end if if ( alpha == 0.0D+00 ) then y(1) = 1.0D+00 if ( n == 1 ) then return end if i1 = 2 else i1 = 1 end if y(i1:n) = 0.0D+00 return end if if ( alpha < 0.0D+00 ) then call xerror ( 'BESJ - order, alpha, less than zero.', 2, 1) return end if ialp = int ( alpha ) fni = real ( ialp + n - 1, kind = rk ) fnf = alpha - real ( ialp, kind = rk ) dfn = fni + fnf fnu = dfn xo2 = x * 0.5D+00 sxo2 = xo2 * xo2 ! ! Decision tree for region where series, asymptotic expansion for x ! to infinity and asymptotic expansion for nu to infinity are applied. ! if ( sxo2 <= ( fnu+1.0D+00 ) ) then go to 90 end if ta = max ( 20.0D+00, fnu ) if ( ta < x ) then go to 120 end if if ( 12.0D+00 < x ) then go to 110 end if xo2l = log ( xo2 ) ns = int ( sxo2 - fnu ) + 1 go to 100 90 continue fn = fnu fnp1 = fn + 1.0D+00 xo2l = log ( xo2 ) is = kt if ( x <= 0.50D+00 ) then go to 330 end if ns = 0 100 continue fni = fni + real ( ns, kind = rk ) dfn = fni + fnf fn = dfn fnp1 = fn + 1.0D+00 is = kt if ( 0 < n - 1 + ns ) then is = 3 end if go to 330 110 continue ans = max ( 36.0D+00 - fnu, 0.0D+00 ) ns = int ( ans ) fni = fni + real ( ns, kind = rk ) dfn = fni + fnf fn = dfn is = kt if ( 0 < n - 1 + ns ) then is = 3 end if go to 130 120 continue rtx = sqrt ( x ) tau = rtwo * rtx ta = tau + fnulim(kt) if ( fnu <= ta ) then go to 480 end if fn = fnu is = kt ! ! Uniform asymptotic expansion for NU to infinity. ! 130 continue i1 = abs ( 3 - is ) i1 = max ( i1, 1 ) flgjy = 1.0D+00 call asyjy ( jairy, x, fn, flgjy, i1, temp(is), wk, iflw ) if ( iflw /= 0 ) then go to 380 end if go to (320, 450, 620), is 310 continue temp(1) = temp(3) kt = 1 320 continue is = 2 fni = fni - 1.0D+00 dfn = fni + fnf fn = dfn if ( i1 == 2 ) then go to 450 end if go to 130 ! ! Series for (x/2)**2<=nu+1 ! 330 continue gln = alngam ( fnp1 ) arg = fn * xo2l - gln if ( arg < (-elim1) ) then go to 400 end if earg = exp ( arg ) 340 continue s = 1.0D+00 if ( x < tol ) then go to 360 end if ak = 3.0D+00 t2 = 1.0D+00 t = 1.0D+00 s1 = fn do k = 1, 17 s2 = t2 + s1 t = - t * sxo2 / s2 s = s + t if ( abs ( t ) < tol ) then exit end if t2 = t2 + ak ak = ak + 2.0D+00 s1 = s1 + fn end do 360 continue temp(is) = s * earg go to (370, 450, 610), is 370 continue earg = earg * fn / xo2 fni = fni - 1.0D+00 dfn = fni + fnf fn = dfn is = 2 go to 340 ! ! Set underflow value and update parameters ! 380 continue y(nn) = 0.0D+00 nn = nn - 1 fni = fni - 1.0D+00 dfn = fni + fnf fn = dfn if ( nn-1 ) 440, 390, 130 390 continue kt = 2 is = 2 go to 130 400 continue y(nn) = 0.0D+00 nn = nn - 1 fnp1 = fn fni = fni - 1.0D+00 dfn = fni + fnf fn = dfn if ( nn-1 ) 440, 410, 420 410 continue kt = 2 is = 2 420 continue if ( sxo2 <= fnp1 ) then go to 430 end if go to 130 430 continue arg = arg - xo2l + log ( fnp1 ) if ( arg < (-elim1) ) then go to 400 end if go to 330 440 nz = n - nn return ! ! Backward recursion section ! 450 continue nz = n - nn if ( kt == 2 ) then go to 470 end if ! ! Backward recur from index ALPHA+NN-1 to ALPHA. ! y(nn) = temp(1) y(nn-1) = temp(2) if ( nn == 2 ) then return end if trx = 2.0D+00 / x dtm = fni tm = ( dtm + fnf ) * trx k = nn + 1 do i = 3, nn k = k - 1 y(k-2) = tm * y(k-1) - y(k) dtm = dtm - 1.0D+00 tm = ( dtm + fnf ) * trx end do return 470 continue y(1) = temp(2) return ! ! Asymptotic expansion for X to infinity with forward recursion in ! oscillatory region max ( 20, NU ) < X, provided the last member ! of the sequence is also in the region. ! 480 continue in = int ( alpha - tau + 2.0D+00 ) if ( in <= 0 ) then go to 490 end if idalp = ialp - in - 1 kt = 1 go to 500 490 continue idalp = ialp in = 0 500 continue is = kt fidal = real ( idalp, kind = rk ) dalpha = fidal + fnf arg = x - pidt * dalpha - pdf sa = sin ( arg ) sb = cos ( arg ) coef = rttp / rtx etx = 8.0D+00 * x 510 continue dtm = fidal + fidal dtm = dtm * dtm tm = 0.0D+00 if ( fidal == 0.0D+00 .and. abs ( fnf ) < tol ) then go to 520 end if tm = 4.0D+00 * fnf * ( fidal + fidal + fnf ) 520 continue trx = dtm - 1.0D+00 t2 = ( trx + tm ) / etx s2 = t2 relb = tol * abs ( t2 ) t1 = etx s1 = 1.0D+00 fn = 1.0D+00 ak = 8.0D+00 do k = 1, 13 t1 = t1 + etx fn = fn + ak trx = dtm - fn ap = trx + tm t2 = -t2 * ap / t1 s1 = s1 + t2 t1 = t1 + etx ak = ak + 8.0D+00 fn = fn + ak trx = dtm - fn ap = trx + tm t2 = t2 * ap / t1 s2 = s2 + t2 if ( abs ( t2 ) <= relb ) then exit end if ak = ak + 8.0D+00 end do !540 continue temp(is) = coef * ( s1 * sb - s2 * sa ) if ( is == 2 ) then go to 560 end if !550 continue fidal = fidal + 1.0D+00 dalpha = fidal + fnf is = 2 tb = sa sa = -sb sb = tb go to 510 ! ! Forward recursion section ! 560 continue if ( kt == 2 ) then go to 470 end if s1 = temp(1) s2 = temp(2) tx = 2.0D+00 / x tm = dalpha * tx if ( in == 0 ) then go to 580 end if ! ! Forward recursion to index alpha ! do i = 1, in s = s2 s2 = tm * s2 - s1 tm = tm + tx s1 = s end do if ( nn == 1 ) then go to 600 end if s = s2 s2 = tm * s2 - s1 tm = tm + tx s1 = s 580 continue ! ! Forward recursion from index ALPHA to ALPHA+N-1. ! y(1) = s1 y(2) = s2 do i = 3, nn y(i) = tm * y(i-1) - y(i-2) tm = tm + tx end do return 600 continue y(1) = s2 return ! ! Backward recursion with normalization by ! asymptotic expansion for nu to infinity or power series. ! 610 continue ! ! Computation of last order for series normalization ! akm = max ( 3.0D+00 - fn, 0.0D+00 ) km = int ( akm ) tfn = fn + real ( km, kind = rk ) ta = ( gln + tfn - 0.9189385332D+00 - 0.0833333333D+00 / tfn ) & / ( tfn + 0.5D+00 ) ta = xo2l - ta tb = - ( 1.0D+00 -1.5D+00 / tfn ) / tfn akm = tolln / ( - ta + sqrt ( ta * ta - tolln * tb ) ) + 1.5D+00 in = km + int ( akm ) go to 660 620 continue ! ! Computation of last order for asymptotic expansion normalization ! gln = wk(3) + wk(2) if ( 30.0D+00 < wk(6) ) then go to 640 end if rden = ( pp(4) * wk(6) + pp(3) ) * wk(6) + 1.0D+00 rzden = pp(1) + pp(2) * wk(6) ta = rzden / rden if ( wk(1) < 0.10D+00 ) then go to 630 end if tb = gln / wk(5) go to 650 630 continue tb = ( 1.259921049D+00 + ( 0.1679894730D+00 + 0.0887944358D+00 & * wk(1) ) * wk(1) ) / wk(7) go to 650 640 continue ta = 0.5D+00 * tolln / wk(4) ta=( ( 0.0493827160D+00 * ta - 0.1111111111D+00 ) * ta & + 0.6666666667D+00 ) * ta * wk(6) if ( wk(1) < 0.10D+00 ) then go to 630 end if tb = gln / wk(5) 650 continue in = int ( ta / tb + 1.5D+00 ) if ( inlim < in ) then go to 310 end if 660 continue dtm = fni + real ( in, kind = rk ) trx = 2.0D+00 / x tm = ( dtm + fnf ) * trx ta = 0.0D+00 tb = tol kk = 1 670 continue ! ! Backward recur unindexed ! do i = 1, in s = tb tb = tm * tb - ta ta = s dtm = dtm - 1.0D+00 tm = ( dtm + fnf ) * trx end do ! ! Normalization. ! if ( kk == 1 ) then ta = ( ta / tb ) * temp(3) tb = temp(3) kk = 2 in = ns if ( ns /= 0 ) then go to 670 end if end if y(nn) = tb nz = n - nn if ( nn == 1 ) then return end if k = nn - 1 y(k) = tm * tb - ta if ( nn == 2 ) then return end if dtm = dtm - 1.0D+00 tm = ( dtm + fnf ) * trx km = k - 1 ! ! Backward recur indexed ! do i = 1, km y(k-1) = tm * y(k) - y(k+1) dtm = dtm - 1.0D+00 tm = ( dtm + fnf ) * trx k = k - 1 end do return end subroutine bessel_i0_values ( n_data, x, fx ) !*****************************************************************************80 ! !! bessel_i0_values() returns some values of the I0 Bessel function. ! ! Discussion: ! ! The modified Bessel functions In(Z) and Kn(Z) are solutions of ! the differential equation ! ! Z^2 W'' + Z * W' - ( Z^2 + N^2 ) * W = 0. ! ! The modified Bessel function I0(Z) corresponds to N = 0. ! ! In Mathematica, the function can be evaluated by: ! ! BesselI[0,x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 20 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 20 real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.1000000000000000D+01, & 0.1010025027795146D+01, & 0.1040401782229341D+01, & 0.1092045364317340D+01, & 0.1166514922869803D+01, & 0.1266065877752008D+01, & 0.1393725584134064D+01, & 0.1553395099731217D+01, & 0.1749980639738909D+01, & 0.1989559356618051D+01, & 0.2279585302336067D+01, & 0.3289839144050123D+01, & 0.4880792585865024D+01, & 0.7378203432225480D+01, & 0.1130192195213633D+02, & 0.1748117185560928D+02, & 0.2723987182360445D+02, & 0.6723440697647798D+02, & 0.4275641157218048D+03, & 0.2815716628466254D+04 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 0.00D+00, & 0.20D+00, & 0.40D+00, & 0.60D+00, & 0.80D+00, & 0.10D+01, & 0.12D+01, & 0.14D+01, & 0.16D+01, & 0.18D+01, & 0.20D+01, & 0.25D+01, & 0.30D+01, & 0.35D+01, & 0.40D+01, & 0.45D+01, & 0.50D+01, & 0.60D+01, & 0.80D+01, & 0.10D+02 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 fx = 0.0D+00 else x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine bessel_j0_values ( n_data, x, fx ) !*****************************************************************************80 ! !! bessel_j0_values() returns some values of the J0 Bessel function. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! BesselJ[0,x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 10 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 21 real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & -0.1775967713143383D+00, & -0.3971498098638474D+00, & -0.2600519549019334D+00, & 0.2238907791412357D+00, & 0.7651976865579666D+00, & 0.1000000000000000D+01, & 0.7651976865579666D+00, & 0.2238907791412357D+00, & -0.2600519549019334D+00, & -0.3971498098638474D+00, & -0.1775967713143383D+00, & 0.1506452572509969D+00, & 0.3000792705195556D+00, & 0.1716508071375539D+00, & -0.9033361118287613D-01, & -0.2459357644513483D+00, & -0.1711903004071961D+00, & 0.4768931079683354D-01, & 0.2069261023770678D+00, & 0.1710734761104587D+00, & -0.1422447282678077D-01 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & -5.0D+00, & -4.0D+00, & -3.0D+00, & -2.0D+00, & -1.0D+00, & 0.0D+00, & 1.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00, & 5.0D+00, & 6.0D+00, & 7.0D+00, & 8.0D+00, & 9.0D+00, & 10.0D+00, & 11.0D+00, & 12.0D+00, & 13.0D+00, & 14.0D+00, & 15.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 fx = 0.0D+00 else x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine bessel_j1_values ( n_data, x, fx ) !*****************************************************************************80 ! !! bessel_j1_values() returns some values of the J1 Bessel function. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! BesselJ[1,x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 August 2004 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 21 real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.3275791375914652D+00, & 0.6604332802354914D-01, & -0.3390589585259365D+00, & -0.5767248077568734D+00, & -0.4400505857449335D+00, & 0.0000000000000000D+00, & 0.4400505857449335D+00, & 0.5767248077568734D+00, & 0.3390589585259365D+00, & -0.6604332802354914D-01, & -0.3275791375914652D+00, & -0.2766838581275656D+00, & -0.4682823482345833D-02, & 0.2346363468539146D+00, & 0.2453117865733253D+00, & 0.4347274616886144D-01, & -0.1767852989567215D+00, & -0.2234471044906276D+00, & -0.7031805212177837D-01, & 0.1333751546987933D+00, & 0.2051040386135228D+00 /) integer n_data real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & -5.0D+00, & -4.0D+00, & -3.0D+00, & -2.0D+00, & -1.0D+00, & 0.0D+00, & 1.0D+00, & 2.0D+00, & 3.0D+00, & 4.0D+00, & 5.0D+00, & 6.0D+00, & 7.0D+00, & 8.0D+00, & 9.0D+00, & 10.0D+00, & 11.0D+00, & 12.0D+00, & 13.0D+00, & 14.0D+00, & 15.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 x = 0.0D+00 fx = 0.0D+00 else x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine bessel_jn_values ( n_data, nu, x, fx ) !*****************************************************************************80 ! !! bessel_jn_values() returns some values of the Jn Bessel function. ! ! Discussion: ! ! In Mathematica, the function can be evaluated by: ! ! BesselJ[n,x] ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 29 April 2001 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Stephen Wolfram, ! The Mathematica Book, ! Fourth Edition, ! Wolfram Media / Cambridge University Press, 1999. ! ! Parameters: ! ! Input/output, integer N_DATA. The user sets N_DATA to 0 ! before the first call. On each call, the routine increments N_DATA by 1, ! and returns the corresponding data; when there is no more data, the ! output value of N_DATA will be 0 again. ! ! Output, integer NU, the order of the function. ! ! Output, real ( kind = rk ) X, the argument of the function. ! ! Output, real ( kind = rk ) FX, the value of the function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: n_max = 20 real ( kind = rk ) fx real ( kind = rk ), save, dimension ( n_max ) :: fx_vec = (/ & 0.1149034849319005D+00, & 0.3528340286156377D+00, & 0.4656511627775222D-01, & 0.2546303136851206D+00, & -0.5971280079425882D-01, & 0.2497577302112344D-03, & 0.7039629755871685D-02, & 0.2611405461201701D+00, & -0.2340615281867936D+00, & -0.8140024769656964D-01, & 0.2630615123687453D-09, & 0.2515386282716737D-06, & 0.1467802647310474D-02, & 0.2074861066333589D+00, & -0.1138478491494694D+00, & 0.3873503008524658D-24, & 0.3918972805090754D-18, & 0.2770330052128942D-10, & 0.1151336924781340D-04, & -0.1167043527595797D+00 /) integer n_data integer nu integer, save, dimension ( n_max ) :: nu_vec = (/ & 2, 2, 2, 2, & 2, 5, 5, 5, & 5, 5, 10, 10, & 10, 10, 10, 20, & 20, 20, 20, 20 /) real ( kind = rk ) x real ( kind = rk ), save, dimension ( n_max ) :: x_vec = (/ & 1.0D+00, & 2.0D+00, & 5.0D+00, & 10.0D+00, & 50.0D+00, & 1.0D+00, & 2.0D+00, & 5.0D+00, & 10.0D+00, & 50.0D+00, & 1.0D+00, & 2.0D+00, & 5.0D+00, & 10.0D+00, & 50.0D+00, & 1.0D+00, & 2.0D+00, & 5.0D+00, & 10.0D+00, & 50.0D+00 /) if ( n_data < 0 ) then n_data = 0 end if n_data = n_data + 1 if ( n_max < n_data ) then n_data = 0 nu = 0 x = 0.0D+00 fx = 0.0D+00 else nu = nu_vec(n_data) x = x_vec(n_data) fx = fx_vec(n_data) end if return end subroutine bp01 ( n, x, b ) !*****************************************************************************80 ! !! bp01() evaluates the N+1 Bernstein basis functions of degree N on [0,1]. ! ! Discussion: ! ! The I-th Bernstein basis polynomial of degree N is defined as: ! ! B(N,I,X)= N!/(I!*(N-I)!) * (1-X)**(N-I) * X**I ! ! although this is not how the values are computed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 February 2003 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer N, should be 0 or greater. ! ! Input, real ( kind = rk ) X, the point where the functions should be ! evaluated. ! ! Output, real ( kind = rk ) B(0:N), the values of the Bernstein polynomials ! at the point X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) b(0:n) integer i integer j real ( kind = rk ) x if ( n == 0 ) then b(0) = 1.0D+00 else if ( 0 < n ) then do i = 1, n if ( i == 1 ) then b(1) = x else b(i) = x * b(i-1) end if do j = i-1, 1, -1 b(j) = x * b(j-1) + ( 1.0D+00 - x ) * b(j) end do if ( i == 1 ) then b(0) = 1.0D+00 - x else b(0) = ( 1.0D+00 - x ) * b(0) end if end do end if return end subroutine c8vec_print_some ( n, x, i_lo, i_hi, title ) !*****************************************************************************80 ! !! c8vec_print_some() prints some of a C8VEC. ! ! Discussion: ! ! A C8VEC is a vector of complex ( kind = ck ) values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 October 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries of the vector. ! ! Input, complex ( kind = ck ) X(N), the vector to be printed. ! ! Input, integer I_LO, I_HI, the first and last entries ! to print. ! ! Input, character ( len = * ) TITLE, an optional title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n integer i integer i_hi integer i_lo character ( len = * ) title complex ( kind = ck ) x(n) if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = max ( 1, i_lo ), min ( n, i_hi ) write ( *, '(2x,i8,2x,2g14.6)' ) i, x(i) end do return end subroutine c8vec_uniform_01 ( n, c ) !*****************************************************************************80 ! !! c8vec_uniform_01() returns a unit pseudorandom C8VEC. ! ! Discussion: ! ! A C8VEC is a vector of complex ( kind = ck ) values. ! ! The angles should be uniformly distributed between 0 and 2 * PI, ! the square roots of the radius uniformly distributed between 0 and 1. ! ! This results in a uniform distribution of values in the unit circle. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 March 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of values to compute. ! ! Output, complex ( kind = ck ) C(N), the pseudorandom complex vector. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) c(n) integer i real ( kind = rk ) r real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) theta do i = 1, n call random_number ( harvest = r ) call random_number ( harvest = theta ) theta = 2.0D+00 * pi * theta c(i) = r * cmplx ( cos ( theta ), sin ( theta ), kind = ck ) end do return end subroutine ch_fake_use ( ch ) !*****************************************************************************80 ! !! ch_fake_use() pretends to use a variable. ! ! Discussion: ! ! Some compilers will issue a warning if a variable is unused. ! Sometimes there's a good reason to include a variable in a program, ! but not to use it. Calling this function with that variable as ! the argument will shut the compiler up. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 June 2020 ! ! Author: ! ! John Burkardt ! ! Input: ! ! character CH, the variable to be "used". ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ch logical, parameter :: printit = .false. if ( ch == '?' ) then if ( printit ) then write ( *, '(a)' ) '' write ( *, '(a)' ) 'ch_fake_use:' write ( *, '(a)' ) ' Another question mark!' end if end if return end subroutine chfdv ( x1, x2, f1, f2, d1, d2, ne, xe, fe, de, next, ierr ) !*****************************************************************************80 ! !! chfdv() evaluates a cubic polynomial and its derivative given in Hermite form. ! ! Discussion: ! ! CHFDV evaluates a cubic polynomial and its first derivative. ! The cubic polynomial is given in Hermite form. The evaluation ! is carried out at an array of points. ! ! This routine was designed for use by PCHFD, but it may also be ! useful directly as an evaluator for a piecewise cubic Hermite ! function in applications, such as graphing, where the interval ! is known in advance. ! ! If only function values are required, use CHFEV instead. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! This version by John Burkardt. ! ! Reference: ! ! Fred Fritsch, Ralph Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, real ( kind = rk ) X1, X2, the endpoints of the interval of ! definition of the cubic. X1 and X2 must be distinct. ! ! Input, real ( kind = rk ) F1, F2, the values of the function at X1 and ! X2, respectively. ! ! Input, real ( kind = rk ) D1, D2, the derivative values at the ends ! of the interval. ! ! Input, integer NE, the number of evaluation points. ! ! Input, real ( kind = rk ) XE(NE), the points at which the functions are to ! be evaluated. If any of the XE are outside the interval ! [X1,X2], a warning error is returned in next. ! ! Output, real ( kind = rk ) FE(NE), DE(NE), the values of the cubic ! function and its derivative at the points XE(*). ! ! Output, integer NEXT(2), indicates the number of ! extrapolation points: ! NEXT(1) = number of evaluation points to left of interval. ! NEXT(2) = number of evaluation points to right of interval. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, NE < 1. ! -2, X1 == X2. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ne real ( kind = rk ) c2 real ( kind = rk ) c2t2 real ( kind = rk ) c3 real ( kind = rk ) c3t3 real ( kind = rk ) d1 real ( kind = rk ) d2 real ( kind = rk ) de(ne) real ( kind = rk ) del1 real ( kind = rk ) del2 real ( kind = rk ) delta real ( kind = rk ) f1 real ( kind = rk ) f2 real ( kind = rk ) fe(ne) real ( kind = rk ) h integer i integer ierr integer next(2) real ( kind = rk ) x real ( kind = rk ) x1 real ( kind = rk ) x2 real ( kind = rk ) xe(ne) real ( kind = rk ) xma real ( kind = rk ) xmi ! ! Check arguments. ! if ( ne < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHFDV - Fatal error!' write ( *, '(a)' ) ' The number of evaluation points was less than 1.' stop end if h = x2 - x1 if ( h == 0.0D+00 ) then ierr = -2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHFDV - Fatal error!' write ( *, '(a)' ) ' The interval endpoints are equal.' return end if ! ! Initialize. ! ierr = 0 next(1) = 0 next(2) = 0 xmi = min ( 0.0D+00, h ) xma = max ( 0.0D+00, h ) ! ! Compute cubic coefficients expanded about X1. ! delta = ( f2 - f1 ) / h del1 = ( d1 - delta ) / h del2 = ( d2 - delta ) / h c2 = -( del1 + del1 + del2 ) c2t2 = c2 + c2 c3 = ( del1 + del2 ) / h c3t3 = c3 + c3 + c3 ! ! Evaluation loop. ! do i = 1, ne x = xe(i) - x1 fe(i) = f1 + x * ( d1 + x * ( c2 + x * c3 ) ) de(i) = d1 + x * ( c2t2 + x * c3t3 ) ! ! Count extrapolation points. ! if ( x < xmi ) then next(1) = next(1) + 1 end if if ( xma < x ) then next(2) = next(2) + 1 end if end do return end subroutine chfev ( x1, x2, f1, f2, d1, d2, ne, xe, fe, next, ierr ) !*****************************************************************************80 ! !! chfev() evaluates a cubic polynomial given in Hermite form. ! ! Discussion: ! ! This routine evaluates a cubic polynomial given in Hermite form at an ! array of points. While designed for use by PCHFE, it may ! be useful directly as an evaluator for a piecewise cubic ! Hermite function in applications, such as graphing, where ! the interval is known in advance. ! ! The cubic polynomial is determined by function values ! F1, F2 and derivatives D1, D2 on the interval [X1,X2]. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! This version by John Burkardt. ! ! Reference: ! ! Fred Fritsch, Ralph Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, real ( kind = rk ) X1, X2, the endpoints of the interval of ! definition of the cubic. X1 and X2 must be distinct. ! ! Input, real ( kind = rk ) F1, F2, the values of the function at X1 and ! X2, respectively. ! ! Input, real ( kind = rk ) D1, D2, the derivative values at X1 and ! X2, respectively. ! ! Input, integer NE, the number of evaluation points. ! ! Input, real ( kind = rk ) XE(NE), the points at which the function is to ! be evaluated. If any of the XE are outside the interval ! [X1,X2], a warning error is returned in NEXT. ! ! Output, real ( kind = rk ) FE(NE), the value of the cubic function ! at the points XE. ! ! Output, integer NEXT(2), the number of extrapolation points: ! NEXT(1) = number of evaluation points to the left of interval. ! NEXT(2) = number of evaluation points to the right of interval. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, NE < 1. ! -2, X1 == X2. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ne real ( kind = rk ) c2 real ( kind = rk ) c3 real ( kind = rk ) d1 real ( kind = rk ) d2 real ( kind = rk ) del1 real ( kind = rk ) del2 real ( kind = rk ) delta real ( kind = rk ) f1 real ( kind = rk ) f2 real ( kind = rk ) fe(ne) real ( kind = rk ) h integer i integer ierr integer next(2) real ( kind = rk ) x real ( kind = rk ) x1 real ( kind = rk ) x2 real ( kind = rk ) xe(ne) real ( kind = rk ) xma real ( kind = rk ) xmi if ( ne < 1 ) then ierr = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHFEV - Fatal error!' write ( *, '(a)' ) ' Number of evaluation points is less than 1.' write ( *, '(a,i6)' ) ' NE = ', ne stop end if h = x2 - x1 if ( h == 0.0D+00 ) then ierr = -2 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHFEV - Fatal error!' write ( *, '(a)' ) ' The interval [X1,X2] is of zero length.' stop end if ! ! Initialize. ! ierr = 0 next(1) = 0 next(2) = 0 xmi = min ( 0.0D+00, h ) xma = max ( 0.0D+00, h ) ! ! Compute cubic coefficients expanded about X1. ! delta = ( f2 - f1 ) / h del1 = ( d1 - delta ) / h del2 = ( d2 - delta ) / h c2 = -( del1 + del1 + del2 ) c3 = ( del1 + del2 ) / h ! ! Evaluation loop. ! do i = 1, ne x = xe(i) - x1 fe(i) = f1 + x * ( d1 + x * ( c2 + x * c3 ) ) ! ! Count the extrapolation points. ! if ( x < xmi ) then next(1) = next(1) + 1 end if if ( xma < x ) then next(2) = next(2) + 1 end if end do return end function chfiv ( x1, x2, f1, f2, d1, d2, a, b, ierr ) !*****************************************************************************80 ! !! chfiv() evaluates the integral of a cubic polynomial in Hermite form. ! ! Discussion: ! ! CHFIV is called by PCHIA to evaluate the integral of a single cubic (in ! Hermite form) over an arbitrary interval (A,B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! This version by John Burkardt. ! ! Reference: ! ! Fred Fritsch, Ralph Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, real ( kind = rk ) VALUE, the value of the requested integral. ! ! Input, real ( kind = rk ) X1, X2, the endpoints of the interval of ! definition of the cubic. X1 and X2 must be distinct. ! ! Input, real ( kind = rk ) F1, F2, the values of the function at X1 ! and X2, respectively. ! ! Input, real ( kind = rk ) D1, D2, the derivative values at the ends ! of the interval. ! ! Input, real ( kind = rk ) A, B, the endpoints of interval of integration. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, X1 == X2. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b real ( kind = rk ) chfiv real ( kind = rk ) d1 real ( kind = rk ) d2 real ( kind = rk ) dterm real ( kind = rk ) f1 real ( kind = rk ) f2 real ( kind = rk ) fterm real ( kind = rk ) h integer ierr real ( kind = rk ) phia1 real ( kind = rk ) phia2 real ( kind = rk ) phib1 real ( kind = rk ) phib2 real ( kind = rk ) psia1 real ( kind = rk ) psia2 real ( kind = rk ) psib1 real ( kind = rk ) psib2 real ( kind = rk ) ta1 real ( kind = rk ) ta2 real ( kind = rk ) tb1 real ( kind = rk ) tb2 real ( kind = rk ) ua1 real ( kind = rk ) ua2 real ( kind = rk ) ub1 real ( kind = rk ) ub2 real ( kind = rk ) x1 real ( kind = rk ) x2 ! ! Check input. ! if ( x1 == x2 ) then ierr = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHFIV - Fatal error!' write ( *, '(a)' ) ' X1 = X2.' stop end if ierr = 0 ! ! Compute integral. ! h = x2 - x1 ta1 = ( a - x1 ) / h ta2 = ( x2 - a ) / h tb1 = ( b - x1 ) / h tb2 = ( x2 - b ) / h ua1 = ta1 * ta1 * ta1 phia1 = ua1 * ( 2.0D+00 - ta1 ) psia1 = ua1 * ( 3.0D+00 * ta1 - 4.0D+00 ) ua2 = ta2 * ta2 * ta2 phia2 = ua2 * ( 2.0D+00 - ta2) psia2 = -ua2 * ( 3.0D+00 * ta2 - 4.0D+00 ) ub1 = tb1 * tb1 * tb1 phib1 = ub1 * ( 2.0D+00 - tb1 ) psib1 = ub1 * ( 3.0D+00 * tb1 - 4.0D+00 ) ub2 = tb2 * tb2 * tb2 phib2 = ub2 * ( 2.0D+00 - tb2 ) psib2 = -ub2 * ( 3.0D+00 * tb2 - 4.0D+00 ) fterm = f1 * ( phia2 - phib2 ) + f2 * ( phib1 - phia1 ) dterm = ( d1 * ( psia2 - psib2 ) + d2 * ( psib1 - psia1 ) ) * ( h / 6.0D+00 ) chfiv = 0.5D+00 * h * ( fterm + dterm ) return end function chfmc ( d1, d2, delta ) !*****************************************************************************80 ! !! chfmc() determines the monotonicity properties of a cubic polynomial. ! ! Discussion: ! ! CHFMC is called by PCHMC to determine the monotonicity properties ! of the cubic with boundary derivative values D1, D2 and chord ! slope DELTA. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! This version by John Burkardt. ! ! Reference: ! ! Fred Fritsch, Ralph Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, real ( kind = rk ) D1, D2, the derivative values at the ends ! of the interval. ! ! Input, real ( kind = rk ) DELTA, the data slope over that interval. ! ! Output, integer CHFMC, indicates the monotonicity of the ! cubic segment: ! -1, if function is strictly decreasing; ! 0, if function is constant; ! 1, if function is strictly increasing; ! 2, if function is non-monotonic; ! 3, if unable to determine. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) a real ( kind = rk ) b integer chfmc real ( kind = rk ) d1 real ( kind = rk ) d2 real ( kind = rk ) delta real ( kind = rk ) eps integer ismon integer itrue real ( kind = rk ) phi eps = 10.0D+00 * epsilon ( eps ) ! ! Make the check. ! if ( delta == 0.0D+00 ) then if ( d1 == 0.0D+00 .and. d2 == 0.0D+00 ) then ismon = 0 else ismon = 2 end if else if ( delta < 0.0 ) then itrue = -1 else itrue = +1 end if a = d1 / delta b = d2 / delta if ( a < 0.0D+00 .or. b < 0.0D+00 ) then ismon = 2 else if ( a <= 3.0D+00 - eps .and. b <= 3.0D+00 -eps ) then ! ! Inside square (0,3)x(0,3) implies OK. ! ismon = itrue else if ( 4.0D+00 + eps < a .and. 4.0D+00 + eps < b ) then ! ! Outside square (0,4)x(0,4) implies nonmonotonic. ! ismon = 2 else ! ! Must check against boundary of ellipse. ! a = a - 2.0D+00 b = b - 2.0D+00 phi = ( ( a * a + b * b ) + a * b ) - 3.0D+00 if ( phi < -eps ) then ismon = itrue else if ( eps < phi ) then ismon = 2 else ! ! Too close to boundary to tell, ! in the presence of round-off errors. ! ismon = 3 end if end if end if chfmc = ismon return end subroutine chkder ( m, n, x, fvec, fjac, ldfjac, xp, fvecp, mode, err ) !*****************************************************************************80 ! !! chkder() checks the gradients of M functions of N variables. ! ! Discussion: ! ! CHKDER checks the gradients of M nonlinear functions in N variables, ! evaluated at a point X, for consistency with the functions themselves. ! ! The user calls CHKDER twice, first with MODE = 1 and then with MODE = 2. ! ! MODE = 1. ! On input, ! X contains the point of evaluation. ! On output, ! XP is set to a neighboring point. ! ! Now the user must evaluate the function and gradients at X, and the ! function at XP. Then the subroutine is called again: ! ! MODE = 2. ! On input, ! FVEC contains the function values at X, ! FJAC contains the function gradients at X. ! FVECP contains the functions evaluated at XP. ! On output, ! ERR contains measures of correctness of the respective gradients. ! ! The subroutine does not perform reliably if cancellation or ! rounding errors cause a severe loss of significance in the ! evaluation of a function. Therefore, none of the components ! of X should be unusually small (in particular, zero) or any ! other value which may cause loss of significance. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jorge More, Burton Garbow, Kenneth Hillstrom, ! User Guide for MINPACK-1, ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer M, is the number of functions. ! ! Input, integer N, is the number of variables. ! ! Input, real ( kind = rk ) X(N), the point at which the jacobian is ! to be evaluated. ! ! Input, real ( kind = rk ) FVEC(M), is used only when MODE = 2. ! In that case, it should contain the function values at X. ! ! Input, real ( kind = rk ) FJAC(LDFJAC,N), an M by N array. When MODE = 2, ! FJAC(I,J) should contain the value of dF(I)/dX(J). ! ! Input, integer LDFJAC, the leading dimension of FJAC. ! LDFJAC must be at least M. ! ! Output, real ( kind = rk ) XP(N), on output with MODE = 1, is a ! neighboring point of X, at which the function is to be evaluated. ! ! Input, real ( kind = rk ) FVECP(M), on input with MODE = 2, is the ! function value at XP. ! ! Input, integer MODE, should be set to 1 on the first call, and ! 2 on the second. ! ! Output, real ( kind = rk ) ERR(M). On output when MODE = 2, ERR ! contains measures of correctness of the respective gradients. If ! there is no severe loss of significance, then if ERR(I): ! = 1.0D+00, the I-th gradient is correct, ! = 0.0D+00, the I-th gradient is incorrect. ! > 0.5D+00, the I-th gradient is probably correct. ! < 0.5D+00, the I-th gradient is probably incorrect. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ldfjac integer m integer n real ( kind = rk ) eps real ( kind = rk ) epsf real ( kind = rk ) epslog real ( kind = rk ) epsmch real ( kind = rk ) err(m) real ( kind = rk ) fjac(ldfjac,n) real ( kind = rk ) fvec(m) real ( kind = rk ) fvecp(m) integer i integer j integer mode real ( kind = rk ) temp real ( kind = rk ) x(n) real ( kind = rk ) xp(n) epsmch = epsilon ( epsmch ) eps = sqrt ( epsmch ) ! ! MODE = 1. ! if ( mode == 1 ) then do j = 1, n temp = eps * abs ( x(j) ) if ( temp == 0.0D+00 ) then temp = eps end if xp(j) = x(j) + temp end do ! ! MODE = 2. ! else if ( mode == 2 ) then epsf = 100.0D+00 * epsmch epslog = log10 ( eps ) err = 0.0D+00 do j = 1, n temp = abs ( x(j) ) if ( temp == 0.0D+00 ) then temp = 1.0D+00 end if err(1:m) = err(1:m) + temp * fjac(1:m,j) end do do i = 1, m temp = 1.0D+00 if ( fvec(i) /= 0.0D+00 .and. fvecp(i) /= 0.0D+00 .and. & epsf * abs ( fvec(i) ) <= abs ( fvecp(i) - fvec(i) ) ) then temp = eps * abs ( ( fvecp(i) - fvec(i) ) / eps - err(i) ) & / ( abs ( fvec(i) ) + abs ( fvecp(i) ) ) end if err(i) = 1.0D+00 if ( epsmch < temp .and. temp < eps ) then err(i) = ( log10 ( temp ) - epslog ) / epslog end if if ( eps <= temp ) then err(i) = 0.0D+00 end if end do end if return end subroutine chlhsn ( nr, n, a, epsm, sx, udiag ) !*****************************************************************************80 ! !! chlhsn() finds the L*L' decomposition of the perturbed model hessian matrix. ! ! Discussion: ! ! The perturbed model Hessian matrix has the form ! ! A + MU * I ! ! (where 0 <= MU and I is the identity matrix) which is safely ! positive definite. ! ! If A is safely positive definite upon entry, then MU=0. ! ! 1. If A has any negative diagonal elements, then choose 0 < MU ! such that the diagonal of A:=A+MU*I is all positive ! with the ratio of its smallest to largest element on the ! order of sqrt ( EPSM ). ! ! 2. A undergoes a perturbed Cholesky decomposition which ! results in an LL+ decomposition of A+D, where D is a ! non-negative diagonal matrix which is implicitly added to ! A during the decomposition if A is not positive definite. ! A is retained and not changed during this process by ! copying L into the upper triangular part of A and the ! diagonal into UDIAG. Then the Cholesky decomposition routine ! is called. On return, ADDMAX contains the maximum element of D. ! ! 3. If ADDMAX=0, A was positive definite going into step 2 ! and return is made to calling program. Otherwise, ! the minimum number SDD which must be added to the ! diagonal of A to make it safely strictly diagonally dominant ! is calculated. Since A + ADDMAX * I and A + SDD * I are safely ! positive definite, choose MU = min ( ADDMAX, SDD ) and decompose ! A + MU * I to obtain L. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input/output, real A(NR,N), contains an N by N matrix. ! On input, A is the model hessian. Only the lower triangular part and ! diagonal are stored. On output, A contains the factor L of the ! LL+ decomposition of the perturbed model hessian in the lower triangular ! part and diagonal, and contains the hessian in the upper triangular part ! and UDIAG. ! ! Input, real ( kind = rk ) EPSM, the machine epsilon. ! ! Input, real ( kind = rk ) SX(N), the diagonal scaling matrix for X. ! ! Output, real ( kind = rk ) UDIAG(N), the diagonal of the hessian. ! ! Local variables: ! ! tol tolerance ! diagmn minimum element on diagonal of a ! diagmx maximum element on diagonal of a ! offmax maximum off-diagonal element of a ! offrow sum of off-diagonal elements in a row of a ! evmin minimum eigenvalue of a ! evmax maximum eigenvalue of a ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) addmax real ( kind = rk ) amu real ( kind = rk ) diagmx real ( kind = rk ) diagmn real ( kind = rk ) epsm real ( kind = rk ) evmax real ( kind = rk ) evmin integer i integer j real ( kind = rk ) offmax real ( kind = rk ) offrow real ( kind = rk ) posmax real ( kind = rk ) sdd real ( kind = rk ) sx(n) real ( kind = rk ) tol real ( kind = rk ) udiag(n) ! ! Scale the hessian. ! do j = 1, n do i = j, n a(i,j) = a(i,j) / ( sx(i) * sx(j) ) end do end do ! ! Step1 ! tol = sqrt ( epsm ) diagmx = a(1,1) diagmn = a(1,1) do i = 2, n if ( a(i,i) < diagmn ) then diagmn = a(i,i) end if if ( diagmx < a(i,i) ) then diagmx = a(i,i) end if end do posmax = max ( diagmx, 0.0D+00 ) if ( diagmn <= posmax * tol ) then amu = tol * ( posmax - diagmn ) - diagmn ! ! Find the largest off-diagonal element of A. ! if ( amu == 0.0D+00 ) then offmax = 0.0D+00 do i = 2, n do j = 1, i-1 if ( offmax < abs ( a(i,j) ) ) then offmax = abs ( a(i,j) ) end if end do end do amu = offmax if ( amu == 0.0D+00 ) then amu = 1.0D+00 else amu = amu * ( 1.0D+00 + tol ) end if end if ! ! A = A + MU*I ! do i = 1, n a(i,i) = a(i,i) + amu end do diagmx = diagmx + amu end if ! ! Step2 ! ! Copy lower triangular part of A to upper triangular part ! and diagonal of A to udiag ! do j = 1, n udiag(j) = a(j,j) do i = j + 1, n a(j,i) = a(i,j) end do end do call choldc ( nr, n, a, diagmx, tol, addmax ) ! ! Step3 ! ! If ADDMAX=0, A was positive definite going into step 2, ! the ll+ decomposition has been done, and we return. ! ! Otherwise, 0 < ADDMAX. perturb A so that it is safely ! diagonally dominant and find ll+ decomposition ! if ( 0.0D+00 < addmax ) then ! ! Restore original A (lower triangular part and diagonal) ! do j = 1, n a(j,j) = udiag(j) do i = j+1, n a(i,j) = a(j,i) end do end do ! ! Find SDD such that A+sdd*i is safely positive definite ! note: evmin<0 since A is not positive definite; ! evmin = 0.0D+00 evmax = a(1,1) do i = 1, n offrow = sum ( abs ( a(i,1:i-1) ) ) + sum ( abs ( a(i+1:n,i) ) ) evmin = min ( evmin, a(i,i)-offrow ) evmax = max ( evmax, a(i,i)+offrow ) end do sdd = tol * ( evmax - evmin ) - evmin ! ! Perturb A and decompose again. ! amu = min ( sdd, addmax ) do i = 1, n a(i,i) = a(i,i) + amu udiag(i) = a(i,i) end do ! ! A is now guaranteed safely positive definite ! call choldc ( nr, n, a, 0.0D+00, tol, addmax ) end if ! ! Unscale the hessian and Cholesky decomposition matrix. ! do j = 1, n a(j:n,j) = sx(j:n) * a(j:n,j) do i = 1, j - 1 a(i,j) = sx(i) * sx(j) * a(i,j) end do udiag(j) = udiag(j) * sx(j) * sx(j) end do return end subroutine choldc ( nr, n, a, diagmx, tol, addmax ) !*****************************************************************************80 ! !! choldc() finds the perturbed L*L' decomposition of A+D. ! ! Discussion: ! ! D is a non-negative diagonal matrix added to A if ! necessary to allow the Cholesky decomposition to continue. ! ! The normal Cholesky decomposition is performed. However, if at any ! point the algorithm would attempt to set ! L(I,I) = sqrt ( TEMP ) ! with ! TEMP < TOL * DIAGMX, ! then L(I,I) is set to sqrt ( TOL * DIAGMX ) ! instead. This is equivalent to adding TOL * DIAGMX-TEMP to A(I,I) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input/output, real ( kind = rk ) A(NR,N), the N by N matrix. ! On input, the matrix for which to find the perturbed ! Cholesky decomposition. ! On output, the lower triangular part contains the L factor, ! and the diagonal of A. ! ! Input, real ( kind = rk ) DIAGMX, the maximum diagonal element of A. ! ! Input, real ( kind = rk ) TOL, a tolerance. ! ! Output, real ( kind = rk ) ADDMAX, the maximum amount implicitly added to ! the diagonal of A in forming the Cholesky decomposition of A+D. ! ! Local variables: ! ! aminl smallest element allowed on diagonal of L. ! ! amnlsq =aminl**2 ! ! offmax maximum off-diagonal element in column of a ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) addmax real ( kind = rk ) aminl real ( kind = rk ) amnlsq real ( kind = rk ) diagmx integer i integer j integer k real ( kind = rk ) offmax real ( kind = rk ) sum2 real ( kind = rk ) temp real ( kind = rk ) tol addmax = 0.0D+00 aminl = sqrt ( diagmx * tol ) amnlsq = aminl**2 ! ! Form column J of L. ! do j = 1, n ! ! Find diagonal elements of L. ! sum2 = sum ( a(j,1:j-1)**2 ) temp = a(j,j) - sum2 if ( amnlsq <= temp ) then a(j,j) = sqrt ( temp ) ! ! Find maximum off-diagonal element in column. ! else offmax = 0.0D+00 do i = j+1, n if ( offmax < abs ( a(i,j) ) ) then offmax = abs ( a(i,j) ) end if end do if ( offmax <= amnlsq ) then offmax = amnlsq end if ! ! Add to diagonal element to allow Cholesky decomposition to continue ! a(j,j) = sqrt ( offmax ) addmax = max ( addmax, offmax - temp ) end if ! ! Find (I,J) element of lower triangular matrix. ! do i = j+1, n sum2 = 0.0D+00 do k = 1, j-1 sum2 = sum2 + a(i,k) * a(j,k) end do a(i,j) = ( a(i,j) - sum2 ) / a(j,j) end do end do return end subroutine cosqb ( n, x, wsave ) !*****************************************************************************80 ! !! cosqb() computes the fast cosine transform of quarter wave data. ! ! Discussion: ! ! COSQB computes a sequence from its representation in terms of a cosine ! series with odd wave numbers. ! ! The transform is defined by: ! ! X_out(I) = sum ( 1 <= K <= N ) ! ! 4 * X_in(K) * cos ( ( 2 * K - 1 ) * ( I - 1 ) * PI / ( 2 * N ) ) ! ! COSQB is the unnormalized inverse of COSQF since a call of COSQB ! followed by a call of COSQF will multiply the input sequence X by 4*N. ! ! The array WSAVE must be initialized by calling COSQI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software, ! W. Cowell, editor, ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array X. The method is ! more efficient when N is the product of small primes. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the cosine series coefficients. ! On output, the corresponding data vector. ! ! Input, real WSAVE(3*N+15), contains data, depending on N, and ! required by the algorithm. The WSAVE array must be initialized by ! calling COSQI. A different WSAVE array must be used for each different ! value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ), parameter :: tsqrt2 = 2.82842712474619D+00 real ( kind = rk ) wsave(3*n+15) real ( kind = rk ) x(n) real ( kind = rk ) x1 if ( n < 2 ) then x(1) = 4.0D+00 * x(1) else if ( n == 2 ) then x1 = 4.0D+00 * ( x(1) + x(2) ) x(2) = tsqrt2 * ( x(1) - x(2) ) x(1) = x1 else call cosqb1 ( n, x, wsave(1), wsave(n+1) ) end if return end subroutine cosqb1 ( n, x, w, xh ) !*****************************************************************************80 ! !! cosqb1() is a lower level routine used by COSQB. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the cosine series coefficients. ! On output, the corresponding data vector. ! ! Input, real ( kind = rk ) W(N). ! ! Input, real ( kind = rk ) XH(2*N+15). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer k integer kc integer ns2 real ( kind = rk ) w(n) real ( kind = rk ) x(n) real ( kind = rk ) xh(2*n+15) real ( kind = rk ) xim1 ns2 = ( n + 1 ) / 2 do i = 3, n, 2 xim1 = x(i-1) + x(i) x(i) = x(i) - x(i-1) x(i-1) = xim1 end do x(1) = x(1) + x(1) if ( mod ( n, 2 ) == 0 ) then x(n) = 2.0D+00 * x(n) end if call dfftb ( n, x, xh ) do k = 2, ns2 kc = n + 2 - k xh(k) = w(k-1) * x(kc) + w(kc-1) * x(k) xh(kc) = w(k-1) * x(k) - w(kc-1) * x(kc) end do if ( mod ( n, 2 ) == 0 ) then x(ns2+1) = w(ns2) * ( x(ns2+1) + x(ns2+1) ) end if do k = 2, ns2 kc = n + 2 - k x(k) = xh(k) + xh(kc) x(kc) = xh(k) - xh(kc) end do x(1) = 2.0D+00 * x(1) return end subroutine cosqf ( n, x, wsave ) !*****************************************************************************80 ! !! cosqf)_ computes the fast cosine transform of quarter wave data. ! ! Discussion: ! ! COSQF computes the coefficients in a cosine series representation ! with only odd wave numbers. ! ! COSQF is the unnormalized inverse of COSQB since a call of COSQF ! followed by a call of COSQB will multiply the input sequence X ! by 4*N. ! ! The array WSAVE must be initialized by calling COSQI. ! ! The transform is defined by: ! ! X_out(I) = X_in(1) + sum ( 2 <= K <= N ) ! ! 2 * X_in(K) * cos ( ( 2 * I - 1 ) * ( K - 1 ) * PI / ( 2 * N ) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software, ! W. Cowell, editor, ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array X. The method is ! more efficient when N is the product of small primes. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the data to be transformed. ! On output, the transformed data. ! ! Input, real ( kind = rk ) WSAVE(3*N+15), contains data, depending on N, and ! required by the algorithm. The WSAVE array must be initialized by ! calling COSQI. A different WSAVE array must be used for each different ! value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ), parameter :: sqrt2 = 1.4142135623731D+00 real ( kind = rk ) tsqx real ( kind = rk ) wsave(3*n+15) real ( kind = rk ) x(n) if ( n < 2 ) then else if ( n == 2 ) then tsqx = sqrt2 * x(2) x(2) = x(1) - tsqx x(1) = x(1) + tsqx else call cosqf1 ( n, x, wsave(1), wsave(n+1) ) end if return end subroutine cosqf1 ( n, x, w, xh ) !*****************************************************************************80 ! !! cosqf1() is a lower level routine used by COSQF. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the data to be transformed. ! On output, the transformed data. ! ! Input, real ( kind = rk ) W(N). ! ! Input, real ( kind = rk ) XH(2*N+15). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer k integer kc integer ns2 real ( kind = rk ) w(n) real ( kind = rk ) x(n) real ( kind = rk ) xh(2*n+15) real ( kind = rk ) xim1 ns2 = ( n + 1 ) / 2 do k = 2, ns2 kc = n + 2 - k xh(k) = x(k) + x(kc) xh(kc) = x(k) - x(kc) end do if ( mod ( n, 2 ) == 0 ) then xh(ns2+1) = x(ns2+1) + x(ns2+1) end if do k = 2, ns2 kc = n+2-k x(k) = w(k-1) * xh(kc) + w(kc-1) * xh(k) x(kc) = w(k-1) * xh(k) - w(kc-1) * xh(kc) end do if ( mod ( n, 2 ) == 0 ) then x(ns2+1) = w(ns2) * xh(ns2+1) end if call dfftf ( n, x, xh ) do i = 3, n, 2 xim1 = x(i-1) - x(i) x(i) = x(i-1) + x(i) x(i-1) = xim1 end do return end subroutine cosqi ( n, wsave ) !*****************************************************************************80 ! !! cosqi() initializes WSAVE, used in COSQF and COSQB. ! ! Discussion: ! ! The prime factorization of N together with a tabulation of the ! trigonometric functions are computed and stored in WSAVE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software, ! W. Cowell, editor, ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! The method is more efficient when N is the product of small primes. ! ! Output, real ( kind = rk ) WSAVE(3*N+15), contains data, depending on N, ! and required by the COSQB and COSQF algorithms. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) :: pi = 3.141592653589793D+00 real ( kind = rk ) dt integer k real ( kind = rk ) wsave(3*n+15) dt = 0.5D+00 * pi / real ( n, kind = rk ) do k = 1, n wsave(k) = cos ( real ( k, kind = rk ) * dt ) end do call dffti ( n, wsave(n+1) ) return end subroutine cost ( n, x, wsave ) !*****************************************************************************80 ! !! COST computes the discrete Fourier cosine transform of an even sequence. ! ! Discussion: ! ! COST is the unnormalized inverse of itself since a call of COST ! followed by another call of COST will multiply the input sequence ! X by 2*(N-1). ! ! The array WSAVE must be initialized by calling COSTI. ! ! The transform is defined by: ! ! X_out(I) = X_in(1) + (-1) **(I-1) * X_in(N) + sum ( 2 <= K <= N-1 ) ! ! 2 * X_in(K) * cos ( ( K - 1 ) * ( I - 1 ) * PI / ( N - 1 ) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software, ! W. Cowell, editor, ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. The method is more efficient when N-1 is the product of ! small primes. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) WSAVE(3*N+15). ! The WSAVE array must be initialized by calling COSTI. A different ! array must be used for each different value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) c1 integer i integer k integer kc integer ns2 real ( kind = rk ) t1 real ( kind = rk ) t2 real ( kind = rk ) tx2 real ( kind = rk ) wsave(3*n+15) real ( kind = rk ) x(n) real ( kind = rk ) x1h real ( kind = rk ) x1p3 real ( kind = rk ) xi real ( kind = rk ) xim2 ns2 = n / 2 if ( n <= 1 ) then return end if if ( n == 2 ) then x1h = x(1) + x(2) x(2) = x(1) - x(2) x(1) = x1h return end if if ( n == 3 ) then x1p3 = x(1) + x(3) tx2 = x(2) + x(2) x(2) = x(1) - x(3) x(1) = x1p3 + tx2 x(3) = x1p3 - tx2 return end if c1 = x(1) - x(n) x(1) = x(1) + x(n) do k = 2, ns2 kc = n + 1 - k t1 = x(k) + x(kc) t2 = x(k) - x(kc) c1 = c1 + wsave(kc) * t2 t2 = wsave(k) * t2 x(k) = t1 - t2 x(kc) = t1 + t2 end do if ( mod ( n, 2 ) /= 0 ) then x(ns2+1) = x(ns2+1) + x(ns2+1) end if call dfftf ( n-1, x, wsave(n+1) ) xim2 = x(2) x(2) = c1 do i = 4, n, 2 xi = x(i) x(i) = x(i-2) - x(i-1) x(i-1) = xim2 xim2 = xi end do if ( mod ( n, 2 ) /= 0 ) then x(n) = xim2 end if return end subroutine costi ( n, wsave ) !*****************************************************************************80 ! !! COSTI initializes WSAVE, used in COST. ! ! Discussion: ! ! The prime factorization of N together with a tabulation of the ! trigonometric functions are computed and stored in WSAVE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software, ! W. Cowell, editor, ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. The method is more efficient when N-1 is the product of ! small primes. ! ! Output, real ( kind = rk ) WSAVE(3*N+15), contains data, depending on N, ! and required by the COST algorithm. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) :: pi = 3.141592653589793D+00 real ( kind = rk ) dt integer k real ( kind = rk ) wsave(3*n+15) if ( n <= 3 ) then return end if dt = pi / real ( n - 1, kind = rk ) do k = 2, ( n / 2 ) wsave(k) = 2.0D+00 * sin ( real ( k - 1, kind = rk ) * dt ) wsave(n+1-k) = 2.0D+00 * cos ( real ( k - 1, kind = rk ) * dt ) end do call dffti ( n-1, wsave(n+1) ) return end function csevl ( x, cs, n ) !*****************************************************************************80 ! !! CSEVL evaluates an N term Chebyshev series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 April 2003 ! ! Reference: ! ! R Broucke, ! Algorithm 446, ! Communications of the ACM, ! Volume 16, page 254, 1973. ! ! Leslie Fox, Ian Parker, ! Chebyshev Polynomials in Numerical Analysis, ! Oxford Press, page 56. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument at which the series is to be ! evaluated. X must satisfy -1.0 <= X <= 1.0. ! ! Input, real ( kind = rk ) CS(N), the array of N terms of a Chebyshev series. ! In evaluating CS, only half the first coefficient is summed. ! ! Input, integer N, the number of terms in array CS. ! N must be at least 1, and no more than 1000. ! ! Output, real ( kind = rk ) CSEVL, the value of the Chebyshev series. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) b0 real ( kind = rk ) b1 real ( kind = rk ) b2 real ( kind = rk ) cs(n) real ( kind = rk ) csevl integer i real ( kind = rk ) x if ( n < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CSEVL - Fatal error!' write ( *, '(a)' ) ' Number of terms N is less than 1.' stop end if if ( 1000 < n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CSEVL - Fatal error!' write ( *, '(a)' ) ' The number of terms is more than 1000.' stop end if if ( x < -1.0D+00 .or. 1.0D+00 < x ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CSEVL - Fatal error!' write ( *, '(a)' ) ' The input argument X is outside the interval [-1,1].' stop end if b1 = 0.0D+00 b0 = 0.0D+00 do i = n, 1, -1 b2 = b1 b1 = b0 b0 = 2.0D+00 * x * b1 - b2 + cs(i) end do csevl = 0.5D+00 * ( b0 - b2 ) return end subroutine d1fcn ( n, x, g ) !*****************************************************************************80 ! !! D1FCN is a dummy routine for evaluating the gradient vector. ! ! Discussion: ! ! We assume that F is a scalar function of N variables X. The routine ! is to compute the vector G where G(I) = d F/d X(I). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 April 2001 ! ! Parameters: ! ! Input, integer N, the dimension of X, and order of A. ! ! Input, real ( kind = rk ) X(N), the point at which the gradient ! is to be evaluated. ! ! Output, real ( kind = rk ) G(N), the gradient vector.. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) g(n) real ( kind = rk ) x(n) call r8_fake_use ( g(1) ) call r8_fake_use ( x(1) ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D1FCN - Fatal error!' write ( *, '(a)' ) ' This is a dummy routine.' write ( *, '(a)' ) ' The user is required to replace it with a' write ( *, '(a)' ) ' routine that computes the gradient of F.' stop 1 end function d1mach ( i ) !*****************************************************************************80 ! !! D1MACH returns double precision real machine constants. ! ! Discussion: ! ! Assuming that the internal representation of a double precision real ! number is in base B, with T the number of base-B digits in the mantissa, ! and EMIN the smallest possible exponent and EMAX the largest possible ! exponent, then ! ! D1MACH(1) = B**(EMIN-1), the smallest positive magnitude. ! D1MACH(2) = B**EMAX*(1-B**(-T)), the largest magnitude. ! D1MACH(3) = B**(-T), the smallest relative spacing. ! D1MACH(4) = B**(1-T), the largest relative spacing. ! D1MACH(5) = log10(B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 April 2007 ! ! Author: ! ! Phyllis Fox, Andrew Hall, Norman Schryer ! ! Reference: ! ! Phyllis Fox, Andrew Hall, Norman Schryer, ! Algorithm 528: ! Framework for a Portable Library, ! ACM Transactions on Mathematical Software, ! Volume 4, Number 2, June 1978, page 176-188. ! ! Parameters: ! ! Input, integer I, chooses the parameter to be returned. ! 1 <= I <= 5. ! ! Output, real ( kind = rk ) D1MACH, the value of the chosen parameter. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) d1mach integer i if ( i < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i d1mach = 0.0D+00 stop else if ( i == 1 ) then d1mach = 4.450147717014403D-308 else if ( i == 2 ) then d1mach = 8.988465674311579D+307 else if ( i == 3 ) then d1mach = 1.110223024625157D-016 else if ( i == 4 ) then d1mach = 2.220446049250313D-016 else if ( i == 5 ) then d1mach = 0.301029995663981D+000 else if ( 5 < i ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i d1mach = 0.0D+00 stop end if return end subroutine d1mpyq ( m, n, a, lda, v, w ) !*****************************************************************************80 ! !! D1MPYQ computes A*Q, where Q is the product of Householder transformations. ! ! Discussion: ! ! Given an M by N matrix A, this subroutine computes A * Q where ! Q is the product of 2 * (N - 1) transformations ! ! GV(N-1) * ... * GV(1) * GW(1) * ... * GW(N-1) ! ! and GV(I), GW(I) are Givens rotations in the (I,N) plane which ! eliminate elements in the I-th and N-th planes, respectively. ! Q itself is not given, rather the information to recover the ! GV, GW rotations is supplied. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jorge More, Burton Garbow, Kenneth Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer M, the number of rows of A. ! ! Input, integer N, the number of columns of A. ! ! Input/output, real ( kind = rk ) A(LDA,N), the M by N array. ! On input, the matrix A to be postmultiplied by the orthogonal matrix Q. ! On output, the value of A*Q. ! ! Input, integer LDA, the leading dimension of A, which must not ! be less than M. ! ! Input, real ( kind = rk ) V(N), W(N), contain the information necessary ! to recover the Givens rotations GV and GW. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer m integer n real ( kind = rk ) a(lda,n) real ( kind = rk ) c integer i integer j real ( kind = rk ) s real ( kind = rk ) temp real ( kind = rk ) v(n) real ( kind = rk ) w(n) ! ! Apply the first set of Givens rotations to A. ! do j = n-1, 1, -1 if ( 1.0D+00 < abs ( v(j) ) ) then c = 1.0D+00 / v(j) s = sqrt ( 1.0D+00 - c * c ) else s = v(j) c = sqrt ( 1.0D+00 - s * s ) end if do i = 1, m temp = c * a(i,j) - s * a(i,n) a(i,n) = s * a(i,j) + c * a(i,n) a(i,j) = temp end do end do ! ! Apply the second set of Givens rotations to A. ! do j = 1, n-1 if ( 1.0D+00 < abs ( w(j) ) ) then c = 1.0D+00 / w(j) s = sqrt ( 1.0D+00 - c * c ) else s = w(j) c = sqrt ( 1.0D+00 - s * s ) end if do i = 1, m temp = c * a(i,j) + s * a(i,n) a(i,n) = - s * a(i,j) + c * a(i,n) a(i,j) = temp end do end do return end subroutine d2fcn ( nr, n, x, a ) !*****************************************************************************80 ! !! D2FCN is a dummy version of a routine that computes the second derivative. ! ! Discussion: ! ! We assume that F is a scalar function of N variables X. The routine ! is to compute the matrix H where H(I,J) = d d F / d X(I) d X(J). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 April 2001 ! ! Parameters: ! ! Input, integer NR, the leading dimension of A, which must be ! at least N. ! ! Input, integer N, the dimension of X, and order of A. ! ! Input, real ( kind = rk ) X(N), the point at which the Hessian matrix ! is to be evaluated. ! ! Output, real ( kind = rk ) A(NR,N), the N by N Hessian matrix. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) x(n) call r8_fake_use ( x(1) ) call r8_fake_use ( a(1,1) ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D2FCN - Fatal error!' write ( *, '(a)' ) ' This is a dummy routine.' write ( *, '(a)' ) ' The user is required to replace it with a' write ( *, '(a)' ) ' routine that computes the Hessian matrix of F.' stop 1 end function d9lgmc ( x ) !*****************************************************************************80 ! !! D9LGMC computes the log gamma correction factor. ! ! Discussion: ! ! The routine computes the log gamma correction factor for 10 <= X ! so that ! ! log ( gamma ( x ) ) = ! log ( sqrt ( 2 * pi ) ) + ( x - 0.5 ) * log ( x ) - x + d9lgmc ( x ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of the log gamma function. ! X must be at least 10. ! ! Output, real ( kind = rk ) D9LGMC, the correction. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), save, dimension ( 6 ) :: algmcs = (/ & 0.166638948045186D+00, -0.0000138494817606D+00, 0.0000000098108256D+00, & -0.0000000000180912D+00, 0.0000000000000622D+00, -0.0000000000000003D+00 /) real ( kind = rk ) arg real ( kind = rk ) csevl real ( kind = rk ) d9lgmc integer inits integer, save :: nalgm = 0 real ( kind = rk ) x real ( kind = rk ), save :: xbig = 0.0D+00 real ( kind = rk ), save :: xmax = 0.0D+00 if ( nalgm == 0 ) then nalgm = inits ( algmcs, 6, epsilon ( algmcs ) ) xbig = 1.0D+00 / sqrt ( epsilon ( xbig ) ) xmax = exp ( min ( log ( huge ( xmax ) / 12.0D+00 ), & -log ( 12.0D+00 * tiny ( xmax ) ) ) ) end if if ( x < 10.0D+00 ) then call xerror ( 'D9LGMC - 10 <= x required', 1, 2 ) else if ( x < xbig ) then arg = 2.0D+00 * ( 10.0D+00 / x )**2 - 1.0D+00 d9lgmc = csevl ( arg, algmcs, nalgm ) / x else if ( x < xmax ) then d9lgmc = 1.0D+00 / ( 12.0D+00 * x ) else d9lgmc = 0.0D+00 call xerror ( 'D9LGMC - X so big d9lgmc underflows', 2, 1) end if return end function damax ( n, x, incx ) !*****************************************************************************80 ! !! DAMAX returns the maximum absolute value of the entries in a vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 1999 ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real ( kind = rk ) X(*), the vector to be examined. ! ! Input, integer INCX, the increment between successive ! entries of X. ! ! Output, real ( kind = rk ) DAMAX, the maximum absolute value of ! an element of X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer incx integer ix integer n real ( kind = rk ) damax real ( kind = rk ) x(*) if ( n <= 0 ) then damax = 0.0D+00 else if ( n == 1 ) then damax = abs ( x(1) ) else if ( incx == 1 ) then damax = abs ( x(1) ) do i = 2, n if ( damax < abs ( x(i) ) ) then damax = abs ( x(i) ) end if end do else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if damax = abs ( x(ix) ) ix = ix + incx do i = 2, n if ( damax < abs ( x(ix) ) ) then damax = abs ( x(ix) ) end if ix = ix + incx end do end if return end function dasum ( n, x, incx ) !*****************************************************************************80 ! !! DASUM takes the sum of the absolute values of a vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 15 February 2001 ! ! Author: ! ! Jack Dongarra ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector to be examined. ! ! Input, integer INCX, the increment between successive ! entries of X. INCX must not be negative. ! ! Output, real ( kind = rk ) DASUM, the sum of the absolute values of X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) dasum integer incx integer n real x(*) dasum = sum ( abs ( x(1:1+(n-1)*incx:incx) ) ) return end subroutine daxpy ( n, da, dx, incx, dy, incy ) !*****************************************************************************80 ! !! DAXPY computes constant times a vector plus a vector. ! ! Discussion: ! ! Uses unrolled loops for increments equal to one. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Jack Dongarra ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of elements in DX and DY. ! ! Input, real ( kind = rk ) DA, the multiplier of DX. ! ! Input, real ( kind = rk ) DX(*), the first vector. ! ! Input, integer INCX, the increment between successive ! entries of DX. ! ! Input/output, real ( kind = rk ) DY(*), the second vector. ! On output, DY(*) has been replaced by DY(*) + DA * DX(*). ! ! Input, integer INCY, the increment between successive ! entries of DY. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) da real ( kind = rk ) dx(*) real ( kind = rk ) dy(*) integer i integer incx integer incy integer ix integer iy integer m integer n if ( n <= 0 ) then return end if if ( da == 0.0D+00 ) then return end if ! ! Code for unequal increments or equal increments ! not equal to 1. ! if ( incx /= 1 .or. incy /= 1 ) then if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if do i = 1, n dy(iy) = dy(iy) + da * dx(ix) ix = ix + incx iy = iy + incy end do ! ! Code for both increments equal to 1. ! else m = mod ( n, 4 ) do i = 1, m dy(i) = dy(i) + da * dx(i) end do do i = m+1, n, 4 dy(i ) = dy(i ) + da * dx(i ) dy(i+1) = dy(i+1) + da * dx(i+1) dy(i+2) = dy(i+2) + da * dx(i+2) dy(i+3) = dy(i+3) + da * dx(i+3) end do end if return end subroutine ddcor ( dfdy, el, fa, h, impl, ipvt, matdim, miter, ml, mu, n, & nde, nq, t, users, y, yh, ywt, evalfa, save1, save2, a, d, jstate ) !*****************************************************************************80 ! !! DDCOR computes corrections to the Y array of DDRIV3. ! ! Discussion: ! ! In the case of functional iteration, update Y directly from the ! result of the last call to F. ! ! In the case of the chord method, compute the corrector error and ! solve the linear system with that as right hand side and DFDY as ! coefficient matrix, using the lu decomposition if miter is 1, 2, 4, ! or 5. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 June 2020 ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer matdim integer n real ( kind = rk ) a(matdim,*) real ( kind = rk ) d real ( kind = rk ) dfdy(matdim,*) real ( kind = rk ) dnrm2 real ( kind = rk ) el(13,12) logical evalfa external fa real ( kind = rk ) h integer i integer i1 integer i2 integer i3 integer iflag integer impl integer ipvt(*) integer j integer jstate integer miter integer ml integer mu integer mw integer nde integer nq real ( kind = rk ) save1(*) real ( kind = rk ) save2(*) real ( kind = rk ) t external users real ( kind = rk ) y(*) real ( kind = rk ) yh(n,*) real ( kind = rk ) ywt(*) if ( miter == 0 ) then save1(1:n) = ( h * save2(1:n) - yh(1:n,2) - save1(1:n) ) / ywt(1:n) d = dnrm2 ( n, save1, 1 ) / sqrt ( real ( n, kind = rk ) ) save1(1:n) = h * save2(1:n) - yh(1:n,2) else if ( miter == 1 .or. miter == 2 ) then if ( impl == 0 ) then save2(1:n) = h * save2(1:n) - yh(1:n,2) - save1(1:n) else if ( impl == 1 ) then if ( evalfa ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if else evalfa = .true. end if save2(1:n) = h * save2(1:n) do j = 1, n save2(1:n) = save2(1:n) - a(1:n,j) * ( yh(j,2) + save1(j) ) end do else if ( impl == 2 ) then if ( evalfa ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if else evalfa = .true. end if save2(1:n) = h * save2(1:n) - a(1:n,1) * ( yh(1:n,2) + save1(1:n) ) end if call dgesl ( dfdy, matdim, n, ipvt, save2, 0 ) save1(1:n) = save1(1:n) + save2(1:n) save2(1:n) = save2(1:n) / ywt(1:n) d = dnrm2 ( n, save2, 1 ) / sqrt ( real ( n, kind = rk ) ) else if ( miter == 4 .or. miter == 5 ) then if ( impl == 0 ) then save2(1:n) = h * save2(1:n) - yh(1:n,2) - save1(1:n) else if ( impl == 1 ) then if ( evalfa ) then call fa ( n, t, y, a(ml+1,1), matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if else evalfa = .true. end if save2(1:n) = h * save2(1:n) mw = ml + 1 + mu do j = 1, n i1 = max ( ml+1, mw+1-j ) i2 = min ( mw+n-j, mw+ml ) do i = i1,i2 i3 = i + j - mw save2(i3) = save2(i3) - a(i,j)*(yh(j,2) + save1(j)) end do end do else if ( impl == 2 ) then if ( evalfa ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if else evalfa = .true. end if save2(1:n) = h * save2(1:n) - a(1:n,1)*(yh(1:n,2) + save1(1:n)) end if call dgbsl ( dfdy, matdim, n, ml, mu, ipvt, save2, 0 ) save1(1:n) = save1(1:n) + save2(1:n) save2(1:n) = save2(1:n) / ywt(1:n) d = dnrm2 ( n, save2, 1 ) / sqrt ( real ( n, kind = rk ) ) else if ( miter == 3 ) then iflag = 2 call users ( y, yh(1,2), ywt, save1, save2, t, h, el(1,nq), impl, & n, nde, iflag ) if ( n == 0 ) then jstate = 10 return end if save1(1:n) = save1(1:n) + save2(1:n) save2(1:n) = save2(1:n) / ywt(1:n) d = dnrm2 ( n, save2, 1) / sqrt ( real ( n, kind = rk ) ) end if end subroutine ddcst ( maxord, mint, iswflg, el, tq ) !*****************************************************************************80 ! !! DDCST sets coefficients used by the core integrator DDSTP. ! ! Discussion: ! ! EL and TQ depend upon MINT, and are calculated ! for orders 1 to maxord(<= 12). for each order NQ, the coefficients ! EL are calculated from the generating polynomial: ! l(t) = el(1,nq) + el(2,nq) * t + ... + el(nq+1,nq) * t**nq. ! for the implicit adams methods, l(t) is given by ! dl/dt = (1+t)*(2+t)* ... *(nq-1+t)/k, l(-1) = 0, ! where k = factorial(nq-1). ! for the gear methods, ! l(t) = (1+t)*(2+t)* ... *(nq+t)/k, ! where k = factorial(nq)*(1 + 1/2 + ... + 1/nq). ! for each order nq, there are three components of tq. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, integer MAXORD, the maximum order to calculate. ! ! Input, integer MINT, 1 for Adams methods, 2 for Gear. ! ! Input, integer ISWFLG, indicates whether the constants used ! in the stiffness test should be calculated. ! ! Output, real ( kind = rk ) EL(13,12), used in specifying the basic method. ! ! Output, real ( kind = rk ) TQ(3,12), used in adjusting the stepsize in ! relation to truncation error. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) el(13,12) real ( kind = rk ) factrl(12) real ( kind = rk ) gamma(14) integer i integer iswflg integer j integer maxord integer mint integer mxrd real ( kind = rk ) sum2 real ( kind = rk ) tq(3,12) factrl(1) = 1.0D+00 do i = 2, maxord factrl(i) = real ( i, kind = rk ) * factrl(i-1) end do ! ! Compute Adams coefficients ! if ( mint == 1 ) then gamma(1) = 1.0D+00 do i = 1, maxord + 1 sum2 = 0.0D+00 do j = 1, i sum2 = sum2 - gamma(j) / real ( i - j + 2, kind = rk ) end do gamma(i+1) = sum2 end do el(1,1) = 1.0D+00 el(2,1) = 1.0D+00 el(2,2) = 1.0D+00 el(3,2) = 1.0D+00 do j = 3, maxord el(2,j) = factrl(j-1) do i = 3,j el(i,j) = real ( j - 1, kind = rk ) * el(i,j-1) + el(i-1,j-1) end do el(j+1,j) = 1.0D+00 end do do j = 2, maxord el(1,j) = el(1,j-1) + gamma(j) el(2,j) = 1.0D+00 do i = 3, j+1 el(i,j) = el(i,j) / ( real ( i - 1, kind = rk ) * factrl(j-1) ) end do end do do j = 1, maxord tq(1,j) = -1.0D+00 / ( factrl(j) * gamma(j) ) tq(2,j) = -1.0D+00 / gamma(j+1) tq(3,j) = -1.0D+00 / gamma(j+2) end do ! ! Compute Gear coefficients. ! else if ( mint == 2 ) then el(1,1) = 1.0D+00 el(2,1) = 1.0D+00 do j = 2, maxord el(1,j) = factrl(j) do i = 2, j el(i,j) = real ( j, kind = rk ) * el(i,j-1) + el(i-1,j-1) end do el(j+1,j) = 1.0D+00 end do sum2 = 1.0D+00 do j = 2, maxord sum2 = sum2 + 1.0D+00 / real ( j, kind = rk ) do i = 1, j+1 el(i,j) = el(i,j) / ( factrl(j) * sum2 ) end do end do do j = 1, maxord if ( 1 < j ) then tq(1,j) = 1.0D+00 / factrl(j-1) end if tq(2,j) = real ( j + 1, kind = rk ) / el(1,j) tq(3,j) = real ( j + 2, kind = rk ) / el(1,j) end do end if ! ! Compute constants used in the stiffness test. ! these are the ratio of tq(2,nq) for the gear ! methods to those for the adams methods. ! if ( iswflg == 3 ) then mxrd = min ( maxord, 5 ) if ( mint == 2 ) then gamma(1) = 1.0D+00 do i = 1, mxrd sum2 = 0.0D+00 do j = 1, i sum2 = sum2 - gamma(j) / real ( i - j + 2, kind = rk ) end do gamma(i+1) = sum2 end do end if sum2 = 1.0D+00 do i = 2, mxrd sum2 = sum2 + 1.0D+00 / real ( i, kind = rk ) el(1+i,1) = - real ( i + 1, kind = rk ) * sum2 * gamma(i+1) end do end if end subroutine ddntl ( eps, f, fa, hmax, hold, impl, jtask, matdim, maxord, & mint, miter, ml, mu, n, nde, save1, t, uround, users, y, ywt, h, mntold, & mtrold, nfe, rc, yh, a, convrg, el, fac, ier, ipvt, nq, nwait, rh, rmax, & save2, tq, trend, iswflg, jstate ) !*****************************************************************************80 ! !! DDNTL sets parameters for DDSTP. ! ! Discussion: ! ! DDNTL is called on the first call to DDSTP, on an internal restart, or ! when the user has altered MINT, miter, and/or h. ! ! On the first call, the order is set to 1 and the initial derivatives ! are calculated. RMAX is the maximum ratio by which h can be ! increased in one step. it is initially rminit to compensate ! for the small initial h, but then is normally equal to rmnorm. ! if a failure occurs (in corrector convergence or error test), rmax ! is set at rmfail for the next increase. ! if the caller has changed mint, or if jtask = 0, DDCST is called ! to set the coefficients of the method. if the caller has changed h, ! yh must be rescaled. if h or mint has been changed, nwait is ! reset to nq + 2 to prevent further increases in h for that many ! steps. also, rc is reset. rc is the ratio of new to old values of ! the coefficient l(0)*h. if the caller has changed miter, rc is ! set to 0 to force the partials to be updated, if partials are used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer matdim integer n real ( kind = rk ) a(matdim,*) logical convrg real ( kind = rk ) dnrm2 real ( kind = rk ) el(13,12) real ( kind = rk ) eps external f external fa real ( kind = rk ) fac(*) real ( kind = rk ) h real ( kind = rk ) hmax real ( kind = rk ) hold integer i logical ier integer iflag integer impl integer info integer ipvt(*) integer iswflg integer jstate integer jtask integer maxord integer mint integer miter integer ml integer mntold integer mtrold integer mu integer nde integer nfe integer nq integer nwait real ( kind = rk ) oldl0 real ( kind = rk ) rc real ( kind = rk ) rh real ( kind = rk ) rmax real ( kind = rk ), parameter :: rminit = 10000.0D+00 real ( kind = rk ) save1(*) real ( kind = rk ) save2(*) real ( kind = rk ) smax real ( kind = rk ) smin real ( kind = rk ) sum0 real ( kind = rk ) sum2 real ( kind = rk ) t real ( kind = rk ) tq(3,12) real ( kind = rk ) trend real ( kind = rk ) uround external users real ( kind = rk ) y(*) real ( kind = rk ) yh(n,*) real ( kind = rk ) ywt(*) ier = .false. if ( 0 <= jtask ) then if ( jtask == 0 ) then call ddcst ( maxord, mint, iswflg, el, tq ) rmax = rminit end if rc = 0.0D+00 convrg = .false. trend = 1.0D+00 nq = 1 nwait = 3 call f ( n, t, y, save2 ) if ( n == 0 ) then jstate = 6 return end if nfe = nfe + 1 if ( impl /= 0 ) then if ( miter == 3 ) then iflag = 0 call users ( y, yh, ywt, save1, save2, t, h, el, impl, n, nde, iflag ) if ( n == 0 ) then jstate = 10 return end if else if ( impl == 1 ) then if ( miter == 1 .or. miter == 2 ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if call dgefa ( a, matdim, n, ipvt, info ) if ( info /= 0 ) then ier = .true. return end if call dgesl ( a, matdim, n, ipvt, save2, 0 ) else if (miter == 4 .or. miter == 5) then call fa ( n, t, y, a(ml+1,1), matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if call dgbfa ( a, matdim, n, ml, mu, ipvt, info ) if ( info /= 0 ) then ier = .true. return end if call dgbsl ( a, matdim, n, ml, mu, ipvt, save2, 0 ) end if else if ( impl == 2 ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if do i = 1, nde if ( a(i,1) == 0.0D+00 ) then ier = .true. return else save2(i) = save2(i) / a(i,1) end if end do do i = nde+1,n a(i,1) = 0.0D+00 end do end if end if save1(1:nde) = save2(1:nde) / ywt(1:nde) sum2 = dnrm2 ( nde, save1, 1 ) sum0 = 1.0D+00 / max ( 1.0D+00 , abs ( t ) ) smax = max ( sum0, sum2 ) smin = min ( sum0, sum2 ) sum2 = smax * sqrt ( 1.0D+00 + ( smin / smax )**2 ) & / sqrt ( real ( nde, kind = rk ) ) h = sign ( min ( 2.0D+00 * eps / sum2, abs ( h ) ), h) yh(1:n,2) = h * save2(1:n) if ( miter == 2 .or. miter == 5 .or. iswflg == 3 ) then do i = 1,n fac(i) = sqrt ( uround ) end do end if else if ( miter /= mtrold ) then mtrold = miter rc = 0.0D+00 convrg = .false. end if if ( mint /= mntold ) then mntold = mint oldl0 = el(1,nq) call ddcst ( maxord, mint, iswflg, el, tq ) rc = rc * el(1,nq) / oldl0 nwait = nq + 2 end if if ( h /= hold ) then nwait = nq + 2 rh = h / hold call ddscl ( hmax, n, nq, rmax, hold, rc, rh, yh ) end if end if return end subroutine ddntp ( h, k, n, nq, t, tout, yh, y ) !*****************************************************************************80 ! !! DDNTP interpolates the K-th derivative of the ODE solution Y at TOUT. ! ! Discussion: ! ! The routine uses the data in the YH array. If K has a value greater ! than NQ, the NQ-th derivative is calculated. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 June 2020 ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) factor real ( kind = rk ) h integer j integer jj integer k integer kk integer kused integer nq real ( kind = rk ) r real ( kind = rk ) t real ( kind = rk ) tout real ( kind = rk ) y(*) real ( kind = rk ) yh(n,*) r = ( tout - t ) / h if ( k == 0 ) then y(1:n) = yh(1:n,nq+1) do jj = 1, nq j = nq + 1 - jj y(1:n) = yh(1:n,j) + r * y(1:n) end do else kused = min ( k, nq ) factor = 1.0D+00 do kk = 1, kused factor = factor * real ( nq + 1 - kk, kind = rk ) end do y(1:n) = factor * yh(1:n,nq+1) do jj = kused+1,nq j = k + 1 + nq - jj factor = 1.0D+00 do kk = 1, kused factor = factor * real ( j - kk, kind = rk ) end do y(1:n) = factor * yh(1:n,j) + r * y(1:n) end do y(1:n) = y(1:n) * h**(-kused) end if return end function ddot ( n, dx, incx, dy, incy ) !*****************************************************************************80 ! !! DDOT forms the dot product of two vectors. ! ! Discussion: ! ! This routine uses unrolled loops for increments equal to one. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Jack Dongarra ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input, real ( kind = rk ) DX(*), the first vector. ! ! Input, integer INCX, the increment between successive entries ! in X. ! ! Input, real ( kind = rk ) DY(*), the second vector. ! ! Input, integer INCY, the increment between successive entries ! in Y. ! ! Output, real DDOT, the sum of the product of the corresponding ! entries of X and Y. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) ddot real ( kind = rk ) dtemp real ( kind = rk ) dx(*) real ( kind = rk ) dy(*) integer i integer incx integer incy integer ix integer iy integer m integer n ddot = 0.0D+00 dtemp = 0.0D+00 if ( n <= 0 ) then return end if ! ! Code for unequal increments or equal increments ! not equal to 1. ! if ( incx /= 1 .or. incy /= 1 ) then if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if do i = 1, n dtemp = dtemp + dx(ix) * dy(iy) ix = ix + incx iy = iy + incy end do ! ! Code for both increments equal to 1. ! else m = mod ( n, 5 ) do i = 1, m dtemp = dtemp + dx(i) * dy(i) end do do i = m+1, n, 5 dtemp = dtemp + dx(i ) * dy(i ) & + dx(i+1) * dy(i+1) & + dx(i+2) * dy(i+2) & + dx(i+3) * dy(i+3) & + dx(i+4) * dy(i+4) end do end if ddot = dtemp return end subroutine ddpsc ( ksgn, n, nq, yh ) !*****************************************************************************80 ! !! DDPSC computes the predicted YH values. ! ! Discussion: ! ! The routine effectively multiplies the YH array by the Pascal ! triangle matrix when KSGN is +1, and performs the inverse function ! when KSGN is -1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, integer KSGN, indicates which operation is to ! be performed. ! ! Input, integer N, ? ! ! Input, integer NQ, ? ! ! Input/output, real ( kind = rk ) YH(N,*), ? ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer j integer j1 integer j2 integer ksgn integer nq real ( kind = rk ) yh(n,*) if ( 0 < ksgn ) then do j1 = 1, nq do j2 = j1, nq j = nq - j2 + j1 yh(1:n,j) = yh(1:n,j) + yh(1:n,j+1) end do end do else do j1 = 1, nq do j2 = j1, nq j = nq - j2 + j1 yh(1:n,j) = yh(1:n,j) - yh(1:n,j+1) end do end do end if return end subroutine ddpst ( el, f, fa, h, impl, jacobn, matdim, miter, ml, mu, n, nde, & nq, save2, t, users, y, yh, ywt, uround, nfe, nje, a, dfdy, fac, ier, ipvt, & save1, iswflg, bnd, jstate ) !*****************************************************************************80 ! !! DDPST is called to reevaluate the partial derivatives. ! ! Discussion: ! ! If MITER is 1, 2, 4, or 5, the matrix ! p = i - l(0)*h*jacobian ! is stored in dfdy and subjected to LU decomposition, with the results ! also stored in dfdy. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer matdim integer n real ( kind = rk ) a(matdim,*) real ( kind = rk ) bl real ( kind = rk ) bnd real ( kind = rk ) bp real ( kind = rk ) br real ( kind = rk ) bu real ( kind = rk ) dfdy(matdim,*) real ( kind = rk ) dfdymx real ( kind = rk ) diff real ( kind = rk ) dnrm2 real ( kind = rk ) dy real ( kind = rk ) el(13,12) external f external fa real ( kind = rk ) fac(*) real ( kind = rk ) facmin real ( kind = rk ), parameter :: facmax = 0.5D+00 real ( kind = rk ) factor real ( kind = rk ) h integer i integer i1 integer i2 integer i3 logical ier integer iflag integer imax integer impl integer info integer ipvt(*) integer iswflg integer j integer j2 external jacobn integer jstate integer k integer miter integer ml integer mu integer mw integer nde integer nfe integer nje integer nq real ( kind = rk ) save1(*) real ( kind = rk ) save2(*) real ( kind = rk ) scale real ( kind = rk ) t real ( kind = rk ) uround external users real ( kind = rk ) y(*) real ( kind = rk ) yh(n,*) real ( kind = rk ) yj real ( kind = rk ) ys real ( kind = rk ) ywt(*) nje = nje + 1 ier = .false. if ( miter == 1 .or. miter == 2 ) then if ( miter == 1 ) then call jacobn ( n, t, y, dfdy, matdim, ml, mu ) if ( n == 0 ) then jstate = 8 return end if if ( iswflg == 3 ) then bnd = dnrm2 ( n*n, dfdy, 1 ) end if dfdy(1:n,1:n) = - el(1,nq) * h * dfdy(1:n,1:n) else if ( miter == 2 ) then br = uround**(0.875D+00 ) bl = uround**(0.75D+00 ) bu = uround**(0.25D+00 ) bp = uround**(-0.15D+00 ) facmin = uround**(0.78D+00 ) do j = 1, n ys = max ( abs ( ywt(j) ), abs ( y(j) ) ) 120 continue dy = fac(j) * ys if ( dy == 0.0D+00 ) then if ( fac(j) < facmax ) then fac(j) = min ( 100.0D+00 * fac(j), facmax ) go to 120 else dy = ys end if end if if ( nq == 1 ) then dy = sign ( dy, save2(j) ) else dy = sign ( dy, yh(j,3) ) end if dy = (y(j) + dy) - y(j) yj = y(j) y(j) = y(j) + dy call f ( n, t, y, save1 ) if ( n == 0 ) then jstate = 6 return end if y(j) = yj factor = -el(1,nq) * h / dy dfdy(1:n,j) = ( save1(1:n) - save2(1:n) ) * factor diff = abs ( save2(1) - save1(1) ) imax = 1 do i = 2, n if ( diff < abs ( save2(i) - save1(i) ) ) then imax = i diff = abs ( save2(i) - save1(i) ) end if end do ! ! Step 2 ! if ( 0.0D+00 < min ( abs ( save2(imax) ), abs ( save1(imax) ) ) ) then scale = max ( abs ( save2(imax) ), abs ( save1(imax) ) ) ! ! Step 3 ! if ( bu * scale < diff ) then fac(j) = max ( facmin, fac(j) * 0.1D+00 ) else if ( br * scale <= diff .and. diff <= bl * scale ) then fac(j) = min ( fac(j) * 10.0D+00, facmax ) ! ! Step 4 ! else if ( diff < br * scale ) then fac(j) = min ( bp * fac(j), facmax ) end if end if end do if ( iswflg == 3 ) bnd = dnrm2 ( n*n, dfdy, 1) / (-el(1,nq)*h) nfe = nfe + n end if if ( impl == 0 ) then do i = 1, n dfdy(i,i) = dfdy(i,i) + 1.0D+00 end do else if ( impl == 1 ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if dfdy(1:n,1:n) = dfdy(1:n,1:n) + a(1:n,1:n) else if ( impl == 2 ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if do i = 1, nde dfdy(i,i) = dfdy(i,i) + a(i,1) end do end if call dgefa ( dfdy, matdim, n, ipvt, info ) if ( info /= 0 ) then ier = .true. end if else if ( miter == 4 .or. miter == 5 ) then if ( miter == 4 ) then call jacobn ( n, t, y, dfdy(ml+1,1), matdim, ml, mu ) if ( n == 0 ) then jstate = 8 return end if factor = -el(1,nq) * h mw = ml + mu + 1 do j = 1, n i1 = max ( ml+1, mw+1-j ) i2 = min ( mw+n-j, mw+ml ) do i = i1, i2 dfdy(i,j) = factor * dfdy(i,j) end do end do else if ( miter == 5 ) then br = uround**(0.875D+00) bl = uround**(0.75D+00) bu = uround**(0.25D+00) bp = uround**(-0.15D+00) facmin = uround**(0.78D+00) mw = ml + mu + 1 j2 = min ( mw, n ) do j = 1, j2 do k = j, n, mw ys = max ( abs (ywt(k) ), abs ( y(k) ) ) 280 continue dy = fac(k) * ys if ( dy == 0.0D+00 ) then if ( fac(k) < facmax ) then fac(k) = min ( 100.0D+00 * fac(k), facmax ) go to 280 else dy = ys end if end if if ( nq == 1 ) then dy = sign ( dy, save2(k) ) else dy = sign ( dy, yh(k,3) ) end if dy = (y(k) + dy) - y(k) dfdy(mw,k) = y(k) y(k) = y(k) + dy end do call f ( n, t, y, save1 ) if ( n == 0 ) then jstate = 6 return end if do k = j, n, mw y(k) = dfdy(mw,k) ys = max ( abs (ywt(k) ), abs ( y(k) ) ) dy = fac(k)*ys if ( dy == 0.0D+00 ) dy = ys if ( nq == 1 ) then dy = sign ( dy, save2(k) ) else dy = sign ( dy, yh(k,3) ) end if dy = (y(k) + dy) - y(k) factor = -el(1,nq) * h / dy i1 = max ( ml+1, mw+1-k ) i2 = min ( mw+n-k, mw+ml ) do i = i1,i2 i3 = k + i - mw dfdy(i,k) = factor*(save1(i3) - save2(i3)) end do imax = max ( 1, k - mu ) diff = abs ( save2(imax) - save1(imax) ) i1 = imax i2 = min ( k + ml, n ) do i = i1+1,i2 if ( diff < abs ( save2(i) - save1(i) ) ) then imax = i diff = abs ( save2(i) - save1(i) ) end if end do if ( 0.0D+00 < min ( abs ( save2(imax) ), abs ( save1(imax) ) ) ) then scale = max ( abs ( save2(imax) ), abs ( save1(imax) ) ) if ( bu * scale < diff ) then fac(k) = max ( facmin, fac(k) * 0.1D+00 ) else if ( br * scale <= diff .and. diff <= bl * scale ) then fac(k) = min ( fac(k) * 10.0D+00, facmax ) else if ( diff < br * scale ) then fac(k) = min ( bp * fac(k), facmax ) end if end if end do end do nfe = nfe + j2 end if if ( iswflg == 3 ) then dfdymx = 0.0D+00 do j = 1, n i1 = max ( ml+1, mw+1-j ) i2 = min ( mw+n-j, mw+ml ) do i = i1, i2 dfdymx = max ( dfdymx, abs ( dfdy(i,j) ) ) end do end do bnd = 0.0D+00 if ( dfdymx /= 0.0D+00 ) then do j = 1,n i1 = max ( ml+1, mw+1-j ) i2 = min ( mw+n-j, mw+ml ) do i = i1,i2 bnd = bnd + (dfdy(i,j) / dfdymx)**2 end do end do bnd = dfdymx * sqrt ( bnd ) / ( -el(1,nq) * h ) end if end if if ( impl == 0 ) then dfdy(mw,1:n) = dfdy(mw,1:n) + 1.0D+00 else if ( impl == 1 ) then call fa (n, t, y, a(ml+1,1), matdim, ml, mu, nde) if ( n == 0 ) then jstate = 9 return end if do j = 1, n i1 = max ( ml+1, mw+1-j ) i2 = min ( mw+n-j, mw+ml ) dfdy(i1:i2,j) = dfdy(i1:i2,j) + a(i1:i2,j) end do else if ( impl == 2 ) then call fa ( n, t, y, a, matdim, ml, mu, nde ) if ( n == 0 ) then jstate = 9 return end if dfdy(mw,1:nde) = dfdy(mw,1:nde) + a(1:nde,1) end if call dgbfa ( dfdy, matdim, n, ml, mu, ipvt, info ) if ( info /= 0 ) then ier = .true. end if else if ( miter == 3 ) then iflag = 1 call users ( y, yh(1,2), ywt, save1, save2, t, h, el(1,nq), impl, n, & nde, iflag ) if ( n == 0 ) then jstate = 10 return end if end if return end subroutine ddriv1 ( n, t, y, tout, mstate, eps, work, lenw ) !*****************************************************************************80 ! !! DDRIV1 solves a system of ordinary differential equations. ! ! Discussion: ! ! The system has the form: ! ! dy(i)/dt = f(y(i),t), ! ! given the initial conditions ! ! y(i) = yi. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Charles Gear, ! Numerical Initial Value Problems in Ordinary Differential Equations, ! Prentice-Hall, 1971. ! ! i. choosing the correct routine ! ! sdriv ! ddriv ! cdriv ! these are the generic names for three packages for solving ! initial value problems for ordinary differential equations. ! sdriv uses single precision arithmetic. ddriv uses double ! precision arithmetic. cdriv allows complex-valued ! differential equations, integrated with respect to a single, ! real, independent variable. ! ! as an aid in selecting the proper program, the following is a ! discussion of the important options or restrictions associated with ! each program: ! ! a. ddriv1 should be tried first for those routine problems with ! no more than 200 differential equations. internally this ! routine has two important technical defaults: ! 1. numerical approximation of the jacobian matrix of the ! right hand side is used. ! 2. the stiff solver option is used. ! most users of ddriv1 should not have to concern themselves ! with these details. ! ! b. ddriv2 should be considered for those problems for which ! ddriv1 is inadequate (ddriv2 has no explicit restriction on ! the number of differential equations.) for example, ddriv1 ! may have difficulty with problems having zero initial ! conditions and zero derivatives. in this case ddriv2, with an ! appropriate value of the parameter ewt, should perform more ! efficiently. ddriv2 provides three important additional ! options: ! 1. the nonstiff equation solver (as well as the stiff ! solver) is available. ! 2. the root-finding option is available. ! 3. the program can dynamically select either the non-stiff ! or the stiff methods. ! internally this routine also defaults to the numerical ! approximation of the jacobian matrix of the right hand side. ! ! c. ddriv3 is the most flexible, and hence the most complex, of ! the programs. its important additional features include: ! 1. the ability to exploit band structure in the jacobian ! matrix. ! 2. the ability to solve some implicit differential ! equations, i.e., those having the form: ! a(y,t) * dy/dt = f(y,t). ! 3. the option of integrating in the one step mode. ! 4. the option of allowing the user to provide a routine ! which computes the analytic jacobian matrix of the right ! hand side. ! 5. the option of allowing the user to provide a routine ! which does all the matrix algebra associated with ! corrections to the solution components. ! ! ii. abstract ! ! the function of ddriv1 is to solve n (200 or fewer) ordinary ! differential equations of the form dy(i)/dt = f(y(i),t), given the ! initial conditions y(i) = yi. ddriv1 is to be called once for each ! output point. ! ! iii. parameters ! ! the user should use parameter names in the call sequence of ddriv1 ! for those quantities whose value may be altered by ddriv1. the ! parameters in the call sequence are: ! ! n = (input) the number of differential equations, n <= 200 ! ! t = the independent variable. on input for the first call, t ! is the initial point. on output, t is the point at which ! the solution is given. ! ! y = the vector of dependent variables. y is used as input on ! the first call, to set the initial values. on output, y ! is the computed solution vector. this array y is passed ! in the call sequence of the user-provided routine f. thus ! parameters required by f can be stored in this array in ! components n+1 and above. (note: changes by the user to ! the first n components of this array will take effect only ! after a restart, i.e., after setting mstate to +1(-1).) ! ! tout = (input) the point at which the solution is desired. ! ! mstate = an integer describing the status of integration. ! the user must initialize mstate to +1 or -1. if mstate is ! positive, the routine will integrate past tout and ! interpolate the solution. this is the most efficient ! mode. if mstate is negative, the routine will adjust its ! internal step to reach tout exactly (useful if a ! singularity exists beyond tout.) the meaning of the ! magnitude of mstate: ! 1 (input) means the first call to the routine. this ! value must be set by the user. on all subsequent ! calls the value of mstate should be tested by the ! user. unless ddriv1 is to be reinitialized, only the ! sign of mstate may be changed by the user. (as a ! convenience to the user who may wish to put out the ! initial conditions, ddriv1 can be called with ! mstate=+1(-1), and tout=t. in this case the program ! will return with mstate unchanged, i.e., ! mstate=+1(-1).) ! 2 (output) means a successful integration. if a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance tout and call ! again. all other parameters are automatically set. ! 3 (output)(unsuccessful) means the integrator has taken ! 1000 steps without reaching tout. the user can ! continue the integration by simply calling ddriv1 ! again. ! 4 (output)(unsuccessful) means too much accuracy has ! been requested. eps has been increased to a value ! the program estimates is appropriate. the user can ! continue the integration by simply calling ddriv1 ! again. ! 5 (output)(unsuccessful) n has been set to zero in ! subroutine f. see description of f in section iv. ! ! eps = on input, the requested relative accuracy in all solution ! components. on output, the adjusted relative accuracy if ! the input value was too small. the value of eps should be ! set as large as is reasonable, because the amount of work ! done by ddriv1 increases as eps decreases. ! ! work ! lenw = (input) ! work is an array of lenw real words used ! internally for temporary storage. the user must allocate ! space for this array in the calling program by a statement ! such as ! real work(...) ! the length of work should be at least n*n + 11*n + 225 ! and lenw should be set to the value used. the contents of ! work should not be disturbed between calls to ddriv1. ! ! long description ! ! iv. usage ! ! program sample ! real alfa, eps, t, tout !c n is the number of equations ! parameter(alfa = 1.0, n = 3, ! 8 lenw = n*n + 11*n + 225) ! real work(lenw), y(n+1) !c initial point ! t = 0.00001 !c set initial conditions ! y(1) = 10.0D+00 ! y(2) = 0.0D+00 ! y(3) = 10.0D+00 !c pass parameter ! y(4) = alfa ! tout = t ! mstate = 1 ! eps = .001 ! 10 call ddriv1 (n, t, y, tout, mstate, eps, work, lenw) ! if ( 2 < mstate ) stop ! write(*, '(4e12.3)') tout, y(1:3) ! tout = 10.0 * tout ! if ( tout < 50.0D+00 ) go to 10 ! end ! ! the user must write a subroutine called f to evaluate the right ! hand side of the differential equations. it is of the form: ! ! subroutine f (n, t, y, ydot) ! real alfa, t, y(*), ydot(*) ! alfa = y(n+1) ! ydot(1) = 1.0D+00 + alfa*(y(2) - y(1)) - y(1)*y(3) ! ydot(2) = alfa*(y(1) - y(2)) - y(2)*y(3) ! ydot(3) = 1.0D+00 - y(3)*(y(1) + y(2)) ! end ! ! this computes ydot = f(y,t), the right hand side of the ! differential equations. here y is a vector of length at least n. ! the actual length of y is determined by the user's declaration in ! the program which calls ddriv1. thus the dimensioning of y in f, ! while required by fortran convention, does not actually allocate ! any storage. when this subroutine is called, the first n ! components of y are intermediate approximations to the solution ! components. the user should not alter these values. here ydot is ! a vector of length n. the user should only compute ydot(i) for i ! from 1 to n. normally a return from f passes control back to ! ddriv1. however, if the user would like to abort the calculation, ! i.e., return control to the program which calls ddriv1, he should ! set n to zero. ddriv1 will signal this by returning a value of ! mstate equal to +5(-5). altering the value of n in f has no effect ! on the value of n in the call sequence of ddriv1. ! ! v. other communication to the user ! ! a. the solver communicates to the user through the parameters ! above. in addition it writes diagnostic messages through the ! standard error handling program XERROR. that program will ! terminate the user's run if it detects a probable problem setup ! error, e.g., insufficient storage allocated by the user for the ! work array. for further information see section iii-a of the ! writeup for ddriv3. ! ! b. the number of evaluations of the right hand side can be found ! in the work array in the location determined by: ! lenw - (n + 21) + 4 ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: idliw = 21 integer, parameter :: mxn = 200 integer n real ( kind = rk ) eps real ( kind = rk ) ewt(1) external f real ( kind = rk ) hmax integer i integer, parameter :: ierror = 2 integer ii integer, parameter :: impl = 0 integer iwork(idliw+mxn) integer leniw integer lenw integer lenwcm integer lnwchk integer, parameter :: mint = 2 integer, parameter :: miter = 2 integer ml integer mstate real ( kind = rk ) mu integer, parameter :: mxord = 5 integer, parameter :: mxstep = 1000 integer nde integer, parameter :: nroot = 0 integer nstate integer ntask real ( kind = rk ) t real ( kind = rk ) tout real ( kind = rk ) work(*) real ( kind = rk ) y(n) ewt(1) = 1.0D+00 if ( mxn < n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV1 - Fatal error!' write ( *, '(a)' ) ' The number of equations is too large.' write ( *, '(a,i6)' ) ' The number of equations N = ', n write ( *, '(a,i6)' ) ' The maximum is MXN = ', mxn stop end if if ( 0 < mstate ) then nstate = mstate ntask = 1 else nstate = - mstate ntask = 3 end if hmax = 2.0D+00 * abs ( tout - t ) leniw = n + idliw lenwcm = lenw - leniw if ( lenwcm < (n*n + 10*n + 204) ) then lnwchk = n*n + 10*n + 204 + leniw write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV1 - Fatal error!' write ( *, '(a)' ) ' Insufficient work storage.' write ( *, '(a,i6)' ) ' The given work storage is = ', lenwcm write ( *, '(a,i6)' ) ' The required work storage is = ', lnwchk stop end if if ( nstate /= 1 ) then do i = 1, leniw ii = i + lenwcm iwork(i) = int ( work(ii) ) end do end if call ddriv3 (n, t, y, f, nstate, tout, ntask, nroot, eps, ewt, & ierror, mint, miter, impl, ml, mu, mxord, hmax, work, & lenwcm, iwork, leniw, f, f, nde, mxstep, f, f) do i = 1, leniw ii = lenwcm + i work(ii) = real ( iwork(i), kind = rk ) end do if ( nstate <= 4 ) then mstate = sign ( nstate, mstate ) else if ( nstate == 6 ) then mstate = sign ( 5, mstate ) end if return end subroutine ddriv2 ( n, t, y, f, tout, mstate, nroot, eps, ewt, mint, work, & lenw, iwork, leniw, g ) !*****************************************************************************80 ! !! DDRIV2 solves a system of ordinary differential equations. ! ! Discussion: ! ! DDRIV2 solves a system of N ordinary differential equations. ! ! dy(i)/dt = f(y(i),t), ! ! given the initial conditions ! ! y(i) = yi. ! ! The program has options to allow the solution of both stiff and ! non-stiff differential equations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! i. abstract ! ! the function of ddriv2 is to solve n ordinary differential ! equations of the form dy(i)/dt = f(y(i),t), given the initial ! conditions y(i) = yi. the program has options to allow the ! solution of both stiff and non-stiff differential equations. ! ddriv2 is to be called once for each output point of t. ! ! ii. parameters ! ! the user should use parameter names in the call sequence of ddriv2 ! for those quantities whose value may be altered by ddriv2. the ! parameters in the call sequence are: ! ! n = (input) the number of differential equations. ! ! t = the independent variable. on input for the first call, t ! is the initial point. on output, t is the point at which ! the solution is given. ! ! y = the vector of dependent variables. y is used as input on ! the first call, to set the initial values. on output, y ! is the computed solution vector. this array y is passed ! in the call sequence of the user-provided routines f and ! g. thus parameters required by f and g can be stored in ! this array in components n+1 and above. (note: changes ! by the user to the first n components of this array will ! take effect only after a restart, i.e., after setting ! mstate to +1(-1).) ! ! f = a subroutine supplied by the user. the name must be ! declared external in the user's calling program. this ! subroutine is of the form: ! subroutine f (n, t, y, ydot) ! real y(*), ydot(*) ! . ! . ! ydot(1) = ... ! . ! . ! ydot(n) = ... ! end (sample) ! this computes ydot = f(y,t), the right hand side of the ! differential equations. here y is a vector of length at ! least n. the actual length of y is determined by the ! user's declaration in the program which calls ddriv2. ! thus the dimensioning of y in f, while required by fortran ! convention, does not actually allocate any storage. when ! this subroutine is called, the first n components of y are ! intermediate approximations to the solution components. ! the user should not alter these values. here ydot is a ! vector of length n. the user should only compute ydot(i) ! for i from 1 to n. normally a return from f passes ! control back to ddriv2. however, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls ddriv2, he should set n to zero. ! ddriv2 will signal this by returning a value of mstate ! equal to +6(-6). altering the value of n in f has no ! effect on the value of n in the call sequence of ddriv2. ! ! tout = (input) the point at which the solution is desired. ! ! mstate = an integer describing the status of integration. ! the user must initialize mstate to +1 or -1. if mstate is ! positive, the routine will integrate past tout and ! interpolate the solution. this is the most efficient ! mode. if mstate is negative, the routine will adjust its ! internal step to reach tout exactly (useful if a ! singularity exists beyond tout.) the meaning of the ! magnitude of mstate: ! 1 (input) means the first call to the routine. this ! value must be set by the user. on all subsequent ! calls the value of mstate should be tested by the ! user. unless ddriv2 is to be reinitialized, only the ! sign of mstate may be changed by the user. (as a ! convenience to the user who may wish to put out the ! initial conditions, ddriv2 can be called with ! mstate=+1(-1), and tout=t. in this case the program ! will return with mstate unchanged, i.e., ! mstate=+1(-1).) ! 2 (output) means a successful integration. if a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance tout and call ! again. all other parameters are automatically set. ! 3 (output)(unsuccessful) means the integrator has taken ! 1000 steps without reaching tout. the user can ! continue the integration by simply calling ddriv2 ! again. other than an error in problem setup, the ! most likely cause for this condition is trying to ! integrate a stiff set of equations with the non-stiff ! integrator option. (see description of mint below.) ! 4 (output)(unsuccessful) means too much accuracy has ! been requested. eps has been increased to a value ! the program estimates is appropriate. the user can ! continue the integration by simply calling ddriv2 ! again. ! 5 (output) a root was found at a point less than tout. ! the user can continue the integration toward tout by ! simply calling ddriv2 again. ! 6 (output)(unsuccessful) n has been set to zero in ! subroutine f. ! 7 (output)(unsuccessful) n has been set to zero in ! function g. see description of g below. ! ! nroot = (input) the number of equations whose roots are desired. ! if nroot is zero, the root search is not active. this ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! the root search is carried out using the user-written ! function g (see description of g below.) ddriv2 attempts ! to find the value of t at which one of the equations ! changes sign. ddriv2 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at tout or at a root, whichever ! occurs first in the direction of integration. the index ! of the equation whose root is being reported is stored in ! the sixth element of iwork. ! note: nroot is never altered by this program. ! ! eps = on input, the requested relative accuracy in all solution ! components. eps = 0 is allowed. on output, the adjusted ! relative accuracy if the input value was too small. the ! value of eps should be set as large as is reasonable, ! because the amount of work done by ddriv2 increases as ! eps decreases. ! ! ewt = (input) problem zero, i.e., the smallest physically ! meaningful value for the solution. this is used inter- ! nally to compute an array ywt(i) = max ( abs ( y(i) ), ewt ). ! one step error estimates divided by ywt(i) are kept less ! than eps. setting ewt to zero provides pure relative ! error control. however, setting ewt smaller than ! necessary can adversely affect the running time. ! ! mint = (input) the integration method flag. ! mint = 1 means the adams methods, and is used for ! non-stiff problems. ! mint = 2 means the stiff methods of gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! mint = 3 means the program dynamically selects the ! adams methods when the problem is non-stiff ! and the gear methods when the problem is ! stiff. ! mint may not be changed without restarting, i.e., setting ! the magnitude of mstate to 1. ! ! work ! lenw = (input) ! work is an array of lenw real words used ! internally for temporary storage. the user must allocate ! space for this array in the calling program by a statement ! such as ! real work(...) ! the length of work should be at least ! 16*n + 2*nroot + 204 if mint is 1, or ! n*n + 10*n + 2*nroot + 204 if mint is 2, or ! n*n + 17*n + 2*nroot + 204 if mint is 3, ! and lenw should be set to the value used. the contents of ! work should not be disturbed between calls to ddriv2. ! ! iwork ! leniw = (input) ! iwork is an integer array of length leniw used ! internally for temporary storage. the user must allocate space ! for this array in the calling program by a statement such as ! integer iwork(...) ! the length of iwork should be at least ! 21 if mint is 1, or ! n+21 if mint is 2 or 3, ! and leniw should be set to the value used. the contents ! of iwork should not be disturbed between calls to ddriv2. ! ! g = a real fortran function supplied by the user ! if nroot is not 0. in this case, the name must be ! declared external in the user's calling program. g is ! repeatedly called with different values of iroot to ! obtain the value of each of the nroot equations for which ! a root is desired. g is of the form: ! real function g (n, t, y, iroot) ! real y(*) ! go to (10, ...), iroot ! 10 g = ... ! . ! . ! end (sample) ! here, y is a vector of length at least n, whose first n ! components are the solution components at the point t. ! the user should not alter these values. the actual length ! of y is determined by the user's declaration in the ! program which calls ddriv2. thus the dimensioning of y in ! g, while required by fortran convention, does not actually ! allocate any storage. normally a return from g passes ! control back to ddriv2. however, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls ddriv2, he should set n to zero. ! ddriv2 will signal this by returning a value of mstate ! equal to +7(-7). in this case, the index of the equation ! being evaluated is stored in the sixth element of iwork. ! altering the value of n in g has no effect on the value of ! n in the call sequence of ddriv2. ! ! long description ! ! iii. other communication to the user ! ! a. the solver communicates to the user through the parameters ! above. in addition it writes diagnostic messages through the ! standard error handling program XERROR. that program will ! terminate the user's run if it detects a probable problem setup ! error, e.g., insufficient storage allocated by the user for the ! work array. messages are written on the standard error message ! file. at installations which have this error handling package ! the user should determine the standard error handling file from ! the local documentation. otherwise the short but serviceable ! routine, XERROR, available with this package, can be used. ! ! b. the first three elements of work and the first five elements of ! iwork will contain the following statistical data: ! avgh the average step size used. ! hused the step size last used (successfully). ! avgord the average order used. ! imxerr the index of the element of the solution vector that ! contributed most to the last error test. ! nqused the order last used (successfully). ! nstep the number of steps taken since last initialization. ! nfe the number of evaluations of the right hand side. ! nje the number of evaluations of the jacobian matrix. ! ! iv. remarks ! ! a. on any return from ddriv2 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! b. if this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to ddriv2. ! ! c. when the routine g is not required, difficulties associated with ! an unsatisfied external can be avoided by using the name of the ! routine which calculates the right hand side of the differential ! equations in place of g in the call sequence of ddriv2. ! ! v. usage ! ! program sample ! external f ! parameter(mint = 1, nroot = 0, n = ..., ! 8 lenw = 16*n + 2*nroot + 204, leniw = 21) ! n is the number of equations ! real eps, ewt, t, tout, work(lenw), y(n) ! integer iwork(leniw) ! open(file='tape6', unit=6, status='new') ! t = 0. initial point ! y(1:n) = ... set initial conditions ! tout = t ! ewt = ... ! mstate = 1 ! eps = ... ! 20 call ddriv2 (n, t, y, f, tout, mstate, nroot, eps, ewt, ! 8 mint, work, lenw, iwork, leniw, f) ! last argument is not the same ! as f if rootfinding is used. ! if ( 2 < mstate ) stop ! write(6, 100) tout, y(1:n)) ! tout = tout + 1. ! if ( tout <= 10.0) go to 20 ! 100 format(...) ! end (sample) ! ! Reference: ! ! Charles Gear, ! Numerical Initial Value Problems in Ordinary Differential Equations, ! Prentice-Hall, 1971. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) eps real ( kind = rk ) ewt real ( kind = rk ) ewtcom(1) external f real ( kind = rk ), external :: g real ( kind = rk ) hmax integer ierror integer, parameter :: impl = 0 integer iwork(*) integer leniw integer lenw integer mint integer miter integer ml integer mstate integer mu integer mxord integer, parameter :: mxstep = 1000 integer nde integer nroot integer nstate integer ntask real ( kind = rk ) t real ( kind = rk ) tout real ( kind = rk ) work(*) real ( kind = rk ) y(n) if ( mint < 1 .or. 3 < mint ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV2 - Fatal error!' write ( *, '(a)' ) ' Improper value for the integration method.' write ( *, '(a,i6)' ) ' MINT = ', mint write ( *, '(a)' ) ' MINT should be between 1 and 3.' stop end if if ( 0 <= mstate ) then nstate = mstate ntask = 1 else nstate = - mstate ntask = 3 end if ewtcom(1) = ewt if ( ewt /= 0.0D+00 ) then ierror = 3 else ierror = 2 end if if ( mint == 1 ) then miter = 0 mxord = 12 else if ( mint == 2 ) then miter = 2 mxord = 5 else if ( mint == 3 ) then miter = 2 mxord = 12 end if hmax = 2.0D+00 * abs ( tout - t ) call ddriv3 ( n, t, y, f, nstate, tout, ntask, nroot, eps, ewtcom, & ierror, mint, miter, impl, ml, mu, mxord, hmax, work, & lenw, iwork, leniw, f, f, nde, mxstep, g, f ) if ( 0 <= mstate ) then mstate = nstate else mstate = - nstate end if return end subroutine ddriv3 ( n, t, y, f, nstate, tout, ntask, nroot, eps, ewt, ierror, & mint, miter, impl, ml, mu, mxord, hmax, work, lenw, iwork, leniw, jacobn, & fa, nde, mxstep, g, users ) !*****************************************************************************80 ! !! DDRIV3 solves a system of ordinary differential equations. ! ! Discussion: ! ! DDRIV3 solves a system of N ordinary differential equations ! ! dy(i)/dt = f(y(i),t), ! ! given the initial conditions ! ! y(i) = yi. ! ! The program has options to solve both stiff and non-stiff differential ! equations. Other important options are available. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Charles Gear, ! Numerical Initial Value Problems in Ordinary Differential Equations, ! Prentice Hall, 1971. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! ! i. abstract ! ! the primary function of ddriv3 is to solve n ordinary differential ! equations of the form dy(i)/dt = f(y(i),t), given the initial ! conditions y(i) = yi. the program has options to allow the ! solution of both stiff and non-stiff differential equations. in ! addition, ddriv3 may be used to solve: ! 1. the initial value problem, a * dy(i)/dt = f(y(i),t), where a is ! a non-singular matrix depending on y and t. ! 2. the hybrid differential/algebraic initial value problem, ! a * dy(i)/dt = f(y(i),t), where a is a vector (whose values may ! depend upon y and t) some of whose components will be zero ! corresponding to those equations which are algebraic rather ! than differential. ! ddriv3 is to be called once for each output point of t. ! ! ii. parameters ! ! the user should use parameter names in the call sequence of ddriv3 ! for those quantities whose value may be altered by ddriv3. the ! parameters in the call sequence are: ! ! n = (input) the number of dependent functions whose solution ! is desired. n must not be altered during a problem. ! ! t = the independent variable. on input for the first call, t ! is the initial point. on output, t is the point at which ! the solution is given. ! ! y = the vector of dependent variables. y is used as input on ! the first call, to set the initial values. on output, y ! is the computed solution vector. this array y is passed ! in the call sequence of the user-provided routines f, ! jacobn, fa, users, and g. thus parameters required by ! those routines can be stored in this array in components ! n+1 and above. (note: changes by the user to the first ! n components of this array will take effect only after a ! restart, i.e., after setting nstate to 1 .) ! ! f = a subroutine supplied by the user. the name must be ! declared external in the user's calling program. this ! subroutine is of the form: ! subroutine f (n, t, y, ydot) ! real y(*), ydot(*) ! . ! . ! ydot(1) = ... ! . ! . ! ydot(n) = ... ! end (sample) ! this computes ydot = f(y,t), the right hand side of the ! differential equations. here y is a vector of length at ! least n. the actual length of y is determined by the ! user's declaration in the program which calls ddriv3. ! thus the dimensioning of y in f, while required by fortran ! convention, does not actually allocate any storage. when ! this subroutine is called, the first n components of y are ! intermediate approximations to the solution components. ! the user should not alter these values. here ydot is a ! vector of length n. the user should only compute ydot(i) ! for i from 1 to n. normally a return from f passes ! control back to ddriv3. however, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls ddriv3, he should set n to zero. ! ddriv3 will signal this by returning a value of nstate ! equal to 6 . altering the value of n in f has no effect ! on the value of n in the call sequence of ddriv3. ! ! nstate = an integer describing the status of integration. the ! meaning of nstate is as follows: ! 1 (input) means the first call to the routine. this ! value must be set by the user. on all subsequent ! calls the value of nstate should be tested by the ! user, but must not be altered. (as a convenience to ! the user who may wish to put out the initial ! conditions, ddriv3 can be called with nstate=1, and ! tout=t. in this case the program will return with ! nstate unchanged, i.e., nstate=1.) ! 2 (output) means a successful integration. if a normal ! continuation is desired (i.e., a further integration ! in the same direction), simply advance tout and call ! again. all other parameters are automatically set. ! 3 (output)(unsuccessful) means the integrator has taken ! mxstep steps without reaching tout. the user can ! continue the integration by simply calling ddriv3 ! again. ! 4 (output)(unsuccessful) means too much accuracy has ! been requested. eps has been increased to a value ! the program estimates is appropriate. the user can ! continue the integration by simply calling ddriv3 ! again. ! 5 (output) a root was found at a point less than tout. ! the user can continue the integration toward tout by ! simply calling ddriv3 again. ! 6 (output)(unsuccessful) n has been set to zero in ! subroutine f. ! 7 (output)(unsuccessful) n has been set to zero in ! function g. see description of g below. ! 8 (output)(unsuccessful) n has been set to zero in ! subroutine jacobn. see description of jacobn below. ! 9 (output)(unsuccessful) n has been set to zero in ! subroutine fa. see description of fa below. ! 10 (output)(unsuccessful) n has been set to zero in ! subroutine users. see description of users below. ! ! Input, real ( kind = rk ) TOUT, the point at which the solution is desired. ! The position of TOUT relative to T on the first call determines the ! direction of integration. ! ! ntask = (input) an index specifying the manner of returning the ! solution, according to the following: ! ntask = 1 means ddriv3 will integrate past tout and ! interpolate the solution. this is the most ! efficient mode. ! ntask = 2 means ddriv3 will return the solution after ! each internal integration step, or at tout, ! whichever comes first. in the latter case, ! the program integrates exactly to tout. ! ntask = 3 means ddriv3 will adjust its internal step to ! reach tout exactly (useful if a singularity ! exists beyond tout.) ! ! nroot = (input) the number of equations whose roots are desired. ! if nroot is zero, the root search is not active. this ! option is useful for obtaining output at points which are ! not known in advance, but depend upon the solution, e.g., ! when some solution component takes on a specified value. ! the root search is carried out using the user-written ! function g (see description of g below.) ddriv3 attempts ! to find the value of t at which one of the equations ! changes sign. ddriv3 can find at most one root per ! equation per internal integration step, and will then ! return the solution either at tout or at a root, whichever ! occurs first in the direction of integration. the index ! of the equation whose root is being reported is stored in ! the sixth element of iwork. ! note: nroot is never altered by this program. ! ! eps = on input, the requested relative accuracy in all solution ! components. eps = 0 is allowed. on output, the adjusted ! relative accuracy if the input value was too small. the ! value of eps should be set as large as is reasonable, ! because the amount of work done by ddriv3 increases as eps ! decreases. ! ! ewt = (input) problem zero, i.e., the smallest, nonzero, ! physically meaningful value for the solution. (array, ! possibly of length one. see following description of ! ierror.) setting ewt smaller than necessary can adversely ! affect the running time. ! ! ierror = (input) error control indicator. a value of 3 is ! suggested for most problems. other choices and detailed ! explanations of ewt and ierror are given below for those ! who may need extra flexibility. ! ! these last three input quantities eps, ewt and ierror ! control the accuracy of the computed solution. ewt and ! ierror are used internally to compute an array ywt. one ! step error estimates divided by ywt(i) are kept less than ! eps in root mean square norm. ! ierror (set by the user) = ! 1 means ywt(i) = 1. (absolute error control) ! ewt is ignored. ! 2 means ywt(i) = abs ( y(i) ), (relative error control) ! ewt is ignored. ! 3 means ywt(i) = max ( abs ( y(i) ), ewt(1) ). ! 4 means ywt(i) = max ( abs ( y(i) ), ewt(i) ). ! this choice is useful when the solution components ! have differing scales. ! 5 means ywt(i) = ewt(i). ! if ierror is 3, ewt need only be dimensioned one. ! if ierror is 4 or 5, the user must dimension ewt at least ! n, and set its values. ! ! mint = (input) the integration method indicator. ! mint = 1 means the adams methods, and is used for ! non-stiff problems. ! mint = 2 means the stiff methods of gear (i.e., the ! backward differentiation formulas), and is ! used for stiff problems. ! mint = 3 means the program dynamically selects the ! adams methods when the problem is non-stiff ! and the gear methods when the problem is ! stiff. when using the adams methods, the ! program uses a value of miter=0; when using ! the gear methods, the program uses the value ! of miter provided by the user. only a value ! of impl = 0 and a value of miter = 1, 2, 4, or ! 5 is allowed for this option. the user may ! not alter the value of mint or miter without ! restarting, i.e., setting nstate to 1. ! ! miter = (input) the iteration method indicator. ! miter = 0 means functional iteration. this value is ! suggested for non-stiff problems. ! miter = 1 means chord method with analytic jacobian. ! in this case, the user supplies subroutine ! jacobn (see description below). ! miter = 2 means chord method with jacobian calculated ! internally by finite differences. ! miter = 3 means chord method with corrections computed ! by the user-written routine users. See ! description of users below. this option ! allows all matrix algebra and storage ! decisions to be made by the user. when using ! a value of miter = 3, the subroutine fa is ! not required, even if impl is not 0. for ! further information on using this option, see ! section iv-e below. ! miter = 4 means the same as miter = 1 but the a and ! jacobian matrices are assumed to be banded. ! miter = 5 means the same as miter = 2 but the a and ! jacobian matrices are assumed to be banded. ! ! impl = (input) the implicit method indicator. ! impl = 0 means solving dy(i)/dt = f(y(i),t). ! impl = 1 means solving a * dy(i)/dt = f(y(i),t), ! non-singular a. See description of fa below. ! only mint = 1 or 2, and miter = 1, 2, 3, 4, or ! 5 are allowed for this option. ! impl = 2 means solving certain systems of hybrid ! differential/algebraic equations. See ! description of fa below. only mint = 2 and ! miter = 1, 2, 3, 4, or 5, are allowed for this ! option. ! the value of impl must not be changed during a problem. ! ! ml = (input) the lower half-bandwidth in the case of a banded ! a or jacobian matrix. (i.e., maximum(r-c) for nonzero ! a(r,c).) ! ! mu = (input) the upper half-bandwidth in the case of a banded ! a or jacobian matrix. (i.e., maximum(c-r).) ! ! mxord = (input) the maximum order desired. this is <= 12 for ! the adams methods and <= 5 for the gear methods. normal ! value is 12 and 5, respectively. if mint is 3, the ! maximum order used will be min ( MXORD, 12 ) when using the ! adams methods, and min ( MXORD, 5 ) when using the gear ! methods. mxord must not be altered during a problem. ! ! hmax = (input) the maximum magnitude of the step size that will ! be used for the problem. this is useful for ensuring that ! important details are not missed. if this is not the ! case, a large value, such as the interval length, is ! suggested. ! ! work ! lenw = (input) ! work is an array of lenw real words used ! internally for temporary storage. the user must allocate ! space for this array in the calling program by a statement ! such as ! real work(...) ! the following table gives the required minimum value for ! the length of work, depending on the value of impl and ! miter. lenw should be set to the value used. the ! contents of work should not be disturbed between calls to ! ddriv3. ! ! impl = 0 1 2 ! --------------------------------------------------------- ! miter = 0 (mxord+4)*n + not allowed not allowed ! 2*nroot + 204 ! ! 1,2 n*n+(mxord+5)*n 2*n*n+(mxord+5)*n n*n+(mxord+6)*n ! + 2*nroot + 204 + 2*nroot + 204 + 2*nroot + 204 ! ! 3 (mxord+4)*n + (mxord+4)*n + (mxord+4)*n + ! 2*nroot + 204 2*nroot + 204 2*nroot + 204 ! ! 4,5 (2*ml+mu)*n + (4*ml+2*mu)*n + (2*ml+mu)*n + ! (mxord+6)*n + (mxord+7)*n + (mxord+7)*n + ! 2*nroot + 204 2*nroot + 204 2*nroot + 204 ! --------------------------------------------------------- ! ! iwork ! leniw = (input) ! iwork is an integer array of length leniw used ! internally for temporary storage. the user must allocate space ! for this array in the calling program by a statement such as ! integer iwork(...) ! the length of iwork should be at least ! 21 if miter is 0 or 3, or ! n+21 if miter is 1, 2, 4, or 5, or mint is 3, ! and leniw should be set to the value used. the contents ! of iwork should not be disturbed between calls to ddriv3. ! ! jacobn = a subroutine supplied by the user, if miter is 1 or 4. ! if this is the case, the name must be declared external in ! the user's calling program. given a system of n ! differential equations, it is meaningful to speak about ! the partial derivative of the i-th right hand side with ! respect to the j-th dependent variable. in general there ! are n*n such quantities. often however the equations can ! be ordered so that the i-th differential equation only ! involves dependent variables with index near i, e.g., i+1, ! i-2. such a system is called banded. if, for all i, the ! i-th equation depends on at most the variables ! y(i-ml), y(i-ml+1), ... , y(i), y(i+1), ... , y(i+mu) ! then we call ml+mu+1 the bandwith of the system. in a ! banded system many of the partial derivatives above are ! automatically zero. for the cases miter = 1, 2, 4, and 5, ! some of these partials are needed. for the cases ! miter = 2 and 5 the necessary derivatives are ! approximated numerically by ddriv3, and we only ask the ! user to tell ddriv3 the value of ml and mu if the system ! is banded. for the cases miter = 1 and 4 the user must ! derive these partials algebraically and encode them in ! subroutine jacobn. by computing these derivatives the ! user can often save 20-30 per cent of the computing time. ! usually, however, the accuracy is not much affected and ! most users will probably forego this option. the optional ! user-written subroutine jacobn has the form: ! subroutine jacobn (n, t, y, dfdy, matdim, ml, mu) ! real y(*), dfdy(matdim,*) ! . ! . ! calculate values of dfdy ! . ! . ! end (sample) ! here y is a vector of length at least n. the actual ! length of y is determined by the user's declaration in the ! program which calls ddriv3. thus the dimensioning of y in ! jacobn, while required by fortran convention, does not ! actually allocate any storage. when this subroutine is ! called, the first n components of y are intermediate ! approximations to the solution components. the user ! should not alter these values. if the system is not ! banded (miter=1), the partials of the i-th equation with ! respect to the j-th dependent function are to be stored in ! dfdy(i,j). thus partials of the i-th equation are stored ! in the i-th row of dfdy. if the system is banded ! (miter=4), then the partials of the i-th equation with ! respect to y(j) are to be stored in dfdy(k,j), where ! k=i-j+mu+1 . normally a return from jacobn passes control ! back to ddriv3. however, if the user would like to abort ! the calculation, i.e., return control to the program which ! calls ddriv3, he should set n to zero. ddriv3 will signal ! this by returning a value of nstate equal to +8(-8). ! altering the value of n in jacobn has no effect on the ! value of n in the call sequence of ddriv3. ! ! fa = a subroutine supplied by the user if impl is 1 or 2, and ! miter is not 3. if so, the name must be declared external ! in the user's calling program. this subroutine computes ! the array a, where a * dy(i)/dt = f(y(i),t). ! there are two cases: ! ! impl=1. ! subroutine fa is of the form: ! subroutine fa (n, t, y, a, matdim, ml, mu, nde) ! real y(*), a(matdim,*) ! . ! . ! calculate all values of a ! . ! . ! end (sample) ! in this case a is assumed to be a nonsingular matrix, ! with the same structure as dfdy (see jacobn description ! above). programming considerations prevent complete ! generality. if miter is 1 or 2, a is assumed to be full ! and the user must compute and store all values of ! A(1:N,1:N). If miter is 4 or 5, a is assumed ! to be banded with lower and upper half bandwidth ml and ! mu. the left hand side of the i-th equation is a linear ! combination of dy(i-ml)/dt, dy(i-ml+1)/dt, ... , ! dy(i)/dt, ... , dy(i+mu-1)/dt, dy(i+mu)/dt. thus in the ! i-th equation, the coefficient of dy(j)/dt is to be ! stored in a(k,j), where k=i-j+mu+1. ! note: the array a will be altered between calls to fa. ! ! impl=2. ! subroutine fa is of the form: ! subroutine fa (n, t, y, a, matdim, ml, mu, nde) ! real y(*), a(*) ! . ! . ! calculate non-zero values of a(1),...,a(nde) ! . ! . ! end (sample) ! in this case it is assumed that the system is ordered by ! the user so that the differential equations appear ! first, and the algebraic equations appear last. the ! algebraic equations must be written in the form: ! 0 = f(y(i),t). when using this option it is up to the ! user to provide initial values for the y(i) that satisfy ! the algebraic equations as well as possible. it is ! further assumed that a is a vector of length nde. all ! of the components of a, which may depend on t, y(i), ! etc., must be set by the user to non-zero values. ! here y is a vector of length at least n. the actual ! length of y is determined by the user's declaration in the ! program which calls ddriv3. thus the dimensioning of y in ! fa, while required by fortran convention, does not ! actually allocate any storage. when this subroutine is ! called, the first n components of y are intermediate ! approximations to the solution components. the user ! should not alter these values. fa is always called ! immediately after calling f, with the same values of t ! and y. normally a return from fa passes control back to ! ddriv3. however, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls ddriv3, he should set n to zero. ddriv3 will signal ! this by returning a value of nstate equal to +9(-9). ! altering the value of n in fa has no effect on the value ! of n in the call sequence of ddriv3. ! ! nde = (input) the number of differential equations. this is ! required only for impl = 2, with nde < n. ! ! mxstep = (input) the maximum number of internal steps allowed on ! one call to ddriv3. ! ! g = a real fortran function supplied by the user ! if nroot is not 0. in this case, the name must be ! declared external in the user's calling program. g is ! repeatedly called with different values of iroot to obtain ! the value of each of the nroot equations for which a root ! is desired. g is of the form: ! real function g (n, t, y, iroot) ! real y(*) ! go to (10, ...), iroot ! 10 g = ... ! . ! . ! end (sample) ! here, y is a vector of length at least n, whose first n ! components are the solution components at the point t. ! the user should not alter these values. the actual length ! of y is determined by the user's declaration in the ! program which calls ddriv3. thus the dimensioning of y in ! g, while required by fortran convention, does not actually ! allocate any storage. normally a return from g passes ! control back to ddriv3. however, if the user would like ! to abort the calculation, i.e., return control to the ! program which calls ddriv3, he should set n to zero. ! ddriv3 will signal this by returning a value of nstate ! equal to +7(-7). in this case, the index of the equation ! being evaluated is stored in the sixth element of iwork. ! altering the value of n in g has no effect on the value of ! n in the call sequence of ddriv3. ! ! users = a subroutine supplied by the user, if miter is 3. ! if this is the case, the name must be declared external in ! the user's calling program. the routine users is called ! by ddriv3 when certain linear systems must be solved. the ! user may choose any method to form, store and solve these ! systems in order to obtain the solution result that is ! returned to ddriv3. in particular, this allows sparse ! matrix methods to be used. the call sequence for this ! routine is: ! ! subroutine users (y, yh, ywt, save1, save2, t, h, el, ! 8 impl, n, nde, iflag) ! real y(*), yh(*), ywt(*), save1(*), ! 8 save2(*), t, h, el ! ! the input variable iflag indicates what action is to be ! taken.subroutine users should perform the following ! operations, depending on the value of iflag and impl. ! ! iflag = 0 ! impl = 0. users is not called. ! impl = 1 or 2. solve the system a*x = save2, ! returning the result in save2. the array save1 can ! be used as a work array. ! ! iflag = 1 ! impl = 0. compute, decompose and store the matrix ! (i - h * el * j), where i is the identity matrix and j ! is the jacobian matrix of the right hand side. the ! array save1 can be used as a work array. ! impl = 1 or 2. compute, decompose and store the matrix ! (a - h * el * j). the array save1 can be used as a work ! array. ! ! iflag = 2 ! impl = 0. solve the system ! (i - h * el * j)*x = h * save2 - yh - save1, ! returning the result in save2. ! impl = 1 or 2. solve the system ! (a - h * el * j)*x = h * save2 - a * (yh + save1) ! returning the result in save2. ! the array save1 should not be altered. ! normally a return from users passes control back to ! ddriv3. however, if the user would like to abort the ! calculation, i.e., return control to the program which ! calls ddriv3, he should set n to zero. ddriv3 will signal ! this by returning a value of nstate equal to +10(-10). ! altering the value of n in users has no effect on the ! value of n in the call sequence of ddriv3. ! ! long description ! ! iii. other communication to the user ! ! a. the solver communicates to the user through the parameters ! above. in addition it writes diagnostic messages through the ! standard error handling program XERROR. that program will ! terminate the user's run if it detects a probable problem setup ! error, e.g., insufficient storage allocated by the user for the ! work array. messages are written on the standard error message ! file. at installations which have this error handling package ! the user should determine the standard error handling file from ! the local documentation. otherwise the short but serviceable ! routine, XERROR, available with this package, can be used. ! following is a list of possible errors. unless otherwise noted, ! all messages come from ddriv3: ! ! no. type message ! --- ---- ------- ! 1 fatal from ddriv2: the integration method flag has ! an illegal value. ! 2 warning the output point is inconsistent with the ! value of ntask and t. ! 3 warning number of steps to reach tout exceeds mxstep. ! 4 recoverable requested accuracy is too stringent. ! 5 warning step size is below the roundoff level. ! 6 fatal eps is less than zero. ! 7 fatal n is not positive. ! 8 fatal insufficient work space provided. ! 9 fatal improper value for nstate, mint, miter and/or ! impl. ! 10 fatal the iwork array is too small. ! 11 fatal the step size has gone to zero. ! 12 fatal excessive amount of work. ! 13 fatal for impl=1 or 2, the matrix a is singular. ! 14 fatal mxord is not positive. ! 15 fatal from ddriv1: n is greater than 200. ! 16 fatal from ddriv1: the work array is too small. ! ! b. the first three elements of work and the first five elements of ! iwork will contain the following statistical data: ! avgh the average step size used. ! hused the step size last used (successfully). ! avgord the average order used. ! imxerr the index of the element of the solution vector that ! contributed most to the last error test. ! nqused the order last used (successfully). ! nstep the number of steps taken since last initialization. ! nfe the number of evaluations of the right hand side. ! nje the number of evaluations of the jacobian matrix. ! ! iv. remarks ! ! a. other routines used: ! ddntp, ddzro, ddstp, ddntl, ddpst, ddcor, ddcst, ! ddpsc, and ddscl; ! dgefa, dgesl, dgbfa, dgbsl, and dnrm2 (from linpack) ! xerror (from the slatec common math library) ! the last seven routines above, not having been written by the ! present authors, are not explicitly part of this package. ! ! b. on any return from ddriv3 all information necessary to continue ! the calculation is contained in the call sequence parameters, ! including the work arrays. thus it is possible to suspend one ! problem, integrate another, and then return to the first. ! ! c. if this package is to be used in an overlay situation, the user ! must declare in the primary overlay the variables in the call ! sequence to ddriv3. ! ! d. changing parameters during an integration. ! the value of nroot, eps, ewt, ierror, mint, miter, or hmax may ! be altered by the user between calls to ddriv3. for example, if ! too much accuracy has been requested (the program returns with ! nstate = 4 and an increased value of eps) the user may wish to ! increase eps further. in general, prudence is necessary when ! making changes in parameters since such changes are not ! implemented until the next integration step, which is not ! necessarily the next call to ddriv3. this can happen if the ! program has already integrated to a point which is beyond the ! new point tout. ! ! e. as the price for complete control of matrix algebra, the ddriv3 ! users option puts all responsibility for jacobian matrix ! evaluation on the user. it is often useful to approximate ! numerically all or part of the jacobian matrix. however this ! must be done carefully. the fortran sequence below illustrates ! the method we recommend. it can be inserted directly into ! subroutine users to approximate jacobian elements in rows i1 ! to i2 and columns j1 to j2. ! real dfdy(n,n), epsj, h, r, ! 8 save1(n), save2(n), t, uround, y(n), yj, ywt(n) ! uround = epsilon ( uround ) ! epsj = sqrt ( uround ) ! do j = j1,j2 ! r = epsj * max ( abs ( ywt(j) ), abs ( y(j) ) ) ! if (r == 0.0) r = ywt(j) ! yj = y(j) ! y(j) = y(j) + r ! call f (n, t, y, save1) ! if (n == 0) return ! y(j) = yj ! do i = i1,i2 ! dfdy(i,j) = (save1(i) - save2(i))/r ! end do ! end do ! ! many problems give rise to structured sparse jacobians, e.g., ! block banded. it is possible to approximate them with fewer ! function evaluations than the above procedure uses; see curtis, ! powell and reid, j. inst. maths applics, (1974), vol. 13, ! pp. 117-119. ! ! f. when any of the routines jacobn, fa, g, or users, is not ! required, difficulties associated with unsatisfied externals can ! be avoided by using the name of the routine which calculates the ! right hand side of the differential equations in place of the ! corresponding name in the call sequence of ddriv3. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) ae real ( kind = rk ) big logical convrg real ( kind = rk ) dnrm2 real ( kind = rk ) eps real ( kind = rk ) ewt(*) external f external fa real ( kind = rk ), external :: g real ( kind = rk ) glast real ( kind = rk ) h real ( kind = rk ) hmax real ( kind = rk ) hsign integer i integer ia integer, parameter :: iavgh = 1 integer, parameter :: iavgrd = 3 integer idfdy integer ierror integer ifac integer iflag integer ignow integer, parameter :: ihused = 2 integer, parameter :: iel = 4 integer, parameter :: ih = 160 integer, parameter :: ihmax = 161 integer, parameter :: ihold = 162 integer, parameter :: ihsign = 163 integer, parameter :: irc = 164 integer, parameter :: irmax = 165 integer, parameter :: it = 166 integer, parameter :: itout = 167 integer, parameter :: itq = 168 integer, parameter :: itrend = 204 integer, parameter :: iyh = 205 integer, parameter :: indmxr = 1 integer, parameter :: inqusd = 2 integer, parameter :: instep = 3 integer, parameter :: infe = 4 integer, parameter :: inje = 5 integer, parameter :: inroot = 6 integer, parameter :: icnvrg = 7 integer, parameter :: ijroot = 8 integer, parameter :: ijtask = 9 integer, parameter :: imntld = 10 integer, parameter :: imtrld = 11 integer, parameter :: inq = 12 integer, parameter :: inrtld = 13 integer, parameter :: indtrt = 14 integer, parameter :: inwait = 15 integer, parameter :: imnt = 16 integer, parameter :: imtrsv = 17 integer, parameter :: imtr = 18 integer, parameter :: imxrds = 19 integer, parameter :: imxord = 20 integer, parameter :: indprt = 21 integer, parameter :: indpvt = 22 integer impl integer imxerr integer info integer iroot integer isave1 integer isave2 integer itroot integer iwork(*) integer iywt integer j integer ja external jacobn integer jaml integer jerror integer jgnow integer jhyp integer jroot integer jsave2 integer jstate integer jtroot integer jyh integer jywt integer lenchk integer leniw integer lenw integer liwchk integer matdim integer maxord integer mint integer miter integer ml integer mu integer mxord integer mxstep integer nde integer ndecom integer npar integer nroot real ( kind = rk ), parameter :: nround = 20.0D+00 integer nstate integer nstepl integer ntask real ( kind = rk ) re real ( kind = rk ) size real ( kind = rk ) sum2 real ( kind = rk ) t real ( kind = rk ) tlast real ( kind = rk ) tout real ( kind = rk ) troot real ( kind = rk ) uround external users real ( kind = rk ) work(*) real ( kind = rk ) y(*) npar = n uround = epsilon ( uround ) if ( nroot /= 0 ) then ae = tiny ( ae ) re = uround end if if ( eps < 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' Improper value of EPS.' write ( *, '(a,g14.6)' ) ' EPS = ', eps write ( *, '(a)' ) ' EPS should be nonnegative.' stop end if if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' Improper value for the number of equations.' write ( *, '(a,i6)' ) ' N = ', n write ( *, '(a)' ) ' N should be positive.' stop end if if ( mxord <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' Improper value for the maximum order.' write ( *, '(a,i6)' ) ' MXORD = ', mxord write ( *, '(a)' ) ' MXORD should be positive.' stop end if if ((mint < 1 .or. 3 < mint ) .or. (mint == 3 .and. & (miter == 0 .or. miter == 3 .or. impl /= 0)) & .or. (miter < 0 .or. 5 < miter ) .or. & (impl /= 0 .and. impl /= 1 .and. impl /= 2) .or. & ((impl == 1 .or. impl == 2) .and. miter == 0) .or. & (impl == 2 .and. mint == 1) .or. & (nstate < 1 .or. 10 < nstate )) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' Improper value for some input quantity.' write ( *, '(a)' ) ' NSTATE/MSTATE/MINT/MITER/IMPL.' stop end if if ( miter == 0 .or. miter == 3 ) then liwchk = indpvt - 1 else if ( miter == 1 .or. miter == 2 .or. miter == 4 .or. miter == 5 ) then liwchk = indpvt + n - 1 end if if ( leniw < liwchk ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' Insufficient integer storage.' write ( *, '(a,i6)' ) ' LENIW = ', leniw write ( *, '(a,i6)' ) ' Required = ', liwchk stop end if ! ! Allocate the work array ! iyh is the index of yh in work. ! if ( mint == 1 .or. mint == 3 ) then maxord = min ( mxord, 12 ) else if ( mint == 2) then maxord = min ( mxord, 5 ) end if idfdy = iyh + (maxord + 1) * n ! ! idfdy is the index of dfdy ! if (miter == 0 .or. miter == 3 ) then iywt = idfdy else if (miter == 1 .or. miter == 2 ) then iywt = idfdy + n*n else if (miter == 4 .or. miter == 5 ) then iywt = idfdy + (2*ml + mu + 1) * n end if ! ! iywt is the index of ywt ! isave1 = iywt + n ! ! isave1 is the index of save1 ! isave2 = isave1 + n ! ! isave2 is the index of save2 ! ignow = isave2 + n ! ! ignow is the index of gnow ! itroot = ignow + nroot ! ! itroot is the index of troot ! ifac = itroot + nroot ! ! ifac is the index of fac ! if (miter == 2 .or. miter == 5 .or. mint == 3) then ia = ifac + n else ia = ifac end if ! ! ia is the index of a ! if (impl == 0 .or. miter == 3) then lenchk = ia - 1 else if (impl == 1 .and. (miter == 1 .or. miter == 2)) then lenchk = ia - 1 + n*n else if (impl == 1 .and. (miter == 4 .or. miter == 5)) then lenchk = ia - 1 + (2*ml + mu + 1)*n else if (impl == 2 .and. miter /= 3) then lenchk = ia - 1 + n end if if (lenw < lenchk) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' Insufficient real storage.' write ( *, '(a,i6)' ) ' LENW = ', lenw write ( *, '(a,i6)' ) ' Required = ', lenchk stop end if if (miter == 0 .or. miter == 3) then matdim = 1 else if (miter == 1 .or. miter == 2) then matdim = n else if (miter == 4 .or. miter == 5) then matdim = 2*ml + mu + 1 end if if (impl == 0 .or. impl == 1) then ndecom = n else if (impl == 2) then ndecom = nde end if if (nstate == 1) then ! ! initialize parameters. ! if (mint == 1 .or. mint == 3) then iwork(imxord) = min ( mxord, 12 ) else if (mint == 2) then iwork(imxord) = min ( mxord, 5 ) end if iwork(imxrds) = mxord if (mint == 1 .or. mint == 2) then iwork(imnt) = mint iwork(imtr) = miter iwork(imntld) = mint iwork(imtrld) = miter else if (mint == 3) then iwork(imnt) = 1 iwork(imtr) = 0 iwork(imntld) = iwork(imnt) iwork(imtrld) = iwork(imtr) iwork(imtrsv) = miter end if work(ihmax) = hmax h = (tout - t)*(1.0D+00 - 4.0D+00 * uround ) h = sign ( min ( abs ( h ), hmax ), h ) work(ih) = h hsign = sign ( 1.0D+00, h ) work(ihsign) = hsign iwork(ijtask) = 0 work(iavgh) = 0.0D+00 work(ihused) = 0.0D+00 work(iavgrd) = 0.0D+00 iwork(indmxr) = 0 iwork(inqusd) = 0 iwork(instep) = 0 iwork(infe) = 0 iwork(inje) = 0 iwork(inroot) = 0 work(it) = t iwork(icnvrg) = 0 iwork(indprt) = 0 ! ! Set initial conditions ! do i = 1,n jyh = i + iyh - 1 work(jyh) = y(i) end do if ( t == tout ) then return end if go to 180 end if ! ! On a continuation, check that output points have ! been or will be overtaken. ! if (iwork(icnvrg) == 1) then convrg = .true. else convrg = .false. end if t = work(it) h = work(ih) hsign = work(ihsign) if (iwork(ijtask) == 0) then go to 180 end if ! ! iwork(ijroot) flags unreported roots, and is set to the value of ! ntask when a root was last selected. ! it is set to zero when all roots ! have been reported. iwork(inroot) ! contains the index and work(itout) ! contains the value of the root last ! selected to be reported. ! iwork(inrtld) contains the value of ! nroot and iwork(indtrt) contains ! the value of itroot when the array ! of roots was last calculated. ! if ( nroot /= 0 ) then jroot = iwork(ijroot) if ( 0 < jroot ) then ! ! tout has just been reported. ! if troot <= tout, report troot. ! if (nstate /= 5) then if ( work(itout)*hsign <= tout * hsign ) then troot = work(itout) call ddntp ( h, 0, n, iwork(inq), t, troot, work(iyh), y ) t = troot nstate = 5 go to 580 end if ! ! A root has just been reported. ! Select the next root. ! else troot = t iroot = 0 do i = 1, iwork(inrtld) jtroot = iwork(indtrt) + i - 1 if ( work(jtroot) * hsign <= troot * hsign ) then ! ! Check for multiple roots. ! if (work(jtroot) == work(itout) .and. iwork(inroot) < i ) then iroot = i troot = work(jtroot) go to 60 end if if ( work(itout) * hsign < work(jtroot) * hsign ) then iroot = i troot = work(jtroot) end if end if end do 60 continue iwork(inroot) = iroot work(itout) = troot iwork(ijroot) = ntask if (ntask == 1) then if (iroot == 0) then iwork(ijroot) = 0 else if ( troot * hsign <= tout * hsign ) then call ddntp(h, 0, n, iwork(inq), t, troot,work(iyh),y) nstate = 5 t = troot go to 580 end if end if else if (ntask == 2 .or. ntask == 3) then ! ! if there are no more roots, or the ! user has altered tout to be less ! than a root, set ijroot to zero. ! if (iroot == 0 .or. (tout*hsign < troot*hsign)) then iwork(ijroot) = 0 else call ddntp(h, 0, n, iwork(inq), t, troot, work(iyh), y) nstate = 5 t = troot go to 580 end if end if end if end if end if if (ntask == 1) then nstate = 2 if ( tout * hsign <= t * hsign ) then call ddntp (h, 0, n, iwork(inq), t, tout, work(iyh), y) t = tout go to 580 end if else if (ntask == 2) then ! ! Check if TOUT has been reset. ! if ( tout * hsign < t * hsign ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Warning!' write ( *, '(a)' ) ' The input T was beyond TOUT.' write ( *, '(a)' ) ' The solution was obtained by interpolation.' call ddntp (h, 0, n, iwork(inq), t, tout, work(iyh), y) t = tout nstate = 2 go to 580 end if ! ! Determine if TOUT has been overtaken. ! if ( abs ( tout - t ) <= & nround * uround * max ( abs ( t ), abs ( tout ) ) ) then t = tout nstate = 2 go to 560 end if ! ! if there are no more roots to report, report t. ! if (nstate == 5) then nstate = 2 go to 560 end if nstate = 2 ! ! see if tout will be overtaken. ! if ( tout * hsign < ( t + h ) * hsign ) then h = tout - t if ( tout * hsign < ( t + h ) * hsign ) then h = h * ( 1.0D+00 - 4.0D+00 *uround ) end if work(ih) = h if (h == 0.0D+00 ) then go to 670 end if iwork(ijtask) = -1 end if else if (ntask == 3) then nstate = 2 if ( tout * hsign < t * hsign ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Warning!' write ( *, '(a)' ) ' The input T was beyond TOUT.' write ( *, '(a)' ) ' The solution was obtained by interpolation.' call ddntp (h, 0, n, iwork(inq), t, tout, work(iyh), y) t = tout go to 580 end if if ( abs ( tout - t ) <= & nround * uround * max ( abs ( t ), abs ( tout ) ) ) then t = tout go to 560 end if if ( tout * hsign < (t + h)*hsign ) then h = tout - t if ( tout * hsign < (t + h)*hsign ) then h = h*(1.0D+00 - 4.0D+00 *uround) end if work(ih) = h if (h == 0.0D+00 ) then go to 670 end if iwork(ijtask) = -1 end if end if ! ! implement changes in mint, miter, and/or hmax. ! if ((mint /= iwork(imntld) .or. miter /= iwork(imtrld)) .and. & mint /= 3 .and. iwork(imntld) /= 3) iwork(ijtask) = -1 if (hmax /= work(ihmax)) then h = sign ( min ( abs ( h ), hmax ), h ) if (h /= work(ih)) then iwork(ijtask) = -1 work(ih) = h end if work(ihmax) = hmax end if 180 nstepl = iwork(instep) do i = 1,n jyh = iyh + i - 1 y(i) = work(jyh) end do if ( nroot /= 0 ) then do i = 1,nroot jgnow = ignow + i - 1 work(jgnow) = g (npar, t, y, i) if ( npar == 0 ) then iwork(inroot) = i nstate = 7 return end if end do end if if (ierror == 1) then do i = 1,n jywt = i + iywt - 1 work(jywt) = 1.0D+00 end do go to 410 else if (ierror == 5) then do i = 1,n jywt = i + iywt - 1 work(jywt) = ewt(i) end do go to 410 end if ! ! reset ywt array. looping point. ! 260 continue if (ierror == 2) then do i = 1,n if (y(i) == 0.0D+00 ) then go to 290 end if jywt = i + iywt - 1 work(jywt) = abs ( y(i) ) end do go to 410 290 continue if (iwork(ijtask) == 0) then call f (npar, t, y, work(isave2)) if (npar == 0) then nstate = 6 return end if iwork(infe) = iwork(infe) + 1 if (miter == 3 .and. impl /= 0) then iflag = 0 call users(y, work(iyh), work(iywt), work(isave1), & work(isave2), t, h, work(iel), impl, npar, ndecom, iflag) if (npar == 0) then nstate = 10 return end if else if (impl == 1) then if (miter == 1 .or. miter == 2) then call fa (npar, t, y, work(ia), matdim, ml, mu, ndecom) if (npar == 0) then nstate = 9 return end if call dgefa (work(ia), matdim, n, iwork(indpvt), info) if (info /= 0) then go to 690 end if call dgesl(work(ia),matdim,n,iwork(indpvt),work(isave2),0) else if (miter == 4 .or. miter == 5) then jaml = ia + ml call fa (npar, t, y, work(jaml), matdim, ml, mu, ndecom) if (npar == 0) then nstate = 9 return end if call dgbfa (work(ia),matdim,n,ml,mu,iwork(indpvt),info) if (info /= 0) then go to 690 end if call dgbsl (work(ia), matdim, n, ml, mu, iwork(indpvt), & work(isave2), 0) end if else if (impl == 2) then call fa (npar, t, y, work(ia), matdim, ml, mu, ndecom) if (npar == 0) then nstate = 9 return end if do i = 1,ndecom ja = i + ia - 1 jsave2 = i + isave2 - 1 if (work(ja) == 0.0D+00 ) then go to 690 end if work(jsave2) = work(jsave2)/work(ja) end do end if end if do j = i,n jywt = j + iywt - 1 if (y(j) /= 0.0D+00 ) then work(jywt) = abs ( y(j) ) else if (iwork(ijtask) == 0) then jsave2 = j + isave2 - 1 work(jywt) = abs ( h * work(jsave2) ) else jhyp = j + iyh + n - 1 work(jywt) = abs ( work(jhyp) ) end if end if if ( work(jywt) == 0.0D+00 ) then work(jywt) = uround end if end do else if ( ierror == 3 ) then do i = 1,n jywt = i + iywt - 1 work(jywt) = max ( ewt(1), abs ( y(i) ) ) end do else if (ierror == 4) then do i = 1,n jywt = i + iywt - 1 work(jywt) = max ( ewt(i), abs ( y(i) ) ) end do end if 410 continue do i = 1,n jywt = i + iywt - 1 jsave2 = i + isave2 - 1 work(jsave2) = y(i) / work(jywt) end do sum2 = dnrm2 ( n, work(isave2), 1) / sqrt ( real ( n, kind = rk ) ) if ( eps < sum2 * uround ) then eps = sum2 * uround * ( 1.0D+00 + 10.0D+00 * uround ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Warning!' write ( *, '(a)' ) ' The requested accuracy EPS was not obtainable.' write ( *, '(a,g14.6)' ) ' EPS has been increased to ', eps nstate = 4 go to 560 end if if ( uround * abs ( t ) <= abs ( h ) ) then iwork(indprt) = 0 else if (iwork(indprt) == 0) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Warning!' write ( *, '(a)' ) ' The stepsize is smaller than roundoff.' write ( *, '(a)' ) ' This may occur when there is an abrupt change' write ( *, '(a)' ) ' in the right hand side.' iwork(indprt) = 1 end if if ( ntask /= 2 ) then if ( mxstep < ( iwork(instep) - nstepl ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Warning!' write ( *, '(a,i6)' ) ' Number of steps taken = ', mxstep write ( *, '(a)' ) ' TOUT not reached.' nstate = 3 go to 560 end if end if call ddstp (eps, f, fa, work(ihmax), impl, jacobn, matdim, & iwork(imxord), iwork(imnt), iwork(imtr), ml, mu, npar, & ndecom, work(iywt), uround, users, work(iavgh), & work(iavgrd), work(ih), work(ihused), iwork(ijtask), & iwork(imntld), iwork(imtrld), iwork(infe), iwork(inje), & iwork(inqusd), iwork(instep), work(it), y, work(iyh), & work(ia), convrg, work(idfdy), work(iel), work(ifac), & work(ihold), iwork(indpvt), jstate, iwork(inq), & iwork(inwait), work(irc), work(irmax), work(isave1), & work(isave2), work(itq), work(itrend), mint, & iwork(imtrsv), iwork(imxrds)) t = work(it) h = work(ih) go to (470, 670, 680, 690, 690, 660, 660, 660, 660, 660), jstate 470 continue iwork(ijtask) = 1 ! ! determine if a root has been overtaken ! if (nroot /= 0) then iroot = 0 do i = 1,nroot jtroot = itroot + i - 1 jgnow = ignow + i - 1 glast = work(jgnow) work(jgnow) = g (npar, t, y, i) if (npar == 0) then iwork(inroot) = i nstate = 7 return end if if ( 0.0D+00 < glast * work(jgnow) ) then work(jtroot) = t + h else if (work(jgnow) == 0.0D+00 ) then work(jtroot) = t iroot = i else if (glast == 0.0D+00 ) then work(jtroot) = t + h else if ( uround * abs ( t ) <= abs ( work(ihused) ) ) then tlast = t - work(ihused) iroot = i troot = t call ddzro (ae, g, h, npar, iwork(inq), iroot, re, t, & work(iyh), uround, troot, tlast, work(jgnow), glast, y) do j = 1,n y(j) = work(iyh + j -1) end do if (npar == 0) then iwork(inroot) = i nstate = 7 return end if work(jtroot) = troot else work(jtroot) = t iroot = i end if end if end if end if end do if (iroot == 0) then iwork(ijroot) = 0 ! ! select the first root ! else iwork(ijroot) = ntask iwork(inrtld) = nroot iwork(indtrt) = itroot troot = t + h do i = 1,nroot jtroot = itroot + i - 1 if (work(jtroot)*hsign < troot*hsign) then troot = work(jtroot) iroot = i end if end do iwork(inroot) = iroot work(itout) = troot if (troot*hsign <= tout*hsign) then call ddntp (h, 0, n, iwork(inq), t, troot, work(iyh), y) nstate = 5 t = troot go to 580 end if end if end if ! ! Test for ntask condition to be satisfied. ! nstate = 2 if (ntask == 1) then if (t*hsign < tout*hsign) then go to 260 end if call ddntp (h, 0, n, iwork(inq), t, tout, work(iyh), y) t = tout go to 580 ! ! TOUT is assumed to have been attained ! exactly if t is within twenty roundoff ! units of tout, relative to max ( tout, t ). ! else if (ntask == 2) then if (abs ( tout - t ) <= nround * uround * & max ( abs ( t ), abs ( tout ) ) ) then t = tout else if ( tout * hsign < (t + h) * hsign ) then h = tout - t if ( tout * hsign < (t + h) * hsign ) then h = h*(1.0D+00 - 4.0D+00 *uround) end if work(ih) = h if (h == 0.0D+00 ) then go to 670 end if iwork(ijtask) = -1 end if end if else if ( ntask == 3 ) then if ( abs ( tout - t ) <= & nround * uround * max ( abs ( t ), abs ( tout ) ) ) then t = tout else if ( tout * hsign < (t + h) * hsign ) then h = tout - t if ( tout * hsign < (t + h) * hsign ) then h = h * (1.0D+00 - 4.0D+00 * uround) end if work(ih) = h if ( h == 0.0D+00 ) then go to 670 end if iwork(ijtask) = -1 end if go to 260 end if end if ! ! All returns are made through this section. imxerr is determined. ! 560 continue do i = 1,n jyh = i + iyh - 1 y(i) = work(jyh) end do 580 continue if (convrg) then iwork(icnvrg) = 1 else iwork(icnvrg) = 0 end if if (iwork(ijtask) == 0) then return end if big = 0.0D+00 imxerr = 1 iwork(indmxr) = imxerr do i = 1,n ! ! size = abs ( error(i) / ywt(i) ) ! jywt = i + iywt - 1 jerror = i + isave1 - 1 size = abs ( work(jerror) / work(jywt) ) if ( big < size ) then big = size imxerr = i iwork(indmxr) = imxerr end if end do return 660 nstate = jstate return 670 continue write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' The attempted stepsize has been reduced to zero.' write ( *, '(a)' ) ' The problem setup may be incorrect.' stop 680 continue write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' The stepsize has been reduced about 50 times.' write ( *, '(a)' ) ' The problem setup may be incorrect.' stop 690 continue write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DDRIV3 - Fatal error!' write ( *, '(a)' ) ' Matrix A is singular.' stop end subroutine ddscl ( hmax, n, nq, rmax, h, rc, rh, yh ) !*****************************************************************************80 ! !! DDSCL rescales the YH array whenever the ODE step size is changed. ! ! Discussion: ! ! DDSCL is a utility routine for the DDRIV family of ODE solvers. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) h real ( kind = rk ) hmax integer j integer nq real ( kind = rk ) r1 real ( kind = rk ) rc real ( kind = rk ) rh real ( kind = rk ) rmax real ( kind = rk ) yh(n,*) if ( h < 1.0D+00 ) then rh = min ( abs ( h ) * rh, abs ( h ) * rmax, hmax ) / abs ( h ) else rh = min ( rh, rmax, hmax / abs ( h ) ) end if r1 = 1.0D+00 do j = 1, nq r1 = r1 * rh yh(1:n,j+1) = yh(1:n,j+1) * r1 end do h = h * rh rc = rc * rh return end subroutine ddstp ( eps, f, fa, hmax, impl, jacobn, matdim, maxord, mint, & miter, ml, mu, n, nde, ywt, uround, users, avgh, avgord, h, hused, jtask, & mntold, mtrold, nfe, nje, nqused, nstep, t, y, yh, a, convrg, dfdy, el, & fac, hold, ipvt, jstate, nq, nwait, rc, rmax, save1, save2, tq, trend, & iswflg, mtrsv, mxrdsv ) !*****************************************************************************80 ! !! DDSTP performs one step of the integration of an ODE system. ! ! Discussion: ! ! DDSTP performs one step of the integration of an initial value ! problem for a system of ordinary differential equations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! yh an n by maxord+1 array containing the dependent variables ! and their scaled derivatives. maxord, the maximum order ! used, is currently 12 for the adams methods and 5 for the ! gear methods. yh(i,j+1) contains the j-th derivative of ! y(i), scaled by h**j/factorial(j). only y(i), ! 1 <= i <= n, need be set by the calling program on ! the first entry. the yh array should not be altered by ! the calling program. when referencing yh as a ! 2-dimensional array, use a column length of n, as this is ! the value used in DDSTP. ! ! dfdy a block of locations used for partial derivatives if miter ! is not 0. if miter is 1 or 2 its length must be at least ! n*n. if miter is 4 or 5 its length must be at least ! (2*ml+mu+1)*n. ! ! ywt an array of n locations used in convergence and error tests ! ! Workspace, real ( kind = rk ) SAVE1(N), SAVE2(N). ! ! ipvt an integer array of length n used by the linear system ! solvers for the storage of row interchange information. ! ! a a block of locations used to store the matrix a, when using ! the implicit method. if impl is 1, a is a matdim by n ! array. if miter is 1 or 2 matdim is n, and if miter is 4 ! or 5 matdim is 2*ml+mu+1. if impl is 2 its length is n. ! ! jtask an integer used on input. ! it has the following values and meanings: ! == 0 perform the first step. this value enables ! the subroutine to initialize itself. ! > 0 take a new step continuing from the last. ! assumes the last step was successful and ! user has not changed any parameters. ! < 0 take a new step with a new value of h and/or ! mint and/or miter. ! ! jstate a completion code with the following meanings: ! 1 the step was successful. ! 2 a solution could not be obtained with h /= 0. ! 3 a solution was not obtained in mxtry attempts. ! 4 for impl /= 0, the matrix a is singular. ! on a return with 1 < JSTATE, the values of t and ! the yh array are as of the beginning of the last ! step, and h is the last step size attempted. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer matdim integer n real ( kind = rk ) a(matdim,*) real ( kind = rk ) avgh real ( kind = rk ) avgord real ( kind = rk ), parameter :: bias1 = 1.30D+00 real ( kind = rk ), parameter :: bias2 = 1.20D+00 real ( kind = rk ), parameter :: bias3 = 1.40D+00 real ( kind = rk ) bnd logical convrg real ( kind = rk ) ctest real ( kind = rk ) d real ( kind = rk ) denom real ( kind = rk ) dfdy(matdim,*) real ( kind = rk ) d1 real ( kind = rk ) dnrm2 real ( kind = rk ) el(13,12) real ( kind = rk ) eps real ( kind = rk ) erdn real ( kind = rk ) erup real ( kind = rk ) etest logical evalfa logical evaljc external f external fa real ( kind = rk ) fac(*) real ( kind = rk ) h real ( kind = rk ) hmax real ( kind = rk ) hn real ( kind = rk ) hold real ( kind = rk ) hs real ( kind = rk ) hused integer i logical, save :: ier = .false. integer impl integer ipvt(*) integer iswflg integer iter integer j external jacobn integer jstate integer jtask integer maxord integer mint integer miter integer ml integer mntold integer mtrold integer mtrsv integer mu integer, parameter :: mxfail = 3 integer, parameter :: mxiter = 3 integer mxrdsv integer, parameter :: mxtry = 50 integer nde integer nfail integer nfe integer nje integer nq integer nqused integer nstep integer nsv integer ntry real ( kind = rk ) numer integer nwait real ( kind = rk ) rc real ( kind = rk ), parameter :: rctest = 0.30D+00 real ( kind = rk ) rh real ( kind = rk ) rh1 real ( kind = rk ) rh2 real ( kind = rk ) rh3 real ( kind = rk ) rmax real ( kind = rk ), parameter :: rmfail = 2.0D+00 real ( kind = rk ), parameter :: rmnorm = 10.0D+00 real ( kind = rk ) save1(n) real ( kind = rk ) save2(n) logical switch real ( kind = rk ) t real ( kind = rk ) told real ( kind = rk ) tq(3,12) real ( kind = rk ) trend real ( kind = rk ), parameter :: trshld = 1.0D+00 real ( kind = rk ) uround external users real ( kind = rk ) y(*) real ( kind = rk ) yh(n,*) real ( kind = rk ) ywt(*) real ( kind = rk ) y0nrm nsv = n bnd = 0.0D+00 switch = .false. ntry = 0 told = t nfail = 0 if ( jtask <= 0 ) then call ddntl (eps, f, fa, hmax, hold, impl, jtask, matdim, & maxord, mint, miter, ml, mu, n, nde, save1, t, & uround, users, y, ywt, h, mntold, mtrold, nfe, rc, & yh, a, convrg, el, fac, ier, ipvt, nq, nwait, rh, & rmax, save2, tq, trend, iswflg, jstate) if ( n == 0) then go to 440 end if if ( h == 0.0D+00 ) then go to 400 end if if ( ier ) then go to 420 end if end if 100 continue ntry = ntry + 1 if ( mxtry < ntry ) then go to 410 end if t = t + h call ddpsc (1, n, nq, yh) evaljc = ( ( rctest < abs ( rc - 1.0D+00 ) ) .and. ( miter /= 0 ) ) evalfa = .not. evaljc 110 continue iter = 0 y(1:n) = yh(1:n,1) call f ( n, t, y, save2 ) if ( n == 0 ) then jstate = 6 go to 430 end if nfe = nfe + 1 if ( evaljc .or. ier ) then call ddpst (el, f, fa, h, impl, jacobn, matdim, miter, ml, & mu, n, nde, nq, save2, t, users, y, yh, ywt, uround, & nfe, nje, a, dfdy, fac, ier, ipvt, save1, iswflg, & bnd, jstate) if ( n == 0 ) then go to 430 end if if ( ier ) then go to 160 end if convrg = .false. rc = 1.0D+00 end if save1(1:n) = 0.0D+00 ! ! Up to mxiter corrector iterations are taken. ! convergence is tested by requiring the r.m.s. ! norm of changes to be less than eps. The sum of ! the corrections is accumulated in the vector ! save1(i). it is approximately equal to the l-th ! derivative of y multiplied by ! h**l/(factorial(l-1) * el(l,nq)), and is thus ! proportional to the actual errors to the lowest ! power of h present (h**l). the yh array is not ! altered in the correction loop. the norm of the ! iterate difference is stored in d. if ! 0 < iter, an estimate of the convergence rate ! constant is stored in trend, and this is used in ! the convergence test. ! 130 continue call ddcor (dfdy, el, fa, h, impl, ipvt, matdim, miter, ml, & mu, n, nde, nq, t, users, y, yh, ywt, evalfa, save1, & save2, a, d, jstate) if ( n == 0 ) then go to 430 end if if ( iswflg == 3 .and. mint == 1 ) then if (iter == 0) then numer = dnrm2 ( n, save1, 1) dfdy(1,1:n) = save1(1:n) y0nrm = dnrm2 ( n, yh, 1) else denom = numer dfdy(1,1:n) = save1(1:n) - dfdy(1,1:n) numer = dnrm2 ( n, dfdy, matdim) if ( el(1,nq) * numer <= 100.0D+00 * uround * y0nrm ) then if ( rmax == rmfail ) then switch = .true. go to 170 end if end if dfdy(1,1:n) = save1(1:n) if ( denom /= 0.0D+00 ) then bnd = max ( bnd, numer / ( denom * abs ( h ) * el(1,nq) ) ) end if end if end if if ( 0 < iter ) then trend = max ( 0.9D+00 * trend, d / d1 ) end if d1 = d ctest = min ( 2.0D+00 * trend, 1.0D+00 ) * d if ( ctest <= eps ) then go to 170 end if iter = iter + 1 if ( iter < mxiter ) then do i = 1,n y(i) = yh(i,1) + el(1,nq) * save1(i) end do call f ( n, t, y, save2 ) if ( n == 0 ) then jstate = 6 go to 430 end if nfe = nfe + 1 go to 130 end if ! ! The corrector iteration failed to converge in ! mxiter tries. if partials are involved but are ! not up to date, they are reevaluated for the next ! try. otherwise the yh array is retracted to its ! values before prediction, and h is reduced, if ! possible. if not, a no-convergence exit is taken. ! if ( convrg ) then evaljc = .true. evalfa = .false. go to 110 end if 160 continue t = told call ddpsc (-1, n, nq, yh) nwait = nq + 2 if ( jtask /= 0 .and. jtask /= 2 ) then rmax = rmfail end if if ( iter == 0 ) then rh = 0.3D+00 else rh = 0.9D+00 * ( eps / ctest )**(0.2D+00 ) end if if ( rh * h == 0.0D+00 ) then go to 400 end if call ddscl ( hmax, n, nq, rmax, h, rc, rh, yh ) go to 100 ! ! The corrector has converged. convrg is set ! to .true. if partial derivatives were used, ! to indicate that they may need updating on ! subsequent steps. the error test is made. ! 170 continue convrg = ( miter /= 0 ) save2(1:nde) = save1(1:nde) / ywt(1:nde) etest = dnrm2 ( nde, save2, 1 ) & / ( tq(2,nq) * sqrt ( real ( nde, kind = rk ) ) ) ! ! The error test failed. nfail keeps track of ! multiple failures. restore t and the yh ! array to their previous values, and prepare ! to try the step again. compute the optimum ! step size for this or one lower order. ! if ( eps < etest ) then t = told call ddpsc (-1, n, nq, yh) nfail = nfail + 1 if ( nfail < mxfail ) then if ( jtask /= 0 .and. jtask /= 2 ) then rmax = rmfail end if rh2 = 1.0D+00 / ( bias2 * ( etest / eps ) & **(1.0D+00 / real ( nq + 1, kind = rk ) ) ) if ( 1 < nq ) then save2(1:nde) = yh(1:nde,nq+1) / ywt(1:nde) erdn = dnrm2 ( nde, save2, 1 ) & / ( tq(1,nq) * sqrt ( real ( nde, kind = rk ) ) ) rh1 = 1.0D+00 / max ( 1.0D+00, & bias1 * ( erdn / eps )**( 1.0D+00 / real ( nq, kind = rk ) ) ) if ( rh2 < rh1 ) then nq = nq - 1 rc = rc * el(1,nq) / el(1,nq+1) rh = rh1 else rh = rh2 end if else rh = rh2 end if nwait = nq + 2 if ( rh * h == 0.0D+00 ) then go to 400 end if call ddscl (hmax, n, nq, rmax, h, rc, rh, yh) go to 100 end if ! ! Control reaches this section if the error test has ! failed mxfail or more times. It is assumed that the ! derivatives that have accumulated in the yh array have ! errors of the wrong order. Hence the first derivative ! is recomputed, the order is set to 1, and the step is retried. ! nfail = 0 jtask = 2 y(1:n) = yh(1:n,1) call ddntl (eps, f, fa, hmax, hold, impl, jtask, matdim, & maxord, mint, miter, ml, mu, n, nde, save1, t, & uround, users, y, ywt, h, mntold, mtrold, nfe, rc, & yh, a, convrg, el, fac, ier, ipvt, nq, nwait, rh, & rmax, save2, tq, trend, iswflg, jstate ) rmax = rmnorm if ( n == 0) then go to 440 end if if ( h == 0.0D+00 ) then go to 400 end if if ( ier ) then go to 420 end if go to 100 end if ! ! After a successful step, update the yh array. ! nstep = nstep + 1 hused = h nqused = nq avgh = ( real ( nstep - 1, kind = rk ) * avgh + h ) & / real ( nstep, kind = rk ) avgord = ( real ( nstep - 1, kind = rk ) * avgord & + real ( nq, kind = rk ) ) / real ( nstep, kind = rk ) do j = 1, nq+1 do i = 1, n yh(i,j) = yh(i,j) + el(j,nq) * save1(i) end do end do y(1:n) = yh(1:n,1) ! ! If iswflg is 3, consider changing integration methods. ! if ( iswflg == 3 ) then if ( bnd /= 0.0D+00 ) then if ( mint == 1 .and. nq <= 5 ) then hn = abs ( h ) / max ( uround, & ( etest / eps )**( 1.0D+00 / real ( nq + 1, kind = rk ) ) ) hn = min ( hn, 1.0D+00 / ( 2.0D+00 * el(1,nq) * bnd ) ) hs = abs ( h ) / max ( uround, & ( etest / ( eps * el(nq+1,1) ) )& **( 1.0D+00 / real ( nq+1, kind = rk ) ) ) if ( 1.2D+00 * hn < hs ) then mint = 2 mntold = mint miter = mtrsv mtrold = miter maxord = min ( mxrdsv, 5 ) rc = 0.0D+00 rmax = rmnorm trend = 1.0D+00 call ddcst ( maxord, mint, iswflg, el, tq ) nwait = nq + 2 end if else if (mint == 2) then hs = abs ( h ) / max ( uround, ( etest / eps )& **( 1.0D+00 / real ( nq+1, kind = rk) ) ) hn = abs ( h ) / max ( uround, & ( etest * el(nq+1,1) / eps)**(1.0D+00 / real ( nq+1, kind = rk ) ) ) hn = min ( hn, 1.0D+00 / ( 2.0D+00 * el(1,nq) * bnd ) ) if ( hs <= hn ) then mint = 1 mntold = mint miter = 0 mtrold = miter maxord = min ( mxrdsv, 12 ) rmax = rmnorm trend = 1.0D+00 convrg = .false. call ddcst (maxord, mint, iswflg, el, tq) nwait = nq + 2 end if end if end if end if if ( switch ) then mint = 2 mntold = mint miter = mtrsv mtrold = miter maxord = min ( mxrdsv, 5 ) nq = min ( nq, maxord ) rc = 0.0D+00 rmax = rmnorm trend = 1.0D+00 call ddcst ( maxord, mint, iswflg, el, tq ) nwait = nq + 2 end if ! ! Consider changing H if nwait = 1. Otherwise ! decrease nwait by 1. If nwait is then 1 and ! nq < maxord, then save1 is saved for use in ! a possible order increase on the next step. ! if (jtask == 0 .or. jtask == 2) then rh = 1.0D+00 / max ( uround, bias2 * ( etest / eps )& **(1.0D+00 / real ( nq+1, kind = rk ) ) ) if ( trshld < rh ) then call ddscl ( hmax, n, nq, rmax, h, rc, rh, yh ) end if else if ( 1 < nwait ) then nwait = nwait - 1 if ( nwait == 1 .and. nq < maxord ) then do i = 1, nde yh(i,maxord+1) = save1(i) end do end if ! ! If a change in H is considered, an increase or decrease in ! order by one is considered also. A change in H is made ! only if it is by a factor of at least trshld. Factors ! rh1, rh2, and rh3 are computed, by which H could be ! multiplied at order nq - 1, order nq, or order nq + 1, ! respectively. The largest of these is determined and the ! new order chosen accordingly. If the order is to be ! increased, we compute one additional scaled derivative. ! If there is a change of order, reset nq and the ! coefficients. In any case, H is reset according to rh and ! the yh array is rescaled. ! else if ( nq == 1 ) then rh1 = 0.0D+00 else do i = 1,nde save2(i) = yh(i,nq+1) / ywt(i) end do erdn = dnrm2 ( nde, save2, 1) & / ( tq(1,nq) * sqrt ( real ( nde, kind = rk ) ) ) rh1 = 1.0D+00 / max ( uround, & bias1 * ( erdn / eps )**( 1.0D+00 / real ( nq ) ) ) end if rh2 = 1.0D+00 / max ( uround, bias2 * ( etest / eps )& **( 1.0D+00 / real ( nq + 1, kind = rk ) ) ) if ( nq == maxord ) then rh3 = 0.0D+00 else do i = 1, nde save2(i) = ( save1(i) - yh(i,maxord+1) ) / ywt(i) end do erup = dnrm2 ( nde, save2, 1) & / (tq(3,nq) * sqrt ( real ( nde, kind = rk ) ) ) rh3 = 1.0D+00 / max ( uround, bias3 * ( erup / eps )& **( 1.0D+00 / real ( nq + 2, kind = rk ) ) ) end if if ( rh2 < rh1 .and. rh3 <= rh1 ) then rh = rh1 if ( rh <= trshld ) then go to 380 end if nq = nq - 1 rc = rc * el(1,nq) / el(1,nq+1) else if ( rh1 <= rh2 .and. rh3 <= rh2 ) then rh = rh2 if ( rh <= trshld ) then go to 380 end if else rh = rh3 if ( rh <= trshld ) then go to 380 end if do i = 1,n yh(i,nq+2) = save1(i) * el(nq+1,nq) / real ( nq + 1, kind = rk ) end do nq = nq + 1 rc = rc * el(1,nq) / el(1,nq-1) end if if ( iswflg == 3 .and. mint == 1 ) then if ( bnd /= 0.0D+00 ) then rh = min ( rh, 1.0D+00 / ( 2.0D+00 * el(1,nq) * bnd * abs ( h ) ) ) end if end if call ddscl (hmax, n, nq, rmax, h, rc, rh, yh) rmax = rmnorm 380 nwait = nq + 2 end if ! ! All returns are made through this section. H is saved ! in HOLD to allow the caller to change H on the next step. ! jstate = 1 hold = h return 400 jstate = 2 hold = h do i = 1,n y(i) = yh(i,1) end do return 410 jstate = 3 hold = h return 420 jstate = 4 hold = h return 430 t = told call ddpsc (-1, nsv, nq, yh) do i = 1,nsv y(i) = yh(i,1) end do 440 continue hold = h return end subroutine ddzro ( ae, f, h, n, nq, iroot, re, t, yh, uround, b, c, fb, fc, y ) !*****************************************************************************80 ! !! DDZRO searches for a zero of a function in a given interval. ! ! Discussion: ! ! The routine searches for a zero of a function f(n, t, y, iroot) ! between the given values B and C until the width of the ! interval (B, C) has collapsed to within a tolerance specified ! by the stopping criterion, abs ( b - c) <= 2 * ( rw * abs ( b ) + ae ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Lawrence Shampine, Herman Watts, ! ZEROIN, a Root-Solving Routine, ! Technical Report SC-TM-70-631, ! Sandia National Laboratories, September 1970. ! ! TJ Dekker, ! Finding a Zero by Means of Successive Linear Interpolation, ! "Constructive Aspects of the Fundamental Theorem of Algebra", ! Edited by B Dejon and P Henrici, 1969. ! ! Parameters: ! ! Input, external F, the name of the routine which evaluates the function. ! It must have the form ! ! function f ( x ) ! real f ! real x ! ! Input/output, real ( kind = rk ) B, C, the ends of the interval (B, C). ! On output, both B and C have been reduced, to give a tighter estimate ! of the root. B will not necessarily be less than C. On output, B ! is the better estimate of the root, in the sense that the function ! value is smaller there. ! ! Input, real ( kind = rk ) RE, the relative error used for RW in the ! stopping criterion. If the requested RE is less than machine precision, ! then RW is set to approximately machine precision. ! ! Input, real ( kind = rk ) AE, the absolute error used in the stopping ! criterion. If the given interval (B, C) contains the origin, then a ! nonzero value should be chosen for AE. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a real ( kind = rk ) acbs real ( kind = rk ) acmb real ( kind = rk ) ae real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) cmb real ( kind = rk ) er real ( kind = rk ), external :: f real ( kind = rk ) fa real ( kind = rk ) fb real ( kind = rk ) fc real ( kind = rk ) h integer ic integer iroot integer kount integer nq real ( kind = rk ) p real ( kind = rk ) q real ( kind = rk ) re real ( kind = rk ) rw real ( kind = rk ) t real ( kind = rk ) tol real ( kind = rk ) uround real ( kind = rk ) y(*) real ( kind = rk ) yh(n,*) er = 4.0D+00 * uround rw = max ( re, er ) ic = 0 acbs = abs ( b - c ) a = c fa = fc kount = 0 ! ! Perform interchange ! 10 continue if ( abs ( fc ) < abs ( fb ) ) then a = b fa = fb b = c fb = fc c = a fc = fa end if cmb = 0.5D+00 * ( c - b ) acmb = abs ( cmb ) tol = rw * abs ( b ) + ae ! ! Test stopping criterion ! if ( acmb <= tol ) then return end if if ( 50 < kount ) then return end if ! ! Calculate new iterate implicitly as b + p/q, where we arrange 0 <= P. ! The implicit form is used to prevent overflow. ! p = ( b - a ) * fb q = fa - fb if ( p < 0.0D+00 ) then p = -p q = -q end if ! ! Update A and check for satisfactory reduction ! in the size of our bounding interval. ! a = b fa = fb ic = ic + 1 if ( 4 <= ic ) then if ( acbs <= 8.0D+00 * acmb ) then ! ! bisect ! b = 0.5D+00 * ( c + b ) go to 20 end if ic = 0 end if acbs = acmb ! ! Test for too small a change. ! if ( p <= abs ( q ) * tol ) then ! ! Increment by tolerance. ! b = b + sign ( tol, cmb ) ! ! Root ought to be between b and (c + b)/2. ! else if ( p < cmb * q ) then ! ! Interpolate ! b = b + p / q else ! ! Bisect ! b = 0.5D+00 * ( c + b ) end if ! ! Have completed computation for new iterate B. ! 20 continue call ddntp ( h, 0, n, nq, t, b, yh, y ) fb = f ( n, b, y, iroot ) if ( n == 0 ) then return end if if ( fb == 0.0D+00 ) then return end if kount = kount + 1 ! ! Decide whether next step is interpolation or extrapolation ! if ( sign ( 1.0D+00, fb ) == sign ( 1.0D+00, fc ) ) then c = a fc = fa end if go to 10 end subroutine dfault ( n, x, typsiz, fscale, method, iexp, msg, ndigit, itnlim, & iagflg, iahflg, ipr, dlt, gradtl, stepmx, steptl ) !*****************************************************************************80 ! !! DFAULT sets default values for the optimization algorithm. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) X(N), an initial guess for the solution, ! used to compute a maximum stepsize. ! ! Output, real ( kind = rk ) TYPSIZ(N), a typical size for each component ! of X. ! ! Output, real ( kind = rk ) FSCALE, an estimate of the scale of the ! minimization function. ! ! Output, integer METHOD, specifies the algorithm to use to ! solve the minimization problem. ! ! Output, integer IEXP, set to 0 if minimization function ! not expensive to evaluate. ! ! Output, integer MSG, a message to inhibit certain automatic ! checks and output. ! ! Output, integer NDIGIT, the number of good digits in ! minimization function. ! ! Output, integer ITNLIM, the maximum number of allowable ! iterations. ! ! Output, integer IAGFLG, set to 0, meaning the analytic ! gradient is not supplied. ! ! Output, integer IAHFLG, set to 0, meaning the analytic ! hessian is not supplied. ! ! Output, integer IPR, the device to which to send output. ! ! Output, real ( kind = rk ) DLT, the trust region radius. ! ! Output, real ( kind = rk ) GRADTL, a tolerance at which the gradient is ! considered close enough to zero to terminate algorithm. ! ! Output, real ( kind = rk ) STEPMX, the maximum stepsize, set to 0.0 to trip ! the default maximum in OPTCHK. ! ! Output, real ( kind = rk ) STEPTL, a tolerance at which successive ! iterates are considered close enough to terminate the algorithm. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) dlt real ( kind = rk ) epsm real ( kind = rk ) fscale real ( kind = rk ) gradtl integer iagflg integer iahflg integer iexp integer ipr integer itnlim integer method integer msg integer ndigit real ( kind = rk ) stepmx real ( kind = rk ) steptl real ( kind = rk ) typsiz(n) real ( kind = rk ) x(n) call r8_fake_use ( x(1) ) ! ! Typical size of X and minimization function. ! typsiz(1:n) = 1.0D+00 fscale = 1.0D+00 ! ! Tolerances. ! dlt = -1.0D+00 epsm = epsilon ( epsm ) gradtl = epsm**( 1.0D+00 / 3.0D+00 ) stepmx = 0.0D+00 steptl = sqrt ( epsm ) ! ! Flags. ! method = 1 iexp = 1 msg = 9 ndigit = -1 itnlim = 150 iagflg = 0 iahflg = 0 ipr = 6 return end subroutine dfftb ( n, r, wsave ) !*****************************************************************************80 ! !! DFFTB computes a real periodic sequence from its Fourier coefficients. ! ! Discussion: ! ! This process is sometimes called Fourier synthesis. ! ! The transform is unnormalized. A call to DFFTF followed by a call to ! DFFTB will multiply the input sequence by N. ! ! If N is even, the transform is defined by: ! ! R_out(I) = R_in(1) + (-1)**(I-1) * R_in(N) + sum ( 2 <= K <= N/2 ) ! ! + 2 * R_in(2*K-2) * cos ( ( K - 1 ) * ( I - 1 ) * 2 * PI / N ) ! ! - 2 * R_in(2*K-1) * sin ( ( K - 1 ) * ( I - 1 ) * 2 * PI / N ) ! ! If N is odd, the transform is defined by: ! ! R_out(I) = R_in(1) + sum ( 2 <= K <= (N+1)/2 ) ! ! + 2 * R_in(2*K-2) * cos ( ( K - 1 ) * ( I - 1 ) * 2 * PI / N ) ! ! - 2 * R_in(2*K-1) * sin ( ( K - 1 ) * ( I - 1 ) * 2 * PI / N ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software, ! W. Cowell, editor, ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! The method is more efficient when N is the product of small primes. ! ! Input/output, real ( kind = rk ) R(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) WSAVE(2*N+15), a work array. The WSAVE array ! must be initialized by calling DFFTI. A different WSAVE array must be used ! for each different value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) r(n) real ( kind = rk ) wsave(2*n+15) if ( n <= 1 ) then return end if call dfftb1 ( n, r, wsave(1), wsave(n+1), wsave(2*n+1) ) return end subroutine dfftb1 ( n, c, ch, wa, ifac ) !*****************************************************************************80 ! !! DFFTB1 is a lower level routine used by DFFTB. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Input/output, real ( kind = rk ) C(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) CH(N). ! ! Input, real ( kind = rk ) WA(N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) c(n) real ( kind = rk ) ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer l1 integer l2 integer na integer nf real ( kind = rk ) wa(n) nf = ifac(2) na = 0 l1 = 1 iw = 1 do k1 = 1, nf ip = ifac(k1+2) l2 = ip * l1 ido = n / l2 idl1 = ido * l1 if ( ip == 4 ) then ix2 = iw + ido ix3 = ix2 + ido if ( na == 0 ) then call radb4 ( ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) ) else call radb4 ( ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3) ) end if na = 1 - na else if ( ip == 2 ) then if ( na == 0 ) then call radb2 ( ido, l1, c, ch, wa(iw) ) else call radb2 ( ido, l1, ch, c, wa(iw) ) end if na = 1 - na else if ( ip == 3 ) then ix2 = iw + ido if ( na == 0 ) then call radb3 ( ido, l1, c, ch, wa(iw), wa(ix2) ) else call radb3 ( ido, l1, ch, c, wa(iw), wa(ix2) ) end if na = 1 - na else if ( ip == 5 ) then ix2 = iw + ido ix3 = ix2 + ido ix4 = ix3 + ido if ( na == 0 ) then call radb5 ( ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) else call radb5 ( ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) end if na = 1 - na else if ( na == 0 ) then call radbg ( ido, ip, l1, idl1, c, c, c, ch, ch, wa(iw) ) else call radbg ( ido, ip, l1, idl1, ch, ch, ch, c, c, wa(iw) ) end if if ( ido == 1 ) then na = 1 - na end if end if l1 = l2 iw = iw + ( ip - 1 ) * ido end do if ( na /= 0 ) then c(1:n) = ch(1:n) end if return end subroutine dfftf ( n, r, wsave ) !*****************************************************************************80 ! !! DFFTF computes the Fourier coefficients of a real periodic sequence. ! ! Discussion: ! ! This process is sometimes called Fourier analysis. ! ! The transform is unnormalized. A call to DFFTF followed by a call ! to DFFTB will multiply the input sequence by N. ! ! The transform is defined by: ! ! R_out(1) = sum ( 1 <= I <= N ) R_in(I) ! ! Letting L = (N+1)/2, then for K = 2,...,L ! ! R_out(2*K-2) = sum ( 1 <= I <= N ) ! ! R_in(I) * cos ( ( K - 1 ) * ( I - 1 ) * 2 * PI / N ) ! ! R_out(2*K-1) = sum ( 1 <= I <= N ) ! ! -R_in(I) * sin ( ( K - 1 ) * ( I - 1 ) * 2 * PI / N ) ! ! And, if N is even, then: ! ! R_out(N) = sum ( 1 <= I <= N ) (-1)**(I-1) * R_in(I) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! The method is more efficient when N is the product of small primes. ! ! Input/output, real ( kind = rk ) R(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) WSAVE(2*N+15), a work array. The WSAVE array ! must be initialized by calling DFFTI. A different WSAVE array must be ! used for each different value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) r(n) real ( kind = rk ) wsave(2*n+15) if ( n <= 1 ) then return end if call dfftf1 ( n, r, wsave(1), wsave(n+1), wsave(2*n+1) ) return end subroutine dfftf1 ( n, c, ch, wa, ifac ) !*****************************************************************************80 ! !! DFFTF1 is a lower level routine used by DFFTF and SINT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Input/output, real ( kind = rk ) C(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) CH(N). ! ! Input, real ( kind = rk ) WA(N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) c(n) real ( kind = rk ) ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer kh integer l1 integer l2 integer na integer nf real ( kind = rk ) wa(n) nf = ifac(2) na = 1 l2 = n iw = n do k1 = 1, nf kh = nf - k1 ip = ifac(kh+3) l1 = l2 / ip ido = n / l2 idl1 = ido * l1 iw = iw - ( ip - 1 ) * ido na = 1 - na if ( ip == 4 ) then ix2 = iw + ido ix3 = ix2 + ido if ( na == 0 ) then call radf4 ( ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) ) else call radf4 ( ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3) ) end if else if ( ip == 2 ) then if ( na == 0 ) then call radf2 ( ido, l1, c, ch, wa(iw) ) else call radf2 ( ido, l1, ch, c, wa(iw) ) end if else if ( ip == 3 ) then ix2 = iw + ido if ( na == 0 ) then call radf3 ( ido, l1, c, ch, wa(iw), wa(ix2) ) else call radf3 ( ido, l1, ch, c, wa(iw), wa(ix2) ) end if else if ( ip == 5 ) then ix2 = iw + ido ix3 = ix2 + ido ix4 = ix3 + ido if ( na == 0 ) then call radf5 ( ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) else call radf5 ( ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) end if else if ( ido == 1 ) then na = 1 - na end if if ( na == 0 ) then call radfg ( ido, ip, l1, idl1, c, c, c, ch, ch, wa(iw) ) na = 1 else call radfg ( ido, ip, l1, idl1, ch, ch, ch, c, c, wa(iw) ) na = 0 end if end if l2 = l1 end do if ( na /= 1 ) then c(1:n) = ch(1:n) end if return end subroutine dffti ( n, wsave ) !*****************************************************************************80 ! !! DFFTI initializes WSAVE, used in DFFTF and DFFTB. ! ! Discussion: ! ! The prime factorization of N together with a tabulation of the ! trigonometric functions are computed and stored in WSAVE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. ! ! Output, real ( kind = rk ) WSAVE(2*N+15), contains data, dependent on the ! value of N, which is necessary for the DFFTF and DFFTB routines. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) wsave(2*n+15) if ( n <= 1 ) then return end if call dffti1 ( n, wsave(n+1), wsave(2*n+1) ) return end subroutine dffti1 ( n, wa, ifac ) !*****************************************************************************80 ! !! DFFTI1 is a lower level routine used by DFFTI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. ! ! Input, real ( kind = rk ) WA(N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) arg real ( kind = rk ) argh real ( kind = rk ) argld real ( kind = rk ) fi integer i integer ido integer ifac(15) integer ii integer ip integer is integer j integer k1 integer l1 integer l2 integer ld integer nf real ( kind = rk ) :: pi = 3.141592653589793D+00 real ( kind = rk ) wa(n) call i8_factor ( n, ifac ) nf = ifac(2) argh = 2.0D+00 * pi / real ( n, kind = rk ) is = 0 l1 = 1 do k1 = 1, nf-1 ip = ifac(k1+2) ld = 0 l2 = l1 * ip ido = n / l2 do j = 1, ip-1 ld = ld + l1 i = is argld = real ( ld, kind = rk ) * argh fi = 0.0D+00 do ii = 3, ido, 2 i = i + 2 fi = fi + 1.0D+00 arg = fi * argld wa(i-1) = cos ( arg ) wa(i) = sin ( arg ) end do is = is + ido end do l1 = l2 end do return end subroutine dgbfa ( abd, lda, n, ml, mu, ipvt, info ) !*****************************************************************************80 ! !! DGBFA factors a real band matrix by elimination. ! ! Discussion: ! ! DGBFA is usually called by DGBCO, but it can be called ! directly with a saving in time if RCOND is not needed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Parameters: ! ! Input/output, real ( kind = rk ) ABD(LDA,N). On input, the matrix in band ! storage. The columns of the matrix are stored in the columns of ABD ! and the diagonals of the matrix are stored in rows ML+1 through ! 2*ML+MU+1 of ABD. On output, an upper triangular matrix in band storage ! and the multipliers which were used to obtain it. The factorization ! can be written A = L*U where L is a product of permutation and unit lower ! triangular matrices and U is upper triangular. ! ! Input, integer LDA, the leading dimension of the array ABD. ! 2*ML + MU + 1 <= LDA. ! ! Input, integer N, the order of the matrix. ! ! Input, integer ML, MU, the number of diagonals below and ! above the main diagonal. 0 <= ML < N, 0 <= MU < N. ! ! Output, integer IPVT(N), the pivot indices. ! ! Output, integer INFO, error flag. ! 0, normal value. ! K, if U(K,K) == 0.0D+00. This is not an error condition for this ! subroutine, but it does indicate that DGBSL will divide by zero if ! called. Use RCOND in DGBCO for a reliable indication of singularity. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n real ( kind = rk ) abd(lda,n) integer i integer i0 integer info integer ipvt(n) integer idamax integer j integer j0 integer j1 integer ju integer jz integer k integer l integer lm integer m integer ml integer mm integer mu real ( kind = rk ) t m = ml + mu + 1 info = 0 ! ! Zero initial fill-in columns. ! j0 = mu + 2 j1 = min ( n, m ) - 1 do jz = j0, j1 i0 = m + 1 - jz do i = i0, ml abd(i,jz) = 0.0D+00 end do end do jz = j1 ju = 0 ! ! Gaussian elimination with partial pivoting. ! do k = 1, n-1 ! ! Zero next fill-in column. ! jz = jz + 1 if ( jz <= n ) then abd(1:ml,jz) = 0.0D+00 end if ! ! Find L = pivot index. ! lm = min ( ml, n-k ) l = idamax ( lm+1, abd(m,k), 1 ) + m - 1 ipvt(k) = l + k - m ! ! Zero pivot implies this column already triangularized. ! if ( abd(l,k) == 0.0D+00 ) then info = k ! ! Interchange if necessary. ! else if ( l /= m ) then t = abd(l,k) abd(l,k) = abd(m,k) abd(m,k) = t end if ! ! Compute multipliers. ! t = -1.0D+00 / abd(m,k) call dscal ( lm, t, abd(m+1,k), 1 ) ! ! Row elimination with column indexing. ! ju = min ( max ( ju, mu+ipvt(k) ), n ) mm = m do j = k+1, ju l = l - 1 mm = mm - 1 t = abd(l,j) if ( l /= mm ) then abd(l,j) = abd(mm,j) abd(mm,j) = t end if call daxpy ( lm, t, abd(m+1,k), 1, abd(mm+1,j), 1 ) end do end if end do ipvt(n) = n if ( abd(m,n) == 0.0D+00 ) then info = n end if return end subroutine dgbsl ( abd, lda, n, ml, mu, ipvt, b, job ) !*****************************************************************************80 ! !! DGBSL solves a real banded system factored by DGBCO or DGBFA. ! ! Discussion: ! ! DGBSL can solve either A * X = B or A' * X = B. ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA. It will not occur if the subroutines are ! called correctly and if DGBCO has set 0.0 < RCOND ! or DGBFA has set INFO == 0. ! ! To compute inverse(A) * C where C is a matrix with P columns: ! ! call dgbco ( abd, lda, n, ml, mu, ipvt, rcond, z ) ! ! if ( rcond is too small ) then ! exit ! end if ! ! do j = 1, p ! call dgbsl ( abd, lda, n, ml, mu, ipvt, c(1,j), 0 ) ! end do ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Parameters: ! ! Input, real ( kind = rk ) ABD(LDA,N), the output from DGBCO or DGBFA. ! ! Input, integer LDA, the leading dimension of the array ABD. ! ! Input, integer N, the order of the matrix. ! ! Input, integer ML, MU, the number of diagonals below and ! above the main diagonal. 0 <= ML < N, 0 <= MU < N. ! ! Input, integer IPVT(N), the pivot vector from DGBCO or DGBFA. ! ! Input/output, real ( kind = rk ) B(N). On input, the right hand side. ! On output, the solution. ! ! Input, integer JOB, job choice. ! 0, solve A*X=B. ! nonzero, solve A'*X=B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n real ( kind = rk ) abd(lda,n) real ( kind = rk ) b(n) integer ipvt(n) integer job integer k integer l integer la integer lb integer lm integer m integer ml integer mu real ( kind = rk ) ddot real ( kind = rk ) t m = mu + ml + 1 ! ! JOB = 0, Solve a * x = b. ! ! First solve l*y = b. ! if ( job == 0 ) then if ( 0 < ml ) then do k = 1, n-1 lm = min ( ml, n-k ) l = ipvt(k) t = b(l) if ( l /= k ) then b(l) = b(k) b(k) = t end if call daxpy ( lm, t, abd(m+1,k), 1, b(k+1), 1 ) end do end if ! ! Now solve U * x = y. ! do k = n, 1, -1 b(k) = b(k) / abd(m,k) lm = min ( k, m ) - 1 la = m - lm lb = k - lm t = -b(k) call daxpy ( lm, t, abd(la,k), 1, b(lb), 1 ) end do ! ! JOB nonzero, solve A' * X = B. ! ! First solve U'*Y = B. ! else do k = 1, n lm = min ( k, m ) - 1 la = m - lm lb = k - lm t = ddot ( lm, abd(la,k), 1, b(lb), 1 ) b(k) = ( b(k) - t ) / abd(m,k) end do ! ! Now solve L'*X = Y. ! if ( 0 < ml ) then do k = n-1, 1, -1 lm = min ( ml, n-k ) b(k) = b(k) + ddot ( lm, abd(m+1,k), 1, b(k+1), 1 ) l = ipvt(k) if ( l /= k ) then t = b(l) b(l) = b(k) b(k) = t end if end do end if end if return end subroutine dgeco ( a, lda, n, ipvt, rcond, z ) !*****************************************************************************80 ! !! DGECO factors a real matrix and estimates its condition number. ! ! Discussion: ! ! If RCOND is not needed, DGEFA is slightly faster. ! ! To solve A * X = B, follow DGECO by DGESL. ! ! To compute inverse ( A ) * C, follow DGECO by DGESL. ! ! To compute determinant ( A ), follow DGECO by DGEDI. ! ! To compute inverse ( A ), follow DGECO by DGEDI. ! ! For the system A * X = B, relative perturbations in A and B ! of size EPSILON may cause relative perturbations in X of size ! EPSILON/RCOND. ! ! If RCOND is so small that the logical expression ! 1.0D+00 + RCOND == 1.0D+00 ! is true, then A may be singular to working precision. In particular, ! RCOND is zero if exact singularity is detected or the estimate ! underflows. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Author: ! ! Cleve Moler, ! University of New Mexico / Argonne National Lab. ! ! Parameters: ! ! Input/output, real ( kind = rk ) A(LDA,N). On input, a matrix to be ! factored. On output, the LU factorization of the matrix. ! ! Input, integer LDA, the leading dimension of the array A. ! ! Input, integer N, the order of the matrix A. ! ! Output, integer IPVT(N), the pivot indices. ! ! Output, real ( kind = rk ) RCOND, an estimate of the reciprocal condition ! number of A. ! ! Output, real ( kind = rk ) Z(N), a work vector whose contents are usually ! unimportant. If A is close to a singular matrix, then Z is an ! approximate null vector in the sense that ! norm ( A * Z ) = RCOND * norm ( A ) * norm ( Z ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n real ( kind = rk ) a(lda,n) real ( kind = rk ) anorm real ( kind = rk ) ek integer info integer ipvt(n) integer j integer k integer l real ( kind = rk ) rcond real ( kind = rk ) s real ( kind = rk ) sm real ( kind = rk ) t real ( kind = rk ) wk real ( kind = rk ) wkm real ( kind = rk ) ynorm real ( kind = rk ) z(n) ! ! Compute the L1 norm of A. ! anorm = 0.0D+00 do j = 1, n anorm = max ( anorm, sum ( abs ( a(1:n,j) ) ) ) end do ! ! Compute the LU factorization. ! call dgefa ( a, lda, n, ipvt, info ) ! ! RCOND = 1 / ( norm(A) * (estimate of norm(inverse(A))) ) ! ! estimate of norm(inverse(A)) = norm(Z) / norm(Y) ! ! where ! A * Z = Y ! and ! A' * Y = E ! ! The components of E are chosen to cause maximum local growth in the ! elements of W, where U'*W = E. The vectors are frequently rescaled ! to avoid overflow. ! ! Solve U' * W = E. ! ek = 1.0D+00 z(1:n) = 0.0D+00 do k = 1, n if ( z(k) /= 0.0D+00 ) then ek = sign ( ek, -z(k) ) end if if ( abs ( a(k,k) ) < abs ( ek - z(k) ) ) then s = abs ( a(k,k) ) / abs ( ek - z(k) ) z(1:n) = s * z(1:n) ek = s * ek end if wk = ek - z(k) wkm = -ek - z(k) s = abs ( wk ) sm = abs ( wkm ) if ( a(k,k) /= 0.0D+00 ) then wk = wk / a(k,k) wkm = wkm / a(k,k) else wk = 1.0D+00 wkm = 1.0D+00 end if if ( k+1 <= n ) then do j = k+1, n sm = sm + abs ( z(j) + wkm * a(k,j) ) z(j) = z(j) + wk * a(k,j) s = s + abs ( z(j) ) end do if ( s < sm ) then t = wkm - wk wk = wkm z(k+1:n) = z(k+1:n) + t * a(k,k+1:n) end if end if z(k) = wk end do z(1:n) = z(1:n) / sum ( abs ( z(1:n) ) ) ! ! Solve L' * Y = W ! do k = n, 1, -1 z(k) = z(k) + dot_product ( a(k+1:n,k), z(k+1:n) ) if ( 1.0D+00 < abs ( z(k) ) ) then z(1:n) = z(1:n) / abs ( z(k) ) end if l = ipvt(k) t = z(l) z(l) = z(k) z(k) = t end do z(1:n) = z(1:n) / sum ( abs ( z(1:n) ) ) ynorm = 1.0D+00 ! ! Solve L * V = Y. ! do k = 1, n l = ipvt(k) t = z(l) z(l) = z(k) z(k) = t z(k+1:n) = z(k+1:n) + t * a(k+1:n,k) if ( 1.0D+00 < abs ( z(k) ) ) then ynorm = ynorm / abs ( z(k) ) z(1:n) = z(1:n) / abs ( z(k) ) end if end do s = sum ( abs ( z(1:n) ) ) z(1:n) = z(1:n) / s ynorm = ynorm / s ! ! Solve U * Z = V. ! do k = n, 1, -1 if ( abs ( a(k,k) ) < abs ( z(k) ) ) then s = abs ( a(k,k) ) / abs ( z(k) ) z(1:n) = s * z(1:n) ynorm = s * ynorm end if if ( a(k,k) /= 0.0D+00 ) then z(k) = z(k) / a(k,k) else z(k) = 1.0D+00 end if z(1:k-1) = z(1:k-1) - z(k) * a(1:k-1,k) end do ! ! Normalize Z in the L1 norm. ! s = 1.0D+00 / sum ( abs ( z(1:n) ) ) z(1:n) = s * z(1:n) ynorm = s * ynorm if ( anorm /= 0.0D+00 ) then rcond = ynorm / anorm else rcond = 0.0D+00 end if return end subroutine dgefa ( a, lda, n, ipvt, info ) !*****************************************************************************80 ! !! DGEFA factors a real matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 March 2001 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Parameters: ! ! Input/output, real ( kind = rk ) A(LDA,N). ! On intput, the matrix to be factored. ! On output, an upper triangular matrix and the multipliers used to obtain ! it. The factorization can be written A=L*U, where L is a product of ! permutation and unit lower triangular matrices, and U is upper triangular. ! ! Input, integer LDA, the leading dimension of A. ! ! Input, integer N, the order of the matrix A. ! ! Output, integer IPVT(N), the pivot indices. ! ! Output, integer INFO, singularity indicator. ! 0, normal value. ! K, if U(K,K) == 0. This is not an error condition for this subroutine, ! but it does indicate that DGESL or DGEDI will divide by zero if called. ! Use RCOND in DGECO for a reliable indication of singularity. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n real ( kind = rk ) a(lda,n) integer info integer ipvt(n) integer idamax integer j integer k integer l real ( kind = rk ) t ! ! Gaussian elimination with partial pivoting. ! info = 0 do k = 1, n - 1 ! ! Find L = pivot index. ! l = idamax ( n-k+1, a(k,k), 1 ) + k - 1 ipvt(k) = l ! ! Zero pivot implies this column already triangularized. ! if ( a(l,k) == 0.0D+00 ) then info = k cycle end if ! ! Interchange if necessary. ! if ( l /= k ) then t = a(l,k) a(l,k) = a(k,k) a(k,k) = t end if ! ! Compute multipliers. ! t = -1.0D+00 / a(k,k) call dscal ( n-k, t, a(k+1,k), 1 ) ! ! Row elimination with column indexing. ! do j = k+1, n t = a(l,j) if ( l /= k ) then a(l,j) = a(k,j) a(k,j) = t end if call daxpy ( n-k, t, a(k+1,k), 1, a(k+1,j), 1 ) end do end do ipvt(n) = n if ( a(n,n) == 0.0D+00 ) then info = n end if return end subroutine dgefs ( a, lda, n, v, itask, ind, work, iwork, rcond ) !*****************************************************************************80 ! !! DGEFS solves a general N by N system of single precision linear equations. ! ! Discussion: ! ! DGEFS uses the LINPACK subroutines DGECO and DGESL. That is, if A is ! an N by N real matrix and if X and B are real N vectors, then DGEFS ! solves the equation ! ! A * X = B. ! ! The matrix A is first factored into upper and lower triangular ! matrices U and L using partial pivoting. These factors and the ! pivoting information are used to find the solution vector X. ! An approximate condition number is calculated to provide a rough ! estimate of the number of digits of accuracy in the computed solution. ! ! If the equation A*X=B is to be solved for more than one vector ! B, the factoring of A does not need to be performed again and ! the option to only solve (ITASK == 2) will be faster for ! the succeeding solutions. In this case, the contents of A, ! LDA, N and IWORK must not have been altered by the user following ! factorization (ITASK=1). IND will not be changed by DGEFS ! in this case. Other settings of ITASK are used to solve linear ! systems involving the transpose of A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input/output, real ( kind = rk ) A(LDA,N). ! On input, the coefficient matrix. ! On output, an upper triangular matrix U and the multipliers necessary to ! construct a matrix L so that A=L*U. ! ! Input, integer LDA, the leading dimension of the array A. ! LDA must be at least N. ! ! Input, integer N, the order of the matrix A. The first N ! elements of the array A are the elements of the first column of the ! matrix A. N must be greater than or equal to 1. (Terminal error ! message IND=-2) ! ! Input/output, real ( kind = rk ) V(N). ! On entry, the right hand side B of a system of simultaneous linear ! equations A*X=B. ! On output, V contains the solution vector, X. ! ! Input, integer ITASK, indicates the task to carry out. ! 1, the matrix A is factored and the linear equation is solved. ! 2, the equation is solved using the existing factored matrix A and IWORK. ! 3, the matrix is factored and A'*X=b is solved ! 4, the transposed equation is solved using the existing factored matrix ! A and IWORK. ! ! Output, integer IND, accuracy estimate and error flag. ! gt. 0 ind is a rough estimate of the number of digits ! of accuracy in the solution, x. ! lt. 0 see error message corresponding to ind below. ! ind=-1 fatal n is greater than lda. ! ind=-2 fatal n is less than 1. ! ind=-3 fatal itask is less than 1 or greater than 4. ! ind=-4 fatal the matrix a is computationally singular. ! a solution has not been computed. ! ind=-10 warning the solution has no apparent significance. ! the solution may be inaccurate or the matrix ! a may be poorly scaled. ! ! Workspace, real ( kind = rk ) WORK(N). ! ! Workspace, integer IWORK(N). ! ! Output, real ( kind = rk ) RCOND, estimate of 1 / condition_number(A). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n real ( kind = rk ) a(lda,n) integer ind integer itask integer iwork(*) integer job real ( kind = rk ) rcond real ( kind = rk ) v(*) real ( kind = rk ) work(*) if ( lda < n ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DGEFS - Fatal error!' write ( *, '(a)' ) ' LDA < N.' return end if if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DGEFS - Fatal error!' write ( *, '(a)' ) ' N <= 0.' return end if if ( itask < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DGEFS - Fatal error!' write ( *, '(a)' ) ' ITASK < 1.' return end if if ( 4 < itask ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DGEFS - Fatal error!' write ( *, '(a)' ) ' 4 < ITASK.' return end if ! ! Factor the matrix. ! if ( itask == 1 .or. itask == 3 ) then call dgeco ( a, lda, n, iwork, rcond, work ) ! ! Check for computational singularity. ! if ( rcond == 0.0D+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DGEFS - Error!' write ( *, '(a)' ) ' The matrix is compuationally singular.' return end if ! ! Estimate the number of significant digits. ! ind = - int ( log10 ( epsilon ( rcond ) / rcond ) ) if ( ind <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DGEFS - Warning!' write ( *, '(a)' ) ' Solution may have no significant digits.' end if end if if ( itask <= 2 ) then job = 0 else job = 1 end if call dgesl ( a, lda, n, iwork, v, job ) return end subroutine dgesl ( a, lda, n, ipvt, b, job ) !*****************************************************************************80 ! !! DGESL solves a real general linear system A * X = B. ! ! Discussion: ! ! DGESL can solve either of the systems A * X = B or A' * X = B. ! ! The system matrix must have been factored by DGECO or DGEFA. ! ! A division by zero will occur if the input factor contains a ! zero on the diagonal. Technically this indicates singularity ! but it is often caused by improper arguments or improper ! setting of LDA. It will not occur if the subroutines are ! called correctly and if DGECO has set 0.0D+00 < RCOND ! or DGEFA has set INFO == 0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 07 March 2001 ! ! Parameters: ! ! Input, real ( kind = rk ) A(LDA,N), the output from DGECO or DGEFA. ! ! Input, integer LDA, the leading dimension of A. ! ! Input, integer N, the order of the matrix A. ! ! Input, integer IPVT(N), the pivot vector from DGECO or DGEFA. ! ! Input/output, real ( kind = rk ) B(N). ! On input, the right hand side vector. ! On output, the solution vector. ! ! Input, integer JOB. ! 0, solve A * X = B; ! nonzero, solve A' * X = B. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n real ( kind = rk ) a(lda,n) real ( kind = rk ) b(n) integer ipvt(n) integer job integer k integer l real ( kind = rk ) ddot real ( kind = rk ) t ! ! Solve A * X = B. ! if ( job == 0 ) then do k = 1, n-1 l = ipvt(k) t = b(l) if ( l /= k ) then b(l) = b(k) b(k) = t end if call daxpy ( n-k, t, a(k+1,k), 1, b(k+1), 1 ) end do do k = n, 1, -1 b(k) = b(k) / a(k,k) t = -b(k) call daxpy ( k-1, t, a(1,k), 1, b(1), 1 ) end do else ! ! Solve A' * X = B. ! do k = 1, n t = ddot ( k-1, a(1,k), 1, b(1), 1 ) b(k) = ( b(k) - t ) / a(k,k) end do do k = n-1, 1, -1 b(k) = b(k) + ddot ( n-k, a(k+1,k), 1, b(k+1), 1 ) l = ipvt(k) if ( l /= k ) then t = b(l) b(l) = b(k) b(k) = t end if end do end if return end function dnor ( ) !*****************************************************************************80 ! !! DNOR generates normal random numbers. ! ! Discussion: ! ! DNOR generates normal random numbers with zero mean and ! unit standard deviation, often denoted n(0,1). ! ! Before the first call to DNOR, you should call DSTART, passing it ! a nonzero value of ISEED. This will initialize the routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 April 2007 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! George Marsaglia, Wai Wan Tsang, ! A fast, easily implemented method for sampling from decreasing or ! symmetric unimodal density functions, ! SIAM Journal of Scientific and Statistical Computing, ! Volume 5, 1983, pages 349-359. ! ! Parameters: ! ! Output, real ( kind = rk ) DNOR, a normal random number. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), parameter :: aa = 12.37586D+00 real ( kind = rk ), parameter :: b = 0.4878992D+00 real ( kind = rk ), parameter :: c = 12.67706D+00 real ( kind = rk ), save :: c1 = 0.9689279D+00 real ( kind = rk ), save :: c2 = 1.301198D+00 real ( kind = rk ) dnor real ( kind = rk ) dstart integer ia integer ib integer ic integer id integer, save :: ii = 17 integer iii integer iseed integer j integer, save :: jj = 5 integer jjj real ( kind = rk ), save :: pc = 0.01958303D+00 real ( kind = rk ) s real ( kind = rk ) t real ( kind = rk ), save, dimension ( 17 ) :: u = (/ & 0.8668672834288D+00, 0.3697986366357D+00, 0.8008968294805D+00, & 0.4173889774680D+00, 0.8254561579836D+00, 0.9640965269077D+00, & 0.4508667414265D+00, 0.6451309529668D+00, 0.1645456024730D+00, & 0.2787901807898D+00, 0.06761531340295D+00, 0.9663226330820D+00, & 0.01963343943798D+00, 0.02947398211399D+00, 0.1636231515294D+00, & 0.3976343250467D+00, 0.2631008574685D+00 /) real ( kind = rk ) un real ( kind = rk ), dimension ( 65 ) :: v = (/ & 0.3409450D+00, 0.4573146D+00, 0.5397793D+00, 0.6062427D+00, 0.6631691D+00, & 0.7136975D+00, 0.7596125D+00, 0.8020356D+00, 0.8417227D+00, 0.8792102D+00, & 0.9148948D+00, 0.9490791D+00, 0.9820005D+00, 1.0138492D+00, 1.0447810D+00, & 1.0749254D+00, 1.1043917D+00, 1.1332738D+00, 1.1616530D+00, 1.1896010D+00, & 1.2171815D+00, 1.2444516D+00, 1.2714635D+00, 1.2982650D+00, 1.3249008D+00, & 1.3514125D+00, 1.3778399D+00, 1.4042211D+00, 1.4305929D+00, 1.4569915D+00, & 1.4834526D+00, 1.5100121D+00, 1.5367061D+00, 1.5635712D+00, 1.5906454D+00, & 1.6179680D+00, 1.6455802D+00, 1.6735255D+00, 1.7018503D+00, 1.7306045D+00, & 1.7598422D+00, 1.7896223D+00, 1.8200099D+00, 1.8510770D+00, 1.8829044D+00, & 1.9155830D+00, 1.9492166D+00, 1.9839239D+00, 2.0198430D+00, 2.0571356D+00, & 2.0959930D+00, 2.1366450D+00, 2.1793713D+00, 2.2245175D+00, 2.2725185D+00, & 2.3239338D+00, 2.3795007D+00, 2.4402218D+00, 2.5075117D+00, 2.5834658D+00, & 2.6713916D+00, 2.7769943D+00, 2.7769943D+00, 2.7769943D+00, 2.7769943D+00 /) real ( kind = rk ) vni real ( kind = rk ) x real ( kind = rk ), save :: xn = 2.776994D+00 real ( kind = rk ) y ! ! fast part... ! ! Basic generator is Fibonacci. ! un = u(ii) - u(jj) if ( un < 0.0D+00 ) then un = un + 1.0D+00 end if u(ii) = un ! ! u(ii) and un are uniform on [0,1) ! vni is uniform on [-1,1) ! vni = un + un - 1.0D+00 ii = ii-1 if ( ii == 0 ) ii = 17 jj = jj-1 if ( jj == 0 ) jj = 17 ! ! int ( un(ii) * 128 ) in range [0,127], j is in range [1,64] ! j = mod ( int ( u(ii) * 128 ), 64 ) + 1 ! ! Pick sign as VNI is positive or negative. ! dnor = vni * v(j+1) if ( abs ( dnor ) <= v(j) ) then return end if ! ! slow part; aa is a * f(0) ! x = ( abs ( dnor ) - v(j) ) / ( v(j+1) - v(j) ) ! ! Y is uniform on [0,1) ! y = u(ii) - u(jj) if ( y < 0.0D+00 ) then y = y + 1.0D+00 end if u(ii) = y ii = ii-1 if ( ii == 0 ) then ii = 17 end if jj = jj-1 if ( jj == 0 ) then jj = 17 end if s = x + y if ( c2 < s ) then dnor = sign ( b - b * x, dnor ) return end if if ( s <= c1 ) then return end if if ( c - aa * exp ( -0.5D+00 * ( b - b * x )**2 ) < y ) then dnor = sign ( b - b * x, dnor ) return end if if ( exp ( -0.5D+00 * v(j+1)**2 ) + y * pc / v(j+1) <= & exp ( -0.5D+00 * dnor**2 ) ) then return end if ! ! tail part; 0.3601016 is 1.0/xn ! y is uniform on [0,1) ! do y = u(ii) - u(jj) if ( y <= 0.0D+00 ) then y = y + 1.0D+00 end if u(ii) = y ii = ii - 1 if ( ii == 0 ) then ii = 17 end if jj = jj - 1 if ( jj == 0 ) then jj = 17 end if x = 0.3601016D+00 * log ( y ) ! ! Y is uniform on [0,1). ! y = u(ii) - u(jj) if ( y <= 0.0D+00 ) then y = y + 1.0D+00 end if u(ii) = y ii = ii - 1 if ( ii == 0 ) then ii = 17 end if jj = jj - 1 if ( jj == 0 ) then jj = 17 end if if ( x * x < -2.0D+00 * log ( y ) ) then dnor = sign ( xn - x, dnor ) return end if end do ! ! fill ! entry dstart ( iseed ) !*****************************************************************************80 ! !! DSTART is an entry point used to initialize DNOR. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! if ( iseed /= 0 ) then ! ! generate random bit pattern in array based on given seed ! ii = 17 jj = 5 ia = mod ( abs ( iseed ), 32707 ) ib = 1111 ic = 1947 do iii = 1, 17 s = 0.0D+00 t = 0.50 ! ! do for each of the bits of mantissa of word ! loop over 64 bits, enough for all known machines in single precision ! do jjj = 1,64 id = ic - ia if ( id < 0 ) then id = id + 32707 s = s + t end if ia = ib ib = ic ic = id t = 0.5D+00 * t end do u(iii) = s end do end if ! ! return floating echo of iseed. ! dstart = iseed return end function dnrm2 ( n, x, incx ) !*****************************************************************************80 ! !! DNRM2 returns the euclidean norm of a vector. ! ! Discussion: ! ! DNRM2 ( X ) = sqrt ( X' * X ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Sven Hammarling ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real ( kind = rk ) X(*), the vector whose norm is to be computed. ! ! Input, integer INCX, the increment between successive ! entries of X. ! ! Output, real ( kind = rk ) DNRM2, the Euclidean norm of X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) absxi real ( kind = rk ) dnrm2 integer incx integer ix integer n real ( kind = rk ) norm real ( kind = rk ) scale real ( kind = rk ) ssq real ( kind = rk ) x(*) if ( n < 1 .or. incx < 1 ) then norm = 0.0D+00 else if ( n == 1 ) then norm = abs ( x(1) ) else scale = 0.0D+00 ssq = 1.0D+00 do ix = 1, 1 + ( n - 1 )*incx, incx if ( x(ix) /= 0.0D+00 ) then absxi = abs ( x(ix) ) if ( scale < absxi ) then ssq = 1.0D+00 + ssq * ( scale / absxi )**2 scale = absxi else ssq = ssq + ( absxi / scale )**2 end if end if end do norm = scale * sqrt( ssq ) end if dnrm2 = norm return end subroutine dnsq ( fcn, jac, iopt, n, x, fvec, fjac, ldfjac, xtol, maxfev, ml, & mu, epsfcn, diag, mode, factor, nprint, info, nfev, njev, r, lr, qtf, wa1, & wa2, wa3, wa4 ) !*****************************************************************************80 ! !! DNSQ finds a zero of a system of N nonlinear functions in N variables. ! ! Discussion: ! ! DNSQ uses a modification of the Powell hybrid method. This code is the ! combination of the MINPACK codes (argonne) hybrd and hybrdj. ! ! The purpose of DNSQ is to find a zero of a system of N non- ! linear functions in N variables by a modification of the powell ! hybrid method. The user must provide a subroutine which calcu- ! lates the functions. The user has the option of either to ! provide a subroutine which calculates the jacobian or to let the ! code calculate it by a forward-difference approximation. ! This code is the combination of the minpack codes (argonne) ! hybrd and hybrdj. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! MJD Powell, ! A Hybrid Method for Nonlinear Equations, ! Numerical Methods for Nonlinear Algebraic Equations, ! P. Rabinowitz, editor. ! Gordon and Breach, 1970. ! ! Parameters: ! ! Input, external FCN, the name of the user-supplied subroutine which ! calculates the functions. FCN must be declared in an external statement ! in the user calling program, and should be written as follows. ! ! subroutine fcn(n,x,fvec,iflag) ! integer n,iflag ! real ( kind = rk ) x(n),fvec(n) ! ! calculate the functions at x and return this vector in fvec. ! ! return ! end ! ! The value of iflag should not be changed by fcn unless the ! user wants to terminate execution of DNSQ. in this case, set ! iflag to a negative integer. ! ! Input, external JAC, the name of the user-supplied subroutine which ! calculates the jacobian. if iopt=1, then jac must be declared in an ! external statement in the user calling program, and should be ! written as follows. ! ! subroutine jac(n,x,fvec,fjac,ldfjac,iflag) ! integer n,ldfjac,iflag ! real ( kind = rk ) x(n),fvec(n),fjac(ldfjac,n) ! ! calculate the jacobian at x and return this ! matrix in fjac. fvec contains the function ! values at x and should not be altered. ! ! return ! end ! ! the value of iflag should not be changed by jac unless the ! user wants to terminate execution of DNSQ. in this case, set ! iflag to a negative integer. ! if iopt=2, jac can be ignored (treat it as a dummy argument). ! ! Input, integer IOPT, specifies how the jacobian will be ! calculated. ! 1, the user must supply the jacobian through the subroutine jac. ! 2, the code will approximate the jacobian by forward-differencing. ! ! Input, integer N, the number of functions and variables. ! ! Input/output, real X(N). On input, x must contain an initial ! estimate of the solution vector. on output, x contains the ! final estimate of the solution vector. ! ! fvec is an output array of length n which contains the functions ! evaluated at the output x. ! ! fjac is an output n by n array which contains the orthogonal ! matrix q produced by the qr factorization of the final approx- ! imate jacobian. ! ! ldfjac is a positive integer input variable not less than n ! which specifies the leading dimension of the array fjac. ! ! xtol is a non-negative input variable. termination occurs when ! the relative error between two consecutive iterates is at most ! xtol. therefore, xtol measures the relative error desired in ! the approximate solution. section 4 contains more details ! about xtol. ! ! maxfev is a positive integer input variable. termination ! occurs when the number of calls to fcn is at least maxfev by the end ! of an iteration. ! ! ml is a non-negative integer input variable which specifies ! the number of subdiagonals within the band of the jacobian matrix. ! if the jacobian is not banded or iopt=1, set ml to at ! least n - 1. ! ! mu is a non-negative integer input variable which specifies ! the number of superdiagonals within the band of the jacobian ! matrix. if the jacobian is not banded or iopt=1, set mu to at ! least n - 1. ! ! epsfcn is an input variable used in determining a suitable step ! for the forward-difference approximation. this approximation ! assumes that the relative errors in the functions are of the ! order of epsfcn. if epsfcn is less than the machine preci- ! sion, it is assumed that the relative errors in the functions ! are of the order of the machine precision. if iopt=1, then ! epsfcn can be ignored (treat it as a dummy argument). ! ! diag is an array of length n. if mode = 1 (see below), diag is ! internally set. if mode = 2, diag must contain positive ! entries that serve as implicit (multiplicative) scale factors ! for the variables. ! ! mode is an integer input variable. if mode = 1, the ! variables will be scaled internally. if mode = 2, the scaling is ! specified by the input diag. other values of mode are equivalent ! to mode = 1. ! ! factor is a positive input variable used in determining the ini- ! tial step bound. this bound is set to the product of factor ! and the euclidean norm of diag*x if nonzero, or else to factor ! itself. in most cases factor should lie in the interval ! (.1,100.). 100. is a generally recommended value. ! ! nprint is an integer input variable that enables controlled ! printing of iterates if it is positive. in this case, fcn is ! called with iflag = 0 at the beginning of the first iteration ! and every nprint iteration thereafter and immediately prior ! to return, with x and fvec available for printing. appropriate ! print statements must be added to fcn(see example). if nprint ! is not positive, no special calls of fcn with iflag = 0 are ! made. ! ! info is an integer output variable. if the user has ! terminated execution, info is set to the (negative) value of iflag. ! see description of fcn and jac. otherwise, info is set as follows. ! ! info = 0 improper input parameters. ! ! info = 1 relative error between two consecutive iterates is ! at most xtol. ! ! info = 2 number of calls to fcn has reached or exceeded ! maxfev. ! ! info = 3 xtol is too small. no further improvement in the ! approximate solution x is possible. ! ! info = 4 iteration is not making good progress, as measured ! by the improvement from the last five jacobian eval- ! uations. ! ! info = 5 iteration is not making good progress, as measured ! by the improvement from the last ten iterations. ! ! sections 4 and 5 contain more details about info. ! ! nfev is an integer output variable set to the number of ! calls to fcn. ! ! njev is an integer output variable set to the number of ! calls to jac. (if iopt=2, then njev is set to zero.) ! ! r is an output array of length lr which contains the upper ! triangular matrix produced by the qr factorization of the ! final approximate jacobian, stored rowwise. ! ! lr is a positive integer input variable not less than ! (n*(n+1))/2. ! ! qtf is an output array of length n which contains the vector ! (q transpose) * fvec. ! ! wa1, wa2, wa3, and wa4 are work arrays of length n. ! ! ! 4. successful completion. ! ! The accuracy of DNSQ is controlled by the convergence parameter ! xtol. this parameter is used in a test which makes a comparison ! between the approximation x and a solution xsol. DNSQ termi- ! nates when the test is satisfied. if the convergence parameter ! is less than the machine precision (as defined by the function ! epsilon), then DNSQ only attempts to satisfy the test ! defined by the machine precision. further progress is not ! usually possible. ! ! The test assumes that the functions are reasonably well behaved, ! and, if the jacobian is supplied by the user, that the functions ! and the jacobian are coded consistently. if these conditions ! are not satisfied, then DNSQ may incorrectly indicate conver- ! gence. the coding of the jacobian can be checked by the ! subroutine chkder. if the jacobian is coded correctly or iopt=2, ! then the validity of the answer can be checked, for example, by ! rerunning DNSQ with a tighter tolerance. ! ! Convergence test. If dnrm2 ( z) denotes the euclidean norm of a ! vector z and d is the diagonal matrix whose entries are ! defined by the array diag, then this test attempts to guaran- ! tee that ! ! dnrm2 ( d*(x-xsol)) <= xtol * dnrm2(d*xsol). ! ! if this condition is satisfied with xtol = 10**(-k), then the ! larger components of d*x have k significant decimal digits and ! info is set to 1. there is a danger that the smaller compo- ! nents of d*x may have large relative errors, but the fast rate ! of convergence of DNSQ usually avoids this possibility. ! unless high precision solutions are required, the recommended ! value for xtol is the square root of the machine precision. ! ! ! 5. unsuccessful completion. ! ! unsuccessful termination of DNSQ can be due to improper input ! parameters, arithmetic interrupts, an excessive number of func- ! tion evaluations, or lack of good progress. ! ! improper input parameters. info is set to 0 if iopt < 1, ! or 2 < iopt, or n <= 0, or ldfjac < n, or ! xtol < 0.0, or maxfev <= 0, or ml < 0, or mu < 0, ! or factor <= 0.0, or lr < (n*(n+1))/2. ! ! arithmetic interrupts. if these interrupts occur in the fcn ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of x by DNSQ. in this ! case, it may be possible to remedy the situation by rerunning ! DNSQ with a smaller value of factor. ! ! excessive number of function evaluations. a reasonable value ! for maxfev is 100*(n+1) for iopt=1 and 200*(n+1) for iopt=2. ! if the number of calls to fcn reaches maxfev, then this ! indicates that the routine is converging very slowly as ! measured by the progress of fvec, and info is set to 2. this ! situation should be unusual because, as indicated below, lack ! of good progress is usually diagnosed earlier by DNSQ, ! causing termination with info = 4 or info = 5. ! ! lack of good progress. DNSQ searches for a zero of the system ! by minimizing the sum of the squares of the functions. in so ! doing, it can become trapped in a region where the minimum ! does not correspond to a zero of the system and, in this situ- ! ation, the iteration eventually fails to make good progress. ! in particular, this will happen if the system does not have a ! zero. if the system has a zero, rerunning DNSQ from a dif- ! ferent starting point may be helpful. ! ! ! 6. characteristics of the algorithm. ! ! DNSQ is a modification of the Powell hybrid method. Two of its ! main characteristics involve the choice of the correction as a ! convex combination of the Newton and scaled gradient directions, ! and the updating of the jacobian by the rank-1 method of Broyden. ! The choice of the correction guarantees (under reasonable ! conditions) global convergence for starting points far from the ! solution and a fast rate of convergence. The jacobian is ! calculated at the starting point by either the user-supplied ! subroutine or a forward-difference approximation, but it is not ! recalculated until the rank-1 method fails to produce satisfactory ! progress. ! ! timing. The time required by DNSQ to solve a given problem ! depends on N, the behavior of the functions, the accuracy ! requested, and the starting point. the number of arithmetic ! operations needed by DNSQ is about 11.5*(n**2) to process ! each evaluation of the functions (call to fcn) and 1.3*(n**3) ! to process each evaluation of the jacobian (call to jac, ! if iopt = 1). unless fcn and jac can be evaluated quickly, ! the timing of DNSQ will be strongly influenced by the time ! spent in FCN and JAC. ! ! storage. DNSQ requires (3*n**2 + 17*n)/2 single precision ! storage locations, in addition to the storage required by the ! program. there are no internally declared storage arrays. ! ! ! 7. example. ! ! the problem is to determine the values of x(1), x(2), ..., x(9), ! which solve the system of tridiagonal equations ! ! (3-2*x(1))*x(1) -2*x(2) = -1 ! -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 ! -x(8) + (3-2*x(9))*x(9) = -1 ! c ********** ! ! program test(input,output,tape6=output) ! c ! c driver for DNSQ example. ! c ! integer j,iopt,n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac ! integer lr, nwrite ! real ( kind = rk ) xtol,epsfcn,factor,fnorm ! real ( kind = rk ) x(9),fvec(9),diag(9),fjac(9,9),r(45),qtf(9) ! real ( kind = rk ) wa1(9),wa2(9),wa3(9),wa4(9) ! real ( kind = rk ) dnrm2 ! external fcn ! data nwrite /6/ ! ! iopt = 2 ! n = 9 ! c ! c the following starting values provide a rough solution. ! c ! do j = 1, 9 ! x(j) = -1.0D+00 ! end do ! ! ldfjac = 9 ! lr = 45 ! c ! c set xtol to the square root of the machine precision. ! c unless high precision solutions are required, ! c this is the recommended setting. ! c ! xtol = sqrt ( epsilon ( xtol ) ) ! ! maxfev = 2000 ! ml = 1 ! mu = 1 ! epsfcn = 0.0D+00 ! mode = 2 ! do j = 1, 9 ! diag(j) = 1.0D+00 ! end do ! factor = 1.e2 ! nprint = 0 ! ! call dnsq (fcn,jac,iopt,n,x,fvec,fjac,ldfjac,xtol,maxfev,ml,mu, ! * epsfcn,diag,mode,factor,nprint,info,nfev,njev, ! * r,lr,qtf,wa1,wa2,wa3,wa4) ! fnorm = dnrm2 ( n,fvec,1) ! write (nwrite,1000) fnorm,nfev,info, x(1:n) ! stop ! 1000 format (5x,' final l2 norm of the residuals',e15.7 // ! * 5x,' number of function evaluations',i10 // ! * 5x,' exit parameter',16x,i10 // ! * 5x,' final approximate solution' // (5x,3e15.7)) ! end ! subroutine fcn(n,x,fvec,iflag) ! integer n,iflag ! real ( kind = rk ) x(n),fvec(n) ! integer k ! real temp,temp1,temp2 ! c ! if (iflag /= 0) go to 5 ! c ! c insert print statements here when nprint is positive. ! c ! return ! 5 continue ! do k = 1, n ! temp = ( 3.0D+00 - 2.0D+00 * x(k) ) * x(k) ! temp1 = 0.0D+00 ! if (k /= 1) temp1 = x(k-1) ! temp2 = 0.0D+00 ! if (k /= n) temp2 = x(k+1) ! fvec(k) = temp - temp1 - 2.0D+00 * temp2 + 1.0D+00 ! end do ! return ! end ! ! results obtained with different compilers or machines ! may be slightly different. ! ! final l2 norm of the residuals 0.1192636e-07 ! ! number of function evaluations 14 ! ! exit parameter 1 ! ! final approximate solution ! ! -0.5706545e+00 -0.6816283e+00 -0.7017325e+00 ! -0.7042129e+00 -0.7013690e+00 -0.6918656e+00 ! -0.6657920e+00 -0.5960342e+00 -0.4164121e+00 ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ldfjac integer lr integer n real ( kind = rk ) actred real ( kind = rk ) delta real ( kind = rk ) diag(n) real ( kind = rk ) dnrm2 real ( kind = rk ) epsfcn real ( kind = rk ) epsmch real ( kind = rk ) factor external fcn real ( kind = rk ) fjac(ldfjac,n) real ( kind = rk ) fnorm real ( kind = rk ) fnorm1 real ( kind = rk ) fvec(n) integer i integer iflag integer info integer iopt integer iter integer iwa(1) integer j external jac logical jeval integer jm1 integer l integer maxfev integer ml integer mode integer mu integer ncfail integer ncsuc integer nfev integer njev integer nprint integer nslow1 integer nslow2 real ( kind = rk ), parameter :: p001 = 0.001D+00 real ( kind = rk ), parameter :: p0001 = 0.0001D+00 real ( kind = rk ), parameter :: p1 = 0.1D+00 real ( kind = rk ), parameter :: p5 = 0.5D+00 real ( kind = rk ) pnorm real ( kind = rk ) prered real ( kind = rk ) qtf(n) real ( kind = rk ) r(lr) real ( kind = rk ) ratio logical sing real ( kind = rk ) sum2 real ( kind = rk ) temp real ( kind = rk ) xnorm real ( kind = rk ) wa1(n) real ( kind = rk ) wa2(n) real ( kind = rk ) wa3(n) real ( kind = rk ) wa4(n) real ( kind = rk ) x(n) real ( kind = rk ) xtol epsmch = epsilon ( epsmch ) info = 0 iflag = 0 nfev = 0 njev = 0 if ( iopt < 1 .or. 2 < iopt ) then go to 300 else if ( n <= 0 .or. xtol < 0.0D+00 .or. maxfev <= 0 ) then go to 300 else if ( ml < 0 .or. mu < 0 .or. factor <= 0.0D+00 ) then go to 300 else if ( ldfjac < n .or. lr < ( n * ( n + 1 ) ) / 2 ) then go to 300 end if if ( mode == 2 ) then do j = 1, n if ( diag(j) <= 0.0D+00 ) then go to 300 end if end do end if 20 continue ! ! Evaluate the function at the starting point and calculate its norm. ! iflag = 1 call fcn ( n, x, fvec, iflag ) nfev = 1 if ( iflag < 0 ) then go to 300 end if fnorm = dnrm2 ( n, fvec, 1 ) ! ! Initialize iteration counter and monitors. ! iter = 1 ncsuc = 0 ncfail = 0 nslow1 = 0 nslow2 = 0 ! ! Beginning of the outer loop. ! 30 continue jeval = .true. ! ! Calculate the jacobian matrix. ! if ( iopt /= 2 ) then ! ! User supplies jacobian ! call jac ( n, x, fvec, fjac, ldfjac, iflag ) njev = njev + 1 ! ! Approximate the jacobian. ! else iflag = 2 call fdjac1 ( fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn ) nfev = nfev + min ( ml + mu + 1, n ) end if if ( iflag < 0 ) then go to 300 end if ! ! Compute the qr factorization of the jacobian. ! call qrfac ( n, n, fjac, ldfjac, .false., iwa, 1, wa1, wa2 ) ! ! On the first iteration and if MODE is 1, scale according ! to the norms of the columns of the initial jacobian. ! if ( iter /= 1 ) then go to 70 end if if ( mode /= 2 ) then diag(1:n) = wa2(1:n) do j = 1, n if ( wa2(j) == 0.0D+00 ) then diag(j) = 1.0D+00 end if end do end if 50 continue ! ! On the first iteration, calculate the norm of the scaled x ! and initialize the step bound delta. ! wa3(1:n) = diag(1:n) * x(1:n) xnorm = dnrm2 ( n, wa3, 1 ) delta = factor * xnorm if ( delta == 0.0D+00 ) then delta = factor end if 70 continue ! ! Form Q' * FVEC and store in QTF. ! qtf(1:n) = fvec(1:n) do j = 1, n if ( fjac(j,j) /= 0.0D+00 ) then sum2 = 0.0D+00 do i = j, n sum2 = sum2 + fjac(i,j) * qtf(i) end do temp = -sum2 / fjac(j,j) do i = j, n qtf(i) = qtf(i) + fjac(i,j) * temp end do end if end do ! ! Copy the triangular factor of the qr factorization into r. ! sing = .false. do j = 1, n l = j jm1 = j - 1 do i = 1, jm1 r(l) = fjac(i,j) l = l + n - i end do r(l) = wa1(j) if ( wa1(j) == 0.0D+00 ) then sing = .true. end if end do ! ! Accumulate the orthogonal factor in FJAC. ! call qform ( n, n, fjac, ldfjac ) ! ! Rescale if necessary. ! if ( mode /= 2 ) then do j = 1, n diag(j) = max ( diag(j), wa2(j) ) end do end if ! ! beginning of the inner loop. ! 180 continue ! ! If requested, call fcn to enable printing of iterates. ! if ( 0 < nprint ) then iflag = 0 if ( mod ( iter-1, nprint ) == 0 ) then call fcn ( n, x, fvec, iflag ) end if if ( iflag < 0 ) then go to 300 end if end if ! ! Determine the direction P. ! call dogleg ( n, r, lr, diag, qtf, delta, wa1 ) ! ! Store the direction p and x + p. calculate the norm of p. ! wa1(1:n) = -wa1(1:n) wa2(1:n) = x(1:n) + wa1(1:n) wa3(1:n) = diag(1:n) * wa1(1:n) pnorm = dnrm2 ( n,wa3,1) ! ! on the first iteration, adjust the initial step bound. ! if ( iter == 1 ) then delta = min ( delta, pnorm ) end if ! ! Evaluate the function at x + p and calculate its norm. ! iflag = 1 call fcn ( n, wa2, wa4, iflag ) nfev = nfev + 1 if ( iflag < 0 ) then go to 300 end if fnorm1 = dnrm2 ( n, wa4, 1 ) ! ! Compute the scaled actual reduction. ! if ( fnorm1 < fnorm ) then actred = 1.0D+00 - ( fnorm1 / fnorm )**2 else actred = -1.0D+00 end if ! ! Compute the scaled predicted reduction. ! l = 1 do i = 1, n sum2 = 0.0D+00 do j = i, n sum2 = sum2 + r(l) * wa1(j) l = l + 1 end do wa3(i) = qtf(i) + sum2 end do temp = dnrm2 ( n, wa3, 1 ) if ( temp < fnorm ) then prered = 1.0D+00 - ( temp / fnorm )**2 else prered = 0.0D+00 end if ! ! Compute the ratio of the actual to the predicted reduction. ! if ( 0.0D+00 < prered ) then ratio = actred / prered else ratio = 0.0D+00 end if ! ! Update the step bound. ! if ( ratio < p1 ) then ncsuc = 0 ncfail = ncfail + 1 delta = p5 * delta else ncfail = 0 ncsuc = ncsuc + 1 if ( p5 <= ratio .or. 1 < ncsuc ) then delta = max ( delta, pnorm / p5 ) end if if ( abs ( ratio - 1.0D+00 ) <= p1 ) then delta = pnorm / p5 end if end if ! ! Successful iteration. Update x, fvec, and their norms. ! if ( p0001 <= ratio ) then x(1:n) = wa2(1:n) wa2(1:n) = diag(1:n) * x(1:n) fvec(1:n) = wa4(1:n) xnorm = dnrm2 ( n, wa2, 1 ) fnorm = fnorm1 iter = iter + 1 end if ! ! Determine the progress of the iteration. ! if ( p001 <= actred ) then nslow1 = 0 else nslow1 = nslow1 + 1 end if if ( jeval ) then nslow2 = nslow2 + 1 end if if ( p1 <= actred ) then nslow2 = 0 end if ! ! Test for convergence. ! if ( delta <= xtol * xnorm .or. fnorm == 0.0D+00 ) then info = 1 go to 300 end if ! ! Tests for termination and stringent tolerances. ! if ( maxfev <= nfev ) then info = 2 go to 300 end if if ( p1 * max ( p1 * delta, pnorm ) <= epsmch * xnorm ) then info = 3 go to 300 end if if ( nslow2 == 5 ) then info = 4 go to 300 end if if ( nslow1 == 10 ) then info = 5 go to 300 end if ! ! Criterion for recalculating jacobian ! if ( ncfail == 2 ) then go to 290 end if ! ! Calculate the rank one modification to the jacobian ! and update QTF if necessary. ! do j = 1, n sum2 = 0.0D+00 do i = 1, n sum2 = sum2 + fjac(i,j) * wa4(i) end do wa2(j) = ( sum2 - wa3(j) ) / pnorm wa1(j) = diag(j) * ( ( diag(j) * wa1(j) ) / pnorm ) if ( p0001 <= ratio ) then qtf(j) = sum2 end if end do ! ! Compute the QR factorization of the updated jacobian. ! call r1updt ( n, n, r, lr, wa1, wa2, wa3, sing ) call d1mpyq ( n, n, fjac, ldfjac, wa2, wa3 ) call d1mpyq ( 1, n, qtf, 1, wa2, wa3 ) ! ! end of the inner loop. ! jeval = .false. go to 180 290 continue ! ! end of the outer loop. ! go to 30 300 continue ! ! Termination, either normal or user imposed. ! if ( iflag < 0 ) then info = iflag end if iflag = 0 if ( 0 < nprint ) then call fcn ( n, x, fvec, iflag ) end if if ( info < 0 ) call xerror ( & 'DNSQ -- execution terminated because user set iflag negative.',1,1) if (info == 0) call xerror ( 'DNSQ -- invalid input parameter.',2,1) if (info == 2) call xerror ( 'DNSQ -- too many function evaluations.',9,1) if (info == 3) then call xerror ( 'DNSQ -- xtol too small. no further improvement possible.', & 3,1) end if if ( 4 < info ) then call xerror ( 'DNSQ -- iteration not making good progress.',1,1) end if return end subroutine dnsqe ( fcn, jac, iopt, n, x, fvec, tol, nprint, info, wa, lwa ) !*****************************************************************************80 ! !! dnsqe() is the easy-to-use version of DNSQ. ! ! Discussion: ! ! DNSQE finds a zero of a system of N non-linear functions in N variables ! by a modification of the Powell hybrid method. This is done by using ! the more general nonlinear equation solver DNSQ. The user must provide ! a subroutine which calculates the functions. The user has the option ! of either to provide a subroutine which calculates the jacobian or ! to let the code calculate it by a forward-difference approximation. ! ! This code is a combination of the MINPACK codes HYBRD1 and HYBRJ1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! MJD Powell, ! A Hybrid Method for Nonlinear Equations, ! in Numerical Methods for Nonlinear Algebraic Equations, ! edited by P. Rabinowitz, ! Gordon and Breach, 1970. ! ! Parameters: ! ! fcn is the name of the user-supplied subroutine which calculates ! the functions. fcn must be declared in an external statement ! in the user calling program, and should be written as follows. ! ! subroutine fcn(n,x,fvec,iflag) ! integer n,iflag ! real ( kind = rk ) x(n),fvec(n) ! ! calculate the functions at x and ! return this vector in fvec. ! ! return ! end ! ! the value of iflag should not be changed by fcn unless the ! user wants to terminate execution of DNSQE. in this case, set ! iflag to a negative integer. ! ! jac is the name of the user-supplied subroutine which calculates ! the jacobian. if iopt=1, then jac must be declared in an ! external statement in the user calling program, and should be ! written as follows. ! ! subroutine jac(n,x,fvec,fjac,ldfjac,iflag) ! integer n,ldfjac,iflag ! real ( kind = rk ) x(n),fvec(n),fjac(ldfjac,n) ! ! calculate the jacobian at x and return this ! matrix in fjac. fvec contains the function ! values at x and should not be altered. ! ! return ! end ! ! the value of iflag should not be changed by jac unless the ! user wants to terminate execution of DNSQE. in this case, set ! iflag to a negative integer. ! ! if iopt=2, jac can be ignored (treat it as a dummy argument). ! ! Input, integer IOPT, specifies how the jacobian will be ! calculated. ! 1, the user supplies the jacobian through the subroutine JAC. ! 2, the code will approximate the jacobian by forward-differencing. ! ! n is a positive integer input variable set to the number of ! functions and variables. ! ! x is an array of length n. on input, x must contain an initial ! estimate of the solution vector. on output, x contains the ! final estimate of the solution vector. ! ! fvec is an output array of length n which contains the functions ! evaluated at the output x. ! ! tol is a non-negative input variable. termination occurs when ! the algorithm estimates that the relative error between x and ! the solution is at most tol. section 4 contains more details ! about tol. ! ! nprint is an integer input variable that enables controlled ! printing of iterates if it is positive. in this case, fcn is ! called with iflag = 0 at the beginning of the first iteration ! and every nprint iteration thereafter and immediately prior ! to return, with x and fvec available for printing. appropriate ! print statements must be added to fcn (see example). if nprint ! is not positive, no special calls of fcn with iflag = 0 are ! made. ! ! info is an integer output variable. if the user has ! terminated execution, info is set to the (negative) value of iflag. ! see description of fcn and jac. otherwise, info is set as follows. ! ! info = 0 improper input parameters. ! ! info = 1 algorithm estimates that the relative error between ! x and the solution is at most tol. ! ! info = 2 number of calls to fcn has reached or exceeded ! 100*(n+1) for iopt=1 or 200*(n+1) for iopt=2. ! ! info = 3 tol is too small. no further improvement in the ! approximate solution x is possible. ! ! info = 4 iteration is not making good progress. ! ! sections 4 and 5 contain more details about info. ! ! wa is a work array of length lwa. ! ! lwa is a positive integer input variable not less than ! (3*n*n+13*n))/2. ! ! ! successful completion. ! ! the accuracy of DNSQE is controlled by the convergence parame- ! ter tol. this parameter is used in a test which makes a compar- ! ison between the approximation x and a solution xsol. DNSQE ! terminates when the test is satisfied. if tol is less than the ! machine precision (as defined by the function epsilon), then ! DNSQE attemps only to satisfy the test defined by the machine ! precision. further progress is not usually possible. unless ! high precision solutions are required, the recommended value ! for tol is the square root of the machine precision. ! ! the test assumes that the functions are reasonably well behaved, ! and, if the jacobian is supplied by the user, that the functions ! and the jacobian coded consistently. if these conditions ! are not satisfied, DNSQE may incorrectly indicate convergence. ! the coding of the jacobian can be checked by the subroutine ! chkder. if the jacobian is coded correctly or iopt=2, then ! the validity of the answer can be checked, for example, by ! rerunning DNSQE with a tighter tolerance. ! ! convergence test. if dnrm2 ( z) denotes the euclidean norm of a ! vector z, then this test attempts to guarantee that ! ! dnrm2 ( x-xsol) <= tol * dnrm2(xsol). ! ! if this condition is satisfied with tol = 10**(-k), then the ! larger components of x have k significant decimal digits and ! info is set to 1. there is a danger that the smaller compo- ! nents of x may have large relative errors, but the fast rate ! of convergence of DNSQE usually avoids this possibility. ! ! ! unsuccessful completion. ! ! unsuccessful termination of DNSQE can be due to improper input ! parameters, arithmetic interrupts, an excessive number of func- ! tion evaluations, errors in the functions, or lack of good prog- ! ress. ! ! improper input parameters. info is set to 0 if iopt < 1, or ! 2 < iopt, or n <= 0, or tol < 0.0, or ! lwa < (3*n**2+13*n)/2. ! ! arithmetic interrupts. if these interrupts occur in the fcn ! subroutine during an early stage of the computation, they may ! be caused by an unacceptable choice of x by DNSQE. in this ! case, it may be possible to remedy the situation by not evalu- ! ating the functions here, but instead setting the components ! of fvec to numbers that exceed those in the initial fvec. ! ! excessive number of function evaluations. if the number of ! calls to fcn reaches 100*(n+1) for iopt=1 or 200*(n+1) for ! iopt=2, then this indicates that the routine is converging ! very slowly as measured by the progress of fvec, and info is ! set to 2. this situation should be unusual because, as ! indicated below, lack of good progress is usually diagnosed ! earlier by DNSQE, causing termination with info = 4. ! ! errors in the functions. when iopt=2, the choice of step length ! in the forward-difference approximation to the jacobian ! assumes that the relative errors in the functions are of the ! order of the machine precision. if this is not the case, ! DNSQE may fail (usually with info = 4). the user should ! then either use DNSQ and set the step length or use iopt=1 ! and supply the jacobian. ! ! lack of good progress. DNSQE searches for a zero of the system ! by minimizing the sum of the squares of the functions. in so ! doing, it can become trapped in a region where the minimum ! does not correspond to a zero of the system and, in this situ- ! ation, the iteration eventually fails to make good progress. ! in particular, this will happen if the system does not have a ! zero. if the system has a zero, rerunning DNSQE from a dif- ! ferent starting point may be helpful. ! ! ! characteristics of the algorithm. ! ! DNSQE is a modification of the powell hybrid method. two of ! its main characteristics involve the choice of the correction as ! a convex combination of the Newton and scaled gradient direc- ! tions, and the updating of the jacobian by the rank-1 method of ! broyden. the choice of the correction guarantees (under reason- ! able conditions) global convergence for starting points far from ! the solution and a fast rate of convergence. the jacobian is ! calculated at the starting point by either the user-supplied ! subroutine or a forward-difference approximation, but it is not ! recalculated until the rank-1 method fails to produce satis- ! factory progress. ! ! timing. the time required by DNSQE to solve a given problem ! depends on n, the behavior of the functions, the accuracy ! requested, and the starting point. the number of arithmetic ! operations needed by DNSQE is about 11.5*(n**2) to process ! each evaluation of the functions (call to fcn) and 1.3*(n**3) ! to process each evaluation of the jacobian (call to jac, ! if iopt = 1). unless fcn and jac can be evaluated quickly, ! the timing of DNSQE will be strongly influenced by the time ! spent in fcn and jac. ! ! storage. DNSQE requires (3*n**2 + 17*n)/2 single precision ! storage locations, in addition to the storage required by the ! program. there are no internally declared storage arrays. ! ! ! example. ! ! the problem is to determine the values of x(1), x(2), ..., x(9), ! which solve the system of tridiagonal equations ! ! (3-2*x(1))*x(1) -2*x(2) = -1 ! -x(i-1) + (3-2*x(i))*x(i) -2*x(i+1) = -1, i=2-8 ! -x(8) + (3-2*x(9))*x(9) = -1 ! ! program test(input,output,tape6=output) ! c ! c driver for DNSQE example. ! c ! integer j,n,iopt,nprint,info,lwa,nwrite ! real ( kind = rk ) tol,fnorm ! real ( kind = rk ) x(9),fvec(9),wa(180) ! real ( kind = rk ) dnrm2 ! external fcn ! data nwrite /6/ ! c ! iopt = 2 ! n = 9 ! c ! c the following starting values provide a rough solution. ! c ! x(1:9) = -1.0D+00 ! ! lwa = 180 ! nprint = 0 ! c ! c set tol to the square root of the machine precision. ! c unless high precision solutions are required, ! c this is the recommended setting. ! c ! tol = sqrt ( epsilon ( tol ) ) ! ! call dnsqe (fcn,jac,iopt,n,x,fvec,tol,nprint,info,wa,lwa) ! fnorm = dnrm2 ( n,fvec) ! write (nwrite,1000) fnorm,info, x(1:n) ! stop ! 1000 format (5x,' final l2 norm of the residuals',e15.7 // ! * 5x,' exit parameter',16x,i10 // ! * 5x,' final approximate solution' // (5x,3e15.7)) ! end ! subroutine fcn(n,x,fvec,iflag) ! integer n,iflag ! real ( kind = rk ) x(n),fvec(n) ! integer k ! real ( kind = rk ) temp,temp1,temp2 ! ! do k = 1, n ! temp = (3.0D+00 - 2.0D+00 * x(k) ) * x(k) ! temp1 = 0.0D+00 ! if (k /= 1) temp1 = x(k-1) ! temp2 = 0.0D+00 ! if (k /= n) temp2 = x(k+1) ! fvec(k) = temp - temp1 - 2.0D+00 * temp2 + 1.0D+00 ! end do ! ! return ! end ! ! results obtained with different compilers or machines ! may be slightly different. ! ! final l2 norm of the residuals 0.1192636e-07 ! ! exit parameter 1 ! ! final approximate solution ! ! -0.5706545e+00 -0.6816283e+00 -0.7017325e+00 ! -0.7042129e+00 -0.7013690e+00 -0.6918656e+00 ! -0.6657920e+00 -0.5960342e+00 -0.4164121e+00 ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lwa integer n real ( kind = rk ) epsfcn real ( kind = rk ), parameter :: factor = 100.0D+00 external fcn real ( kind = rk ) fvec(n) integer index integer info integer iopt external jac integer lr integer maxfev integer ml integer mode integer mu integer nfev integer njev integer nprint real ( kind = rk ) tol real ( kind = rk ) wa(lwa) real ( kind = rk ) x(n) real ( kind = rk ) xtol info = 0 ! ! Check the input parameters for errors. ! if ( iopt < 1 ) then call xerror ( 'DNSQE -- invalid input parameter.', 2, 1 ) return end if if ( 2 < iopt ) then call xerror ( 'DNSQE -- invalid input parameter.', 2, 1 ) return end if if ( n <= 0 .or. tol < 0.0D+00 .or. & lwa < (3*n**2 +13*n)/2 ) then if ( info == 0 ) then call xerror ( 'DNSQE -- invalid input parameter.', 2, 1 ) end if return end if maxfev = 100 * ( n + 1 ) if ( iopt == 2 ) then maxfev = 2 * maxfev end if xtol = tol ml = n - 1 mu = n - 1 epsfcn = 0.0D+00 mode = 2 wa(1:n) = 1.0D+00 lr = ( n * ( n + 1 ) ) / 2 index = 6 * n + lr call dnsq ( fcn, jac, iopt, n, x, fvec, wa(index+1), n, xtol, maxfev, ml, & mu, epsfcn, wa(1), mode, factor, nprint, info, nfev, njev, & wa(6*n+1), lr, wa(n+1), wa(2*n+1), wa(3*n+1), wa(4*n+1), wa(5*n+1) ) if ( info == 5 ) then info = 4 end if if ( info == 0 ) then call xerror ( 'DNSQE -- invalid input parameter.', 2, 1 ) end if return end subroutine dogdrv ( nr, n, x, f, g, a, p, xpls, fpls, fcn, sx, stepmx, & steptl, dlt, iretcd, mxtake, sc, wrk1, wrk2, wrk3, ipr ) !*****************************************************************************80 ! !! DOGDRV finds the next Newton iterate by the double dogleg method. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! John Dennis, Robert Schnabel, ! Numerical Methods for Unconstrained Optimization ! and Nonlinear Equations, ! SIAM, 1996, ! ISBN13: 978-0-898713-64-0, ! LC: QA402.5.D44. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) X(N), the old iterate, "X[K-1]". ! ! Input, real ( kind = rk ) F, the function value at the old iterate, "F(X)". ! ! Input, real ( kind = rk ) G(N), the gradient at the old iterate. ! ! Input, real ( kind = rk ) A(N,N), the Cholesky decomposition of the ! Hessian matrix in lower triangular part and diagonal. ! ! Input, real ( kind = rk ) P(N), the Newton step. ! ! Output, real ( kind = rk ) XPLS(N), the new iterate "X[K]". ! ! Output, real ( kind = rk ) FPLS, the function value at the new iterate, ! F(XPLS). ! ! Input, external FCN, the name of the subroutine to evaluate the function, ! of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real x(n) ! real f ! ! Input, real ( kind = rk ) SX(N), the diagonal scaling matrix for X. ! ! Input, real ( kind = rk ) STEPMX, the maximum allowable step size. ! ! Input, real ( kind = rk ) STEPTL, the relative step size at which ! successive iterates are considered close enough to terminate algorithm. ! ! Input/output, real ( kind = rk ) DLT, the trust region radius. ! [retain value between successive calls]. ! ! Output, integer IRETCD, the return code. ! 0, satisfactory XPLS found ! 1, failed to find satisfactory XPLS sufficiently distinct from X. ! ! Output, logical MXTAKE, TRUE if a step of maximum length was used. ! ! Workspace, real ( kind = rk ) SC(N), holds the current step. ! ! Workspace, real ( kind = rk ) WRK1(N). ! ! Workspace, real ( kind = rk ) WRK2(N). ! ! Workspace, real ( kind = rk ) WRK3(N). ! ! Input, integer IPR, the device to which to send output. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) cln real ( kind = rk ) dlt real ( kind = rk ) eta real ( kind = rk ) f external fcn real ( kind = rk ) fpls real ( kind = rk ) fplsp logical fstdog real ( kind = rk ) g(n) integer ipr integer iretcd logical mxtake logical nwtake real ( kind = rk ) p(n) real ( kind = rk ) rnwtln real ( kind = rk ) sc(n) real ( kind = rk ) stepmx real ( kind = rk ) steptl real ( kind = rk ) sx(n) real ( kind = rk ) wrk1(n) real ( kind = rk ) wrk2(n) real ( kind = rk ) wrk3(n) real ( kind = rk ) x(n) real ( kind = rk ) xpls(n) iretcd = 4 fstdog = .true. rnwtln = sqrt ( sum ( sx(1:n)**2 * p(1:n)**2 ) ) do ! ! Find new step by double dogleg algorithm. ! call dogstp ( nr, n, g, a, p, sx, rnwtln, dlt, nwtake, fstdog, wrk1, & wrk2, cln, eta, sc, ipr, stepmx ) ! ! Check new point and update trust region. ! call tregup ( nr, n, x, f, g, a, fcn, sc, sx, nwtake, stepmx, steptl, dlt, & iretcd, wrk3, fplsp, xpls, fpls, mxtake, ipr, 2, wrk1 ) if ( iretcd <= 1 ) then exit end if end do return end subroutine dogleg ( n, r, lr, diag, qtb, delta, x ) !*****************************************************************************80 ! !! DOGLEG finds the minimizing combination of Gauss-Newton and gradient steps. ! ! Discussion: ! ! Given an M by N matrix A, an N by N nonsingular diagonal ! matrix D, an M-vector B, and a positive number DELTA, the ! problem is to determine the convex combination X of the ! Gauss-Newton and scaled gradient directions that minimizes ! (A*X - B) in the least squares sense, subject to the ! restriction that the euclidean norm of D*X be at most DELTA. ! ! This subroutine completes the solution of the problem ! if it is provided with the necessary information from the ! QR factorization of A. That is, if A = Q*R, where Q has ! orthogonal columns and R is an upper triangular matrix, ! then DOGLEG expects the full upper triangle of R and ! the first N components of Q'*B. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jorge More, Burton Garbow, Kenneth Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer N, the order of the matrix R. ! ! Input, real ( kind = rk ) R(LR), the upper triangular matrix R stored ! by rows. ! ! Input, integer LR, the size of the R array, which must be ! no less than (N*(N+1))/2. ! ! Input, real ( kind = rk ) DIAG(N), the diagonal elements of the matrix D. ! ! Input, real ( kind = rk ) QTB(N), the first N elements of the vector Q'* B. ! ! Input, real ( kind = rk ) DELTA, is a positive upper bound on the ! euclidean norm of D*X(1:N). ! ! Output, real ( kind = rk ) X(N), the desired convex combination of the ! Gauss-Newton direction and the scaled gradient direction. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lr integer n real ( kind = rk ) alpha real ( kind = rk ) bnorm real ( kind = rk ) delta real ( kind = rk ) diag(n) real ( kind = rk ) enorm real ( kind = rk ) epsmch real ( kind = rk ) gnorm integer i integer j integer jj integer k integer l real ( kind = rk ) qnorm real ( kind = rk ) qtb(n) real ( kind = rk ) r(lr) real ( kind = rk ) sgnorm real ( kind = rk ) sum2 real ( kind = rk ) temp real ( kind = rk ) wa1(n) real ( kind = rk ) wa2(n) real ( kind = rk ) x(n) epsmch = epsilon ( epsmch ) ! ! Calculate the Gauss-Newton direction. ! jj = ( n * ( n + 1 ) ) / 2 + 1 do k = 1, n j = n - k + 1 jj = jj - k l = jj + 1 sum2 = 0.0D+00 do i = j+1, n sum2 = sum2 + r(l) * x(i) l = l + 1 end do temp = r(jj) if ( temp == 0.0D+00 ) then l = j do i = 1, j temp = max ( temp, abs ( r(l)) ) l = l + n - i end do if ( temp == 0.0D+00 ) then temp = epsmch else temp = epsmch * temp end if end if x(j) = ( qtb(j) - sum2 ) / temp end do ! ! Test whether the Gauss-Newton direction is acceptable. ! wa1(1:n) = 0.0D+00 wa2(1:n) = diag(1:n) * x(1:n) qnorm = enorm ( n, wa2 ) if ( qnorm <= delta ) then return end if ! ! The Gauss-Newton direction is not acceptable. ! Calculate the scaled gradient direction. ! l = 1 do j = 1, n temp = qtb(j) do i = j, n wa1(i) = wa1(i) + r(l) * temp l = l + 1 end do wa1(j) = wa1(j) / diag(j) end do ! ! Calculate the norm of the scaled gradient. ! Test for the special case in which the scaled gradient is zero. ! gnorm = enorm ( n, wa1 ) sgnorm = 0.0D+00 alpha = delta / qnorm if ( gnorm /= 0.0D+00 ) then ! ! Calculate the point along the scaled gradient which minimizes the quadratic. ! wa1(1:n) = ( wa1(1:n) / gnorm ) / diag(1:n) l = 1 do j = 1, n sum2 = 0.0D+00 do i = j, n sum2 = sum2 + r(l) * wa1(i) l = l + 1 end do wa2(j) = sum2 end do temp = enorm ( n, wa2 ) sgnorm = ( gnorm / temp ) / temp ! ! Test whether the scaled gradient direction is acceptable. ! alpha = 0.0D+00 ! ! The scaled gradient direction is not acceptable. ! Calculate the point along the dogleg at which the quadratic is minimized. ! if ( sgnorm < delta ) then bnorm = enorm ( n, qtb ) temp = ( bnorm / gnorm ) * ( bnorm / qnorm ) * ( sgnorm / delta ) temp = temp - ( delta / qnorm ) * ( sgnorm / delta)**2 & + sqrt ( ( temp - ( delta / qnorm ) )**2 & + ( 1.0D+00 - ( delta / qnorm )**2 ) & * ( 1.0D+00 - ( sgnorm / delta )**2 ) ) alpha = ( ( delta / qnorm ) * ( 1.0D+00 - ( sgnorm / delta )**2 ) ) / temp end if end if ! ! Form appropriate convex combination of the Gauss-Newton ! direction and the scaled gradient direction. ! temp = ( 1.0D+00 - alpha ) * min ( sgnorm, delta ) x(1:n) = temp * wa1(1:n) + alpha * x(1:n) return end subroutine dogstp ( nr, n, g, a, p, sx, rnwtln, dlt, nwtake, fstdog, ssd, v, & cln, eta, sc, ipr, stepmx ) !*****************************************************************************80 ! !! DOGSTP finds a new step by the double dogleg algorithm. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) G(N), the gradient at the current iterate. ! ! Input, real ( kind = rk ) A(NR,N), the Cholesky decomposition of the ! hessian in the lower triangle and diagonal. ! ! Input, real ( kind = rk ) P(N), the Newton step. ! ! Input, real ( kind = rk ) SX(N), the diagonal scaling matrix for X. ! ! Input, real ( kind = rk ) RNWTLN, the Newton step length. ! ! Input/output, real ( kind = rk ) DLT, the trust region radius. ! ! Input/output, logical NWTAKE, TRUE if a Newton step was taken. ! ! Input/output, logical FSTDOG, TRUE if on first leg of dogleg. ! ! Input/output, real ( kind = rk ) SSD(N), workspace [cauchy step to ! the minimum of the quadratic model in the scaled steepest descent ! direction] [retain value between successive calls] ! ! Workspace, real ( kind = rk ) V(N), workspace [retain value ! between successive calls] ! ! Workspace, real ( kind = rk ) CLN, the cauchy length. ! [retain value between successive calls] ! ! Workspace, real ( kind = rk ) ETA, [retain value between successive calls] ! ! Output, real ( kind = rk ) SC(N), the current step. ! ! Input, integer IPR, the device to which to send output. ! ! Input, real ( kind = rk ) STEPMX, the maximum allowable step size. ! ! Local variables: ! ! CLN, the length of cauchy step ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) alam real ( kind = rk ) alpha real ( kind = rk ) beta real ( kind = rk ) cln real ( kind = rk ) dlt real ( kind = rk ) dot1 real ( kind = rk ) dot2 real ( kind = rk ) eta logical fstdog real ( kind = rk ) g(n) integer i integer ipr integer j logical nwtake real ( kind = rk ) p(n) real ( kind = rk ) rnwtln real ( kind = rk ) sc(n) real ( kind = rk ) ssd(n) real ( kind = rk ) stepmx real ( kind = rk ) sx(n) real ( kind = rk ) tmp real ( kind = rk ) v(n) call i4_fake_use ( ipr ) ! ! Can we take a Newton step? ! if ( rnwtln <= dlt ) then nwtake = .true. sc(1:n) = p(1:n) dlt = rnwtln else ! ! The Newton step is too long. ! The Cauchy step is on double dogleg curve. ! nwtake = .false. if ( fstdog ) then ! ! Calculate double dogleg curve, SSD. ! fstdog = .false. alpha = sum ( ( g(1:n) / sx(1:n) )**2 ) beta = 0.0D+00 do i = 1, n tmp = 0.0D+00 do j = i, n tmp = tmp + ( a(j,i) * g(j) ) / ( sx(j) * sx(j) ) end do beta = beta + tmp * tmp end do ssd(1:n) = - ( alpha / beta ) * g(1:n) / sx(1:n) cln = alpha * sqrt ( alpha ) / beta eta = 0.2D+00 + ( 0.8D+00 * alpha * alpha ) / & ( - beta * dot_product ( g, p ) ) v(1:n) = eta * sx(1:n) * p(1:n) - ssd(1:n) if ( dlt == - 1.0D+00 ) then dlt = min ( cln, stepmx ) end if end if ! ! Take a partial step in the Newton direction. ! if ( eta * rnwtln <= dlt ) then sc(1:n) = ( dlt / rnwtln ) * p(1:n) ! ! Take a step in steepest descent direction. ! else if ( dlt <= cln ) then sc(1:n) = ( dlt / cln ) * ssd(1:n) / sx(1:n) ! ! Convex combination of SSD and eta*p which has scaled length DLT. ! else dot1 = dot_product ( v, ssd ) dot2 = dot_product ( v, v ) alam = ( -dot1 + sqrt ( ( dot1 * dot1 ) & - dot2 * ( cln * cln - dlt * dlt ) ) ) / dot2 sc(1:n) = ( ssd(1:n) + alam * v(1:n) ) / sx(1:n) end if end if return end subroutine dqrank ( a, lda, m, n, tol, kr, jpvt, qraux, work ) !*****************************************************************************80 ! !! DQRANK computes the QR factorization of a rectangular matrix. ! ! Discussion: ! ! This routine is used in conjunction with sqrlss to solve ! overdetermined, underdetermined and singular linear systems ! in a least squares sense. ! ! DQRANK uses the LINPACK subroutine DQRDC to compute the QR ! factorization, with column pivoting, of an M by N matrix A. ! The numerical rank is determined using the tolerance TOL. ! ! Note that on output, ABS ( A(1,1) ) / ABS ( A(KR,KR) ) is an estimate ! of the condition number of the matrix of independent columns, ! and of R. This estimate will be <= 1/TOL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Parameters: ! ! Input/output, real ( kind = rk ) A(LDA,N). On input, the matrix whose ! decomposition is to be computed. On output, the information from DQRDC. ! The triangular matrix R of the QR factorization is contained in the ! upper triangle and information needed to recover the orthogonal ! matrix Q is stored below the diagonal in A and in the vector QRAUX. ! ! Input, integer LDA, the leading dimension of A, which must ! be at least M. ! ! Input, integer M, the number of rows of A. ! ! Input, integer N, the number of columns of A. ! ! Input, real ( kind = rk ) TOL, a relative tolerance used to determine the ! numerical rank. The problem should be scaled so that all the elements ! of A have roughly the same absolute accuracy, EPS. Then a reasonable ! value for TOL is roughly EPS divided by the magnitude of the largest ! element. ! ! Output, integer KR, the numerical rank. ! ! Output, integer JPVT(N), the pivot information from DQRDC. ! Columns JPVT(1), ..., JPVT(KR) of the original matrix are linearly ! independent to within the tolerance TOL and the remaining columns ! are linearly dependent. ! ! Output, real ( kind = rk ) QRAUX(N), will contain extra information defining ! the QR factorization. ! ! Workspace, real ( kind = rk ) WORK(N). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n real ( kind = rk ) a(lda,n) integer j integer jpvt(n) integer k integer kr integer m real ( kind = rk ) qraux(n) real ( kind = rk ) tol real ( kind = rk ) work(n) jpvt(1:n) = 0 call dqrdc ( a, lda, m, n, qraux, jpvt, work, 1 ) kr = 0 k = min ( m, n ) do j = 1, k if ( abs ( a(j,j) ) <= tol * abs ( a(1,1) ) ) then return end if kr = j end do return end subroutine dqrdc ( a, lda, n, p, qraux, jpvt, work, job ) !*****************************************************************************80 ! !! DQRDC computes the QR factorization of a real rectangular matrix. ! ! Discussion: ! ! DQRDC uses Householder transformations. ! ! Column pivoting based on the 2-norms of the reduced columns may be ! performed at the user's option. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Parameters: ! ! Input/output, real ( kind = rk ) A(LDA,P). On input, the N by P matrix ! whose decomposition is to be computed. On output, A contains in ! its upper triangle the upper triangular matrix R of the QR ! factorization. Below its diagonal A contains information from ! which the orthogonal part of the decomposition can be recovered. ! Note that if pivoting has been requested, the decomposition is not that ! of the original matrix A but that of A with its columns permuted ! as described by JPVT. ! ! Input, integer LDA, the leading dimension of the array A. ! LDA must be at least N. ! ! Input, integer N, the number of rows of the matrix A. ! ! Input, integer P, the number of columns of the matrix A. ! ! Output, real ( kind = rk ) QRAUX(P), contains further information required ! to recover the orthogonal part of the decomposition. ! ! Input/output, integer JPVT(P). On input, JPVT contains ! integers that control the selection of the pivot columns. The K-th ! column A(*,K) of A is placed in one of three classes according to the ! value of JPVT(K). ! > 0, then A(K) is an initial column. ! = 0, then A(K) is a free column. ! < 0, then A(K) is a final column. ! Before the decomposition is computed, initial columns are moved to ! the beginning of the array A and final columns to the end. Both ! initial and final columns are frozen in place during the computation ! and only free columns are moved. At the K-th stage of the ! reduction, if A(*,K) is occupied by a free column it is interchanged ! with the free column of largest reduced norm. JPVT is not referenced ! if JOB == 0. On output, JPVT(K) contains the index of the column of the ! original matrix that has been interchanged into the K-th column, if ! pivoting was requested. ! ! Workspace, real ( kind = rk ) WORK(P). WORK is not referenced if JOB == 0. ! ! Input, integer JOB, initiates column pivoting. ! 0, no pivoting is done. ! nonzero, pivoting is done. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer n integer p real ( kind = rk ) a(lda,p) integer jpvt(p) real ( kind = rk ) qraux(p) real ( kind = rk ) work(p) integer j integer job integer jp integer l integer lup integer maxj real ( kind = rk ) maxnrm real ( kind = rk ) nrmxl integer pl integer pu real ( kind = rk ) ddot real ( kind = rk ) dnrm2 logical swapj real ( kind = rk ) t real ( kind = rk ) tt pl = 1 pu = 0 ! ! If pivoting is requested, rearrange the columns. ! if ( job /= 0 ) then do j = 1, p swapj = 0 < jpvt(j) if ( jpvt(j) < 0 ) then jpvt(j) = - j else jpvt(j) = j end if if ( swapj ) then if ( j /= pl ) then call dswap ( n, a(1,pl), 1, a(1,j), 1 ) end if jpvt(j) = jpvt(pl) jpvt(pl) = j pl = pl + 1 end if end do pu = p do j = p, 1, -1 if ( jpvt(j) < 0 ) then jpvt(j) = - jpvt(j) if ( j /= pu ) then call dswap ( n, a(1,pu), 1, a(1,j), 1 ) jp = jpvt(pu) jpvt(pu) = jpvt(j) jpvt(j) = jp end if pu = pu - 1 end if end do end if ! ! Compute the norms of the free columns. ! do j = pl, pu qraux(j) = dnrm2 ( n, a(1,j), 1 ) end do work(pl:pu) = qraux(pl:pu) ! ! Perform the Householder reduction of A. ! lup = min ( n, p ) do l = 1, lup ! ! Bring the column of largest norm into the pivot position. ! if ( pl <= l .and. l < pu ) then maxnrm = 0.0D+00 maxj = l do j = l, pu if ( maxnrm < qraux(j) ) then maxnrm = qraux(j) maxj = j end if end do if ( maxj /= l ) then call dswap ( n, a(1,l), 1, a(1,maxj), 1 ) qraux(maxj) = qraux(l) work(maxj) = work(l) jp = jpvt(maxj) jpvt(maxj) = jpvt(l) jpvt(l) = jp end if end if ! ! Compute the Householder transformation for column L. ! qraux(l) = 0.0D+00 if ( l /= n ) then nrmxl = dnrm2 ( n-l+1, a(l,l), 1 ) if ( nrmxl /= 0.0D+00 ) then if ( a(l,l) /= 0.0D+00 ) then nrmxl = sign ( nrmxl, a(l,l) ) end if call dscal ( n-l+1, 1.0D+00 / nrmxl, a(l,l), 1 ) a(l,l) = 1.0D+00 + a(l,l) ! ! Apply the transformation to the remaining columns, updating the norms. ! do j = l + 1, p t = - ddot ( n-l+1, a(l,l), 1, a(l,j), 1 ) / a(l,l) call daxpy ( n-l+1, t, a(l,l), 1, a(l,j), 1 ) if ( pl <= j .and. j <= pu ) then if ( qraux(j) /= 0.0D+00 ) then tt = 1.0D+00 - ( abs ( a(l,j) ) / qraux(j) )**2 tt = max ( tt, 0.0D+00 ) t = tt tt = 1.0D+00 + 0.05D+00 * tt * ( qraux(j) / work(j) )**2 if ( tt /= 1.0D+00 ) then qraux(j) = qraux(j) * sqrt ( t ) else qraux(j) = dnrm2 ( n-l, a(l+1,j), 1 ) work(j) = qraux(j) end if end if end if end do ! ! Save the transformation. ! qraux(l) = a(l,l) a(l,l) = - nrmxl end if end if end do return end subroutine dqrls ( a, lda, m, n, tol, kr, b, x, rsd, jpvt, qraux, work, & itask, ind ) !*****************************************************************************80 ! !! DQRLS factors and solves a linear system in the least squares sense. ! ! Discussion: ! ! The linear system may be overdetermined, underdetermined or singular. ! The solution is obtained using a QR factorization of the ! coefficient matrix. ! ! DQRLS can be efficiently used to solve several least squares ! problems with the same matrix A. The first system is solved ! with ITASK = 1. The subsequent systems are solved with ! ITASK = 2, to avoid the recomputation of the matrix factors. ! The parameters KR, JPVT, and QRAUX must not be modified ! between calls to DQRLS. ! ! DQRLS is used to solve in a least squares sense ! overdetermined, underdetermined and singular linear systems. ! The system is A*X approximates B where A is M by N. ! B is a given M-vector, and X is the N-vector to be computed. ! A solution X is found which minimimzes the sum of squares (2-norm) ! of the residual, A*X - B. ! ! The numerical rank of A is determined using the tolerance TOL. ! ! DQRLS uses the LINPACK subroutine DQRDC to compute the QR ! factorization, with column pivoting, of an M by N matrix A. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input/output, real ( kind = rk ) A(LDA,N), an M by N matrix. ! On input, the matrix whose decomposition is to be computed. ! In a least squares data fitting problem, A(I,J) is the ! value of the J-th basis (model) function at the I-th data point. ! On output, A contains the output from DQRDC. The triangular matrix R ! of the QR factorization is contained in the upper triangle and ! information needed to recover the orthogonal matrix Q is stored ! below the diagonal in A and in the vector QRAUX. ! ! Input, integer LDA, the leading dimension of A. ! M <= LDA. ! ! Input, integer M, the number of rows of A. ! ! Input, integer N, the number of columns of A. ! ! Input, real ( kind = rk ) TOL, a relative tolerance used to determine the ! numerical rank. The problem should be scaled so that all the elements ! of A have roughly the same absolute accuracy EPS. Then a reasonable ! value for TOL is roughly EPS divided by the magnitude of the largest ! element. ! ! Output, integer KR, the numerical rank. ! ! Input, real ( kind = rk ) B(M), the right hand side of the linear system. ! In a least squares data fitting problem B(I) contains the ! value of the I-th observation. ! ! Output, real ( kind = rk ) X(N), a least squares solution to the linear ! system. ! ! Output, real ( kind = rk ) RSD(M), the residual, B - A*X. RSD may ! overwrite B. ! ! Workspace, integer JPVT(N), required if ITASK = 1. ! Columns JPVT(1), ..., JPVT(KR) of the original matrix are linearly ! independent to within the tolerance TOL and the remaining columns ! are linearly dependent. ABS ( A(1,1) ) / ABS ( A(KR,KR) ) is an estimate ! of the condition number of the matrix of independent columns, ! and of R. This estimate will be <= 1/TOL. ! ! Workspace, real ( kind = rk ) QRAUX(N), required if ITASK = 1. ! ! Workspace, real ( kind = rk ) WORK(N), required if ITASK = 1. ! ! Input, integer ITASK. ! 1, DQRLS factors the matrix A and solves the least squares problem. ! 2, DQRLS assumes that the matrix A was factored with an earlier ! call to DQRLS, and only solves the least squares problem. ! ! Output, integer IND, error code. ! 0: no error ! -1: LDA < N (fatal error) ! -2: N < 1 (fatal error) ! -3: ITASK < 1 (fatal error) ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer m integer n real ( kind = rk ) a(lda,n) real ( kind = rk ) b(m) integer ind integer itask integer jpvt(n) integer kr real ( kind = rk ) qraux(n) real ( kind = rk ) rsd(m) real ( kind = rk ) tol real ( kind = rk ) work(n) real ( kind = rk ) x(n) if ( lda < m ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DQRLS - Fatal error!' write ( *, '(a)' ) ' LDA < M.' stop end if if ( n <= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DQRLS - Fatal error!' write ( *, '(a)' ) ' N <= 0.' stop end if if ( itask < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'DQRLS - Fatal error!' write ( *, '(a)' ) ' ITASK < 1.' stop end if ind = 0 ! ! Factor the matrix. ! if ( itask == 1 ) then call dqrank ( a, lda, m, n, tol, kr, jpvt, qraux, work ) end if ! ! Solve the least-squares problem. ! call dqrlss ( a, lda, m, n, kr, b, x, rsd, jpvt, qraux ) return end subroutine dqrlss ( a, lda, m, n, kr, b, x, rsd, jpvt, qraux ) !*****************************************************************************80 ! !! DQRLSS solves a linear system in a least squares sense. ! ! Discussion: ! ! DQRLSS must be preceeded by a call to DQRANK. ! ! The system is to be solved is ! A * X = B ! where ! A is an M by N matrix with rank KR, as determined by DQRANK, ! B is a given M-vector, ! X is the N-vector to be computed. ! ! A solution X, with at most KR nonzero components, is found which ! minimizes the 2-norm of the residual (A*X-B). ! ! Once the matrix A has been formed, DQRANK should be ! called once to decompose it. Then, for each right hand ! side B, DQRLSS should be called once to obtain the ! solution and residual. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, real ( kind = rk ) A(LDA,N), the QR factorization information ! from DQRANK. The triangular matrix R of the QR factorization is ! contained in the upper triangle and information needed to recover ! the orthogonal matrix Q is stored below the diagonal in A and in ! the vector QRAUX. ! ! Input, integer LDA, the leading dimension of A, which must ! be at least M. ! ! Input, integer M, the number of rows of A. ! ! Input, integer N, the number of columns of A. ! ! Input, integer KR, the rank of the matrix, as estimated ! by DQRANK. ! ! Input, real ( kind = rk ) B(M), the right hand side of the linear system. ! ! Output, real ( kind = rk ) X(N), a least squares solution to the ! linear system. ! ! Output, real ( kind = rk ) RSD(M), the residual, B - A*X. RSD may ! overwite B. ! ! Input, integer JPVT(N), the pivot information from DQRANK. ! Columns JPVT(1), ..., JPVT(KR) of the original matrix are linearly ! independent to within the tolerance TOL and the remaining columns ! are linearly dependent. ! ! Input, real ( kind = rk ) QRAUX(N), auxiliary information from DQRANK ! defining the QR factorization. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lda integer m integer n real ( kind = rk ) a(lda,n) real ( kind = rk ) b(m) integer info integer j integer jpvt(n) integer k integer kr real ( kind = rk ) qraux(n) real ( kind = rk ) rsd(m) real ( kind = rk ) t real ( kind = rk ) x(n) if ( kr /= 0 ) then call dqrsl ( a, lda, m, kr, qraux, b, rsd, rsd, x, rsd, rsd, 110, info ) end if jpvt(1:n) = - jpvt(1:n) x(kr+1:n) = 0.0D+00 do j = 1, n if ( jpvt(j) <= 0 ) then k = -jpvt(j) jpvt(j) = k do while ( k /= j ) t = x(j) x(j) = x(k) x(k) = t jpvt(k) = -jpvt(k) k = jpvt(k) end do end if end do return end subroutine dqrsl ( a, lda, n, k, qraux, y, qy, qty, b, rsd, ab, job, info ) !*****************************************************************************80 ! !! DQRSL computes transformations, projections, and least squares solutions. ! ! Discussion: ! ! DQRSL requires the output of DQRDC. ! ! For K <= min(N,P), let AK be the matrix ! ! AK = ( A(JPVT(1)), A(JPVT(2)), ..., A(JPVT(K)) ) ! ! formed from columns JPVT(1), ..., JPVT(K) of the original ! N by P matrix A that was input to DQRDC. If no pivoting was ! done, AK consists of the first K columns of A in their ! original order. DQRDC produces a factored orthogonal matrix Q ! and an upper triangular matrix R such that ! ! AK = Q * (R) ! (0) ! ! This information is contained in coded form in the arrays ! A and QRAUX. ! ! The parameters QY, QTY, B, RSD, and AB are not referenced ! if their computation is not requested and in this case ! can be replaced by dummy variables in the calling program. ! To save storage, the user may in some cases use the same ! array for different parameters in the calling sequence. A ! frequently occuring example is when one wishes to compute ! any of B, RSD, or AB and does not need Y or QTY. In this ! case one may identify Y, QTY, and one of B, RSD, or AB, while ! providing separate arrays for anything else that is to be ! computed. ! ! Thus the calling sequence ! ! call dqrsl ( a, lda, n, k, qraux, y, dum, y, b, y, dum, 110, info ) ! ! will result in the computation of B and RSD, with RSD ! overwriting Y. More generally, each item in the following ! list contains groups of permissible identifications for ! a single calling sequence. ! ! 1. (Y,QTY,B) (RSD) (AB) (QY) ! ! 2. (Y,QTY,RSD) (B) (AB) (QY) ! ! 3. (Y,QTY,AB) (B) (RSD) (QY) ! ! 4. (Y,QY) (QTY,B) (RSD) (AB) ! ! 5. (Y,QY) (QTY,RSD) (B) (AB) ! ! 6. (Y,QY) (QTY,AB) (B) (RSD) ! ! In any group the value returned in the array allocated to ! the group corresponds to the last member of the group. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Parameters: ! ! Input, real ( kind = rk ) A(LDA,P), contains the output of DQRDC. ! ! Input, integer LDA, the leading dimension of the array A. ! ! Input, integer N, the number of rows of the matrix AK. It ! must have the same value as N in DQRDC. ! ! Input, integer K, the number of columns of the matrix AK. K ! must not be greater than min(N,P), where P is the same as in the ! calling sequence to DQRDC. ! ! Input, real ( kind = rk ) QRAUX(P), the auxiliary output from DQRDC. ! ! Input, real ( kind = rk ) Y(N), a vector to be manipulated by DQRSL. ! ! Output, real ( kind = rk ) QY(N), contains Q * Y, if requested. ! ! Output, real ( kind = rk ) QTY(N), contains Q' * Y, if requested. ! ! Output, real ( kind = rk ) B(K), the solution of the least squares problem ! minimize norm2 ( Y - AK * B), ! if its computation has been requested. Note that if pivoting was ! requested in DQRDC, the J-th component of B will be associated with ! column JPVT(J) of the original matrix A that was input into DQRDC. ! ! Output, real ( kind = rk ) RSD(N), the least squares residual Y - AK * B, ! if its computation has been requested. RSD is also the orthogonal ! projection of Y onto the orthogonal complement of the column space ! of AK. ! ! Output, real ( kind = rk ) AB(N), the least squares approximation Ak * B, ! if its computation has been requested. AB is also the orthogonal ! projection of Y onto the column space of A. ! ! Input, integer JOB, specifies what is to be computed. JOB has ! the decimal expansion ABCDE, with the following meaning: ! ! if A /= 0, compute QY. ! if B /= 0, compute QTY. ! if C /= 0, compute QTY and B. ! if D /= 0, compute QTY and RSD. ! if E /= 0, compute QTY and AB. ! ! Note that a request to compute B, RSD, or AB automatically triggers ! the computation of QTY, for which an array must be provided in the ! calling sequence. ! ! Output, integer INFO, is zero unless the computation of B has ! been requested and R is exactly singular. In this case, INFO is the ! index of the first zero diagonal element of R, and B is left unaltered. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer k integer lda integer n real ( kind = rk ) a(lda,*) real ( kind = rk ) ab(n) real ( kind = rk ) b(k) logical cab logical cb logical cqty logical cqy logical cr integer info integer j integer jj integer job integer ju integer kp1 real ( kind = rk ) qraux(*) real ( kind = rk ) qty(n) real ( kind = rk ) qy(n) real ( kind = rk ) rsd(n) real ( kind = rk ) ddot real ( kind = rk ) t real ( kind = rk ) temp real ( kind = rk ) y(n) ! ! set info flag. ! info = 0 ! ! Determine what is to be computed. ! cqy = job / 10000 /= 0 cqty = mod ( job, 10000 ) /= 0 cb = mod ( job, 1000 ) / 100 /= 0 cr = mod ( job, 100 ) / 10 /= 0 cab = mod ( job, 10 ) /= 0 ju = min ( k, n-1 ) ! ! Special action when N = 1. ! if ( ju == 0 ) then if ( cqy ) then qy(1) = y(1) end if if ( cqty ) then qty(1) = y(1) end if if ( cab ) then ab(1) = y(1) end if if ( cb ) then if ( a(1,1) == 0.0D+00 ) then info = 1 else b(1) = y(1) / a(1,1) end if end if if ( cr ) then rsd(1) = 0.0D+00 end if return end if ! ! Set up to compute QY or QTY. ! if ( cqy ) then qy(1:n) = y(1:n) end if if ( cqty ) then qty(1:n) = y(1:n) end if ! ! Compute QY. ! if ( cqy ) then do jj = 1, ju j = ju - jj + 1 if ( qraux(j) /= 0.0D+00 ) then temp = a(j,j) a(j,j) = qraux(j) t = - ddot ( n-j+1, a(j,j), 1, qy(j), 1 ) / a(j,j) call daxpy ( n-j+1, t, a(j,j), 1, qy(j), 1 ) a(j,j) = temp end if end do end if ! ! Compute Q'*Y. ! if ( cqty ) then do j = 1, ju if ( qraux(j) /= 0.0D+00 ) then temp = a(j,j) a(j,j) = qraux(j) t = - ddot ( n-j+1, a(j,j), 1, qty(j), 1 ) / a(j,j) call daxpy ( n-j+1, t, a(j,j), 1, qty(j), 1 ) a(j,j) = temp end if end do end if ! ! Set up to compute B, RSD, or AB. ! if ( cb ) then b(1:k) = qty(1:k) end if kp1 = k + 1 if ( cab ) then ab(1:k) = qty(1:k) end if if ( cr .and. k < n ) then rsd(k+1:n) = qty(k+1:n) end if if ( cab .and. k+1 <= n ) then ab(k+1:n) = 0.0D+00 end if if ( cr ) then rsd(1:k) = 0.0D+00 end if ! ! Compute B. ! if ( cb ) then do jj = 1, k j = k - jj + 1 if ( a(j,j) == 0.0D+00 ) then info = j exit end if b(j) = b(j)/a(j,j) if ( j /= 1 ) then t = -b(j) call daxpy ( j-1, t, a(1,j), 1, b, 1 ) end if end do end if if ( cr .or. cab ) then ! ! Compute RSD or AB as required. ! do jj = 1, ju j = ju - jj + 1 if ( qraux(j) /= 0.0D+00 ) then temp = a(j,j) a(j,j) = qraux(j) if ( cr ) then t = - ddot ( n-j+1, a(j,j), 1, rsd(j), 1 ) / a(j,j) call daxpy ( n-j+1, t, a(j,j), 1, rsd(j), 1 ) end if if ( cab ) then t = - ddot ( n-j+1, a(j,j), 1, ab(j), 1 ) / a(j,j) call daxpy ( n-j+1, t, a(j,j), 1, ab(j), 1 ) end if a(j,j) = temp end if end do end if return end subroutine drot ( n, x, incx, y, incy, c, s ) !*****************************************************************************80 ! !! DROT applies a plane rotation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 1999 ! ! Author: ! ! Jack Dongarra ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input/output, real ( kind = rk ) X(*), one of the vectors to be rotated. ! ! Input, integer INCX, the increment between successive entries ! of X. ! ! Input/output, real ( kind = rk ) Y(*), one of the vectors to be rotated. ! ! Input, integer INCY, the increment between successive elements ! of Y. ! ! Input, real ( kind = rk ) C, S, parameters (presumably the cosine and ! sine of some angle) that define a plane rotation. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) c integer i integer incx integer incy integer ix integer iy integer n real ( kind = rk ) s real ( kind = rk ) stemp real ( kind = rk ) x(*) real ( kind = rk ) y(*) if ( n <= 0 ) then else if ( incx == 1 .and. incy == 1 ) then do i = 1, n stemp = c * x(i) + s * y(i) y(i) = c * y(i) - s * x(i) x(i) = stemp end do else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if do i = 1, n stemp = c * x(ix) + s * y(iy) y(iy) = c * y(iy) - s * x(ix) x(ix) = stemp ix = ix + incx iy = iy + incy end do end if return end subroutine drotg ( sa, sb, c, s ) !*****************************************************************************80 ! !! DROTG constructs a Givens plane rotation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 1999 ! ! Author: ! ! Jack Dongarra ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input/output, real ( kind = rk ) SA, SB, ... ! ! Output, real ( kind = rk ) C, S, ... ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) c real ( kind = rk ) r real ( kind = rk ) roe real ( kind = rk ) s real ( kind = rk ) sa real ( kind = rk ) sb real ( kind = rk ) scale real ( kind = rk ) z if ( abs ( sb ) < abs ( sa ) ) then roe = sa else roe = sb end if scale = abs ( sa ) + abs ( sb ) if ( scale == 0.0D+00 ) then c = 1.0D+00 s = 0.0D+00 r = 0.0D+00 else r = scale * sqrt ( ( sa / scale )**2 + ( sb / scale )**2 ) r = sign ( 1.0D+00, roe ) * r c = sa / r s = sb / r end if if ( 0.0D+00 < abs ( c ) .and. abs ( c ) <= s ) then z = 1.0D+00 / c else z = s end if sa = r sb = z return end subroutine dscal ( n, sa, x, incx ) !*****************************************************************************80 ! !! DSCAL scales a vector by a constant. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 08 April 1999 ! ! Author: ! ! Jack Dongarra ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real ( kind = rk ) SA, the multiplier. ! ! Input/output, real ( kind = rk ) X(*), the vector to be scaled. ! ! Input, integer INCX, the increment between successive ! entries of X. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer incx integer ix integer m integer n real ( kind = rk ) sa real ( kind = rk ) x(*) if ( n <= 0 ) then else if ( incx == 1 ) then m = mod ( n, 5 ) x(1:m) = sa * x(1:m) do i = m+1, n, 5 x(i) = sa * x(i) x(i+1) = sa * x(i+1) x(i+2) = sa * x(i+2) x(i+3) = sa * x(i+3) x(i+4) = sa * x(i+4) end do else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if do i = 1, n x(ix) = sa * x(ix) ix = ix + incx end do end if return end subroutine dsftb ( n, r, azero, a, b ) !*****************************************************************************80 ! !! DSFTB computes a "slow" backward Fourier transform of real data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of data values. ! ! Output, real ( kind = rk ) R(N), the reconstructed data sequence. ! ! Input, real ( kind = rk ) AZERO, the constant Fourier coefficient. ! ! Input, real ( kind = rk ) A(N/2), B(N/2), the Fourier coefficients. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n/2) real ( kind = rk ) azero real ( kind = rk ) b(n/2) integer i integer k real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) r(n) real ( kind = rk ) theta r(1:n) = azero do i = 1, n do k = 1, n/2 theta = real ( k * ( i - 1 ) * 2 ) * pi / real ( n, kind = rk ) r(i) = r(i) + a(k) * cos ( theta ) + b(k) * sin ( theta ) end do end do return end subroutine dsftf ( n, r, azero, a, b ) !*****************************************************************************80 ! !! DSFTF computes a "slow" forward Fourier transform of real data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 March 2001 ! ! Parameters: ! ! Input, integer N, the number of data values. ! ! Input, real ( kind = rk ) R(N), the data to be transformed. ! ! Output, real ( kind = rk ) AZERO, = sum ( 1 <= I <= N ) R(I) / N. ! ! Output, real ( kind = rk ) A(N/2), B(N/2), the Fourier coefficients. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(1:n/2) real ( kind = rk ) azero real ( kind = rk ) b(1:n/2) integer i integer j real ( kind = rk ), parameter :: pi = 3.141592653589793D+00 real ( kind = rk ) r(n) real ( kind = rk ) theta azero = sum ( r(1:n) ) / real ( n, kind = rk ) do i = 1, n / 2 a(i) = 0.0D+00 b(i) = 0.0D+00 do j = 1, n theta = real ( 2 * i * ( j - 1 ) ) * pi / real ( n, kind = rk ) a(i) = a(i) + r(j) * cos ( theta ) b(i) = b(i) + r(j) * sin ( theta ) end do a(i) = a(i) / real ( n, kind = rk ) b(i) = b(i) / real ( n, kind = rk ) if ( i /= ( n / 2 ) ) then a(i) = 2.0D+00 * a(i) b(i) = 2.0D+00 * b(i) end if end do return end subroutine dsvdc ( x, ldx, n, p, s, e, u, ldu, v, ldv, work, job, info ) !*****************************************************************************80 ! !! DSVDC computes the singular value decomposition of a real rectangular matrix. ! ! Discussion: ! ! DSVDC reduces a real ( kind = rk ) N by P matrix X to diagonal form by ! orthogonal transformations U and V. The diagonal elements S(I) are ! the singular values of X. The columns of U are the corresponding ! left singular vectors, and the columns of V the right singular vectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Parameters: ! ! Input/output, real ( kind = rk ) X(LDX,P). On input, the matrix whose ! singular value decomposition is to be computed. On output, the matrix ! has been destroyed. ! ! Input, integer LDX, the leading dimension of the array X. ! LDX must be at least N. ! ! Input, integer N, the number of rows of the matrix. ! ! Input, integer P, the number of columns of the matrix X. ! ! Output, real ( kind = rk ) S(MM), where MM = min(N+1,P). The first min(N,P) ! entries of S contain the singular values of X arranged in descending ! order of magnitude. ! ! Output, real ( kind = rk ) E(P), ordinarily contains zeros. However see the ! discussion of INFO for exceptions. ! ! Output, real ( kind = rk ) U(LDU,K). If JOBA = 1 then K = N; if ! 2 <= JOBA, then K = min(N,P). U contains the matrix of left singular ! vectors. U is not referenced if JOBA = 0. If N <= P or if JOBA = 2, then ! U may be identified with X in the subroutine call. ! ! Input, integer LDU, the leading dimension of the array U. ! LDU must be at least N. ! ! Output, real ( kind = rk ) V(LDV,P), the matrix of right singular vectors. ! V is not referenced if JOB is 0. If P <= N, then V may be identified ! with X in the subroutine call. ! ! Input, integer LDV, the leading dimension of the array V. ! LDV must be at least P. ! ! Workspace, real ( kind = rk ) WORK(N). ! ! Input, integer JOB, controls the computation of the singular ! vectors. It has the decimal expansion AB with the following meaning: ! ! A = 0, do not compute the left singular vectors. ! A = 1, return the N left singular vectors in U. ! A >= 2, return the first min(N,P) singular vectors in U. ! B = 0, do not compute the right singular vectors. ! B = 1, return the right singular vectors in V. ! ! Output, integer INFO, status indicator. ! The singular values (and their corresponding singular vectors) ! S(INFO+1), S(INFO+2),...,S(M) are correct (here M=min(N,P)). ! Thus if INFO is 0, all the singular values and their vectors are ! correct. In any event, the matrix B = U'*X*V is the bidiagonal matrix ! with the elements of S on its diagonal and the elements of E on ! its superdiagonal (U' is the transpose of U). Thus the singular ! values of X and B are the same. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ldu integer ldv integer ldx integer n integer p real ( kind = rk ) b real ( kind = rk ) c real ( kind = rk ) cs real ( kind = rk ) e(p) real ( kind = rk ) el real ( kind = rk ) emm1 real ( kind = rk ) f real ( kind = rk ) g integer info integer iter integer j integer job integer jobu integer k integer kase integer kk integer l integer ll integer lls integer ls integer lu integer m integer, parameter :: maxit = 30 integer mm integer mm1 integer mp1 integer nct integer nctp1 integer ncu integer nrt integer nrtp1 real ( kind = rk ) s(*) real ( kind = rk ) scale real ( kind = rk ) ddot real ( kind = rk ) shift real ( kind = rk ) sl real ( kind = rk ) sm real ( kind = rk ) smm1 real ( kind = rk ) sn real ( kind = rk ) dnrm2 real ( kind = rk ) t real ( kind = rk ) t1 real ( kind = rk ) test real ( kind = rk ) u(ldu,*) real ( kind = rk ) v(ldv,p) logical wantu logical wantv real ( kind = rk ) work(n) real ( kind = rk ) x(ldx,p) real ( kind = rk ) ztest ! ! Determine what is to be computed. ! wantu = .false. wantv = .false. jobu = mod ( job, 100 ) / 10 if ( 1 < jobu ) then ncu = min ( n, p ) else ncu = n end if if ( jobu /= 0 ) then wantu = .true. end if if ( mod ( job, 10 ) /= 0 ) then wantv = .true. end if ! ! Reduce X to bidiagonal form, storing the diagonal elements ! in S and the super-diagonal elements in E. ! info = 0 nct = min ( n-1, p ) nrt = max ( 0, min ( p-2, n ) ) lu = max ( nct, nrt ) do l = 1, lu ! ! Compute the transformation for the L-th column and ! place the L-th diagonal in S(L). ! if ( l <= nct ) then s(l) = dnrm2 ( n-l+1, x(l,l), 1 ) if ( s(l) /= 0.0D+00 ) then if (x(l,l) /= 0.0D+00 ) then s(l) = sign ( s(l), x(l,l) ) end if call dscal ( n-l+1, 1.0D+00 / s(l), x(l,l), 1 ) x(l,l) = 1.0D+00 + x(l,l) end if s(l) = -s(l) end if do j = l+1, p ! ! Apply the transformation. ! if ( l <= nct .and. s(l) /= 0.0D+00 ) then t = - ddot ( n-l+1, x(l,l), 1, x(l,j), 1 ) / x(l,l) call daxpy ( n-l+1, t, x(l,l), 1, x(l,j), 1 ) end if ! ! Place the L-th row of X into E for the ! subsequent calculation of the row transformation. ! e(j) = x(l,j) end do ! ! Place the transformation in U for subsequent back multiplication. ! if ( wantu .and. l <= nct ) then u(l:n,l) = x(l:n,l) end if if ( l <= nrt ) then ! ! Compute the L-th row transformation and place the ! L-th superdiagonal in E(L). ! e(l) = dnrm2 ( p-l, e(l+1), 1 ) if ( e(l) /= 0.0D+00 ) then if ( e(l+1) /= 0.0D+00 ) then e(l) = sign ( e(l), e(l+1) ) end if call dscal ( p-l, 1.0D+00 / e(l), e(l+1), 1 ) e(l+1) = 1.0D+00 + e(l+1) end if e(l) = -e(l) ! ! Apply the transformation. ! if ( l+1 <= n .and. e(l) /= 0.0D+00 ) then work(l+1:n) = 0.0D+00 do j = l+1, p call daxpy ( n-l, e(j), x(l+1,j), 1, work(l+1), 1 ) end do do j = l+1, p call daxpy ( n-l, -e(j)/e(l+1), work(l+1), 1, x(l+1,j), 1 ) end do end if ! ! Place the transformation in V for subsequent back multiplication. ! if ( wantv ) then v(l+1:p,l) = e(l+1:p) end if end if end do ! ! Set up the final bidiagonal matrix of order M. ! m = min ( p, n+1 ) nctp1 = nct + 1 nrtp1 = nrt + 1 if ( nct < p ) then s(nctp1) = x(nctp1,nctp1) end if if ( n < m ) then s(m) = 0.0D+00 end if if ( nrtp1 < m ) then e(nrtp1) = x(nrtp1,m) end if e(m) = 0.0D+00 ! ! If required, generate U. ! if ( wantu ) then u(1:n,nctp1:ncu) = 0.0D+00 do j = nctp1, ncu u(j,j) = 1.0D+00 end do do ll = 1, nct l = nct - ll + 1 if ( s(l) /= 0.0D+00 ) then do j = l+1, ncu t = - ddot ( n-l+1, u(l,l), 1, u(l,j), 1 ) / u(l,l) call daxpy ( n-l+1, t, u(l,l), 1, u(l,j), 1 ) end do call dscal ( n-l+1, -1.0D+00, u(l,l), 1 ) u(l,l) = 1.0D+00 + u(l,l) u(1:l-1,l) = 0.0D+00 else u(1:n,l) = 0.0D+00 u(l,l) = 1.0D+00 end if end do end if ! ! If it is required, generate V. ! if ( wantv ) then do ll = 1, p l = p - ll + 1 if ( l <= nrt .and. e(l) /= 0.0D+00 ) then do j = l+1, p t = - ddot ( p-l, v(l+1,l), 1, v(l+1,j), 1 ) / v(l+1,l) call daxpy ( p-l, t, v(l+1,l), 1, v(l+1,j), 1 ) end do end if v(1:p,l) = 0.0D+00 v(l,l) = 1.0D+00 end do end if ! ! Main iteration loop for the singular values. ! mm = m iter = 0 do while ( 0 < m ) ! ! If too many iterations have been performed, set flag and return. ! if ( maxit <= iter ) then info = m return end if ! ! This section of the program inspects for ! negligible elements in the S and E arrays. ! ! On completion the variables KASE and L are set as follows: ! ! KASE = 1 if S(M) and E(L-1) are negligible and L & ( ( 1.0D+00 + 100.0D+00 * epmach ) & * ( abs ( xm ) + 0.1D+04 * uflow ) ) ) then call gl15t ( f, w(loc,1), xm, w(loc,5), w(loc,6), & tr1, te1, rab, rav, fminl, fmaxl ) kf = kf + 15 if ( te1 < ( eb * ( xm - w(loc,1) ) / ( b - a ) ) ) then te1 = -te1 end if call gl15t ( f, xm, w(loc,2), w(loc,5), w(loc,6), & tr2, te2, rab, rav, fminr, fmaxr ) kf = kf + 15 fmin = min ( fmin, fminl, fminr ) fmax = max ( fmax, fmaxl, fmaxr ) if ( te2 < ( eb * ( w(loc,2) - xm ) / ( b - a ) ) ) then te2 = -te2 end if te = abs ( w(loc,3) ) tr = w(loc,4) w(c,3) = te2 w(c,4) = tr2 w(c,1) = xm w(c,2) = w(loc,2) w(c,5) = w(loc,5) w(c,6) = w(loc,6) w(loc,3) = te1 w(loc,4) = tr1 w(loc,2) = xm e = e - te + ( abs ( te1 ) + abs ( te2 ) ) r = r - tr + ( tr1 + tr2 ) if ( abs ( abs ( te1 ) + abs ( te2 ) - te ) < 0.001D+00 * te ) then iroff = iroff + 1 if ( 10 <= iroff ) then iflag = 4 go to 20 end if end if else if ( w(loc,3) < eb ) then w(loc,3) = 0.0D+00 else iflag = 6 go to 20 end if end if go to 15 20 continue if ( 4 <= iflag ) then return end if t = eps * abs ( r ) if ( eps < e .and. t < e ) then iflag = 3 return end if if ( eps < e .and. e < t ) then iflag = 2 return end if if ( e < eps .and. t < e ) then iflag = 1 return end if iflag = 0 return end subroutine qagi ( f, bound, inf, epsabs, epsrel, result, abserr, neval, & ier, limit, lenw, last, iwork, work ) !*****************************************************************************80 ! !! QAGI approximates an integral over an infinite or semi-infinite interval. ! ! Discussion: ! ! QAGI calculates an approximation RESULT to a given integral: ! ! I = integral of F(X) over (bound,+infinity), or ! I = integral of F(X) over (-infinity,bound), or ! I = integral of F(X) over (-infinity,+infinity) ! ! hopefully satisfying following claim for accuracy: ! ! abs ( i - result ) <= max ( epsabs, epsrel * abs ( i ) ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Robert Piessens, Elise de Doncker-Kapenger, ! Christian Ueberhuber, David Kahaner, ! QUADPACK, a Subroutine Package for Automatic Integration, ! Springer Verlag, 1983 ! ! Parameters: ! ! Input, external F, the name of the routine that evaluates the function, ! of the form ! ! function f ( x ) ! real ( kind = rk ) f ! real ( kind = rk ) x ! ! Input, real ( kind = rk ) BOUND, the value of the finite endpoint of ! the integration range, if any, that is, if INF is 1 or -1. ! ! Input, integer INF, indicates the type of integration range. ! 1: ( BOUND, +Infinity), ! -1: ( -Infinity, BOUND), ! 2: ( -Infinity, +Infinity). ! ! Input, real ( kind = rk ) EPSABS, the absolute accuracy requested. ! ! Input, real ( kind = rk ) EPSREL, the relative accuracy requested ! If EPSABS <= 0 and EPSREL < max ( 50 * epsilon, 0.5D-14), ! the routine will end with IER = 6. ! ! Output, real ( kind = rk ) RESULT, the estimated value of the integral. ! ! Output, real ( kind = rk ) ABSERR, the estimate of the modulus of the ! absolute error, which should equal or exceed | I - RESULT |. ! ! Output, integer NEVAL, the number of integrand evaluations. ! ! on return ! ! ier - integer ! ier = 0 normal and reliable termination of the ! routine. it is assumed that the requested ! accuracy has been achieved. ! - 0 < ier, abnormal termination of the routine. the ! estimates for result and error are less ! reliable. it is assumed that the requested ! accuracy has not been achieved. ! error messages ! ier = 1 maximum number of subdivisions allowed ! has been achieved. one can allow more ! subdivisions by increasing the value of ! limit (and taking the according dimension ! adjustments into account). however, if ! this yields no improvement it is advised ! to analyze the integrand in order to ! determine the integration difficulties. if ! the position of a local difficulty can be ! determined (e.g. singularity, ! discontinuity within the interval) one ! will probably gain from splitting up the ! interval at this point and calling the ! integrator on the subranges. if possible, ! an appropriate special-purpose integrator ! should be used, which is designed for ! handling the type of difficulty involved. ! = 2 the occurrence of roundoff error is ! detected, which prevents the requested ! tolerance from being achieved. ! the error may be under-estimated. ! = 3 extremely bad integrand behaviour occurs ! at some points of the integration ! interval. ! = 4 the algorithm does not converge. ! roundoff error is detected in the ! extrapolation table. ! it is assumed that the requested tolerance ! cannot be achieved, and that the returned ! result is the best which can be obtained. ! = 5 the integral is probably divergent, or ! slowly convergent. it must be noted that ! divergence can occur with any other value ! of ier. ! = 6 the input is invalid, because ! (epsabs <= 0 and ! epsrel < max ( 50 * EPSILON, 0.5d-28 ) ) ! or limit<1 or leniw (r*) + ( u(1) * e1 ) (v+) ! which is upper Hessenberg ! if ( 1 < k ) then do i = k-1, 1, -1 if ( u(i) == 0.0D+00 ) then call qraux1 ( nr, n, a, i ) u(i) = u(i+1) else call qraux2 ( nr, n, a, i, u(i), -u(i+1) ) u(i) = sqrt ( u(i) * u(i) + u(i+1) * u(i+1) ) end if end do end if ! ! R <-- R + ( u(1) * e1 ) (v+) ! a(1,1:n) = a(1,1:n) + u(1) * v(1:n) ! ! (k-1) Jacobi rotations transform upper Hessenberg R ! to upper triangular (R*) ! do i = 1, k-1 if ( a(i,i) == 0.0D+00 ) then call qraux1 ( nr, n, a, i ) else t1 = a(i,i) t2 = -a(i+1,i) call qraux2 ( nr, n, a, i, t1, t2 ) end if end do return end function r1mach ( i ) !*****************************************************************************80 ! !! r1mach() returns single precision real machine constants. ! ! Discussion: ! ! Assume that single precision real numbers are stored with a mantissa ! of T digits in base B, with an exponent whose value must lie ! between EMIN and EMAX. Then for values of I between 1 and 5, ! R1MACH will return the following values: ! ! R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. ! R1MACH(2) = B**EMAX*(1-B**(-T)), the largest magnitude. ! R1MACH(3) = B**(-T), the smallest relative spacing. ! R1MACH(4) = B**(1-T), the largest relative spacing. ! R1MACH(5) = log10(B) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 24 April 2007 ! ! Author: ! ! Phyllis Fox, Andrew Hall, Norman Schryer ! ! Reference: ! ! Phyllis Fox, Andrew Hall, Norman Schryer, ! Algorithm 528, ! Framework for a Portable Library, ! ACM Transactions on Mathematical Software, ! Volume 4, Number 2, June 1978, page 176-188. ! ! Parameters: ! ! Input, integer I, chooses the parameter to be returned. ! 1 <= I <= 5. ! ! Output, real R1MACH, the value of the chosen parameter. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i real r1mach if ( i < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i r1mach = 0.0E+00 stop else if ( i == 1 ) then r1mach = 1.1754944E-38 else if ( i == 2 ) then r1mach = 3.4028235E+38 else if ( i == 3 ) then r1mach = 5.9604645E-08 else if ( i == 4 ) then r1mach = 1.1920929E-07 else if ( i == 5 ) then r1mach = 0.3010300E+00 else if ( 5 < i ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i r1mach = 0.0E+00 stop end if return end subroutine r1updt ( m, n, s, ls, u, v, w, sing ) !*****************************************************************************80 ! !! r1updt() retriangularizes a matrix after a rank one update. ! ! Discussion: ! ! Given an M by N lower trapezoidal matrix S, an M-vector U, and an ! N-vector V, the problem is to determine an orthogonal matrix Q such that ! ! (S + U * V' ) * Q ! ! is again lower trapezoidal. ! ! This subroutine determines Q as the product of 2 * (N - 1) ! transformations ! ! GV(N-1) * ... * GV(1) * GW(1) * ... * GW(N-1) ! ! where GV(I), GW(I) are Givens rotations in the (I,N) plane ! which eliminate elements in the I-th and N-th planes, ! respectively. Q itself is not accumulated, rather the ! information to recover the GV and GW rotations is returned. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! Jorge More, Burton Garbow and Kenneth Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer M, the number of rows of S. ! ! Input, integer N, the number of columns of S. ! N must not exceed M. ! ! Input/output, real ( kind = rk ) S(LS). On input, the lower trapezoidal ! matrix S stored by columns. On output S contains the lower trapezoidal ! matrix produced as described above. ! ! Input, integer LS, the length of the S array. ! LS must be at least (N*(2*M-N+1))/2. ! ! Input, real ( kind = rk ) U(M), the U vector. ! ! Input/output, real ( kind = rk ) V(N). On input, V must contain the ! vector V. On output V contains the information necessary to recover ! the Givens rotations GV described above. ! ! Output, real ( kind = rk ) W(M), contains information necessary to ! recover the Givens rotations GW described above. ! ! Output, logical SING, is set to TRUE if any of the diagonal elements ! of the output S are zero. Otherwise SING is set FALSE. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ls integer m integer n real ( kind = rk ) cos real ( kind = rk ) cotan real ( kind = rk ) giant integer i integer j integer jj integer l real ( kind = rk ) s(ls) real ( kind = rk ) sin logical sing real ( kind = rk ) tan real ( kind = rk ) tau real ( kind = rk ) temp real ( kind = rk ) u(m) real ( kind = rk ) v(n) real ( kind = rk ) w(m) ! ! GIANT is the largest magnitude. ! giant = huge ( 1.0D+00 ) ! ! Initialize the diagonal element pointer. ! jj = ( n * ( 2 * m - n + 1 ) ) / 2 - ( m - n ) ! ! Move the nontrivial part of the last column of S into W. ! l = jj do i = n, m w(i) = s(l) l = l + 1 end do ! ! Rotate the vector V into a multiple of the N-th unit vector ! in such a way that a spike is introduced into W. ! do j = n-1, 1, -1 jj = jj - ( m - j + 1 ) w(j) = 0.0D+00 if ( v(j) /= 0.0D+00 ) then ! ! Determine a Givens rotation which eliminates the ! J-th element of V. ! if ( abs ( v(n) ) < abs ( v(j) ) ) then cotan = v(n) / v(j) sin = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan**2 ) cos = sin * cotan tau = 1.0D+00 if ( 1.0D+00 < abs ( cos ) * giant ) then tau = 1.0D+00 / cos end if else tan = v(j) / v(n) cos = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan**2 ) sin = cos * tan tau = sin end if ! ! Apply the transformation to V and store the information ! necessary to recover the Givens rotation. ! v(n) = sin * v(j) + cos * v(n) v(j) = tau ! ! Apply the transformation to S and extend the spike in W. ! l = jj do i = j, m temp = cos * s(l) - sin * w(i) w(i) = sin * s(l) + cos * w(i) s(l) = temp l = l + 1 end do end if end do ! ! Add the spike from the rank 1 update to W. ! w(1:m) = w(1:m) + v(n) * u(1:m) ! ! Eliminate the spike. ! sing = .false. do j = 1, n-1 if ( w(j) /= 0.0D+00 ) then ! ! Determine a Givens rotation which eliminates the ! J-th element of the spike. ! if ( abs ( s(jj) ) < abs ( w (j) ) ) then cotan = s(jj) / w(j) sin = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * cotan**2 ) cos = sin * cotan tau = 1.0D+00 if ( 1.0D+00 < abs ( cos ) * giant ) then tau = 1.0D+00 / cos end if else tan = w(j) / s(jj) cos = 0.5D+00 / sqrt ( 0.25D+00 + 0.25D+00 * tan**2 ) sin = cos * tan tau = sin end if ! ! Apply the transformation to S and reduce the spike in W. ! l = jj do i = j, m temp = cos * s(l) + sin * w(i) w(i) = - sin * s(l) + cos * w(i) s(l) = temp l = l + 1 end do ! ! Store the information necessary to recover the Givens rotation. ! w(j) = tau end if ! ! Test for zero diagonal elements in the output S. ! if ( s(jj) == 0.0D+00 ) then sing = .true. end if jj = jj + ( m - j + 1 ) end do ! ! Move W back into the last column of the output S. ! l = jj do i = n, m s(l) = w(i) l = l + 1 end do if ( s(jj) == 0.0D+00 ) then sing = .true. end if return end subroutine r8_fake_use ( x ) !*****************************************************************************80 ! !! r8_fake_use() pretends to use a variable. ! ! Discussion: ! ! Some compilers will issue a warning if a variable is unused. ! Sometimes there's a good reason to include a variable in a program, ! but not to use it. Calling this function with that variable as ! the argument will shut the compiler up. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 21 April 2020 ! ! Author: ! ! John Burkardt ! ! Input: ! ! real ( kind = rk ) X, the variable to be "used". ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x if ( x /= x ) then write ( *, '(a)' ) ' r8_fake_use: variable is NAN.' end if return end subroutine r8_swap ( x, y ) !*****************************************************************************80 ! !! r8_swap() swaps two R8's. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = rk ) X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) x real ( kind = rk ) y real ( kind = rk ) z z = x x = y y = z return end subroutine r8vec_print_some ( n, a, i_lo, i_hi, title ) !*****************************************************************************80 ! !! r8vec_print_some() prints "some" of an R8VEC. ! ! Discussion: ! ! An R8VEC is a vector of R8 values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 16 October 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries of the vector. ! ! Input, real ( kind = rk ) A(N), the vector to be printed. ! ! Input, integer I_LO, I_HI, the first and last indices ! to print. The routine expects 1 <= I_LO <= I_HI <= N. ! ! Input, character ( len = * ) TITLE, an optional title. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i integer i_hi integer i_lo character ( len = * ) title if ( 0 < len_trim ( title ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) trim ( title ) end if write ( *, '(a)' ) ' ' do i = max ( i_lo, 1 ), min ( i_hi, n ) write ( *, '(2x,i8,2x,g14.8)' ) i, a(i) end do return end subroutine r8vec_reverse ( n, a ) !*****************************************************************************80 ! !! R8VEC_REVERSE reverses the elements of an R8VEC. ! ! Discussion: ! ! Input: ! ! N = 5, A = ( 11.0, 12.0, 13.0, 14.0, 15.0 ). ! ! Output: ! ! A = ( 15.0, 14.0, 13.0, 12.0, 11.0 ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of entries in the array. ! ! Input/output, real ( kind = rk ) A(N), the array to be reversed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) a(n) integer i do i = 1, n/2 call r8_swap ( a(i), a(n+1-i) ) end do return end subroutine radb2 ( ido, l1, cc, ch, wa1 ) !*****************************************************************************80 ! !! RADB2 is a lower level routine used by RFFTB1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,2,l1) real ( kind = rk ) ch(ido,l1,2) integer i integer ic integer k real ( kind = rk ) ti2 real ( kind = rk ) tr2 real ( kind = rk ) wa1(ido) ch(1,1:l1,1) = cc(1,1,1:l1) + cc(ido,2,1:l1) ch(1,1:l1,2) = cc(1,1,1:l1) - cc(ido,2,1:l1) if ( ido < 2 ) then return end if if ( 2 < ido ) then do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i ch(i-1,k,1) = cc(i-1,1,k) + cc(ic-1,2,k) tr2 = cc(i-1,1,k) - cc(ic-1,2,k) ch(i,k,1) = cc(i,1,k) - cc(ic,2,k) ti2 = cc(i,1,k) + cc(ic,2,k) ch(i-1,k,2) = wa1(i-2) * tr2 - wa1(i-1) * ti2 ch(i,k,2) = wa1(i-2) * ti2 + wa1(i-1) * tr2 end do end do if ( mod ( ido, 2 ) == 1 ) then return end if end if ch(ido,1:l1,1) = cc(ido,1,1:l1) + cc(ido,1,1:l1) ch(ido,1:l1,2) = -( cc(1,2,1:l1) + cc(1,2,1:l1) ) return end subroutine radb3 ( ido, l1, cc, ch, wa1, wa2 ) !*****************************************************************************80 ! !! RADB3 is a lower level routine used by RFFTB1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,3,l1) real ( kind = rk ) ch(ido,l1,3) real ( kind = rk ) ci2 real ( kind = rk ) ci3 real ( kind = rk ) cr2 real ( kind = rk ) cr3 real ( kind = rk ) di2 real ( kind = rk ) di3 real ( kind = rk ) dr2 real ( kind = rk ) dr3 integer i integer ic integer k real ( kind = rk ), parameter :: taui = 0.866025403784439D+00 real ( kind = rk ), parameter :: taur = -0.5D+00 real ( kind = rk ) ti2 real ( kind = rk ) tr2 real ( kind = rk ) wa1(ido) real ( kind = rk ) wa2(ido) do k = 1, l1 tr2 = cc(ido,2,k) + cc(ido,2,k) cr2 = cc(1,1,k) + taur * tr2 ch(1,k,1) = cc(1,1,k) + tr2 ci3 = taui * ( cc(1,3,k) + cc(1,3,k) ) ch(1,k,2) = cr2 - ci3 ch(1,k,3) = cr2 + ci3 end do if ( ido == 1 ) then return end if do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i tr2 = cc(i-1,3,k) + cc(ic-1,2,k) cr2 = cc(i-1,1,k) + taur * tr2 ch(i-1,k,1) = cc(i-1,1,k) + tr2 ti2 = cc(i,3,k) - cc(ic,2,k) ci2 = cc(i,1,k) + taur * ti2 ch(i,k,1) = cc(i,1,k) + ti2 cr3 = taui * ( cc(i-1,3,k) - cc(ic-1,2,k) ) ci3 = taui * ( cc(i,3,k) + cc(ic,2,k) ) dr2 = cr2 - ci3 dr3 = cr2 + ci3 di2 = ci2 + cr3 di3 = ci2 - cr3 ch(i-1,k,2) = wa1(i-2) * dr2 - wa1(i-1) * di2 ch(i,k,2) = wa1(i-2) * di2 + wa1(i-1) * dr2 ch(i-1,k,3) = wa2(i-2) * dr3 - wa2(i-1) * di3 ch(i,k,3) = wa2(i-2) * di3 + wa2(i-1) * dr3 end do end do return end subroutine radb4 ( ido, l1, cc, ch, wa1, wa2, wa3 ) !*****************************************************************************80 ! !! RADB4 is a lower level routine used by RFFTB1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,4,l1) real ( kind = rk ) ch(ido,l1,4) real ( kind = rk ) ci2 real ( kind = rk ) ci3 real ( kind = rk ) ci4 real ( kind = rk ) cr2 real ( kind = rk ) cr3 real ( kind = rk ) cr4 integer i integer ic integer k real ( kind = rk ), parameter :: sqrt2 = 1.414213562373095D+00 real ( kind = rk ) ti1 real ( kind = rk ) ti2 real ( kind = rk ) ti3 real ( kind = rk ) ti4 real ( kind = rk ) tr1 real ( kind = rk ) tr2 real ( kind = rk ) tr3 real ( kind = rk ) tr4 real ( kind = rk ) wa1(ido) real ( kind = rk ) wa2(ido) real ( kind = rk ) wa3(ido) do k = 1, l1 tr1 = cc(1,1,k) - cc(ido,4,k) tr2 = cc(1,1,k) + cc(ido,4,k) tr3 = cc(ido,2,k) + cc(ido,2,k) tr4 = cc(1,3,k) + cc(1,3,k) ch(1,k,1) = tr2 + tr3 ch(1,k,2) = tr1 - tr4 ch(1,k,3) = tr2 - tr3 ch(1,k,4) = tr1 + tr4 end do if ( ido < 2 ) then return end if if ( 2 < ido ) then do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i ti1 = cc(i,1,k) + cc(ic,4,k) ti2 = cc(i,1,k) - cc(ic,4,k) ti3 = cc(i,3,k) - cc(ic,2,k) tr4 = cc(i,3,k) + cc(ic,2,k) tr1 = cc(i-1,1,k) - cc(ic-1,4,k) tr2 = cc(i-1,1,k) + cc(ic-1,4,k) ti4 = cc(i-1,3,k) - cc(ic-1,2,k) tr3 = cc(i-1,3,k) + cc(ic-1,2,k) ch(i-1,k,1) = tr2 + tr3 cr3 = tr2 - tr3 ch(i,k,1) = ti2 + ti3 ci3 = ti2 - ti3 cr2 = tr1 - tr4 cr4 = tr1 + tr4 ci2 = ti1 + ti4 ci4 = ti1 - ti4 ch(i-1,k,2) = wa1(i-2) * cr2 - wa1(i-1) * ci2 ch(i,k,2) = wa1(i-2) * ci2 + wa1(i-1) * cr2 ch(i-1,k,3) = wa2(i-2) * cr3 - wa2(i-1) * ci3 ch(i,k,3) = wa2(i-2) * ci3 + wa2(i-1) * cr3 ch(i-1,k,4) = wa3(i-2) * cr4 - wa3(i-1) * ci4 ch(i,k,4) = wa3(i-2) * ci4 + wa3(i-1) * cr4 end do end do if ( mod ( ido, 2 ) == 1 ) then return end if end if do k = 1, l1 ti1 = cc(1,2,k) + cc(1,4,k) ti2 = cc(1,4,k) - cc(1,2,k) tr1 = cc(ido,1,k) - cc(ido,3,k) tr2 = cc(ido,1,k) + cc(ido,3,k) ch(ido,k,1) = tr2 + tr2 ch(ido,k,2) = sqrt2 * ( tr1 - ti1 ) ch(ido,k,3) = ti2 + ti2 ch(ido,k,4) = -sqrt2 * ( tr1 + ti1 ) end do return end subroutine radb5 ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 ) !*****************************************************************************80 ! !! RADB5 is a lower level routine used by RFFTB1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,5,l1) real ( kind = rk ) ch(ido,l1,5) real ( kind = rk ) ci2 real ( kind = rk ) ci3 real ( kind = rk ) ci4 real ( kind = rk ) ci5 real ( kind = rk ) cr2 real ( kind = rk ) cr3 real ( kind = rk ) cr4 real ( kind = rk ) cr5 real ( kind = rk ) di2 real ( kind = rk ) di3 real ( kind = rk ) di4 real ( kind = rk ) di5 real ( kind = rk ) dr2 real ( kind = rk ) dr3 real ( kind = rk ) dr4 real ( kind = rk ) dr5 integer i integer ic integer k real ( kind = rk ), parameter :: ti11 = 0.951056516295154D+00 real ( kind = rk ), parameter :: ti12 = 0.587785252292473D+00 real ( kind = rk ) ti2 real ( kind = rk ) ti3 real ( kind = rk ) ti4 real ( kind = rk ) ti5 real ( kind = rk ), parameter :: tr11 = 0.309016994374947D+00 real ( kind = rk ), parameter :: tr12 = -0.809016994374947D+00 real ( kind = rk ) tr2 real ( kind = rk ) tr3 real ( kind = rk ) tr4 real ( kind = rk ) tr5 real ( kind = rk ) wa1(ido) real ( kind = rk ) wa2(ido) real ( kind = rk ) wa3(ido) real ( kind = rk ) wa4(ido) do k = 1, l1 ti5 = cc(1,3,k) + cc(1,3,k) ti4 = cc(1,5,k) + cc(1,5,k) tr2 = cc(ido,2,k) + cc(ido,2,k) tr3 = cc(ido,4,k) + cc(ido,4,k) ch(1,k,1) = cc(1,1,k) + tr2 + tr3 cr2 = cc(1,1,k) + tr11 * tr2 + tr12 * tr3 cr3 = cc(1,1,k) + tr12 * tr2 + tr11 * tr3 ci5 = ti11 * ti5 + ti12 * ti4 ci4 = ti12 * ti5 - ti11 * ti4 ch(1,k,2) = cr2 - ci5 ch(1,k,3) = cr3 - ci4 ch(1,k,4) = cr3 + ci4 ch(1,k,5) = cr2 + ci5 end do if ( ido == 1 ) then return end if do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i ti5 = cc(i,3,k) + cc(ic,2,k) ti2 = cc(i,3,k) - cc(ic,2,k) ti4 = cc(i,5,k) + cc(ic,4,k) ti3 = cc(i,5,k) - cc(ic,4,k) tr5 = cc(i-1,3,k) - cc(ic-1,2,k) tr2 = cc(i-1,3,k) + cc(ic-1,2,k) tr4 = cc(i-1,5,k) - cc(ic-1,4,k) tr3 = cc(i-1,5,k) + cc(ic-1,4,k) ch(i-1,k,1) = cc(i-1,1,k) + tr2 + tr3 ch(i,k,1) = cc(i,1,k) + ti2 + ti3 cr2 = cc(i-1,1,k) + tr11 * tr2 + tr12 * tr3 ci2 = cc(i,1,k) + tr11 * ti2 + tr12 * ti3 cr3 = cc(i-1,1,k) + tr12 * tr2 + tr11 * tr3 ci3 = cc(i,1,k) + tr12 * ti2 + tr11 * ti3 cr5 = ti11 * tr5 + ti12 * tr4 ci5 = ti11 * ti5 + ti12 * ti4 cr4 = ti12 * tr5 - ti11 * tr4 ci4 = ti12 * ti5 - ti11 * ti4 dr3 = cr3 - ci4 dr4 = cr3 + ci4 di3 = ci3 + cr4 di4 = ci3 - cr4 dr5 = cr2 + ci5 dr2 = cr2 - ci5 di5 = ci2 - cr5 di2 = ci2 + cr5 ch(i-1,k,2) = wa1(i-2) * dr2 - wa1(i-1) * di2 ch(i,k,2) = wa1(i-2) * di2 + wa1(i-1) * dr2 ch(i-1,k,3) = wa2(i-2) * dr3 - wa2(i-1) * di3 ch(i,k,3) = wa2(i-2) * di3 + wa2(i-1) * dr3 ch(i-1,k,4) = wa3(i-2) * dr4 - wa3(i-1) * di4 ch(i,k,4) = wa3(i-2) * di4 + wa3(i-1) * dr4 ch(i-1,k,5) = wa4(i-2) * dr5 - wa4(i-1) * di5 ch(i,k,5) = wa4(i-2) * di5 + wa4(i-1) * dr5 end do end do return end subroutine radbg ( ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa ) !*****************************************************************************80 ! !! RADBG is a lower level routine used by RFFTB1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer idl1 integer ido integer ip integer l1 real ( kind = rk ) ai1 real ( kind = rk ) ai2 real ( kind = rk ) ar1 real ( kind = rk ) ar1h real ( kind = rk ) ar2 real ( kind = rk ) ar2h real ( kind = rk ) arg real ( kind = rk ) c1(ido,l1,ip) real ( kind = rk ) c2(idl1,ip) real ( kind = rk ) cc(ido,ip,l1) real ( kind = rk ) ch(ido,l1,ip) real ( kind = rk ) ch2(idl1,ip) real ( kind = rk ) dc2 real ( kind = rk ) dcp real ( kind = rk ) ds2 real ( kind = rk ) dsp integer i integer ic integer idij integer ik integer ipph integer is integer j integer j2 integer jc integer k integer l integer lc integer nbd real ( kind = rk ) :: pi = 3.141592653589793D+00 real ( kind = rk ) wa(*) arg = 2.0D+00 * pi / real ( ip, kind = rk ) dcp = cos ( arg ) dsp = sin ( arg ) nbd = ( ido - 1 ) / 2 ipph = ( ip + 1 ) / 2 ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1) do j = 2, ipph jc = ip + 2 - j j2 = j + j ch(1,1:l1,j) = cc(ido,j2-2,1:l1) + cc(ido,j2-2,1:l1) ch(1,1:l1,jc) = cc(1,j2-1,1:l1) + cc(1,j2-1,1:l1) end do if ( ido /= 1 ) then if ( l1 <= nbd ) then do j = 2, ipph jc = ip + 2 - j do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i ch(i-1,k,j) = cc(i-1,2*j-1,k) + cc(ic-1,2*j-2,k) ch(i-1,k,jc) = cc(i-1,2*j-1,k) - cc(ic-1,2*j-2,k) ch(i,k,j) = cc(i,2*j-1,k) - cc(ic,2*j-2,k) ch(i,k,jc) = cc(i,2*j-1,k) + cc(ic,2*j-2,k) end do end do end do else do j = 2, ipph jc = ip + 2 - j do i = 3, ido, 2 ic = ido + 2 - i ch(i-1,1:l1,j) = cc(i-1,2*j-1,1:l1) + cc(ic-1,2*j-2,1:l1) ch(i-1,1:l1,jc) = cc(i-1,2*j-1,1:l1) - cc(ic-1,2*j-2,1:l1) ch(i,1:l1,j) = cc(i,2*j-1,1:l1) - cc(ic,2*j-2,1:l1) ch(i,1:l1,jc) = cc(i,2*j-1,1:l1) + cc(ic,2*j-2,1:l1) end do end do end if end if ar1 = 1.0D+00 ai1 = 0.0D+00 do l = 2, ipph lc = ip + 2 - l ar1h = dcp * ar1 - dsp * ai1 ai1 = dcp * ai1 + dsp * ar1 ar1 = ar1h do ik = 1, idl1 c2(ik,l) = ch2(ik,1) + ar1 * ch2(ik,2) c2(ik,lc) = ai1 * ch2(ik,ip) end do dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do j = 3, ipph jc = ip + 2 - j ar2h = dc2 * ar2 - ds2 * ai2 ai2 = dc2 * ai2 + ds2 * ar2 ar2 = ar2h do ik = 1, idl1 c2(ik,l) = c2(ik,l) + ar2 * ch2(ik,j) c2(ik,lc) = c2(ik,lc) + ai2 * ch2(ik,jc) end do end do end do do j = 2, ipph ch2(1:idl1,1) = ch2(1:idl1,1) + ch2(1:idl1,j) end do do j = 2, ipph jc = ip + 2 - j ch(1,1:l1,j) = c1(1,1:l1,j) - c1(1,1:l1,jc) ch(1,1:l1,jc) = c1(1,1:l1,j) + c1(1,1:l1,jc) end do if ( ido /= 1 ) then if ( l1 <= nbd ) then do j = 2, ipph jc = ip + 2 - j do k = 1, l1 do i = 3, ido, 2 ch(i-1,k,j) = c1(i-1,k,j) - c1(i,k,jc) ch(i-1,k,jc) = c1(i-1,k,j) + c1(i,k,jc) ch(i,k,j) = c1(i,k,j) + c1(i-1,k,jc) ch(i,k,jc) = c1(i,k,j) - c1(i-1,k,jc) end do end do end do else do j = 2, ipph jc = ip + 2 - j do i = 3, ido, 2 ch(i-1,1:l1,j) = c1(i-1,1:l1,j) - c1(i,1:l1,jc) ch(i-1,1:l1,jc) = c1(i-1,1:l1,j) + c1(i,1:l1,jc) ch(i,1:l1,j) = c1(i,1:l1,j) + c1(i-1,1:l1,jc) ch(i,1:l1,jc) = c1(i,1:l1,j) - c1(i-1,1:l1,jc) end do end do end if end if if ( ido == 1 ) then return end if c2(1:idl1,1) = ch2(1:idl1,1) c1(1,1:l1,2:ip) = ch(1,1:l1,2:ip) if ( nbd <= l1 ) then is = -ido do j = 2, ip is = is + ido idij = is do i = 3, ido, 2 idij = idij + 2 c1(i-1,1:l1,j) = wa(idij-1) * ch(i-1,1:l1,j) - wa(idij) * ch(i,1:l1,j) c1(i,1:l1,j) = wa(idij-1) * ch(i,1:l1,j) + wa(idij) * ch(i-1,1:l1,j) end do end do else is = -ido do j = 2, ip is = is + ido do k = 1, l1 idij = is do i = 3, ido, 2 idij = idij + 2 c1(i-1,k,j) = wa(idij-1) * ch(i-1,k,j) - wa(idij) * ch(i,k,j) c1(i,k,j) = wa(idij-1) * ch(i,k,j) + wa(idij) * ch(i-1,k,j) end do end do end do end if return end subroutine radf2 ( ido, l1, cc, ch, wa1 ) !*****************************************************************************80 ! !! RADF2 is a lower level routine used by RFFTF1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,l1,2) real ( kind = rk ) ch(ido,2,l1) integer i integer ic integer k real ( kind = rk ) ti2 real ( kind = rk ) tr2 real ( kind = rk ) wa1(ido) ch(1,1,1:l1) = cc(1,1:l1,1) + cc(1,1:l1,2) ch(ido,2,1:l1) = cc(1,1:l1,1) - cc(1,1:l1,2) if ( ido < 2 ) then return end if if ( 2 < ido ) then do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i tr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2) ti2 = wa1(i-2) * cc(i,k,2) - wa1(i-1) * cc(i-1,k,2) ch(i,1,k) = cc(i,k,1) + ti2 ch(ic,2,k) = ti2 - cc(i,k,1) ch(i-1,1,k) = cc(i-1,k,1) + tr2 ch(ic-1,2,k) = cc(i-1,k,1) - tr2 end do end do if ( mod ( ido, 2 ) == 1 ) then return end if end if ch(1,2,1:l1) = -cc(ido,1:l1,2) ch(ido,1,1:l1) = cc(ido,1:l1,1) return end subroutine radf3 ( ido, l1, cc, ch, wa1, wa2 ) !*****************************************************************************80 ! !! RADF3 is a lower level routine used by RFFTF1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,l1,3) real ( kind = rk ) ch(ido,3,l1) real ( kind = rk ) ci2 real ( kind = rk ) cr2 real ( kind = rk ) di2 real ( kind = rk ) di3 real ( kind = rk ) dr2 real ( kind = rk ) dr3 integer i integer ic integer k real ( kind = rk ), parameter :: taui = 0.866025403784439D+00 real ( kind = rk ), parameter :: taur = -0.5D+00 real ( kind = rk ) ti2 real ( kind = rk ) ti3 real ( kind = rk ) tr2 real ( kind = rk ) tr3 real ( kind = rk ) wa1(ido) real ( kind = rk ) wa2(ido) do k = 1, l1 cr2 = cc(1,k,2) + cc(1,k,3) ch(1,1,k) = cc(1,k,1) + cr2 ch(1,3,k) = taui * ( cc(1,k,3) - cc(1,k,2) ) ch(ido,2,k) = cc(1,k,1) + taur * cr2 end do if ( ido == 1 ) then return end if do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i dr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2) di2 = wa1(i-2) * cc(i,k,2) - wa1(i-1) * cc(i-1,k,2) dr3 = wa2(i-2) * cc(i-1,k,3) + wa2(i-1) * cc(i,k,3) di3 = wa2(i-2) * cc(i,k,3) - wa2(i-1) * cc(i-1,k,3) cr2 = dr2 + dr3 ci2 = di2 + di3 ch(i-1,1,k) = cc(i-1,k,1) + cr2 ch(i,1,k) = cc(i,k,1) + ci2 tr2 = cc(i-1,k,1) + taur * cr2 ti2 = cc(i,k,1) + taur * ci2 tr3 = taui * ( di2 - di3 ) ti3 = taui * ( dr3 - dr2 ) ch(i-1,3,k) = tr2 + tr3 ch(ic-1,2,k) = tr2 - tr3 ch(i,3,k) = ti2 + ti3 ch(ic,2,k) = ti3 - ti2 end do end do return end subroutine radf4 ( ido, l1, cc, ch, wa1, wa2, wa3 ) !*****************************************************************************80 ! !! RADF4 is a lower level routine used by RFFTF1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,l1,4) real ( kind = rk ) ch(ido,4,l1) real ( kind = rk ) ci2 real ( kind = rk ) ci3 real ( kind = rk ) ci4 real ( kind = rk ) cr2 real ( kind = rk ) cr3 real ( kind = rk ) cr4 real ( kind = rk ), parameter :: hsqt2 = 0.7071067811865475D+00 integer i integer ic integer k real ( kind = rk ) ti1 real ( kind = rk ) ti2 real ( kind = rk ) ti3 real ( kind = rk ) ti4 real ( kind = rk ) tr1 real ( kind = rk ) tr2 real ( kind = rk ) tr3 real ( kind = rk ) tr4 real ( kind = rk ) wa1(ido) real ( kind = rk ) wa2(ido) real ( kind = rk ) wa3(ido) do k = 1, l1 tr1 = cc(1,k,2) + cc(1,k,4) tr2 = cc(1,k,1) + cc(1,k,3) ch(1,1,k) = tr1 + tr2 ch(ido,4,k) = tr2 - tr1 ch(ido,2,k) = cc(1,k,1) - cc(1,k,3) ch(1,3,k) = cc(1,k,4) - cc(1,k,2) end do if ( ido < 2 ) then return end if if ( 2 < ido ) then do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i cr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2) ci2 = wa1(i-2) * cc(i,k,2) - wa1(i-1) * cc(i-1,k,2) cr3 = wa2(i-2) * cc(i-1,k,3) + wa2(i-1) * cc(i,k,3) ci3 = wa2(i-2) * cc(i,k,3) - wa2(i-1) * cc(i-1,k,3) cr4 = wa3(i-2) * cc(i-1,k,4) + wa3(i-1) * cc(i,k,4) ci4 = wa3(i-2) * cc(i,k,4) - wa3(i-1) * cc(i-1,k,4) tr1 = cr2+cr4 tr4 = cr4-cr2 ti1 = ci2+ci4 ti4 = ci2-ci4 ti2 = cc(i,k,1) + ci3 ti3 = cc(i,k,1) - ci3 tr2 = cc(i-1,k,1) + cr3 tr3 = cc(i-1,k,1) - cr3 ch(i-1,1,k) = tr1 + tr2 ch(ic-1,4,k) = tr2 - tr1 ch(i,1,k) = ti1 + ti2 ch(ic,4,k) = ti1 - ti2 ch(i-1,3,k) = ti4 + tr3 ch(ic-1,2,k) = tr3 - ti4 ch(i,3,k) = tr4 + ti3 ch(ic,2,k) = tr4 - ti3 end do end do if ( mod ( ido, 2 ) == 1 ) then return end if end if do k = 1, l1 ti1 = -hsqt2 * ( cc(ido,k,2) + cc(ido,k,4) ) tr1 = hsqt2 * ( cc(ido,k,2) - cc(ido,k,4) ) ch(ido,1,k) = tr1 + cc(ido,k,1) ch(ido,3,k) = cc(ido,k,1) - tr1 ch(1,2,k) = ti1 - cc(ido,k,3) ch(1,4,k) = ti1 + cc(ido,k,3) end do return end subroutine radf5 ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 ) !*****************************************************************************80 ! !! RADF5 is a lower level routine used by RFFTF1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ido integer l1 real ( kind = rk ) cc(ido,l1,5) real ( kind = rk ) ch(ido,5,l1) real ( kind = rk ) ci2 real ( kind = rk ) ci3 real ( kind = rk ) ci4 real ( kind = rk ) ci5 real ( kind = rk ) cr2 real ( kind = rk ) cr3 real ( kind = rk ) cr4 real ( kind = rk ) cr5 real ( kind = rk ) di2 real ( kind = rk ) di3 real ( kind = rk ) di4 real ( kind = rk ) di5 real ( kind = rk ) dr2 real ( kind = rk ) dr3 real ( kind = rk ) dr4 real ( kind = rk ) dr5 integer i integer ic integer k real ( kind = rk ), parameter :: ti11 = 0.951056516295154D+00 real ( kind = rk ), parameter :: ti12 = 0.587785252292473D+00 real ( kind = rk ) ti2 real ( kind = rk ) ti3 real ( kind = rk ) ti4 real ( kind = rk ) ti5 real ( kind = rk ), parameter :: tr11 = 0.309016994374947D+00 real ( kind = rk ), parameter :: tr12 = -0.809016994374947D+00 real ( kind = rk ) tr2 real ( kind = rk ) tr3 real ( kind = rk ) tr4 real ( kind = rk ) tr5 real ( kind = rk ) wa1(ido) real ( kind = rk ) wa2(ido) real ( kind = rk ) wa3(ido) real ( kind = rk ) wa4(ido) do k = 1, l1 cr2 = cc(1,k,5) + cc(1,k,2) ci5 = cc(1,k,5) - cc(1,k,2) cr3 = cc(1,k,4) + cc(1,k,3) ci4 = cc(1,k,4) - cc(1,k,3) ch(1,1,k) = cc(1,k,1) + cr2 + cr3 ch(ido,2,k) = cc(1,k,1) + tr11 * cr2 + tr12 * cr3 ch(1,3,k) = ti11 * ci5 + ti12 * ci4 ch(ido,4,k) = cc(1,k,1) + tr12 * cr2 + tr11 * cr3 ch(1,5,k) = ti12 * ci5 - ti11 * ci4 end do if ( ido == 1 ) then return end if do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i dr2 = wa1(i-2) * cc(i-1,k,2) + wa1(i-1) * cc(i,k,2) di2 = wa1(i-2) * cc(i,k,2) - wa1(i-1) * cc(i-1,k,2) dr3 = wa2(i-2) * cc(i-1,k,3) + wa2(i-1) * cc(i,k,3) di3 = wa2(i-2) * cc(i,k,3) - wa2(i-1) * cc(i-1,k,3) dr4 = wa3(i-2) * cc(i-1,k,4) + wa3(i-1) * cc(i,k,4) di4 = wa3(i-2) * cc(i,k,4) - wa3(i-1) * cc(i-1,k,4) dr5 = wa4(i-2) * cc(i-1,k,5) + wa4(i-1) * cc(i,k,5) di5 = wa4(i-2) * cc(i,k,5) - wa4(i-1) * cc(i-1,k,5) cr2 = dr2 + dr5 ci5 = dr5 - dr2 cr5 = di2 - di5 ci2 = di2 + di5 cr3 = dr3 + dr4 ci4 = dr4 - dr3 cr4 = di3 - di4 ci3 = di3 + di4 ch(i-1,1,k) = cc(i-1,k,1) + cr2 + cr3 ch(i,1,k) = cc(i,k,1) + ci2 + ci3 tr2 = cc(i-1,k,1) + tr11 * cr2 + tr12 * cr3 ti2 = cc(i,k,1) + tr11 * ci2 + tr12 * ci3 tr3 = cc(i-1,k,1) + tr12 * cr2 + tr11 * cr3 ti3 = cc(i,k,1) + tr12 * ci2 + tr11 * ci3 tr5 = ti11 * cr5 + ti12 * cr4 ti5 = ti11 * ci5 + ti12 * ci4 tr4 = ti12 * cr5 - ti11 * cr4 ti4 = ti12 * ci5 - ti11 * ci4 ch(i-1,3,k) = tr2 + tr5 ch(ic-1,2,k) = tr2 - tr5 ch(i,3,k) = ti2 + ti5 ch(ic,2,k) = ti5 - ti2 ch(i-1,5,k) = tr3 + tr4 ch(ic-1,4,k) = tr3 - tr4 ch(i,5,k) = ti3 + ti4 ch(ic,4,k) = ti4 - ti3 end do end do return end subroutine radfg ( ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa ) !*****************************************************************************80 ! !! RADFG is a lower level routine used by RFFTF1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer idl1 integer ido integer ip integer l1 real ( kind = rk ) ai1 real ( kind = rk ) ai2 real ( kind = rk ) ar1 real ( kind = rk ) ar1h real ( kind = rk ) ar2 real ( kind = rk ) ar2h real ( kind = rk ) arg real ( kind = rk ) c1(ido,l1,ip) real ( kind = rk ) c2(idl1,ip) real ( kind = rk ) cc(ido,ip,l1) real ( kind = rk ) ch(ido,l1,ip) real ( kind = rk ) ch2(idl1,ip) real ( kind = rk ) dc2 real ( kind = rk ) dcp real ( kind = rk ) ds2 real ( kind = rk ) dsp integer i integer ic integer idij integer ik integer ipph integer is integer j integer j2 integer jc integer k integer l integer lc integer nbd real ( kind = rk ) :: pi = 3.141592653589793D+00 real ( kind = rk ) wa(*) arg = 2.0D+00 * pi / real ( ip, kind = rk ) dcp = cos ( arg ) dsp = sin ( arg ) ipph = ( ip + 1 ) / 2 nbd = ( ido - 1 ) / 2 if ( ido == 1 ) then c2(1:idl1,1) = ch2(1:idl1,1) else ch2(1:idl1,1) = c2(1:idl1,1) ch(1,1:l1,2:ip) = c1(1,1:l1,2:ip) if ( nbd <= l1 ) then is = -ido do j = 2, ip is = is + ido idij = is do i = 3, ido, 2 idij = idij + 2 do k = 1, l1 ch(i-1,k,j) = wa(idij-1) * c1(i-1,k,j) + wa(idij) * c1(i,k,j) ch(i,k,j) = wa(idij-1) * c1(i,k,j) - wa(idij) * c1(i-1,k,j) end do end do end do else is = -ido do j = 2, ip is = is + ido do k = 1, l1 idij = is do i = 3, ido, 2 idij = idij + 2 ch(i-1,k,j) = wa(idij-1) * c1(i-1,k,j) + wa(idij) * c1(i,k,j) ch(i,k,j) = wa(idij-1) * c1(i,k,j) - wa(idij) * c1(i-1,k,j) end do end do end do end if if ( l1 <= nbd ) then do j = 2, ipph jc = ip + 2 - j do k = 1, l1 do i = 3, ido, 2 c1(i-1,k,j) = ch(i-1,k,j) + ch(i-1,k,jc) c1(i-1,k,jc) = ch(i,k,j) - ch(i,k,jc) c1(i,k,j) = ch(i,k,j) + ch(i,k,jc) c1(i,k,jc) = ch(i-1,k,jc) - ch(i-1,k,j) end do end do end do else do j = 2, ipph jc = ip + 2 - j do i = 3, ido, 2 c1(i-1,1:l1,j) = ch(i-1,1:l1,j) + ch(i-1,1:l1,jc) c1(i-1,1:l1,jc) = ch(i,1:l1,j) - ch(i,1:l1,jc) c1(i,1:l1,j) = ch(i,1:l1,j) + ch(i,1:l1,jc) c1(i,1:l1,jc) = ch(i-1,1:l1,jc) - ch(i-1,1:l1,j) end do end do end if end if do j = 2, ipph jc = ip + 2 - j c1(1,1:l1,j) = ch(1,1:l1,j) + ch(1,1:l1,jc) c1(1,1:l1,jc) = ch(1,1:l1,jc) - ch(1,1:l1,j) end do ar1 = 1.0D+00 ai1 = 0.0D+00 do l = 2, ipph lc = ip + 2 - l ar1h = dcp * ar1 - dsp * ai1 ai1 = dcp * ai1 + dsp * ar1 ar1 = ar1h do ik = 1, idl1 ch2(ik,l) = c2(ik,1) + ar1 * c2(ik,2) ch2(ik,lc) = ai1 * c2(ik,ip) end do dc2 = ar1 ds2 = ai1 ar2 = ar1 ai2 = ai1 do j = 3, ipph jc = ip + 2 - j ar2h = dc2 * ar2 - ds2 * ai2 ai2 = dc2 * ai2 + ds2 * ar2 ar2 = ar2h do ik = 1, idl1 ch2(ik,l) = ch2(ik,l) + ar2 * c2(ik,j) ch2(ik,lc) = ch2(ik,lc) + ai2 * c2(ik,jc) end do end do end do do j = 2, ipph ch2(1:idl1,1) = ch2(1:idl1,1) + c2(1:idl1,j) end do cc(1:ido,1,1:l1) = ch(1:ido,1:l1,1) do j = 2, ipph jc = ip + 2 - j j2 = j + j cc(ido,j2-2,1:l1) = ch(1,1:l1,j) cc(1,j2-1,1:l1) = ch(1,1:l1,jc) end do if ( ido == 1 ) then return end if if ( l1 <= nbd ) then do j = 2, ipph jc = ip + 2 - j j2 = j + j do k = 1, l1 do i = 3, ido, 2 ic = ido + 2 - i cc(i-1,j2-1,k) = ch(i-1,k,j) + ch(i-1,k,jc) cc(ic-1,j2-2,k) = ch(i-1,k,j) - ch(i-1,k,jc) cc(i,j2-1,k) = ch(i,k,j) + ch(i,k,jc) cc(ic,j2-2,k) = ch(i,k,jc) - ch(i,k,j) end do end do end do else do j = 2, ipph jc = ip + 2 - j j2 = j + j do i = 3, ido, 2 ic = ido + 2 - i cc(i-1,j2-1,1:l1) = ch(i-1,1:l1,j) + ch(i-1,1:l1,jc) cc(ic-1,j2-2,1:l1) = ch(i-1,1:l1,j) - ch(i-1,1:l1,jc) cc(i,j2-1,1:l1) = ch(i,1:l1,j) + ch(i,1:l1,jc) cc(ic,j2-2,1:l1) = ch(i,1:l1,jc) - ch(i,1:l1,j) end do end do end if return end subroutine result ( nr, n, x, f, g, a, p, itncnt, iflg, ipr ) !*****************************************************************************80 ! !! RESULT prints information about the optimization process. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) X(N), the current iterate. ! ! Input, real ( kind = rk ) F, the function value at X. ! ! Input, real ( kind = rk ) G(N), the gradient at X. ! ! Input, real ( kind = rk ) A(NR,N), the N by N Hessian matrix at X. ! ! Input, real ( kind = rk ) P(N), the step taken. ! ! Input, integer ITNCNT, the iteration number. ! ! Input, integer IFLG, the flag controlling the amount ! of printout. ! ! Input, integer IPR, the device to which to send output. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) f real ( kind = rk ) g(n) integer i integer iflg integer ipr integer itncnt real ( kind = rk ) p(n) real ( kind = rk ) x(n) write ( ipr, 903 ) itncnt if ( iflg /= 0 ) then write ( ipr, * ) ' result step' write ( ipr,905) p(1:n) end if write ( ipr, * ) ' result x(k)' write ( ipr, 905) x(1:n) write ( ipr, * ) ' result function at x(k)' write ( ipr, 905) f write ( ipr, * ) ' result gradient at x(k)' write ( ipr, 905) g(1:n) if ( iflg /= 0 ) then write ( ipr, * ) ' result Hessian at x(k)' do i = 1, n write ( ipr, 900) i write ( ipr, 902) a(i,1:i) end do end if return 900 format(' result row',i5) 902 format(' result ',5(2x,e20.13)) 903 format(/'0result iterate k=',i5) 905 format(' result ',5(2x,e20.13) ) end function runge ( x ) !*****************************************************************************80 ! !! RUNGE evaluates Runge's function. ! ! Discussion: ! ! Runge's function is a common test case for interpolation ! and approximation, over the interval [-1,1]. ! ! RUNGE(X) = 1 / ( 1 + 25 * X**2 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) X, the argument of Runge's function. ! ! Output, real ( kind = rk ) RUNGE, the value of Runge's function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) runge real ( kind = rk ) x runge = 1.0D+00 / ( 1.0D+00 + 25.0D+00 * x * x ) return end function rungep ( x ) !*****************************************************************************80 ! !! RUNGEP evaluates the derivative of Runge's function. ! ! Discussion: ! ! Runge's function is a common test case for interpolation ! and approximation, over the interval [-1,1]. ! ! RUNGE(X) = 1 / ( 1 + 25 * X**2 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 11 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = rk ) X, the evaluation point. ! ! Output, real ( kind = rk ) RUNGEP, the derivative of Runge's function. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ) rungep real ( kind = rk ) x rungep = ( -50.0D+00 * x ) / ( 1.0D+00 + 25.0D+00 * x * x )**2 return end subroutine secfac ( nr, n, x, g, a, xpls, gpls, epsm, itncnt, rnf, & iagflg, noupdt, s, y, u, w ) !*****************************************************************************80 ! !! SECFAC updates the hessian by the BFGS factored method. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) X(N), the old iterate, X[K-1]. ! ! Input, real ( kind = rk ) G(N), the gradient or an approximation, ! at the old iterate. ! ! Input/output, real ( kind = rk ) A(NR,N). ! On input, the Cholesky decomposition of hessian in lower part and diagonal. ! On output, the updated Cholesky decomposition of hessian ! in lower triangular part and diagonal ! ! Input, real ( kind = rk ) XPLS(N), the new iterate, X[K]. ! ! Input, real ( kind = rk ) GPLSN(N), gradient, or an approximation, ! at the new iterate. ! ! Input, real ( kind = rk ) EPSM, the machine epsilon. ! ! Input, integer ITNCNT, the iteration count. ! ! Input, real ( kind = rk ) RNF, the relative noise in the optimization ! function FCN. ! ! Input, integer IAGFLG, 1 if analytic gradient supplied. ! ! Input/output, logical NOUPDT, is TRUE if there has been no update ! yet. The user should retain the output value between successive ! calls. ! ! Workspace, real ( kind = rk ) S(N). ! ! Workspace, real ( kind = rk ) Y(N). ! ! Workspace, real ( kind = rk ) U(N). ! ! Workspace, real ( kind = rk ) W(N). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) alp real ( kind = rk ) den1 real ( kind = rk ) den2 real ( kind = rk ) dnrm2 real ( kind = rk ) epsm real ( kind = rk ) g(n) real ( kind = rk ) gpls(n) integer i integer iagflg integer itncnt integer j logical noupdt real ( kind = rk ) reltol real ( kind = rk ) rnf real ( kind = rk ) s(n) logical skpupd real ( kind = rk ) snorm2 real ( kind = rk ) u(n) real ( kind = rk ) w(n) real ( kind = rk ) x(n) real ( kind = rk ) xpls(n) real ( kind = rk ) y(n) real ( kind = rk ) ynrm2 if ( itncnt == 1 ) then noupdt = .true. end if s(1:n) = xpls(1:n) - x(1:n) y(1:n) = gpls(1:n) - g(1:n) den1 = dot_product ( s, y ) snorm2 = dnrm2 ( n, s, 1) ynrm2 = dnrm2 ( n, y, 1) if ( den1 < sqrt ( epsm ) * snorm2 * ynrm2 ) then return end if call mvmltu ( nr, n, a, s, u ) den2 = dot_product ( u, u ) ! ! L <-- sqrt ( den1 / den2 ) * L ! alp = sqrt ( den1 / den2 ) if ( noupdt ) then u(1:n) = alp * u(1:n) do j = 1, n do i = j, n a(i,j) = alp * a(i,j) end do end do noupdt = .false. den2 = den1 alp = 1.0D+00 end if skpupd = .true. ! ! W = l(l+)s = hs ! call mvmltl ( nr, n, a, u, w ) i = 1 if ( iagflg == 0 ) then reltol = sqrt ( rnf ) else reltol = rnf end if 60 continue if ( i <= n .and. skpupd ) then if ( abs ( y(i) - w(i) ) < reltol * & max ( abs ( g(i) ), abs ( gpls(i) ) ) ) then i = i + 1 else skpupd = .false. end if go to 60 end if if ( skpupd ) then return end if ! ! W = y-alp*l(l+)s ! w(1:n) = y(1:n) - alp * w(1:n) ! ! ALP = 1 / sqrt ( den1 * den2 ) ! alp = alp / den1 ! ! U = (l+) / sqrt ( den1 * den2 ) = (l+)s/ sqrt ( ( y+ ) s * (s+) l (l+) s ) ! u(1:n) = alp * u(1:n) ! ! Copy L into upper triangular part. Zero L. ! do i = 2, n do j = 1, i-1 a(j,i) = a(i,j) a(i,j) = 0.0D+00 end do end do ! ! Find Q, (l+) such that q(l+) = (l+) + u(w+) ! call qrupdt ( nr, n, a, u, w ) ! ! Upper triangular part and diagonal of a now contain updated ! Cholesky decomposition of hessian. Copy back to lower triangular part. ! do i = 2, n do j = 1, i-1 a(i,j) = a(j,i) end do end do return end subroutine secunf ( nr, n, x, g, a, udiag, xpls, gpls, epsm, itncnt, & rnf, iagflg, noupdt, s, y, t ) !*****************************************************************************80 ! !! SECUNF updates a Hessian matrix by the BFGS unfactored method. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) X(N), the old iterate, X[K-1]. ! ! Input, real ( kind = rk ) G(N), the gradient, or an approximate value, ! at the old iterate. ! ! Input/output, real ( kind = rk ) A(NR,N). ! on entry: approximate hessian at old iterate ! in upper triangular part (and udiag) ! on exit: updated approx hessian at new iterate ! in lower triangular part and diagonal ! [lower triangular part of symmetric matrix] ! ! Input, real ( kind = rk ) UDIAG(N), the diagonal entries of the hessian. ! ! Input, real ( kind = rk ) XPLS(N), the new iterate, X[K]. ! ! Input, real ( kind = rk ) GPLS(N), the gradient or an approximate value, at ! the new iterate ! ! Input, real ( kind = rk ) EPSM, the machine epsilon. ! ! Input, integer ITNCNT, the iteration count. ! ! Input, real ( kind = rk ) RNF, the relative noise in the optimization ! function. ! ! Input, integer IAGFLG, =1 if analytic gradient supplied, ! =0 otherwise ! ! Input/output, logical NOUPDT, TRUE if no update yet. ! [retain value between successive calls] ! ! Workspace, real ( kind = rk ) S(N). ! ! Workspace, real ( kind = rk ) Y(N). ! ! Workspace, real ( kind = rk ) T(N). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) den1 real ( kind = rk ) den2 real ( kind = rk ) dnrm2 real ( kind = rk ) epsm real ( kind = rk ) g(n) real ( kind = rk ) gam real ( kind = rk ) gpls(n) integer i integer iagflg integer itncnt integer j logical noupdt real ( kind = rk ) rnf real ( kind = rk ) s(n) logical skpupd real ( kind = rk ) snorm2 real ( kind = rk ) t(n) real ( kind = rk ) tol real ( kind = rk ) udiag(n) real ( kind = rk ) x(n) real ( kind = rk ) xpls(n) real ( kind = rk ) y(n) real ( kind = rk ) ynrm2 ! ! Copy hessian in upper triangular part and UDIAG to ! lower triangular part and diagonal. ! do j = 1, n a(j,j) = udiag(j) do i = j+1, n a(i,j) = a(j,i) end do end do if ( itncnt == 1 ) then noupdt = .true. end if s(1:n) = xpls(1:n) - x(1:n) y(1:n) = gpls(1:n) - g(1:n) den1 = dot_product ( s, y ) snorm2 = dnrm2 ( n, s, 1 ) ynrm2 = dnrm2 ( n, y, 1 ) if ( den1 < sqrt ( epsm ) * snorm2 * ynrm2 ) then return end if call mvmlts ( nr, n, a, s, t ) den2 = dot_product ( s, t ) if ( noupdt ) then ! ! H <-- [(s+)y/(s+)hs]h ! gam = den1 / den2 den2 = gam * den2 do j = 1, n t(j) = gam * t(j) do i = j, n a(i,j) = gam * a(i,j) end do end do noupdt = .false. end if skpupd = .true. ! ! Check update condition on row I. ! do i = 1, n tol = rnf * max ( abs ( g(i) ), abs ( gpls(i) ) ) if ( iagflg == 0 ) then tol = tol / sqrt ( rnf ) end if if ( tol <= abs ( y(i) - t(i) ) ) then skpupd = .false. exit end if end do if ( skpupd ) then return end if ! ! BFGS update ! do j = 1, n do i = j, n a(i,j) = a(i,j) + y(i) * y(j) / den1 - t(i) * t(j) / den2 end do end do return end subroutine sinqb ( n, x, wsave ) !*****************************************************************************80 ! !! SINQB computes the fast sine transform of quarter wave data. ! ! Discussion: ! ! SINQB computes a sequence from its representation in terms of a sine ! series with odd wave numbers. ! ! SINQF is the unnormalized inverse of SINQB since a call of SINQB ! followed by a call of SINQF will multiply the input sequence X by 4*N. ! ! The array WSAVE must be initialized by calling SINQI. ! ! The transform is defined by: ! ! X_out(I) = sum ( 1 <= K <= N ) ! ! 4 * X_in(K) * sin ( ( 2 * K - 1 ) * I * PI / ( 2 * N ) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! The method is more efficient when N is the product of small primes. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) WSAVE(3*N+15), a work array. The WSAVE array ! must be initialized by calling SINQI. A different WSAVE array must be ! used for each different value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) wsave(3*n+15) real ( kind = rk ) x(n) if ( n < 1 ) then return end if if ( n == 1 ) then x(1) = 4.0D+00 * x(1) return end if x(2:n:2) = -x(2:n:2) call cosqb ( n, x, wsave ) ! ! Reverse the X vector. ! call r8vec_reverse ( n, x ) return end subroutine sinqf ( n, x, wsave ) !*****************************************************************************80 ! !! SINQF computes the fast sine transform of quarter wave data. ! ! Discussion: ! ! SINQF computes the coefficients in a sine series representation with ! only odd wave numbers. ! ! SINQB is the unnormalized inverse of SINQF since a call of SINQF ! followed by a call of SINQB will multiply the input sequence X by 4*N. ! ! The array WSAVE, which is used by SINQF, must be initialized by ! calling SINQI. ! ! The transform is defined by: ! ! X_out(I) = (-1)**(I-1) * X_in(N) + sum ( 1 <= K <= N-1 ) ! 2 * X_in(K) * sin ( ( 2 * I - 1 ) * K * PI / ( 2 * N ) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! The method is more efficient when N is the product of small primes. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) WSAVE(3*N+15), a work array. The WSAVE array ! must be initialized by calling SINQI. A different WSAVE array must be ! used for each different value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) wsave(3*n+15) real ( kind = rk ) x(n) if ( n <= 1 ) then return end if ! ! Reverse the X vector. ! call r8vec_reverse ( n, x ) call cosqf ( n, x, wsave ) x(2:n:2) = -x(2:n:2) return end subroutine sinqi ( n, wsave ) !*****************************************************************************80 ! !! SINQI initializes WSAVE, used in SINQF and SINQB. ! ! Discussion: ! ! The prime factorization of N together with a tabulation of the ! trigonometric functions are computed and stored in WSAVE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Output, real ( kind = rk ) WSAVE(3*N+15), contains data, dependent on ! the value of N, which is necessary for the SINQF or SINQB routines. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) wsave(3*n+15) call cosqi ( n, wsave ) return end subroutine sint ( n, x, wsave ) !*****************************************************************************80 ! !! SINT computes the discrete Fourier sine transform of an odd sequence. ! ! Discussion: ! ! SINT is the unnormalized inverse of itself since a call of SINT ! followed by another call of SINT will multiply the input sequence ! X by 2*(N+1). ! ! The array WSAVE must be initialized by calling SINTI. ! ! The transform is defined by: ! ! X_out(I) = sum ( 1 <= K <= N ) ! 2 * X_in(K) * sin ( K * I * PI / ( N + 1 ) ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. The method is most efficient when N+1 is the product of ! small primes. ! ! Input/output, real ( kind = rk ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) WSAVE((5*N+30)/2), a work array. The WSAVE ! array must be initialized by calling SINTI. A different WSAVE array ! must be used for each different value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer iw1 integer iw2 integer iw3 real ( kind = rk ) wsave((5*n+30)/2) real ( kind = rk ) x(n) iw1 = ( n / 2 ) + 1 iw2 = iw1 + n + 1 iw3 = iw2 + n + 1 call sint1 ( n, x, wsave(1), wsave(iw1), wsave(iw2), wsave(iw3) ) return end subroutine sint1 ( n, war, was, xh, x, ifac ) !*****************************************************************************80 ! !! SINT1 is a lower level routine used by SINT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to ! be transformed. ! ! Input/output, real ( kind = rk ) WAR(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = rk ) WAS(N/2). ! ! Input, real ( kind = rk ) XH(N). ! ! Input, real ( kind = rk ) X(N+1). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer ifac(15) integer k integer ns2 real ( kind = rk ), parameter :: sqrt3 = 1.73205080756888D+00 real ( kind = rk ) t1 real ( kind = rk ) t2 real ( kind = rk ) war(n) real ( kind = rk ) was(n/2) real ( kind = rk ) x(n+1) real ( kind = rk ) xh(n) real ( kind = rk ) xhold xh(1:n) = war(1:n) war(1:n) = x(1:n) if ( n <= 1 ) then xh(1) = 2.0D+00 * xh(1) return end if if ( n == 2 ) then xhold = sqrt3 * ( xh(1) + xh(2) ) xh(2) = sqrt3 * ( xh(1) - xh(2) ) xh(1) = xhold return end if ns2 = n / 2 x(1) = 0.0D+00 do k = 1, n/2 t1 = xh(k) - xh(n+1-k) t2 = was(k) * ( xh(k) + xh(n+1-k) ) x(k+1) = t1 + t2 x(n+2-k) = t2 - t1 end do if ( mod ( n, 2 ) /= 0 ) then x(n/2+2) = 4.0D+00 * xh(n/2+1) end if call dfftf1 ( n+1, x, xh, war, ifac ) xh(1) = 0.5D+00 * x(1) do i = 3, n, 2 xh(i-1) = -x(i) xh(i) = xh(i-2) + x(i-1) end do if ( mod ( n, 2 ) == 0 ) then xh(n) = -x(n+1) end if x(1:n) = war(1:n) war(1:n) = xh(1:n) return end subroutine sinti ( n, wsave ) !*****************************************************************************80 ! !! SINTI initializes WSAVE, used in SINT. ! ! Discussion: ! ! The prime factorization of N together with a tabulation of the ! trigonometric functions are computed and stored in WSAVE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to ! be transformed. The method is most efficient when N+1 is a product of ! small primes. ! ! Output, real ( kind = rk ) WSAVE((5*N+30)/2), contains data, dependent ! on the value of N, which is necessary for the SINT routine. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) :: pi = 3.141592653589793D+00 real ( kind = rk ) dt integer k real ( kind = rk ) wsave((5*n+30)/2) if ( n <= 1 ) then return end if dt = pi / real ( n + 1, kind = rk ) do k = 1, n/2 wsave(k) = 2.0D+00 * sin ( real ( k, kind = rk ) * dt ) end do call dffti ( n+1, wsave((n/2)+1) ) return end subroutine sndofd ( nr, n, xpls, fcn, fpls, a, sx, rnoise, stepsz, anbr ) !*****************************************************************************80 ! !! SNDOFD approximates a Hessian with a second order finite difference. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) XPLS(N), the new iterate, X[K]. ! ! Input, external FCN, the name of the subroutine to evaluate the function, ! of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real x(n) ! real f ! ! Input, real ( kind = rk ) FPLS, the function value at the new iterate. ! ! Output, real ( kind = rk ) A(NR,N), the N by N finite difference ! approximation to the hessian matrix. Only the lower triangular matrix and ! diagonal are returned. ! ! Input, real ( kind = rk ) SX(N), the diagonal scaling for X. ! ! Input, real ( kind = rk ) RNOISE, the relative noise in the function. ! ! Workspace, real ( kind = rk ) STEPSZ(N), used for the stepsize. ! ! Workspace, real ( kind = rk ) ANBR(N), holds neighbors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) anbr(n) external fcn real ( kind = rk ) fhat real ( kind = rk ) fpls integer i integer j real ( kind = rk ) ov3 real ( kind = rk ) rnoise real ( kind = rk ) stepsz(n) real ( kind = rk ) sx(n) real ( kind = rk ) xpls(n) real ( kind = rk ) xtmpi real ( kind = rk ) xtmpj ! ! Find I-th stepsize and evaluate neighbor in direction of I-th unit vector. ! ov3 = 1.0D+00 / 3.0D+00 do i = 1, n stepsz(i) = rnoise**ov3 * max ( abs ( xpls(i) ), 1.0D+00 / sx(i) ) xtmpi = xpls(i) xpls(i) = xtmpi + stepsz(i) call fcn ( n, xpls, anbr(i) ) xpls(i) = xtmpi end do ! ! Calculate column I of A. ! do i = 1, n xtmpi = xpls(i) xpls(i) = xtmpi + 2.0D+00 * stepsz(i) call fcn ( n, xpls, fhat ) a(i,i) = ( ( fpls - anbr(i) ) & + ( fhat - anbr(i) ) ) / ( stepsz(i) * stepsz(i) ) ! ! Calculate sub-diagonal elements of column. ! if ( i /= n ) then xpls(i) = xtmpi + stepsz(i) do j = i + 1, n xtmpj = xpls(j) xpls(j) = xtmpj + stepsz(j) call fcn ( n, xpls, fhat ) a(j,i) = ( ( fpls - anbr(i) ) + ( fhat - anbr(j) ) ) & / ( stepsz(i) * stepsz(j) ) xpls(j) = xtmpj end do end if xpls(i) = xtmpi end do return end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 18 May 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = 8 ) ampm integer d integer h integer m integer mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer n integer s integer values(8) integer y call date_and_time ( values = values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine tregup ( nr, n, x, f, g, a, fcn, sc, sx, nwtake, stepmx, steptl, & dlt, iretcd, xplsp, fplsp, xpls, fpls, mxtake, ipr, method, udiag ) !*****************************************************************************80 ! !! TREGUP decides whether to accept the next optimization iterate. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) X(N), the old iterate X[K-1]. ! ! Input, real ( kind = rk ) F, the function value at the old iterate. ! ! Input, real ( kind = rk ) G(N), the gradient at the old iterate, or ! an approximate value of it. ! ! Input, real ( kind = rk ) A(NR,N), the Cholesky decomposition of hessian in ! lower triangular part and diagonal. Hessian or approximation in ! upper triangular part. ! ! Input, external FCN, the name of the subroutine to evaluate the function, ! of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real ( kind = rk ) x(n) ! real ( kind = rk ) f ! ! Input, real ( kind = rk ) SC(N), the current step. ! ! Input, real ( kind = rk ) SX(N), the diagonal scaling matrix for X. ! ! Input, logical NWTAKE, is TRUE if a Newton step is taken. ! ! Input, real ( kind = rk ) STEPMX, the maximum allowable step size. ! ! Input, real ( kind = rk ) STEPTL, the relative step size at which successive ! iterates are considered close enough to terminate algorithm. ! ! Input/output, real ( kind = rk ) DLT, the trust region radius. ! ! Input/output, integer IRETCD, the status code. ! 0, xpls accepted as next iterate; dlt trust region for next iteration. ! 1, xpls unsatisfactory but accepted as next iterate because ! xpls-x < smallest allowable step length. ! 2, f(xpls) too large. continue current iteration with new reduced dlt. ! 3, f(xpls) sufficiently small, but quadratic model predicts f(xpls) ! sufficiently well to continue current iteration with new doubled dlt. ! ! Workspace, real ( kind = rk ) XPLSP(N), [value needs to be retained between ! succesive calls of k-th global step]. ! ! Worskpace, real ( kind = rk ) FPLSP, [retain value between successive ! calls]. ! ! Output, real ( kind = rk ) XPLS(N), the new iterate x[k]. ! ! Output, real ( kind = rk ) FPLS, the function value at the new iterate. ! ! Output, logical MXTAKE, is TRUE if a step of maximum length was taken. ! ! Input, integer IPR, the device to which to send output. ! ! Input, integer METHOD, the algorithm to use. ! 1, line search, ! 2, double dogleg, ! 3, More-Hebdon. ! ! Input, real ( kind = rk ) UDIAG(N), the diagonal of hessian in a(.,.) ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer nr real ( kind = rk ) a(nr,n) real ( kind = rk ) dlt real ( kind = rk ) dltf real ( kind = rk ) dltfp real ( kind = rk ) dltmp real ( kind = rk ) f external fcn real ( kind = rk ) fpls real ( kind = rk ) fplsp real ( kind = rk ) g(n) integer i integer ipr integer iretcd integer j integer method logical mxtake logical nwtake real ( kind = rk ) rln real ( kind = rk ) sc(n) real ( kind = rk ) slp real ( kind = rk ) stepmx real ( kind = rk ) steptl real ( kind = rk ) sx(n) real ( kind = rk ) temp real ( kind = rk ) udiag(n) real ( kind = rk ) x(n) real ( kind = rk ) xpls(n) real ( kind = rk ) xplsp(n) call i4_fake_use ( ipr ) mxtake = .false. xpls(1:n) = x(1:n) + sc(1:n) call fcn ( n, xpls, fpls ) dltf = fpls - f slp = dot_product ( g(1:n), sc(1:n) ) ! ! Next statement added for case of compilers which do not optimize ! evaluation of next "if" statement (in which case fplsp could be ! undefined). ! if ( iretcd == 4 ) then fplsp = 0.0D+00 end if ! ! Reset XPLS to XPLSP and terminate global step. ! if ( iretcd == 3 .and. ( fplsp <= fpls .or. 1.0D-04 * slp < dltf ) ) then iretcd = 0 xpls(1:n) = xplsp(1:n) fpls = fplsp dlt = 0.5D+00 * dlt return end if if ( dltf <= 1.0D-04 * slp ) then go to 170 end if rln = 0.0D+00 do i = 1, n rln = max ( & rln, & abs ( sc(i) ) / max ( & abs ( xpls(i) ), & 1.0D+00 / sx(i) & ) & ) end do ! ! Cannot find satisfactory xpls sufficiently distinct from x ! if ( rln < steptl ) then iretcd = 1 return end if ! ! Reduce trust region and continue global step ! iretcd = 2 dltmp = -slp * dlt / ( 2.0D+00 * ( dltf - slp ) ) if ( 0.1D+00 * dlt <= dltmp ) then go to 155 end if dlt = 0.1D+00 * dlt go to 160 155 continue dlt = dltmp 160 continue return ! ! FPLS sufficiently small ! 170 continue dltfp = 0.0D+00 if ( method == 2 ) then do i = 1, n temp = dot_product ( sc(i:n), a(i:n,i) ) dltfp = dltfp + temp**2 end do else do i = 1, n dltfp = dltfp + udiag(i) * sc(i) * sc(i) temp = 0.0D+00 do j = i+1, n temp = temp + a(i,j) * sc(i) * sc(j) end do dltfp = dltfp + 2.0D+00 * temp end do end if dltfp = slp + dltfp / 2.0D+00 if ( iretcd == 2 .or. & 0.1D+00 * abs ( dltf ) < abs ( dltfp - dltf ) .or. & nwtake .or. & 0.99D+00 * stepmx < dlt ) then go to 210 end if ! ! Double trust region and continue global step ! iretcd = 3 xplsp(1:n) = xpls(1:n) fplsp = fpls dlt = min ( 2.0D+00 * dlt, stepmx ) return ! ! Accept XPLS as the next iterate. Choose the new trust region. ! 210 continue iretcd = 0 if ( 0.99D+00 * stepmx < dlt ) then mxtake = .true. end if if ( dltf < 0.1D+00 * dltfp ) then if ( dltf <= 0.75D+00 * dltfp ) then dlt = min ( 2.0D+00 * dlt, stepmx ) end if else dlt = 0.5D+00 * dlt end if return end subroutine uncmin ( n, x0, fcn, x, f, info, w, lw ) !*****************************************************************************80 ! !! UNCMIN minimizes a smooth nonlinear function of N variables. ! ! Discussion: ! ! A subroutine that computes the function value at any point ! must be supplied. Derivative values are not required. ! This subroutine provides the simplest interface to the uncmin ! minimization package. The user has no control over options. ! ! This routine uses a quasi-Newton algorithm with line search ! to minimize the function represented by the subroutine fcn. ! At each iteration, the nonlinear function is approximated ! by a quadratic function derived from a taylor series. ! The quadratic function is minimized to obtain a search direction, ! and an approximate minimum of the nonlinear function along ! the search direction is found using a line search. The ! algorithm computes an approximation to the second derivative ! matrix of the nonlinear function using quasi-Newton techniques. ! ! The uncmin package is quite general, and provides many options ! for the user. However, this subroutine is designed to be ! easy to use, with few choices allowed. For example: ! ! 1. only function values need be computed. first derivative ! values are obtained by finite differencing. this can be ! very costly when the number of variables is large. ! ! 2. it is assumed that the function values can be obtained ! accurately (to an accuracy comparable to the precision of ! the computer arithmetic). ! ! 3. at most 150 iterations are allowed. ! ! 4. it is assumed that the function values are well-scaled, ! that is, that the optimal function value is not pathologically ! large or small. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! John Dennis, Robert Schnabel, ! Numerical Methods for Unconstrained Optimization ! and Nonlinear Equations, ! SIAM, 1996, ! ISBN13: 978-0-898713-64-0, ! LC: QA402.5.D44. ! ! Robert Schnabel, John Koontz, B E Weiss, ! A modular system of algorithms for unconstrained minimization, ! Report cu-cs-240-82, ! Computer Science Department, ! University of Colorado at Boulder, 1982. ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real ( kind = rk ) X0(N), an initial estimate of the minimizer. ! ! Input, external FCN, the name of the routine to evaluate the minimization ! function, of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real ( kind = rk ) x(n) ! real ( kind = rk ) f ! ! Output, real ( kind = rk ) X(N), the local minimizer. ! ! Output, real ( kind = rk ) F, the function value at X. ! ! Output, integer INFO, termination code. ! 0: optimal solution found. ! 1: terminated with gradient small, X is probably optimal. ! 2: terminated with stepsize small, X is probably optimal. ! 3: lower point cannot be found, X is probably optimal. ! 4: iteration limit (150) exceeded. ! 5: too many large steps, function may be unbounded. ! -1: insufficient workspace. ! ! Workspace, real ( kind = rk ) W(LW). ! ! Input, integer LW, the size of the workspace vector W, which ! must be at least N * ( N + 10 ). ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer lw integer n external d1fcn external d2fcn real ( kind = rk ) dlt real ( kind = rk ) epsm real ( kind = rk ) f external fcn real ( kind = rk ) fscale real ( kind = rk ) gradtl integer ia integer iagflg integer iahflg integer iexp integer ig integer info integer ipr integer it integer itnlim integer iw1 integer iw2 integer iw3 integer iw4 integer iw5 integer iw6 integer iw7 integer iw8 integer lwmin integer method integer msg integer ndigit integer nr real ( kind = rk ) stepmx real ( kind = rk ) steptl real ( kind = rk ) w(lw) real ( kind = rk ) x(n) real ( kind = rk ) x0(n) ! ! Subdivide workspace ! ig = 1 it = ig + n iw1 = it + n iw2 = iw1 + n iw3 = iw2 + n iw4 = iw3 + n iw5 = iw4 + n iw6 = iw5 + n iw7 = iw6 + n iw8 = iw7 + n ia = iw8 + n lwmin = ia + n*n-1 if ( lw < lwmin ) then info = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNCMIN - Fatal error!' write ( *, '(a)' ) ' Insufficient workspace.' write ( *, '(a)' ) ' LW < LWMIN.' write ( *, '(a,i6)' ) ' LW = ', lw write ( *, '(a,i6)' ) ' LWMIN = ', lwmin stop end if ! ! Set up parameters for OPTDRV. ! ! parameters that should not be changed when using condensed code ! ! nr = parameter used to divide workspace ! method = 1 (line search) -- do not change ! msg = 9 => no printing, n=1 allowed ! iahflg = 1 => analytic hessian supplied (0 otherwise) ! ipr = device for output (irrelevant in current version) ! dlt = (irrelevant parameter for method = 1) ! epsm = machine epsilon ! nr = n method = 1 msg = 9 iahflg = 0 ipr = 6 dlt = -1.0D+00 epsm = epsilon ( epsm ) ! ! parameters that may be changed: ! ! iexp = 1 means function expensive to evaluate (iexp = 0 => cheap) ! iagflg = 1 means analytic gradient supplied (0 otherwise) ! ndigit = -1 means optdrv assumes f is fully accurate ! itnlim = 150 = maximum number of iterations allowed ! gradtl = zero tolerance for gradient, for convergence tests ! stepmx = maximum allowable step size ! steptl = zero tolerance for step, for convergence tests ! fscale = typical order-of-magnitude size of function ! typsiz = typical order-of-magnitude size of x (stored in w(lt)) ! iexp = 1 iagflg = 0 ndigit = -1 itnlim = 150 gradtl = epsm**(1.0D+00 / 3.0D+00 ) stepmx = 0.0D+00 steptl = sqrt ( epsm ) fscale = 1.0D+00 w(it:it+n-1) = 1.0D+00 ! ! Minimize function ! call optdrv ( nr, n, x0, fcn, d1fcn, d2fcn, w(it), fscale, method, iexp, & msg, ndigit, itnlim, iagflg, iahflg, ipr, dlt, gradtl, stepmx, steptl, & x, f, w(ig), info, w(ia), w(iw1), w(iw2), w(iw3), w(iw4), & w(iw5), w(iw6), w(iw7), w(iw8)) if ( info == 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNCMIN - Note!' write ( *, '(a)' ) ' INFO = 1.' write ( *, '(a)' ) ' The iteration probably converged.' write ( *, '(a)' ) ' The gradient is very small.' return end if if ( info == 2 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNCMIN - Note!' write ( *, '(a)' ) ' INFO = 2.' write ( *, '(a)' ) ' The iteration probably converged.' write ( *, '(a)' ) ' The stepsize is very small.' return end if if ( info == 3 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNCMIN - Warning!' write ( *, '(a)' ) ' INFO = 3.' write ( *, '(a)' ) ' Cannot find a point with lower value.' write ( *, '(a)' ) ' (But not completely happy with the current value.)' return end if if ( info == 4 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNCMIN - Warning!' write ( *, '(a)' ) ' INFO = 4.' write ( *, '(a)' ) ' Too many iterations.' return end if if ( info == 5 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'UNCMIN - Warning!' write ( *, '(a)' ) ' INFO = 5.' write ( *, '(a)' ) ' Too many large steps.' write ( *, '(a)' ) ' The function may be unbounded.' return end if return end function uni ( ) !*****************************************************************************80 ! !! UNI generates real uniform random numbers on [0,1). ! ! Discussion: ! ! Before calling UNI, initialize the generator by calling USTART with ! a seed value. ! ! Users can choose to run UNI in its default mode (requiring no user action) ! which will generate the same sequence of numbers on any computer supporting ! floating point numbers with at least 24 bit mantissas, or in a mode that ! will generate numbers with a longer period on computers with ! larger mantissas. ! ! To exercise this option, before invoking USTART, insert the instruction ! ! UBITS = UNIB ( K ) ! ! with ! ! 24 <= K ! ! where K is the number of bits in the mantissa of your floating ! point word (K=48 for cray, cyber 205). UNIB returns the ! floating point value of K that it actually used. ! K input as <= 24, then UBITS=24. ! K input as > 24, then UBITS=float(K) ! ! If 24 < K, the sequence of numbers generated by UNI may differ ! from one computer to another. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! George Marsaglia, ! "Comments on the perfect uniform random number generator", ! Unpublished notes, ! Washington State University. ! ! Parameters: ! ! Output, real ( kind = rk ) UNI, a random number in the interval [0,1]. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) real ( kind = rk ), save :: c = 362436.0D+00 / 16777216.0D+00 real ( kind = rk ), parameter :: cd = 7654321.0D+00 / 16777216.0D+00 real ( kind = rk ), parameter :: cm = 16777213.0D+00 / 16777216.0D+00 real ( kind = rk ), parameter :: csave = 362436.0D+00 / 16777216.0D+00 integer, save :: i = 17 integer i1 integer ii integer iseed integer, save :: j = 5 integer j1 integer jj integer, save :: k = 24 integer k1 integer kk integer l1 integer m1 real ( kind = rk ) s real ( kind = rk ) t real ( kind = rk ), save, dimension ( 17 ) :: u = (/ & 0.8668672834288D+00, 0.3697986366357D+00, 0.8008968294805D+00, & 0.4173889774680D+00, 0.8254561579836D+00, 0.9640965269077D+00, & 0.4508667414265D+00, 0.6451309529668D+00, 0.1645456024730D+00, & 0.2787901807898D+00, 0.06761531340295D+00, 0.9663226330820D+00, & 0.01963343943798D+00, 0.02947398211399D+00, 0.1636231515294D+00, & 0.3976343250467D+00, 0.2631008574685D+00 /) real ( kind = rk ) uni real ( kind = rk ) unib real ( kind = rk ) ustart ! ! The basic generator is Fibonacci. ! uni = u(i) - u(j) if ( uni < 0.0D+00 ) then uni = uni + 1.0D+00 end if u(i) = uni i = i - 1 if ( i == 0 ) then i = 17 end if j = j - 1 if ( j == 0 ) then j = 17 end if ! ! The second generator is congruential. ! c = c - cd if ( c < 0.0D+00 ) then c = c + cm end if ! ! Combination generator. ! uni = uni - c if ( uni < 0.0D+00 ) then uni = uni + 1.0D+00 end if return entry ustart ( iseed ) !*****************************************************************************80 ! !! USTART is an entry into UNI that allows the user to specify the seed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! set up ... ! convert iseed to four smallish positive integers. ! i1 = mod ( abs ( iseed ), 177 ) + 1 j1 = mod ( abs ( iseed ), 167 ) + 1 k1 = mod ( abs ( iseed ), 157 ) + 1 l1 = mod ( abs ( iseed ), 147 ) + 1 ! ! Generate random bit pattern in array based on given seed. ! do ii = 1, 17 s = 0.0D+00 t = 0.5D+00 ! ! Do for each of the bits of mantissa of word ! loop over k bits, where k is defaulted to 24 but can ! be changed by user call to unib(k) ! do jj = 1, k m1 = mod ( mod ( i1 * j1, 179 ) * k1, 179 ) i1 = j1 j1 = k1 k1 = m1 l1 = mod ( 53 * l1 + 1, 169 ) if ( 32 <= mod ( l1 * m1, 64 ) ) then s = s + t end if t = 0.5D+00 * t end do u(ii) = s end do ustart = real ( iseed, kind = rk ) return entry unib ( kk ) !*****************************************************************************80 ! !! UNIB ? ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! if ( kk <= 24 ) then k = 24 else k = kk end if unib = real ( k, kind = rk ) return end subroutine xerabt ( messg, nmessg ) !*****************************************************************************80 ! !! XERABT aborts program execution and prints an error message. ! ! Discussion: ! ! XERABT aborts the execution of the program. The error message causing ! the abort is given in the calling sequence, in case one needs it for ! printing on a dayfile, for example. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be processed, ! containing no more than 72 characters. ! ! Input, integer NMESSG, the actual number of characters ! in MESSG. If NMESSG is 0, no message is being supplied. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = * ) messg integer nmessg if ( 0 < nmessg ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'XERABT - Termination after fatal error!' write ( *, '(a)' ) trim ( messg ) end if stop end subroutine xerclr !*****************************************************************************80 ! !! XERCLR resets the current error number to zero. ! ! Discussion: ! ! This routine simply resets the current error number to zero. ! This may be necessary to do in order to determine that ! a certain error has occurred again since the last time ! NUMXER was referenced. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! None ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer j4save integer junk junk = j4save ( 1, 0, .true. ) return end subroutine xerctl ( messg1, nmessg, nerr, level, kontrl ) !*****************************************************************************80 ! !! XERCTL allows user control over handling of individual errors. ! ! Discussion: ! ! Allows user control over handling of individual errors. ! Just after each message is recorded, but before it is ! processed any further (i.e., before it is printed or ! a decision to abort is made), a call is made to XERCTL. ! If the user has provided his own version of XERCTL, he ! can then override the value of KONTRL used in processing ! this message by redefining its value. ! ! KONTRL may be set to any value from -2 to 2. ! The meanings for KONTRL are the same as in XSETF, except ! that the value of KONTRL changes only for this message. ! If KONTRL is set to a value outside the range from -2 to 2, ! it will be moved back into that range. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 April 2007 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG1, the first word (only) of the error ! message. ! ! Input, integer NMESSG, same as in the call to XERROR ! or XERRWV. ! ! Input, integer NERR, same as in the call to XERROR or XERRWV. ! ! Input, integer LEVEL, same as in the call to XERROR or XERRWV. ! ! Input/output, integer KONTRL. On input, the current value of ! the control flag as set by a call to XSETF. On output, the new value of ! kontrl. If KONTRL is not defined, it will remain at its original value. ! This changed value affects only the current occurrence of the current ! message. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kontrl integer level character ( len = * ) messg1 integer nerr integer nmessg call i4_fake_use ( kontrl ) call i4_fake_use ( level ) call ch_fake_use ( messg1(1:1) ) call i4_fake_use ( nerr ) call i4_fake_use ( nmessg ) return end subroutine xerdmp !*****************************************************************************80 ! !! XERDMP prints the error tables and then clears them. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 April 2007 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! None ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer kount call xersav ( ' ', 0, 0, 0, kount ) return end subroutine xermax ( maxnum ) !*****************************************************************************80 ! !! XERMAX sets the maximum number of times any error message is to be printed. ! ! Discussion: ! ! XERMAX sets the maximum number of times any message is to be printed. ! That is, non-fatal messages are not to be printed after they have ! occured MAXNUM times. Such non-fatal messages may be printed less than ! MAXNUM times even if they occur MAXNUM times, if error suppression mode ! (KONTRL=0) is ever in effect. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer MAXNUM, the maximum number of times any one ! message is to be printed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer j4save integer junk integer maxnum junk = j4save ( 4, maxnum, .true. ) return end subroutine xerprt ( messg, nmessg ) !*****************************************************************************80 ! !! XERPRT prints a message on each file indicated by xgetua. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 05 April 2007 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be printed. ! ! Input, integer NMESSG, the actual number of characters ! in MESSG. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer ichar integer iunit integer kunit integer last integer lenmes integer lun(5) character ( len = * ) messg integer nmessg integer nunit call i4_fake_use ( nmessg ) ! ! Obtain unit numbers and write line to each unit ! call xgetua ( lun, nunit ) lenmes = len ( messg ) do kunit = 1, nunit iunit = lun(kunit) do ichar = 1, lenmes, 72 last = min ( ichar+71 , lenmes ) if ( iunit == 0 ) then write (*,'(1x,a)') messg(ichar:last) else write (iunit,'(1x,a)') messg(ichar:last) end if end do end do return end subroutine xerror ( messg, nerr, level ) !*****************************************************************************80 ! !! XERROR processes a diagnostic error message. ! ! Discussion: ! ! XERROR processes a diagnostic message, in a manner ! determined by the value of level and the current value ! of the library error control flag, kontrl. ! See subroutine xsetf for details. ! ! call xerror('smooth -- num was zero.',1,2) ! ! call xerror('integ -- less than full accuracy achieved.',2,1) ! ! call xerror( & ! 'rooter -- actual zero of f found before interval fully collapsed.',3,0) ! ! call xerror('exp -- underflows being set to zero.',1,-1) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 13 August 2005 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be processed, ! containing no more than 72 characters. ! ! Input, integer NERR, the error number associated with this ! message. NERR must not be zero. ! ! Input, integer LEVEL, the error category. ! 2 means this is an unconditionally fatal error. ! 1 means this is a recoverable error. (i.e., it is ! non-fatal if XSETF has been appropriately called.) ! 0 means this is a warning message only. ! -1 means this is a warning message which is to be printed at most once, ! regardless of how many times this call is executed. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer level character ( len = * ) messg integer nerr integer nmessg nmessg = len ( messg ) call xerrwv ( messg, nmessg, nerr, level, 0, 0, 0, 0, 0.0D+00, 0.0D+00 ) return end subroutine xerrwv ( messg, nmessg, nerr, level, ni, i1, i2, nr, r1, r2 ) !*****************************************************************************80 ! !! XERRWV processes an error message that includes numeric information. ! ! Discussion: ! ! XERRWV processes a diagnostic message, in a manner ! determined by the value of level and the current value ! of the library error control flag, kontrl. ! (see subroutine xsetf for details.) ! in addition, up to two integer values and two real ! values may be printed along with the message. ! ! call xerrwv ( 'smooth -- num (=i1) was zero.',29,1,2,1,num,0,0,0.,0.) ! ! call xerrwv ( & ! 'quadxy -- requested error (r1) less than minimum(r2).', & ! 54,77,1,0,0,0,2,errreq,errmin) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be processed. ! ! Input, integer NMESSG, the number of characters in MESSG. ! ! Input, integer NERR, the error number associated with ! this message. NERR must not be zero. ! ! Input, integer LEVEL, the error category. ! 2 means this is an unconditionally fatal error. ! 1 means this is a recoverable error. (i.e., it is ! non-fatal if xsetf has been appropriately called.) ! 0 means this is a warning message only. ! -1 means this is a warning message which is to be printed at most ! once, regardless of how many times this call is executed. ! ! Input, integer NI, the number of integer values to be ! printed. (0 to 2) ! ! Input, integer I1, I2, the first and second integer values. ! ! Input, integer NR, the number of real values to be ! printed. (0 to 2) ! ! Input, real ( kind = rk ) R1, R2, the first and second real values. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) character ( len = 37 ) form integer i integer i1 integer i1mach integer i2 integer ifatal integer isizei integer isizef integer iunit integer j4save integer junk integer kdummy integer kount integer kunit integer lerr integer level character ( len = 20 ) lfirst integer lkntrl integer llevel integer lmessg integer lun(5) integer maxmes character ( len = * ) messg integer mkntrl integer nerr integer ni integer nmessg integer nr integer nunit real ( kind = rk ) r1 real ( kind = rk ) r2 ! ! Get flags ! lkntrl = j4save ( 2, 0, .false. ) maxmes = j4save ( 4, 0, .false. ) ! ! Check for valid input ! if ( 0 < nmessg .and. nerr /= 0 .and. -1 <= level .and. level <= 2 ) then go to 10 end if if ( 0 < lkntrl ) then call xerprt('fatal error in...',17) end if call xerprt( 'XERROR -- invalid input', 23 ) if ( 0 < lkntrl ) then call xerprt('job abort due to fatal error.',29) end if if ( 0 < lkntrl ) then call xersav ( ' ', 0, 0, 0, kdummy ) end if call xerabt('XERROR -- invalid input',23) return 10 continue ! ! Record the message. ! junk = j4save(1,nerr,.true.) call xersav ( messg, nmessg, nerr, level, kount ) ! ! Let user override ! lfirst = messg lmessg = nmessg lerr = nerr llevel = level call xerctl(lfirst,lmessg,lerr,llevel,lkntrl) ! ! Reset to original values. ! lmessg = nmessg lerr = nerr llevel = level lkntrl = max ( -2, min ( 2, lkntrl ) ) mkntrl = abs ( lkntrl ) ! ! Decide whether to print message ! if ( llevel < 2 .and. lkntrl == 0 ) then go to 100 end if if (((llevel == (-1)) .and. ( min ( 1, maxmes ) < kount ) ) & .or.((llevel == 0) .and. ( maxmes < kount )) & .or.((llevel == 1) .and. ( maxmes < kount ).and.(mkntrl==1) ) & .or.((llevel == 2) .and. ( max ( 1, maxmes ) < kount ) ) ) then go to 100 end if if ( 0 < lkntrl ) then call xerprt(' ',1) if ( llevel == -1 ) then call xerprt & ( 'warning message...this message will only be printed once.',57) end if if ( llevel == 0 ) then call xerprt ( 'warning in...', 13 ) else if ( llevel == 1 ) then call xerprt ( 'recoverable error in...', 23 ) else if ( llevel == 2 ) then call xerprt ( 'fatal error in...', 17 ) end if end if ! ! Message ! call xerprt(messg,lmessg) call xgetua(lun,nunit) isizei = int ( log10 ( real ( i1mach(9), kind = rk ) ) + 1.0D+00 ) isizef = int ( log10 ( real ( i1mach(10), kind = rk )**i1mach(14) ) + 1.0D+00 ) do kunit = 1, nunit iunit = lun(kunit) do i = 1, min ( ni, 2 ) write (form,21) i,isizei 21 format ('(11x,21hin above message, i',i1,'=,i',i2,') ') if ( iunit == 0 ) then if (i == 1) write (*,form) i1 if (i == 2) write (*,form) i2 else if (i == 1) write (iunit,form) i1 if (i == 2) write (iunit,form) i2 end if end do do i = 1, min ( nr, 2 ) write (form,23) i,isizef+10,isizef 23 format ('(11x,21hin above message, r',i1,'=,e',i2,'.',i2,')') if ( iunit == 0 ) then if ( i == 1 ) write (*,form) r1 if ( i == 2 ) write (*,form) r2 else if (i == 1) write (iunit,form) r1 if (i == 2) write (iunit,form) r2 end if end do if ( lkntrl <= 0 ) then go to 40 end if ! ! error number ! if ( iunit == 0 ) then write(*,30) lerr else write (iunit,30) lerr end if 30 format (15h error number =,i10) 40 continue end do ! ! Traceback ! 100 continue ifatal = 0 if ((llevel == 2).or.((llevel==1) .and. (mkntrl==2))) then ifatal = 1 end if ! ! quit here if message is not fatal ! if ( ifatal <= 0 ) then return end if if ( lkntrl <= 0 .or. max ( 1, maxmes ) < kount ) then go to 120 end if ! ! Print reason for abort ! if ( llevel == 1 ) then call xerprt ('job abort due to unrecovered error.',35) end if if ( llevel == 2 ) then call xerprt('job abort due to fatal error.',29) end if ! ! Print error summary ! call xersav ( ' ', -1, 0, 0, kdummy ) 120 continue ! ! Abort ! if ( llevel == 2 .and. max ( 1, maxmes ) < kount ) then lmessg = 0 end if call xerabt ( messg, lmessg ) return end subroutine xersav ( messg, nmessg, nerr, level, icount ) !*****************************************************************************80 ! !! XERSAV records that an error occurred. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, as in XERROR. ! ! Input, integer NMESSG, as in XERROR, except that, when ! NMESSG = 0, the tables will be dumped and cleared; and when NMESSG < 0, ! the tables will be dumped, but not cleared. ! ! Input, integer NERR, as in XERROR. ! ! Input, integer LEVEL, as in XERROR. ! ! Output, integer ICOUNT, the number of times this message has ! been seen, or zero if the table has overflowed and ! does not contain this message specifically. ! when nmessg=0, icount will not be altered. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer i1mach integer icount integer ii integer iunit integer, save, dimension ( 10 ) :: kount = (/ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) integer, save :: kountx = 0 integer kunit integer level integer, save, dimension ( 10 ) :: levtab integer lun(5) character ( len = 20 ) mes character ( len = * ) messg character ( len = 20 ), save, dimension ( 10 ) :: mestab integer nerr integer, save, dimension ( 10 ) :: nertab integer nmessg integer nunit ! ! Dump the table ! if ( nmessg <= 0 ) then if ( kount(1) == 0 ) then return end if ! ! Print to each unit ! call xgetua ( lun, nunit ) do kunit = 1, nunit iunit = lun(kunit) if ( iunit == 0 ) then iunit = i1mach(4) end if ! ! Print table header ! write ( iunit, 10 ) 10 format ('0 error message summary'/ & ' message start nerr level count') ! ! print body of table ! do i = 1, 10 if ( kount(i) == 0 ) then exit end if write (iunit,15) mestab(i),nertab(i),levtab(i),kount(i) 15 format (1x,a20,3i10) end do ! ! Print number of other errors ! if ( kountx /= 0 ) then write (iunit,40) kountx end if 40 format (41h0other errors not individually tabulated=,i10) write ( iunit, '(a)' ) ' ' end do ! ! Clear the error tables ! if ( nmessg == 0 ) then kount(1:10) = 0 kountx = 0 end if return end if ! ! process a message... ! search for this message, or else an empty slot for this messg, ! or else determine that the error table is full. ! mes = messg do i = 1, 10 ii = i if ( kount(i) == 0 ) then mestab(ii) = mes nertab(ii) = nerr levtab(ii) = level kount(ii) = 1 icount = 1 return end if if ( mes /= mestab(i) ) then go to 90 end if if (nerr /= nertab(i) ) then go to 90 end if if (level /= levtab(i) ) then go to 90 end if go to 100 90 continue end do ! ! The table is full. ! kountx = kountx + 1 icount = 1 return ! ! Message found in table ! 100 continue kount(ii) = kount(ii) + 1 icount = kount(ii) return end subroutine xgetf ( kontrl ) !*****************************************************************************80 ! !! XGETF returns current value of error control flag. ! ! Discussion: ! ! See subroutine XSETF for flag value meanings. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, integer KONTRL, the current value of the error ! control flag. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer j4save integer kontrl kontrl = j4save ( 2, 0, .false. ) return end subroutine xgetua ( iunita, n ) !*****************************************************************************80 ! !! XGETUA returns the unit number(s) to which error messages are being sent. ! ! Discussion: ! ! XGETUA may be called to determine the unit number or numbers to which ! error messages are being sent. These unit numbers may have been set ! by a call to XSETUN, or a call to XSETUA, or may be a default value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, integer IUNITA(N), an array unit numbers, ! A value of zero refers to the default unit, as defined by the ! I1MACH machine constant routine. Only IUNITA(1),..., IUNITA(N) are ! defined by XGETUA. The values of IUNITA(N+1),..., IUNITA(5) are ! not defined (for N < 5) or altered in any way by XGETUA. ! ! Output, integer N, the number of units to which copies of the ! error messages are being sent. N will be in the range from 1 to 5. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer i integer index integer iunita(5) integer j4save integer n n = j4save ( 5, 0, .false. ) do i = 1, n index = i+4 if ( i == 1 ) then index = 3 end if iunita(i) = j4save ( index, 0, .false. ) end do return end subroutine xgetun ( iunit ) !*****************************************************************************80 ! !! XGETUN returns the (first) output file to which messages are being sent. ! ! Discussion: ! ! XGETUN gets the (first) output file to which error messages ! are being sent. To find out if more than one file is being ! used, one must use the XGETUA routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, integer IUNIT, the logical unit number of the ! (first) unit to which error messages are being sent. A value of zero ! means that the default file, as defined by the I1MACH routine, is ! being used. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer iunit integer j4save iunit = j4save ( 3, 0, .false. ) return end subroutine xsetf ( kontrl ) !*****************************************************************************80 ! !! XSETF sets the error control flag. ! ! Discussion: ! ! XSETF sets the error control flag value to KONTRL. ! ! The following table shows how each message is treated, ! depending on the values of KONTRL and LEVEL. See XERROR ! for description of LEVEL. ! ! if kontrl is zero or negative, no information other than the ! message itself (including numeric values, if any) will be ! printed. if kontrl is positive, introductory messages, ! tracebacks, etc., will be printed in addition to the message. ! ! abs ( kontrl ) ! level 0 1 2 ! value ! 2 fatal fatal fatal ! ! 1 not printed printed fatal ! ! 0 not printed printed printed ! ! -1 not printed printed printed ! only only ! once once ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer KONTRL, the desired value of the error ! control flag. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer j4save integer junk integer kontrl if ( kontrl < -2 .or. 2 < kontrl ) then call xerrwv ( 'xsetf -- invalid value of kontrl (i1).', 33, 1, 2, & 1, kontrl, 0, 0, 0.0D+00, 0.0D+00 ) return end if junk = j4save ( 2, kontrl, .true. ) return end subroutine xsetua ( iunita, n ) !*****************************************************************************80 ! !! XSETUA sets up to 5 unit numbers to which messages are to be sent. ! ! Discussion: ! ! XSETUA may be called to declare a list of up to five ! logical units, each of which is to receive a copy of ! each error message processed by this package. ! The purpose of XSETUA is to allow simultaneous printing ! of each error message on, say, a main output file, ! an interactive terminal, and other files such as graphics ! communication files. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer IUNIT(N), unit numbers, which should normally ! be distinct. ! ! Input, integer N, the number of unit numbers provided ! in IUNIT. N must be between 1 and 5. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n integer i integer index integer iunita(n) integer j4save integer junk if ( n < 1 .or. 5 < n ) then call xerrwv ( 'xsetua -- invalid value of n (i1).', 34, 1, 2, 1, n, 0, & 0, 0.0D+00, 0.0D+00 ) return end if do i = 1, n index = i + 4 if ( i == 1 ) then index = 3 end if junk = j4save ( index, iunita(i), .true. ) end do junk = j4save ( 5, n, .true. ) return end subroutine xsetun ( iunit ) !*****************************************************************************80 ! !! XSETUN sets the output file to which error messages are to be sent. ! ! Discussion: ! ! XSETUN sets the output file to which error messages are to be sent. ! Only one file will be used. See XSETUA for how to declare more than ! one file. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 06 November 2023 ! ! Author: ! ! Ron Jones ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer IUNIT, the logical unit number to which error ! messages are to be sent. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer iunit integer j4save integer junk junk = j4save ( 3, iunit, .true. ) junk = j4save ( 5, 1, .true. ) return end subroutine zfftb ( n, c, wsave ) !*****************************************************************************80 ! !! ZFFTB computes the backward complex discrete Fourier transform. ! ! Discussion: ! ! This process is sometimes called Fourier synthesis. ! ! ZFFTB computes a complex periodic sequence from its Fourier coefficients. ! ! A call of ZFFTF followed by a call of ZFFTB will multiply the ! sequence by N. In other words, the transforms are not normalized. ! ! The array WSAVE must be initialized by ZFFTI. ! ! The transform is defined by: ! ! C_out(J) = sum ( 1 <= K <= N ) ! C_in(K) * exp ( sqrt ( - 1 ) * ( J - 1 ) * ( K - 1 ) * 2 * PI / N ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. The method is more efficient when N is the product of ! small primes. ! ! Input/output, complex ( kind = ck ) C(N). ! On input, C contains the sequence of Fourier coefficients. ! On output, C contains the sequence of data values that correspond ! to the input coefficients. ! ! Input, real ( kind = rk ) WSAVE(4*N+15). The array must be initialized ! by calling ZFFTI. A different WSAVE array must be used for each different ! value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) c(n) real ( kind = rk ) wsave(4*n+15) if ( n <= 1 ) then return end if call zfftb1 ( n, c, wsave(1), wsave(2*n+1), wsave(4*n+1) ) return end subroutine zfftb1 ( n, c, ch, wa, ifac ) !*****************************************************************************80 ! !! ZFFTB1 is a lower-level routine used by ZFFTB. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. ! ! Input/output, complex ( kind = ck ) C(N). ! On input, C contains the sequence of Fourier coefficients. ! On output, C contains the sequence of data values that correspond ! to the input coefficients. ! ! Input, complex ( kind = ck ) CH(N). ! ! Input, real ( kind = rk ) WA(2*N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) c(n) complex ( kind = ck ) ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer l1 integer l2 integer na integer nac integer nf real ( kind = rk ) wa(2*n) nf = ifac(2) na = 0 l1 = 1 iw = 1 do k1 = 1, nf ip = ifac(k1+2) l2 = ip * l1 ido = n / l2 idl1 = 2 * ido * l1 if ( ip == 4 ) then ix2 = iw + 2 * ido ix3 = ix2 + 2 * ido if ( na == 0 ) then call passb4 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) ) else call passb4 ( 2*ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3) ) end if na = 1 - na else if ( ip == 2 ) then if ( na == 0 ) then call passb2 ( 2*ido, l1, c, ch, wa(iw) ) else call passb2 ( 2*ido, l1, ch, c, wa(iw) ) end if na = 1 - na else if ( ip == 3 ) then ix2 = iw + 2 * ido if ( na == 0 ) then call passb3 ( 2*ido, l1, c, ch, wa(iw), wa(ix2) ) else call passb3 ( 2*ido, l1, ch, c, wa(iw), wa(ix2) ) end if na = 1 - na else if ( ip == 5 ) then ix2 = iw + 2 * ido ix3 = ix2 + 2 * ido ix4 = ix3 + 2 * ido if ( na == 0 ) then call passb5 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) else call passb5 ( 2*ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) end if na = 1 - na else if ( na == 0 ) then call passb ( nac, 2*ido, ip, l1, idl1, c, c, c, ch, ch, wa(iw) ) else call passb ( nac, 2*ido, ip, l1, idl1, ch, ch, ch, c, c, wa(iw) ) end if if ( nac /= 0 ) then na = 1 - na end if end if l1 = l2 iw = iw + ( ip - 1 ) * 2 * ido end do if ( na /= 0 ) then c(1:n) = ch(1:n) end if return end subroutine zfftb_2d ( ldf, n, f, wsave ) !*****************************************************************************80 ! !! ZFFTB_2D computes a backward two dimensional complex fast Fourier transform. ! ! Discussion: ! ! The routine computes the backward two dimensional fast Fourier transform, ! of a complex N by N matrix of data. ! ! The output is unscaled, that is, a call to ZFFTB_2D followed by a call ! to ZFFTF_2D will return the original data multiplied by N*N. ! ! For some applications it is desirable to have the transform scaled so ! the center of the N by N frequency square corresponds to zero ! frequency. The user can do this replacing the original input data ! F(I,J) by F(I,J) * (-1.0)**(I+J), I,J =0,...,N-1. ! ! Before calling ZFFTF_2D or ZFFTB_2D, it is necessary to initialize ! the array WSAVE by calling ZFFTI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer LDF, the leading dimension of the matrix. ! ! Input, integer N, the number of rows and columns in the ! matrix. ! ! Input/output, complex ( kind = ck ) F(LDF,N), ! On input, an N by N array of complex values to be transformed. ! On output, the transformed values. ! ! Input, real ( kind = rk ) WSAVE(4*N+15), a work array whose values ! depend on N, and which must be initialized by calling ZFFTI. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer ldf integer n complex ( kind = ck ) f(ldf,n) integer i real ( kind = rk ) wsave(4*n+15) ! ! Row transforms: ! f(1:n,1:n) = transpose ( f(1:n,1:n) ) do i = 1, n call zfftb ( n, f(1,i), wsave ) end do f(1:n,1:n) = transpose ( f(1:n,1:n) ) ! ! Column transforms: ! do i = 1, n call zfftb ( n, f(1,i), wsave ) end do return end subroutine zfftf ( n, c, wsave ) !*****************************************************************************80 ! !! ZFFTF computes the forward complex discrete Fourier transform. ! ! Discussion: ! ! This process is sometimes called Fourier analysis. ! ! ZFFTF computes the Fourier coefficients of a complex periodic sequence. ! ! The transform is not normalized. To obtain a normalized transform, ! the output must be divided by N. Otherwise a call of ZFFTF ! followed by a call of ZFFTB will multiply the sequence by N. ! ! The array WSAVE must be initialized by calling ZFFTI. ! ! The transform is defined by: ! ! C_out(J) = sum ( 1 <= K <= N ) ! C_in(K) * exp ( - sqrt ( -1 ) * ( J - 1 ) * ( K - 1 ) * 2 * PI / N ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be ! transformed. The method is more efficient when N is the product of ! small primes. ! ! Input/output, complex ( kind = ck ) C(N). ! On input, the data sequence to be transformed. ! On output, the Fourier coefficients. ! ! Input, real ( kind = rk ) WSAVE(4*N+15). The array must be initialized ! by calling ZFFTI. A different WSAVE array must be used for each different ! value of N. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) c(n) real ( kind = rk ) wsave(4*n+15) if ( n <= 1 ) then return end if call zfftf1 ( n, c, wsave(1), wsave(2*n+1), wsave(4*n+1) ) return end subroutine zfftf1 ( n, c, ch, wa, ifac ) !*****************************************************************************80 ! !! ZFFTF1 is a lower level routine used by ZFFTF. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to ! be transformed. ! ! Input/output, complex ( kind = ck ) C(N). ! On input, the data sequence to be transformed. ! On output, the Fourier coefficients. ! ! Input, complex ( kind = ck ) CH(N). ! ! Input, real ( kind = rk ) WA(2*N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer n complex ( kind = ck ) c(n) complex ( kind = ck ) ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer l1 integer l2 integer na integer nac integer nf real ( kind = rk ) wa(2*n) nf = ifac(2) na = 0 l1 = 1 iw = 1 do k1 = 1, nf ip = ifac(k1+2) l2 = ip * l1 ido = n / l2 idl1 = 2 * ido * l1 if ( ip == 4 ) then ix2 = iw + 2 * ido ix3 = ix2 + 2 * ido if ( na == 0 ) then call passf4 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3) ) else call passf4 ( 2*ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3) ) end if na = 1 - na else if ( ip == 2 ) then if ( na == 0 ) then call passf2 ( 2*ido, l1, c, ch, wa(iw) ) else call passf2 ( 2*ido, l1, ch, c, wa(iw) ) end if na = 1 - na else if ( ip == 3 ) then ix2 = iw + 2 * ido if ( na == 0 ) then call passf3 ( 2*ido, l1, c, ch, wa(iw), wa(ix2) ) else call passf3 ( 2*ido, l1, ch, c, wa(iw), wa(ix2) ) end if na = 1 - na else if ( ip == 5 ) then ix2 = iw + 2 * ido ix3 = ix2 + 2 * ido ix4 = ix3 + 2 * ido if ( na == 0 ) then call passf5 ( 2*ido, l1, c, ch, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) else call passf5 ( 2*ido, l1, ch, c, wa(iw), wa(ix2), wa(ix3), wa(ix4) ) end if na = 1 - na else if ( na == 0 ) then call passf ( nac, 2*ido, ip, l1, idl1, c, c, c, ch, ch, wa(iw) ) else call passf ( nac, 2*ido, ip, l1, idl1, ch, ch, ch, c, c, wa(iw) ) end if if ( nac /= 0 ) then na = 1 - na end if end if l1 = l2 iw = iw + ( ip - 1 ) * 2 * ido end do if ( na /= 0 ) then c(1:n) = ch(1:n) end if return end subroutine zfftf_2d ( ldf, n, f, wsave ) !*****************************************************************************80 ! !! ZFFTF_2D computes a two dimensional complex fast Fourier transform. ! ! Discussion: ! ! The routine computes the forward two dimensional fast Fourier transform, ! of a complex N by N matrix of data. ! ! The output is unscaled, that is, a call to ZFFTF_2D, ! followed by a call to ZFFTB_2D will return the original data ! multiplied by N*N. ! ! For some applications it is desirable to have the transform scaled so ! the center of the N by N frequency square corresponds to zero ! frequency. The user can do this replacing the original input data ! F(I,J) by F(I,J) *(-1.0)**(I+J), I,J =0,...,N-1. ! ! Before calling ZFFTF_2D or ZFFTB_2D, it is necessary to initialize ! the array WSAVE by calling ZFFTI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 12 March 2001 ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer LDF, the leading dimension of the matrix. ! ! Input, integer N, the number of rows and columns in ! the matrix. ! ! Input/output, complex ( kind = ck ) F(LDF,N), ! On input, an N by N array of complex values to be transformed. ! On output, the transformed values. ! ! Input, real ( kind = rk ) WSAVE(4*N+15), a work array whose values depend ! on N, and which must be initialized by calling CFFTI. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer, parameter :: ck = kind ( ( 1.0D+00, 1.0D+00 ) ) integer ldf integer n complex ( kind = ck ) f(ldf,n) integer i real ( kind = rk ) wsave(4*n+15) ! ! Row transforms: ! f(1:n,1:n) = transpose ( f(1:n,1:n) ) do i = 1, n call zfftf ( n, f(1,i), wsave ) end do f(1:n,1:n) = transpose ( f(1:n,1:n) ) ! ! Column transforms: ! do i = 1, n call zfftf ( n, f(1,i), wsave ) end do return end subroutine zffti ( n, wsave ) !*****************************************************************************80 ! !! ZFFTI initializes WSAVE, used in ZFFTF and ZFFTB. ! ! Discussion: ! ! The prime factorization of N together with a tabulation of the ! trigonometric functions are computed and stored in WSAVE. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Paul Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! Bill Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to ! be transformed. ! ! Output, real ( kind = rk ) WSAVE(4*N+15), contains data, dependent on ! the value of N, which is necessary for the CFFTF or CFFTB routines. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) wsave(4*n+15) if ( n <= 1 ) then return end if call zffti1 ( n, wsave(2*n+1), wsave(4*n+1) ) return end subroutine zffti1 ( n, wa, ifac ) !*****************************************************************************80 ! !! ZFFTI1 is a lower level routine used by ZFFTI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to ! be transformed. ! ! Input, real ( kind = rk ) WA(2*N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none integer, parameter :: rk = kind ( 1.0D+00 ) integer n real ( kind = rk ) arg real ( kind = rk ) argh real ( kind = rk ) argld real ( kind = rk ) fi integer i integer i1 integer ido integer ifac(15) integer ii integer ip integer j integer k1 integer l1 integer l2 integer ld integer nf real ( kind = rk ) :: pi = 3.141592653589793D+00 real ( kind = rk ) wa(2*n) call i8_factor ( n, ifac ) nf = ifac(2) argh = 2.0D+00 * pi / real ( n, kind = rk ) i = 2 l1 = 1 do k1 = 1, nf ip = ifac(k1+2) ld = 0 l2 = l1 * ip ido = n / l2 do j = 1, ip-1 i1 = i wa(i-1) = 1.0D+00 wa(i) = 0.0D+00 ld = ld + l1 fi = 0.0D+00 argld = real ( ld, kind = rk ) * argh do ii = 4, 2*ido+2, 2 i = i + 2 fi = fi + 1.0D+00 arg = fi * argld wa(i-1) = cos ( arg ) wa(i) = sin ( arg ) end do if ( 5 < ip ) then wa(i1-1) = wa(i-1) wa(i1) = wa(i) end if end do l1 = l2 end do return end