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] ! ! 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 ( kind = 4 ) 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 = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) AI, the value of the Airy AI function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 11 real ( kind = 8 ) ai real ( kind = 8 ), 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 ( kind = 4 ) n_data real ( kind = 8 ) x real ( kind = 8 ), 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] ! ! 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 ( kind = 4 ) 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 = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) AIP, the derivative of the Airy AI function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 11 real ( kind = 8 ) aip real ( kind = 8 ), 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 ( kind = 4 ) n_data real ( kind = 8 ) x real ( kind = 8 ), 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] ! ! 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 ( kind = 4 ) 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 = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) BI, the value of the Airy BI function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 11 real ( kind = 8 ) bi real ( kind = 8 ), 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 ( kind = 4 ) n_data real ( kind = 8 ) x real ( kind = 8 ), 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] ! ! 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 ( kind = 4 ) 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 = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) BIP, the derivative of the Airy BI function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 11 real ( kind = 8 ) bip real ( kind = 8 ), 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 ( kind = 4 ) n_data real ( kind = 8 ) x real ( kind = 8 ), 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 ( kind = 4 ), GAMMA(Z) = (Z-1)!, the factorial. ! ! There is a special value: ! ! GAMMA(0.5) = SQRT ( PI ). ! ! 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 = 8 ) X, the argument of the gamma function. ! ! Output, real ( kind = 8 ) ALNGAM, the logarithm of the absolute ! value of GAMMA(X). ! implicit none real ( kind = 8 ) alngam real ( kind = 8 ) d9lgmc real ( kind = 8 ), save :: dxrel = 0.0D+00 real ( kind = 8 ) gamma real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) sinpiy real ( kind = 8 ), parameter :: sq2pil = 0.91893853320467274D+00 real ( kind = 8 ), parameter :: sqpi2l = 0.22579135264472743D+00 real ( kind = 8 ) x real ( kind = 8 ), save :: xmax = 0.0D+00 real ( kind = 8 ) 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 ( kind = 4 ).' stop end if if ( abs ( ( x - real ( int ( x - 0.5D+00 ), kind = 8 ) ) / 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 ( kind = 4 ).' 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. ! ! 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 = 8 ) X, the argument, which must be greater than 0. ! ! Input, real ( kind = 8 ) FNU, the order of the first Bessel function. ! FNU is generally at least 35. ! ! Input, real ( kind = 8 ) FLGJY, a selection flag ! 1.0D+00 gives the J function ! -1.0D+00 gives the Y function ! ! Input, integer ( kind = 4 ) IN, the number of functions desired, which ! should be 1 or 2. ! ! Output, real ( kind = 8 ) Y(IN), contains the desired function values. ! ! Output, integer ( kind = 4 ) IFLW, a flag indicating underflow or overflow ! return variables for BESJ only. ! ! Output, real ( kind = 8 ) 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 real ( kind = 8 ) abw2 real ( kind = 8 ) akm real ( kind = 8 ) alfa(26,4) real ( kind = 8 ) alfa1(26,2) real ( kind = 8 ) alfa2(26,2) real ( kind = 8 ) ap real ( kind = 8 ), 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 = 8 ) asum real ( kind = 8 ) az real ( kind = 8 ) beta(26,5) real ( kind = 8 ) beta1(26,2) real ( kind = 8 ) beta2(26,2) real ( kind = 8 ) beta3(26,1) real ( kind = 8 ) br(10) real ( kind = 8 ) bsum real ( kind = 8 ) c(65) real ( kind = 8 ), parameter :: con1 = 6.66666666666667D-01 real ( kind = 8 ), parameter :: con2 = 3.33333333333333D-01 real ( kind = 8 ), parameter :: con548 = 1.04166666666667D-01 real ( kind = 8 ) cr(10) real ( kind = 8 ) crz32 real ( kind = 8 ) d1mach real ( kind = 8 ) dfi real ( kind = 8 ) elim real ( kind = 8 ) dr(10) real ( kind = 8 ) fi real ( kind = 8 ) flgjy real ( kind = 8 ) fn real ( kind = 8 ) fnu real ( kind = 8 ) fn2 external funjy real ( kind = 8 ) gama(26) integer ( kind = 4 ) i integer ( kind = 4 ) i1mach integer ( kind = 4 ) iflw integer ( kind = 4 ) in integer ( kind = 4 ) j integer ( kind = 4 ) jn integer ( kind = 4 ) jr integer ( kind = 4 ) ju integer ( kind = 4 ) k integer ( kind = 4 ) kb integer ( kind = 4 ) klast integer ( kind = 4 ) kmax(5) integer ( kind = 4 ) kp1 integer ( kind = 4 ) ks integer ( kind = 4 ) ksp1 integer ( kind = 4 ) kstemp integer ( kind = 4 ) l integer ( kind = 4 ) lr integer ( kind = 4 ) lrp1 real ( kind = 8 ) phi real ( kind = 8 ) rcz real ( kind = 8 ) rden real ( kind = 8 ) relb real ( kind = 8 ) rfn2 real ( kind = 8 ) rtz real ( kind = 8 ) rzden real ( kind = 8 ) sa real ( kind = 8 ) sb real ( kind = 8 ) suma real ( kind = 8 ) sumb real ( kind = 8 ) s1 real ( kind = 8 ) ta real ( kind = 8 ) tau real ( kind = 8 ) tb real ( kind = 8 ) tfn real ( kind = 8 ) tol real ( kind = 8 ), save :: tols = -6.90775527898214D+00 real ( kind = 8 ) t2 real ( kind = 8 ) upol(10) real ( kind = 8 ) wk(*) real ( kind = 8 ) x real ( kind = 8 ) xx real ( kind = 8 ) y(*) real ( kind = 8 ) z real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) NR, the leading dimension of A. ! ! Input, integer ( kind = 4 ) N, the number of rows and columns in A. ! ! Input, real ( kind = 8 ) A(NR,N), the N by N matrix, containing the lower ! triangular matrix. A is not altered by this routine. ! ! Output, real ( kind = 8 ) X(N), the solution vector. ! ! Input, real ( kind = 8 ) B(N), the right hand side vector. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) b(n) integer ( kind = 4 ) i integer ( kind = 4 ) ip1 real ( kind = 8 ) 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 ! ! 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 ( kind = 4 ) 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 ( kind = 4 ) N, the degree of the polynomial. ! ! Output, integer ( kind = 4 ) K, the index of the polynomial. ! ! Output, real ( kind = 8 ) X, the argument of the polynomial. ! ! Output, real ( kind = 8 ) B, the value of the polynomial B(N,K)(X). ! implicit none integer ( kind = 4 ), parameter :: n_max = 15 real ( kind = 8 ) b real ( kind = 8 ), 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 ( kind = 4 ) k integer ( kind = 4 ), save, dimension ( n_max ) :: k_vec = (/ & 0, & 0, 1, & 0, 1, 2, & 0, 1, 2, 3, & 0, 1, 2, 3, 4 /) integer ( kind = 4 ) n integer ( kind = 4 ) n_data integer ( kind = 4 ), save, dimension ( n_max ) :: n_vec = (/ & 0, & 1, 1, & 2, 2, 2, & 3, 3, 3, 3, & 4, 4, 4, 4, 4 /) real ( kind = 8 ) x real ( kind = 8 ), 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. ! ! 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 = 8 ) X, the argument of the Bessel function. ! ! Output, real ( kind = 8 ) BESI0, the value of the Bessel function at X. ! implicit none real ( kind = 8 ) besi0 real ( kind = 8 ) besi0e real ( kind = 8 ), 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 = 8 ) csevl integer ( kind = 4 ) inits integer ( kind = 4 ), save :: nti0 = 0 real ( kind = 8 ) x real ( kind = 8 ), save :: xmax = 0.0D+00 real ( kind = 8 ), save :: xsml = 0.0D+00 real ( kind = 8 ) 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 ). ! ! 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 = 8 ) X, the argument of the Bessel function. ! ! Output, real ( kind = 8 ) BESI0E, the value of the Bessel function at X. ! implicit none real ( kind = 8 ) ai02cs(22) real ( kind = 8 ) ai0cs(21) real ( kind = 8 ) besi0e real ( kind = 8 ) bi0cs(12) real ( kind = 8 ) csevl integer ( kind = 4 ) inits integer ( kind = 4 ), save :: ntai0 = 0 integer ( kind = 4 ), save :: ntai02 = 0 integer ( kind = 4 ), save :: nti0 = 0 real ( kind = 8 ) x real ( kind = 8 ), save :: xsml = 0.0D+00 real ( kind = 8 ) 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 ( kind = 4 ) 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. ! ! 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 = 8 ) X, the argument of the Bessel function. ! X must be nonnegative. ! ! Input, real ( kind = 8 ) ALPHA, the order of the first member of ! the sequence. ALPHA must be at least 0.0. ! ! Input, integer ( kind = 4 ) N, the number of members in the sequence, ! N must be at least 1. ! ! Output, real ( kind = 8 ) Y(N), a vector whose first N components contain ! values for J(ALPHA+K-1)(X), K=1,...,N ! ! Output, integer ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) ak real ( kind = 8 ) akm real ( kind = 8 ) alngam real ( kind = 8 ) alpha real ( kind = 8 ) ans real ( kind = 8 ) ap real ( kind = 8 ) arg real ( kind = 8 ) coef real ( kind = 8 ) d1mach real ( kind = 8 ) dalpha real ( kind = 8 ) dfn real ( kind = 8 ) dtm real ( kind = 8 ) earg real ( kind = 8 ) elim1 real ( kind = 8 ) etx real ( kind = 8 ) fidal real ( kind = 8 ) flgjy real ( kind = 8 ) fn real ( kind = 8 ) fnf real ( kind = 8 ) fni real ( kind = 8 ) fnp1 real ( kind = 8 ) fnu real ( kind = 8 ), parameter, dimension ( 2 ) :: fnulim = (/ & 100.0D+00, 60.0D+00 /) real ( kind = 8 ) gln integer ( kind = 4 ) i integer ( kind = 4 ) i1 integer ( kind = 4 ) i1mach integer ( kind = 4 ) i2 integer ( kind = 4 ) ialp integer ( kind = 4 ) idalp integer ( kind = 4 ) iflw integer ( kind = 4 ) in integer ( kind = 4 ), parameter :: inlim = 150 integer ( kind = 4 ) is external jairy integer ( kind = 4 ) k integer ( kind = 4 ) kk integer ( kind = 4 ) km integer ( kind = 4 ) kt integer ( kind = 4 ) nn integer ( kind = 4 ) ns integer ( kind = 4 ) nz real ( kind = 8 ), parameter :: pdf = 0.785398163397448D+00 real ( kind = 8 ), parameter :: pidt = 1.57079632679490D+00 real ( kind = 8 ), parameter, dimension ( 4 ) :: pp = (/ & 8.72909153935547D+00, 2.65693932265030D-01, & 1.24578576865586D-01, 7.70133747430388D-04 /) real ( kind = 8 ) rden real ( kind = 8 ) relb real ( kind = 8 ), parameter :: rttp = 7.97884560802865D-01 real ( kind = 8 ), parameter :: rtwo = 1.34839972492648D+00 real ( kind = 8 ) rtx real ( kind = 8 ) rzden real ( kind = 8 ) s real ( kind = 8 ) sa real ( kind = 8 ) sb real ( kind = 8 ) sxo2 real ( kind = 8 ) s1 real ( kind = 8 ) s2 real ( kind = 8 ) t real ( kind = 8 ) ta real ( kind = 8 ) tau real ( kind = 8 ) tb real ( kind = 8 ) temp(3) real ( kind = 8 ) tfn real ( kind = 8 ) tm real ( kind = 8 ) tol real ( kind = 8 ) tolln real ( kind = 8 ) trx real ( kind = 8 ) tx real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) wk(7) real ( kind = 8 ) x real ( kind = 8 ) xo2 real ( kind = 8 ) xo2l real ( kind = 8 ) 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 = 8 ) * tb - 3.0D+00 ) ! ! TOLLN = -ln(tol) ! tolln = 2.303D+00 * tb * real ( i1, kind = 8 ) 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 = 8 ) fnf = alpha - real ( ialp, kind = 8 ) 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 = 8 ) 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 = 8 ) 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 = 8 ) 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 = 8 ) 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 = 8 ) 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] ! ! 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 ( kind = 4 ) 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 = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 20 real ( kind = 8 ) fx real ( kind = 8 ), 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 ( kind = 4 ) n_data real ( kind = 8 ) x real ( kind = 8 ), 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] ! ! 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 ( kind = 4 ) 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 = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 21 real ( kind = 8 ) fx real ( kind = 8 ), 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 ( kind = 4 ) n_data real ( kind = 8 ) x real ( kind = 8 ), 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] ! ! 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 ( kind = 4 ) 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 = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 21 real ( kind = 8 ) fx real ( kind = 8 ), 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 ( kind = 4 ) n_data real ( kind = 8 ) x real ( kind = 8 ), 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] ! ! 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 ( kind = 4 ) 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 ( kind = 4 ) NU, the order of the function. ! ! Output, real ( kind = 8 ) X, the argument of the function. ! ! Output, real ( kind = 8 ) FX, the value of the function. ! implicit none integer ( kind = 4 ), parameter :: n_max = 20 real ( kind = 8 ) fx real ( kind = 8 ), 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 ( kind = 4 ) n_data integer ( kind = 4 ) nu integer ( kind = 4 ), 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 = 8 ) x real ( kind = 8 ), 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]. ! ! Definition: ! ! 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. ! ! 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 ( kind = 4 ) N, should be 0 or greater. ! ! Input, real ( kind = 8 ) X, the point where the functions should be ! evaluated. ! ! Output, real ( kind = 8 ) B(0:N), the values of the Bernstein polynomials ! at the point X. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) b(0:n) integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ) 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 = 8 ) values. ! ! Modified: ! ! 18 October 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of entries of the vector. ! ! Input, complex ( kind = 8 ) X(N), the vector to be printed. ! ! Input, integer ( kind = 4 ) I_LO, I_HI, the first and last entries ! to print. ! ! Input, character ( len = * ) TITLE, an optional title. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) i_hi integer ( kind = 4 ) i_lo character ( len = * ) title complex ( kind = 8 ) 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, seed, c ) !*****************************************************************************80 ! !! C8VEC_UNIFORM_01 returns a unit pseudorandom C8VEC. ! ! Discussion: ! ! A C8VEC is a vector of complex ( kind = 8 ) values. ! ! For now, the input quantity SEED is an integer ( kind = 4 ) variable. ! ! 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. ! ! Modified: ! ! 15 March 2005 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of values to compute. ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, ! which should NOT be 0. On output, SEED has been updated. ! ! Output, complex ( kind = 8 ) C(N), the pseudorandom complex vector. ! implicit none integer ( kind = 4 ) n complex ( kind = 8 ) c(n) integer ( kind = 4 ) i real ( kind = 8 ) r integer ( kind = 4 ) k real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 integer ( kind = 4 ) seed real ( kind = 8 ) theta if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'C8VEC_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop end if do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if r = sqrt ( real ( seed, kind = 8 ) * 4.656612875D-10 ) k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if theta = 2.0D+00 * pi * ( real ( seed, kind = 8 ) * 4.656612875D-10 ) c(i) = r * cmplx ( cos ( theta ), sin ( theta ), kind = 8 ) end do 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. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! FORTRAN90 translation 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 = 8 ) X1, X2, the endpoints of the interval of ! definition of the cubic. X1 and X2 must be distinct. ! ! Input, real ( kind = 8 ) F1, F2, the values of the function at X1 and ! X2, respectively. ! ! Input, real ( kind = 8 ) D1, D2, the derivative values at the ends ! of the interval. ! ! Input, integer ( kind = 4 ) NE, the number of evaluation points. ! ! Input, real ( kind = 8 ) 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 = 8 ) FE(NE), DE(NE), the values of the cubic ! function and its derivative at the points XE(*). ! ! Output, integer ( kind = 4 ) 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 ( kind = 4 ) IERR, error flag. ! 0, no errors. ! -1, NE < 1. ! -2, X1 == X2. ! implicit none integer ( kind = 4 ) ne real ( kind = 8 ) c2 real ( kind = 8 ) c2t2 real ( kind = 8 ) c3 real ( kind = 8 ) c3t3 real ( kind = 8 ) d1 real ( kind = 8 ) d2 real ( kind = 8 ) de(ne) real ( kind = 8 ) del1 real ( kind = 8 ) del2 real ( kind = 8 ) delta real ( kind = 8 ) f1 real ( kind = 8 ) f2 real ( kind = 8 ) fe(ne) real ( kind = 8 ) h integer ( kind = 4 ) i integer ( kind = 4 ) ierr integer ( kind = 4 ) next(2) real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) xe(ne) real ( kind = 8 ) xma real ( kind = 8 ) 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]. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! FORTRAN90 translation 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 = 8 ) X1, X2, the endpoints of the interval of ! definition of the cubic. X1 and X2 must be distinct. ! ! Input, real ( kind = 8 ) F1, F2, the values of the function at X1 and ! X2, respectively. ! ! Input, real ( kind = 8 ) D1, D2, the derivative values at X1 and ! X2, respectively. ! ! Input, integer ( kind = 4 ) NE, the number of evaluation points. ! ! Input, real ( kind = 8 ) 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 = 8 ) FE(NE), the value of the cubic function ! at the points XE. ! ! Output, integer ( kind = 4 ) 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 ( kind = 4 ) IERR, error flag. ! 0, no errors. ! -1, NE < 1. ! -2, X1 == X2. ! implicit none integer ( kind = 4 ) ne real ( kind = 8 ) c2 real ( kind = 8 ) c3 real ( kind = 8 ) d1 real ( kind = 8 ) d2 real ( kind = 8 ) del1 real ( kind = 8 ) del2 real ( kind = 8 ) delta real ( kind = 8 ) f1 real ( kind = 8 ) f2 real ( kind = 8 ) fe(ne) real ( kind = 8 ) h integer ( kind = 4 ) i integer ( kind = 4 ) ierr integer ( kind = 4 ) next(2) real ( kind = 8 ) x real ( kind = 8 ) x1 real ( kind = 8 ) x2 real ( kind = 8 ) xe(ne) real ( kind = 8 ) xma real ( kind = 8 ) 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). ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! FORTRAN90 translation 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 = 8 ) VALUE, the value of the requested integral. ! ! Input, real ( kind = 8 ) X1, X2, the endpoints of the interval of ! definition of the cubic. X1 and X2 must be distinct. ! ! Input, real ( kind = 8 ) F1, F2, the values of the function at X1 ! and X2, respectively. ! ! Input, real ( kind = 8 ) D1, D2, the derivative values at the ends ! of the interval. ! ! Input, real ( kind = 8 ) A, B, the endpoints of interval of integration. ! ! Output, integer ( kind = 4 ) IERR, error flag. ! 0, no errors. ! -1, X1 == X2. ! implicit none real ( kind = 8 ) a real ( kind = 8 ) b real ( kind = 8 ) chfiv real ( kind = 8 ) d1 real ( kind = 8 ) d2 real ( kind = 8 ) dterm real ( kind = 8 ) f1 real ( kind = 8 ) f2 real ( kind = 8 ) fterm real ( kind = 8 ) h integer ( kind = 4 ) ierr real ( kind = 8 ) phia1 real ( kind = 8 ) phia2 real ( kind = 8 ) phib1 real ( kind = 8 ) phib2 real ( kind = 8 ) psia1 real ( kind = 8 ) psia2 real ( kind = 8 ) psib1 real ( kind = 8 ) psib2 real ( kind = 8 ) ta1 real ( kind = 8 ) ta2 real ( kind = 8 ) tb1 real ( kind = 8 ) tb2 real ( kind = 8 ) ua1 real ( kind = 8 ) ua2 real ( kind = 8 ) ub1 real ( kind = 8 ) ub2 real ( kind = 8 ) x1 real ( kind = 8 ) 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. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! FORTRAN90 translation 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 = 8 ) D1, D2, the derivative values at the ends ! of the interval. ! ! Input, real ( kind = 8 ) DELTA, the data slope over that interval. ! ! Output, integer ( kind = 4 ) 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 real ( kind = 8 ) a real ( kind = 8 ) b integer ( kind = 4 ) chfmc real ( kind = 8 ) d1 real ( kind = 8 ) d2 real ( kind = 8 ) delta real ( kind = 8 ) eps integer ( kind = 4 ) ismon integer ( kind = 4 ) itrue real ( kind = 8 ) 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 itrue = sign ( 1.0D+00, delta) 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. ! ! Reference: ! ! Jorge More, Burton Garbow, Kenneth Hillstrom, ! User Guide for MINPACK-1, ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer ( kind = 4 ) M, is the number of functions. ! ! Input, integer ( kind = 4 ) N, is the number of variables. ! ! Input, real ( kind = 8 ) X(N), the point at which the jacobian is ! to be evaluated. ! ! Input, real ( kind = 8 ) FVEC(M), is used only when MODE = 2. ! In that case, it should contain the function values at X. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) LDFJAC, the leading dimension of FJAC. ! LDFJAC must be at least M. ! ! Output, real ( kind = 8 ) XP(N), on output with MODE = 1, is a ! neighboring point of X, at which the function is to be evaluated. ! ! Input, real ( kind = 8 ) FVECP(M), on input with MODE = 2, is the ! function value at XP. ! ! Input, integer ( kind = 4 ) MODE, should be set to 1 on the first call, and ! 2 on the second. ! ! Output, real ( kind = 8 ) 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 ( kind = 4 ) ldfjac integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) eps real ( kind = 8 ) epsf real ( kind = 8 ) epslog real ( kind = 8 ) epsmch real ( kind = 8 ) err(m) real ( kind = 8 ) fjac(ldfjac,n) real ( kind = 8 ) fvec(m) real ( kind = 8 ) fvecp(m) integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) mode real ( kind = 8 ) temp real ( kind = 8 ) x(n) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) 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 = 8 ) EPSM, the machine epsilon. ! ! Input, real ( kind = 8 ) SX(N), the diagonal scaling matrix for X. ! ! Output, real ( kind = 8 ) 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 ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) addmax real ( kind = 8 ) amu real ( kind = 8 ) diagmx real ( kind = 8 ) diagmn real ( kind = 8 ) epsm real ( kind = 8 ) evmax real ( kind = 8 ) evmin integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ) offmax real ( kind = 8 ) offrow real ( kind = 8 ) posmax real ( kind = 8 ) sdd real ( kind = 8 ) sx(n) real ( kind = 8 ) tol real ( kind = 8 ) 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) ! ! 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 ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input/output, real ( kind = 8 ) 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 = 8 ) DIAGMX, the maximum diagonal element of A. ! ! Input, real ( kind = 8 ) TOL, a tolerance. ! ! Output, real ( kind = 8 ) 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 ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) addmax real ( kind = 8 ) aminl real ( kind = 8 ) amnlsq real ( kind = 8 ) diagmx integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) k real ( kind = 8 ) offmax real ( kind = 8 ) sum2 real ( kind = 8 ) temp real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the length of the array X. The method is ! more efficient when N is the product of small primes. ! ! Input/output, real ( kind = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ), parameter :: tsqrt2 = 2.82842712474619D+00 real ( kind = 8 ) wsave(3*n+15) real ( kind = 8 ) x(n) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the array. ! ! Input/output, real ( kind = 8 ) X(N). ! On input, the cosine series coefficients. ! On output, the corresponding data vector. ! ! Input, real ( kind = 8 ) W(N). ! ! Input, real ( kind = 8 ) XH(2*N+15). ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) ns2 real ( kind = 8 ) w(n) real ( kind = 8 ) x(n) real ( kind = 8 ) xh(2*n+15) real ( kind = 8 ) 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 ) ) ! ! 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 ( kind = 4 ) N, the length of the array X. The method is ! more efficient when N is the product of small primes. ! ! Input/output, real ( kind = 8 ) X(N). ! On input, the data to be transformed. ! On output, the transformed data. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ), parameter :: sqrt2 = 1.4142135623731D+00 real ( kind = 8 ) tsqx real ( kind = 8 ) wsave(3*n+15) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the array to be transformed. ! ! Input/output, real ( kind = 8 ) X(N). ! On input, the data to be transformed. ! On output, the transformed data. ! ! Input, real ( kind = 8 ) W(N). ! ! Input, real ( kind = 8 ) XH(2*N+15). ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) ns2 real ( kind = 8 ) w(n) real ( kind = 8 ) x(n) real ( kind = 8 ) xh(2*n+15) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) 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 = 8 ) WSAVE(3*N+15), contains data, depending on N, ! and required by the COSQB and COSQF algorithms. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) :: pi = 3.141592653589793D+00 real ( kind = 8 ) dt integer ( kind = 4 ) k real ( kind = 8 ) wsave(3*n+15) dt = 0.5D+00 * pi / real ( n, kind = 8 ) do k = 1, n wsave(k) = cos ( real ( k, kind = 8 ) * 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 ) ) ! ! 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 ( kind = 4 ) 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 = 8 ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ) c1 integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) kc integer ( kind = 4 ) ns2 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) tx2 real ( kind = 8 ) wsave(3*n+15) real ( kind = 8 ) x(n) real ( kind = 8 ) x1h real ( kind = 8 ) x1p3 real ( kind = 8 ) xi real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) 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 = 8 ) WSAVE(3*N+15), contains data, depending on N, ! and required by the COST algorithm. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) :: pi = 3.141592653589793D+00 real ( kind = 8 ) dt integer ( kind = 4 ) k real ( kind = 8 ) wsave(3*n+15) if ( n <= 3 ) then return end if dt = pi / real ( n - 1, kind = 8 ) do k = 2, ( n / 2 ) wsave(k) = 2.0D+00 * sin ( real ( k - 1, kind = 8 ) * dt ) wsave(n+1-k) = 2.0D+00 * cos ( real ( k - 1, kind = 8 ) * 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. ! ! 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 = 8 ) X, the argument at which the series is to be ! evaluated. X must satisfy -1.0 <= X <= 1.0. ! ! Input, real ( kind = 8 ) CS(N), the array of N terms of a Chebyshev series. ! In evaluating CS, only half the first coefficient is summed. ! ! Input, integer ( kind = 4 ) N, the number of terms in array CS. ! N must be at least 1, and no more than 1000. ! ! Output, real ( kind = 8 ) CSEVL, the value of the Chebyshev series. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) b0 real ( kind = 8 ) b1 real ( kind = 8 ) b2 real ( kind = 8 ) cs(n) real ( kind = 8 ) csevl integer ( kind = 4 ) i real ( kind = 8 ) 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). ! ! Modified: ! ! 16 April 2001 ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the dimension of X, and order of A. ! ! Input, real ( kind = 8 ) X(N), the point at which the gradient ! is to be evaluated. ! ! Output, real ( kind = 8 ) G(N), the gradient vector.. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) g(n) real ( kind = 8 ) x(n) 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 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). ! ! 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 ( kind = 4 ) I, chooses the parameter to be returned. ! 1 <= I <= 5. ! ! Output, real ( kind = 8 ) D1MACH, the value of the chosen parameter. ! implicit none real ( kind = 8 ) d1mach integer ( kind = 4 ) 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. ! ! Reference: ! ! Jorge More, Burton Garbow, Kenneth Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer ( kind = 4 ) M, the number of rows of A. ! ! Input, integer ( kind = 4 ) N, the number of columns of A. ! ! Input/output, real ( kind = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of A, which must not ! be less than M. ! ! Input, real ( kind = 8 ) V(N), W(N), contain the information necessary ! to recover the Givens rotations GV and GW. ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) real ( kind = 8 ) c integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ) s real ( kind = 8 ) temp real ( kind = 8 ) v(n) real ( kind = 8 ) 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). ! ! Modified: ! ! 16 April 2001 ! ! Parameters: ! ! Input, integer ( kind = 4 ) NR, the leading dimension of A, which must be ! at least N. ! ! Input, integer ( kind = 4 ) N, the dimension of X, and order of A. ! ! Input, real ( kind = 8 ) X(N), the point at which the Hessian matrix ! is to be evaluated. ! ! Output, real ( kind = 8 ) A(NR,N), the N by N Hessian matrix. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) x(n) 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 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 ) ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of the log gamma function. ! X must be at least 10. ! ! Output, real ( kind = 8 ) D9LGMC, the correction. ! implicit none real ( kind = 8 ), save, dimension ( 6 ) :: algmcs = (/ & 0.166638948045186D+00, -0.0000138494817606D+00, 0.0000000098108256D+00, & -0.0000000000180912D+00, 0.0000000000000622D+00, -0.0000000000000003D+00 /) real ( kind = 8 ) arg real ( kind = 8 ) csevl real ( kind = 8 ) d9lgmc integer ( kind = 4 ) inits integer ( kind = 4 ), save :: nalgm = 0 real ( kind = 8 ) x real ( kind = 8 ), save :: xbig = 0.0D+00 real ( kind = 8 ), 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. ! ! Modified: ! ! 08 April 1999 ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of entries in the vector. ! ! Input, real ( kind = 8 ) X(*), the vector to be examined. ! ! Input, integer ( kind = 4 ) INCX, the increment between successive ! entries of X. ! ! Output, real ( kind = 8 ) DAMAX, the maximum absolute value of ! an element of X. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) incx integer ( kind = 4 ) ix integer ( kind = 4 ) n real ( kind = 8 ) damax real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the number of entries in the vector. ! ! Input, real X(*), the vector to be examined. ! ! Input, integer ( kind = 4 ) INCX, the increment between successive ! entries of X. INCX must not be negative. ! ! Output, real ( kind = 8 ) DASUM, the sum of the absolute values of X. ! implicit none real ( kind = 8 ) dasum integer ( kind = 4 ) incx integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) N, the number of elements in DX and DY. ! ! Input, real ( kind = 8 ) DA, the multiplier of DX. ! ! Input, real ( kind = 8 ) DX(*), the first vector. ! ! Input, integer ( kind = 4 ) INCX, the increment between successive ! entries of DX. ! ! Input/output, real ( kind = 8 ) DY(*), the second vector. ! On output, DY(*) has been replaced by DY(*) + DA * DX(*). ! ! Input, integer ( kind = 4 ) INCY, the increment between successive ! entries of DY. ! implicit none real ( kind = 8 ) da real ( kind = 8 ) dx(*) real ( kind = 8 ) dy(*) integer ( kind = 4 ) i integer ( kind = 4 ) incx integer ( kind = 4 ) incy integer ( kind = 4 ) ix integer ( kind = 4 ) iy integer ( kind = 4 ) m integer ( kind = 4 ) 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. ! ! Parameters: ! implicit none integer ( kind = 4 ) matdim integer ( kind = 4 ) n real ( kind = 8 ) a(matdim,*) real ( kind = 8 ) d real ( kind = 8 ) dfdy(matdim,*) real ( kind = 8 ) dnrm2 real ( kind = 8 ) el(13,12) logical evalfa external fa real ( kind = 8 ) h integer ( kind = 4 ) i integer ( kind = 4 ) i1 integer ( kind = 4 ) i2 integer ( kind = 4 ) i3 integer ( kind = 4 ) iflag integer ( kind = 4 ) impl integer ( kind = 4 ) ipvt(*) integer ( kind = 4 ) j integer ( kind = 4 ) jstate integer ( kind = 4 ) miter integer ( kind = 4 ) ml integer ( kind = 4 ) mu integer ( kind = 4 ) mw integer ( kind = 4 ) nde integer ( kind = 4 ) nq real ( kind = 8 ) save1(*) real ( kind = 8 ) save2(*) real ( kind = 8 ) t external users real ( kind = 8 ) y(*) real ( kind = 8 ) yh(n,*) real ( kind = 8 ) 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 = 8 ) ) 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(i,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 = 8 ) ) 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 = 8 ) ) 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 = 8 ) ) 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. ! ! Parameters: ! ! Input, integer ( kind = 4 ) MAXORD, the maximum order to calculate. ! ! Input, integer ( kind = 4 ) MINT, 1 for Adams methods, 2 for Gear. ! ! Input, integer ( kind = 4 ) ISWFLG, indicates whether the constants used ! in the stiffness test should be calculated. ! ! Output, real ( kind = 8 ) EL(13,12), used in specifying the basic method. ! ! Output, real ( kind = 8 ) TQ(3,12), used in adjusting the stepsize in ! relation to truncation error. ! implicit none real ( kind = 8 ) el(13,12) real ( kind = 8 ) factrl(12) real ( kind = 8 ) gamma(14) integer ( kind = 4 ) i integer ( kind = 4 ) iswflg integer ( kind = 4 ) j integer ( kind = 4 ) maxord integer ( kind = 4 ) mint integer ( kind = 4 ) mxrd real ( kind = 8 ) sum2 real ( kind = 8 ) tq(3,12) factrl(1) = 1.0D+00 do i = 2, maxord factrl(i) = real ( i, kind = 8 ) * 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 = 8 ) 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 = 8 ) * 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 = 8 ) * 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 = 8 ) * 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 = 8 ) 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 = 8 ) / el(1,j) tq(3,j) = real ( j + 2, kind = 8 ) / 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 = 8 ) 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 = 8 ) el(1+i,1) = - real ( i + 1, kind = 8 ) * 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. ! ! Parameters: ! implicit none integer ( kind = 4 ) matdim integer ( kind = 4 ) n real ( kind = 8 ) a(matdim,*) logical convrg real ( kind = 8 ) dnrm2 real ( kind = 8 ) el(13,12) real ( kind = 8 ) eps external f external fa real ( kind = 8 ) fac(*) real ( kind = 8 ) h real ( kind = 8 ) hmax real ( kind = 8 ) hold integer ( kind = 4 ) i logical ier integer ( kind = 4 ) iflag integer ( kind = 4 ) impl integer ( kind = 4 ) info integer ( kind = 4 ) ipvt(*) integer ( kind = 4 ) iswflg integer ( kind = 4 ) jstate integer ( kind = 4 ) jtask integer ( kind = 4 ) maxord integer ( kind = 4 ) mint integer ( kind = 4 ) miter integer ( kind = 4 ) ml integer ( kind = 4 ) mntold integer ( kind = 4 ) mtrold integer ( kind = 4 ) mu integer ( kind = 4 ) nde integer ( kind = 4 ) nfe integer ( kind = 4 ) nq integer ( kind = 4 ) nwait real ( kind = 8 ) oldl0 real ( kind = 8 ) rc real ( kind = 8 ) rh real ( kind = 8 ) rmax real ( kind = 8 ), parameter :: rminit = 10000.0D+00 real ( kind = 8 ) save1(*) real ( kind = 8 ) save2(*) real ( kind = 8 ) smax real ( kind = 8 ) smin real ( kind = 8 ) sum0 real ( kind = 8 ) sum2 real ( kind = 8 ) t real ( kind = 8 ) tq(3,12) real ( kind = 8 ) trend real ( kind = 8 ) uround external users real ( kind = 8 ) y(*) real ( kind = 8 ) yh(n,*) real ( kind = 8 ) 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 = 8 ) ) 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. ! ! Parameters: ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) factor real ( kind = 8 ) h integer ( kind = 4 ) j integer ( kind = 4 ) jj integer ( kind = 4 ) k integer ( kind = 4 ) kk integer ( kind = 4 ) kused integer ( kind = 4 ) nq real ( kind = 8 ) r real ( kind = 8 ) t real ( kind = 8 ) tout real ( kind = 8 ) y(*) real ( kind = 8 ) yh(n,*) if ( k == 0 ) then y(1:n) = yh(1:n,nq+1) r = ( tout - t ) / h 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 = 8 ) 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 = 8 ) 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 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. ! ! 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 ( kind = 4 ) N, the number of entries in the vectors. ! ! Input, real ( kind = 8 ) DX(*), the first vector. ! ! Input, integer ( kind = 4 ) INCX, the increment between successive entries ! in X. ! ! Input, real ( kind = 8 ) DY(*), the second vector. ! ! Input, integer ( kind = 4 ) 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 real ( kind = 8 ) ddot real ( kind = 8 ) dtemp real ( kind = 8 ) dx(*) real ( kind = 8 ) dy(*) integer ( kind = 4 ) i integer ( kind = 4 ) incx integer ( kind = 4 ) incy integer ( kind = 4 ) ix integer ( kind = 4 ) iy integer ( kind = 4 ) m integer ( kind = 4 ) 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. ! ! Parameters: ! ! Input, integer ( kind = 4 ) KSGN, indicates which operation is to ! be performed. ! ! Input, integer ( kind = 4 ) N, ? ! ! Input, integer ( kind = 4 ) NQ, ? ! ! Input/output, real ( kind = 8 ) YH(N,*), ? ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) j integer ( kind = 4 ) j1 integer ( kind = 4 ) j2 integer ( kind = 4 ) ksgn integer ( kind = 4 ) nq real ( kind = 8 ) 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. ! ! Parameters: ! implicit none integer ( kind = 4 ) matdim integer ( kind = 4 ) n real ( kind = 8 ) a(matdim,*) real ( kind = 8 ) bl real ( kind = 8 ) bnd real ( kind = 8 ) bp real ( kind = 8 ) br real ( kind = 8 ) bu real ( kind = 8 ) dfdy(matdim,*) real ( kind = 8 ) dfdymx real ( kind = 8 ) diff real ( kind = 8 ) dnrm2 real ( kind = 8 ) dy real ( kind = 8 ) el(13,12) external f external fa real ( kind = 8 ) fac(*) real ( kind = 8 ) facmin real ( kind = 8 ), parameter :: facmax = 0.5D+00 real ( kind = 8 ) factor real ( kind = 8 ) h integer ( kind = 4 ) i integer ( kind = 4 ) i1 integer ( kind = 4 ) i2 integer ( kind = 4 ) i3 logical ier integer ( kind = 4 ) iflag integer ( kind = 4 ) imax integer ( kind = 4 ) impl integer ( kind = 4 ) info integer ( kind = 4 ) ipvt(*) integer ( kind = 4 ) iswflg integer ( kind = 4 ) j integer ( kind = 4 ) j2 external jacobn integer ( kind = 4 ) jstate integer ( kind = 4 ) k integer ( kind = 4 ) miter integer ( kind = 4 ) ml integer ( kind = 4 ) mu integer ( kind = 4 ) mw integer ( kind = 4 ) nde integer ( kind = 4 ) nfe integer ( kind = 4 ) nje integer ( kind = 4 ) nq real ( kind = 8 ) save1(*) real ( kind = 8 ) save2(*) real ( kind = 8 ) scale real ( kind = 8 ) t real ( kind = 8 ) uround external users real ( kind = 8 ) y(*) real ( kind = 8 ) yh(n,*) real ( kind = 8 ) yj real ( kind = 8 ) ys real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) 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 ( kind = 4 ), parameter :: idliw = 21 integer ( kind = 4 ), parameter :: mxn = 200 integer ( kind = 4 ) n real ( kind = 8 ) eps real ( kind = 8 ) ewt(1) external f real ( kind = 8 ) hmax integer ( kind = 4 ) i integer ( kind = 4 ), parameter :: ierror = 2 integer ( kind = 4 ) ii integer ( kind = 4 ), parameter :: impl = 0 integer ( kind = 4 ) iwork(idliw+mxn) integer ( kind = 4 ) leniw integer ( kind = 4 ) lenw integer ( kind = 4 ) lenwcm integer ( kind = 4 ) lnwchk integer ( kind = 4 ), parameter :: mint = 2 integer ( kind = 4 ), parameter :: miter = 2 integer ( kind = 4 ) ml integer ( kind = 4 ) mstate real ( kind = 8 ) mu integer ( kind = 4 ), parameter :: mxord = 5 integer ( kind = 4 ), parameter :: mxstep = 1000 integer ( kind = 4 ) nde integer ( kind = 4 ), parameter :: nroot = 0 integer ( kind = 4 ) nstate integer ( kind = 4 ) ntask real ( kind = 8 ) t real ( kind = 8 ) tout real ( kind = 8 ) work(*) real ( kind = 8 ) 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 = 8 ) 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. ! ! 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) eps real ( kind = 8 ) ewt real ( kind = 8 ) ewtcom(1) external f real ( kind = 8 ), external :: g real ( kind = 8 ) hmax integer ( kind = 4 ) ierror integer ( kind = 4 ), parameter :: impl = 0 integer ( kind = 4 ) iwork(*) integer ( kind = 4 ) leniw integer ( kind = 4 ) lenw integer ( kind = 4 ) mint integer ( kind = 4 ) miter integer ( kind = 4 ) ml integer ( kind = 4 ) mstate integer ( kind = 4 ) mu integer ( kind = 4 ) mxord integer ( kind = 4 ), parameter :: mxstep = 1000 integer ( kind = 4 ) nde integer ( kind = 4 ) nroot integer ( kind = 4 ) nstate integer ( kind = 4 ) ntask real ( kind = 8 ) t real ( kind = 8 ) tout real ( kind = 8 ) work(*) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) 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 = 8 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) ae real ( kind = 8 ) big logical convrg real ( kind = 8 ) dnrm2 real ( kind = 8 ) eps real ( kind = 8 ) ewt(*) external f external fa real ( kind = 8 ), external :: g real ( kind = 8 ) glast real ( kind = 8 ) h real ( kind = 8 ) hmax real ( kind = 8 ) hsign integer ( kind = 4 ) i integer ( kind = 4 ) ia integer ( kind = 4 ), parameter :: iavgh = 1 integer ( kind = 4 ), parameter :: iavgrd = 3 integer ( kind = 4 ) idfdy integer ( kind = 4 ) ierror integer ( kind = 4 ) ifac integer ( kind = 4 ) iflag integer ( kind = 4 ) ignow integer ( kind = 4 ), parameter :: ihused = 2 integer ( kind = 4 ), parameter :: iel = 4 integer ( kind = 4 ), parameter :: ih = 160 integer ( kind = 4 ), parameter :: ihmax = 161 integer ( kind = 4 ), parameter :: ihold = 162 integer ( kind = 4 ), parameter :: ihsign = 163 integer ( kind = 4 ), parameter :: irc = 164 integer ( kind = 4 ), parameter :: irmax = 165 integer ( kind = 4 ), parameter :: it = 166 integer ( kind = 4 ), parameter :: itout = 167 integer ( kind = 4 ), parameter :: itq = 168 integer ( kind = 4 ), parameter :: itrend = 204 integer ( kind = 4 ), parameter :: iyh = 205 integer ( kind = 4 ), parameter :: indmxr = 1 integer ( kind = 4 ), parameter :: inqusd = 2 integer ( kind = 4 ), parameter :: instep = 3 integer ( kind = 4 ), parameter :: infe = 4 integer ( kind = 4 ), parameter :: inje = 5 integer ( kind = 4 ), parameter :: inroot = 6 integer ( kind = 4 ), parameter :: icnvrg = 7 integer ( kind = 4 ), parameter :: ijroot = 8 integer ( kind = 4 ), parameter :: ijtask = 9 integer ( kind = 4 ), parameter :: imntld = 10 integer ( kind = 4 ), parameter :: imtrld = 11 integer ( kind = 4 ), parameter :: inq = 12 integer ( kind = 4 ), parameter :: inrtld = 13 integer ( kind = 4 ), parameter :: indtrt = 14 integer ( kind = 4 ), parameter :: inwait = 15 integer ( kind = 4 ), parameter :: imnt = 16 integer ( kind = 4 ), parameter :: imtrsv = 17 integer ( kind = 4 ), parameter :: imtr = 18 integer ( kind = 4 ), parameter :: imxrds = 19 integer ( kind = 4 ), parameter :: imxord = 20 integer ( kind = 4 ), parameter :: indprt = 21 integer ( kind = 4 ), parameter :: indpvt = 22 integer ( kind = 4 ) impl integer ( kind = 4 ) imxerr integer ( kind = 4 ) info integer ( kind = 4 ) iroot integer ( kind = 4 ) isave1 integer ( kind = 4 ) isave2 integer ( kind = 4 ) itroot integer ( kind = 4 ) iwork(*) integer ( kind = 4 ) iywt integer ( kind = 4 ) j integer ( kind = 4 ) ja external jacobn integer ( kind = 4 ) jaml integer ( kind = 4 ) jerror integer ( kind = 4 ) jgnow integer ( kind = 4 ) jhyp integer ( kind = 4 ) jroot integer ( kind = 4 ) jsave2 integer ( kind = 4 ) jstate integer ( kind = 4 ) jtroot integer ( kind = 4 ) jyh integer ( kind = 4 ) jywt integer ( kind = 4 ) lenchk integer ( kind = 4 ) leniw integer ( kind = 4 ) lenw integer ( kind = 4 ) liwchk integer ( kind = 4 ) matdim integer ( kind = 4 ) maxord integer ( kind = 4 ) mint integer ( kind = 4 ) miter integer ( kind = 4 ) ml integer ( kind = 4 ) mu integer ( kind = 4 ) mxord integer ( kind = 4 ) mxstep integer ( kind = 4 ) nde integer ( kind = 4 ) ndecom integer ( kind = 4 ) npar integer ( kind = 4 ) nroot real ( kind = 8 ), parameter :: nround = 20.0D+00 integer ( kind = 4 ) nstate integer ( kind = 4 ) nstepl integer ( kind = 4 ) ntask real ( kind = 8 ) re real ( kind = 8 ) size real ( kind = 8 ) sum2 real ( kind = 8 ) t real ( kind = 8 ) tlast real ( kind = 8 ) tout real ( kind = 8 ) troot real ( kind = 8 ) uround external users real ( kind = 8 ) work(*) real ( kind = 8 ) 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 ( kind = 4 ) 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 = 8 ) ) 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. ! ! Parameters: ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) h real ( kind = 8 ) hmax integer ( kind = 4 ) j integer ( kind = 4 ) nq real ( kind = 8 ) r1 real ( kind = 8 ) rc real ( kind = 8 ) rh real ( kind = 8 ) rmax real ( kind = 8 ) 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. ! ! 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 = 8 ) SAVE1(N), SAVE2(N). ! ! ipvt an integer ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) matdim integer ( kind = 4 ) n real ( kind = 8 ) a(matdim,*) real ( kind = 8 ) avgh real ( kind = 8 ) avgord real ( kind = 8 ), parameter :: bias1 = 1.30D+00 real ( kind = 8 ), parameter :: bias2 = 1.20D+00 real ( kind = 8 ), parameter :: bias3 = 1.40D+00 real ( kind = 8 ) bnd logical convrg real ( kind = 8 ) ctest real ( kind = 8 ) d real ( kind = 8 ) denom real ( kind = 8 ) dfdy(matdim,*) real ( kind = 8 ) d1 real ( kind = 8 ) dnrm2 real ( kind = 8 ) el(13,12) real ( kind = 8 ) eps real ( kind = 8 ) erdn real ( kind = 8 ) erup real ( kind = 8 ) etest logical evalfa logical evaljc external f external fa real ( kind = 8 ) fac(*) real ( kind = 8 ) h real ( kind = 8 ) hmax real ( kind = 8 ) hn real ( kind = 8 ) hold real ( kind = 8 ) hs real ( kind = 8 ) hused integer ( kind = 4 ) i logical, save :: ier = .false. integer ( kind = 4 ) impl integer ( kind = 4 ) ipvt(*) integer ( kind = 4 ) iswflg integer ( kind = 4 ) iter integer ( kind = 4 ) j external jacobn integer ( kind = 4 ) jstate integer ( kind = 4 ) jtask integer ( kind = 4 ) maxord integer ( kind = 4 ) mint integer ( kind = 4 ) miter integer ( kind = 4 ) ml integer ( kind = 4 ) mntold integer ( kind = 4 ) mtrold integer ( kind = 4 ) mtrsv integer ( kind = 4 ) mu integer ( kind = 4 ), parameter :: mxfail = 3 integer ( kind = 4 ), parameter :: mxiter = 3 integer ( kind = 4 ) mxrdsv integer ( kind = 4 ), parameter :: mxtry = 50 integer ( kind = 4 ) nde integer ( kind = 4 ) nfail integer ( kind = 4 ) nfe integer ( kind = 4 ) nje integer ( kind = 4 ) nq integer ( kind = 4 ) nqused integer ( kind = 4 ) nstep integer ( kind = 4 ) nsv integer ( kind = 4 ) ntry real ( kind = 8 ) numer integer ( kind = 4 ) nwait real ( kind = 8 ) rc real ( kind = 8 ), parameter :: rctest = 0.30D+00 real ( kind = 8 ) rh real ( kind = 8 ) rh1 real ( kind = 8 ) rh2 real ( kind = 8 ) rh3 real ( kind = 8 ) rmax real ( kind = 8 ), parameter :: rmfail = 2.0D+00 real ( kind = 8 ), parameter :: rmnorm = 10.0D+00 real ( kind = 8 ) save1(n) real ( kind = 8 ) save2(n) logical switch real ( kind = 8 ) t real ( kind = 8 ) told real ( kind = 8 ) tq(3,12) real ( kind = 8 ) trend real ( kind = 8 ), parameter :: trshld = 1.0D+00 real ( kind = 8 ) uround external users real ( kind = 8 ) y(*) real ( kind = 8 ) yh(n,*) real ( kind = 8 ) ywt(*) real ( kind = 8 ) 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 = 8 ) ) ) ! ! 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 = 8 ) ) ) 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 = 8 ) ) ) rh1 = 1.0D+00 / max ( 1.0D+00, & bias1 * ( erdn / eps )**( 1.0D+00 / real ( nq, kind = 8 ) ) ) 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 = 8 ) * avgh + h ) & / real ( nstep, kind = 8 ) avgord = ( real ( nstep - 1, kind = 8 ) * avgord & + real ( nq, kind = 8 ) ) / real ( nstep, kind = 8 ) 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 = 8 ) ) ) 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 = 8 ) ) ) 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 = 8) ) ) hn = abs ( h ) / max ( uround, & ( etest * el(nq+1,1) / eps)**(1.0D+00 / real ( nq+1, kind = 8 ) ) ) 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 = 8 ) ) ) 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 = 8 ) ) ) 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 = 8 ) ) ) 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 = 8 ) ) ) rh3 = 1.0D+00 / max ( uround, bias3 * ( erup / eps )& **( 1.0D+00 / real ( nq + 2, kind = 8 ) ) ) 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 = 8 ) 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 ). ! ! 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 = 8 ) 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 = 8 ) 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 = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ) a real ( kind = 8 ) acbs real ( kind = 8 ) acmb real ( kind = 8 ) ae real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cmb real ( kind = 8 ) er real ( kind = 8 ), external :: f real ( kind = 8 ) fa real ( kind = 8 ) fb real ( kind = 8 ) fc real ( kind = 8 ) h integer ( kind = 4 ) ic integer ( kind = 4 ) iroot integer ( kind = 4 ) kount integer ( kind = 4 ) nq real ( kind = 8 ) p real ( kind = 8 ) q real ( kind = 8 ) re real ( kind = 8 ) rw real ( kind = 8 ) t real ( kind = 8 ) tol real ( kind = 8 ) uround real ( kind = 8 ) y(*) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) X(N), an initial guess for the solution, ! used to compute a maximum stepsize. ! ! Output, real ( kind = 8 ) TYPSIZ(N), a typical size for each component ! of X. ! ! Output, real ( kind = 8 ) FSCALE, an estimate of the scale of the ! minimization function. ! ! Output, integer ( kind = 4 ) METHOD, specifies the algorithm to use to ! solve the minimization problem. ! ! Output, integer ( kind = 4 ) IEXP, set to 0 if minimization function ! not expensive to evaluate. ! ! Output, integer ( kind = 4 ) MSG, a message to inhibit certain automatic ! checks and output. ! ! Output, integer ( kind = 4 ) NDIGIT, the number of good digits in ! minimization function. ! ! Output, integer ( kind = 4 ) ITNLIM, the maximum number of allowable ! iterations. ! ! Output, integer ( kind = 4 ) IAGFLG, set to 0, meaning the analytic ! gradient is not supplied. ! ! Output, integer ( kind = 4 ) IAHFLG, set to 0, meaning the analytic ! hessian is not supplied. ! ! Output, integer ( kind = 4 ) IPR, the device to which to send output. ! ! Output, real ( kind = 8 ) DLT, the trust region radius. ! ! Output, real ( kind = 8 ) GRADTL, a tolerance at which the gradient is ! considered close enough to zero to terminate algorithm. ! ! Output, real ( kind = 8 ) STEPMX, the maximum stepsize, set to 0.0 to trip ! the default maximum in OPTCHK. ! ! Output, real ( kind = 8 ) STEPTL, a tolerance at which successive ! iterates are considered close enough to terminate the algorithm. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) dlt real ( kind = 8 ) epsm real ( kind = 8 ) fscale real ( kind = 8 ) gradtl integer ( kind = 4 ) iagflg integer ( kind = 4 ) iahflg integer ( kind = 4 ) iexp integer ( kind = 4 ) ipr integer ( kind = 4 ) itnlim integer ( kind = 4 ) method integer ( kind = 4 ) msg integer ( kind = 4 ) ndigit real ( kind = 8 ) stepmx real ( kind = 8 ) steptl real ( kind = 8 ) typsiz(n) real ( kind = 8 ) x(n) ! ! 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 ) ! ! 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 ( kind = 4 ) 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 = 8 ) R(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ) r(n) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the array to be transformed. ! ! Input/output, real ( kind = 8 ) C(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) CH(N). ! ! Input, real ( kind = 8 ) WA(N). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) c(n) real ( kind = 8 ) ch(n) integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ifac(15) integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) na integer ( kind = 4 ) nf real ( kind = 8 ) 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) ! ! 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 ( kind = 4 ) 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 = 8 ) R(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ) r(n) real ( kind = 8 ) 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. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the array to be transformed. ! ! Input/output, real ( kind = 8 ) C(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) CH(N). ! ! Input, real ( kind = 8 ) WA(N). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) c(n) real ( kind = 8 ) ch(n) integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ifac(15) integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) k1 integer ( kind = 4 ) kh integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) na integer ( kind = 4 ) nf real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the length of the sequence to be ! transformed. ! ! Output, real ( kind = 8 ) WSAVE(2*N+15), contains data, dependent on the ! value of N, which is necessary for the DFFTF and DFFTB routines. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. ! ! Input, real ( kind = 8 ) WA(N). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) arg real ( kind = 8 ) argh real ( kind = 8 ) argld real ( kind = 8 ) fi integer ( kind = 4 ) i integer ( kind = 4 ) ido integer ( kind = 4 ) ifac(15) integer ( kind = 4 ) ii integer ( kind = 4 ) ip integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) ld integer ( kind = 4 ) nf real ( kind = 8 ) :: pi = 3.141592653589793D+00 real ( kind = 8 ) wa(n) call i8_factor ( n, ifac ) nf = ifac(2) argh = 2.0D+00 * pi / real ( n, kind = 8 ) 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 = 8 ) * 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. ! ! 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 = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of the array ABD. ! 2*ML + MU + 1 <= LDA. ! ! Input, integer ( kind = 4 ) N, the order of the matrix. ! ! Input, integer ( kind = 4 ) ML, MU, the number of diagonals below and ! above the main diagonal. 0 <= ML < N, 0 <= MU < N. ! ! Output, integer ( kind = 4 ) IPVT(N), the pivot indices. ! ! Output, integer ( kind = 4 ) 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 ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) abd(lda,n) integer ( kind = 4 ) i integer ( kind = 4 ) i0 integer ( kind = 4 ) info integer ( kind = 4 ) ipvt(n) integer ( kind = 4 ) idamax integer ( kind = 4 ) j integer ( kind = 4 ) j0 integer ( kind = 4 ) j1 integer ( kind = 4 ) ju integer ( kind = 4 ) jz integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) lm integer ( kind = 4 ) m integer ( kind = 4 ) ml integer ( kind = 4 ) mm integer ( kind = 4 ) mu real ( kind = 8 ) 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 ! ! 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 = 8 ) ABD(LDA,N), the output from DGBCO or DGBFA. ! ! Input, integer ( kind = 4 ) LDA, the leading dimension of the array ABD. ! ! Input, integer ( kind = 4 ) N, the order of the matrix. ! ! Input, integer ( kind = 4 ) ML, MU, the number of diagonals below and ! above the main diagonal. 0 <= ML < N, 0 <= MU < N. ! ! Input, integer ( kind = 4 ) IPVT(N), the pivot vector from DGBCO or DGBFA. ! ! Input/output, real ( kind = 8 ) B(N). On input, the right hand side. ! On output, the solution. ! ! Input, integer ( kind = 4 ) JOB, job choice. ! 0, solve A*X=B. ! nonzero, solve A'*X=B. ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) abd(lda,n) real ( kind = 8 ) b(n) integer ( kind = 4 ) ipvt(n) integer ( kind = 4 ) job integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) la integer ( kind = 4 ) lb integer ( kind = 4 ) lm integer ( kind = 4 ) m integer ( kind = 4 ) ml integer ( kind = 4 ) mu real ( kind = 8 ) ddot real ( kind = 8 ) 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. ! ! 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 = 8 ) A(LDA,N). On input, a matrix to be ! factored. On output, the LU factorization of the matrix. ! ! Input, integer ( kind = 4 ) LDA, the leading dimension of the array A. ! ! Input, integer ( kind = 4 ) N, the order of the matrix A. ! ! Output, integer ( kind = 4 ) IPVT(N), the pivot indices. ! ! Output, real ( kind = 8 ) RCOND, an estimate of the reciprocal condition ! number of A. ! ! Output, real ( kind = 8 ) 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 ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) real ( kind = 8 ) anorm real ( kind = 8 ) ek integer ( kind = 4 ) info integer ( kind = 4 ) ipvt(n) integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) l real ( kind = 8 ) rcond real ( kind = 8 ) s real ( kind = 8 ) sm real ( kind = 8 ) t real ( kind = 8 ) wk real ( kind = 8 ) wkm real ( kind = 8 ) ynorm real ( kind = 8 ) 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. ! ! 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 = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of A. ! ! Input, integer ( kind = 4 ) N, the order of the matrix A. ! ! Output, integer ( kind = 4 ) IPVT(N), the pivot indices. ! ! Output, integer ( kind = 4 ) 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 ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) integer ( kind = 4 ) info integer ( kind = 4 ) ipvt(n) integer ( kind = 4 ) idamax integer ( kind = 4 ) j integer ( kind = 4 ) k integer ( kind = 4 ) l real ( kind = 8 ) 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. ! ! Parameters: ! ! Input/output, real ( kind = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of the array A. ! LDA must be at least N. ! ! Input, integer ( kind = 4 ) 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 = 8 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 = 8 ) WORK(N). ! ! Workspace, integer ( kind = 4 ) IWORK(N). ! ! Output, real ( kind = 8 ) RCOND, estimate of 1 / condition_number(A). ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) integer ( kind = 4 ) ind integer ( kind = 4 ) itask integer ( kind = 4 ) iwork(*) integer ( kind = 4 ) job real ( kind = 8 ) rcond real ( kind = 8 ) v(*) real ( kind = 8 ) 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. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979, ! ISBN13: 978-0-898711-72-1, ! LC: QA214.L56. ! ! Modified: ! ! 07 March 2001 ! ! Parameters: ! ! Input, real ( kind = 8 ) A(LDA,N), the output from DGECO or DGEFA. ! ! Input, integer ( kind = 4 ) LDA, the leading dimension of A. ! ! Input, integer ( kind = 4 ) N, the order of the matrix A. ! ! Input, integer ( kind = 4 ) IPVT(N), the pivot vector from DGECO or DGEFA. ! ! Input/output, real ( kind = 8 ) B(N). ! On input, the right hand side vector. ! On output, the solution vector. ! ! Input, integer ( kind = 4 ) JOB. ! 0, solve A * X = B; ! nonzero, solve A' * X = B. ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) real ( kind = 8 ) b(n) integer ( kind = 4 ) ipvt(n) integer ( kind = 4 ) job integer ( kind = 4 ) k integer ( kind = 4 ) l real ( kind = 8 ) ddot real ( kind = 8 ) 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. ! ! 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 = 8 ) DNOR, a normal random number. ! implicit none real ( kind = 8 ), parameter :: aa = 12.37586D+00 real ( kind = 8 ), parameter :: b = 0.4878992D+00 real ( kind = 8 ), parameter :: c = 12.67706D+00 real ( kind = 8 ), save :: c1 = 0.9689279D+00 real ( kind = 8 ), save :: c2 = 1.301198D+00 real ( kind = 8 ) dnor real ( kind = 8 ) dstart integer ( kind = 4 ) ia integer ( kind = 4 ) ib integer ( kind = 4 ) ic integer ( kind = 4 ) id integer ( kind = 4 ), save :: ii = 17 integer ( kind = 4 ) iii integer ( kind = 4 ) iseed integer ( kind = 4 ) j integer ( kind = 4 ), save :: jj = 5 integer ( kind = 4 ) jjj real ( kind = 8 ), save :: pc = 0.01958303D+00 real ( kind = 8 ) s real ( kind = 8 ) t real ( kind = 8 ), 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 = 8 ) un real ( kind = 8 ), 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 = 8 ) vni real ( kind = 8 ) x real ( kind = 8 ), save :: xn = 2.776994D+00 real ( kind = 8 ) 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. ! 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 ) ! ! 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 ( kind = 4 ) N, the number of entries in the vector. ! ! Input, real ( kind = 8 ) X(*), the vector whose norm is to be computed. ! ! Input, integer ( kind = 4 ) INCX, the increment between successive ! entries of X. ! ! Output, real ( kind = 8 ) DNRM2, the Euclidean norm of X. ! implicit none real ( kind = 8 ) absxi real ( kind = 8 ) dnrm2 integer ( kind = 4 ) incx integer ( kind = 4 ) ix integer ( kind = 4 ) n real ( kind = 8 ) norm real ( kind = 8 ) scale real ( kind = 8 ) ssq real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) n,iflag ! real ( kind = 8 ) 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 ( kind = 4 ). ! ! 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 ( kind = 4 ) n,ldfjac,iflag ! real ( kind = 8 ) 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 ( kind = 4 ). ! if iopt=2, jac can be ignored (treat it as a dummy argument). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) output variable set to the number of ! calls to fcn. ! ! njev is an integer ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) j,iopt,n,maxfev,ml,mu,mode,nprint,info,nfev,ldfjac ! integer ( kind = 4 ) lr, nwrite ! real ( kind = 8 ) xtol,epsfcn,factor,fnorm ! real ( kind = 8 ) x(9),fvec(9),diag(9),fjac(9,9),r(45),qtf(9) ! real ( kind = 8 ) wa1(9),wa2(9),wa3(9),wa4(9) ! real ( kind = 8 ) 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 ( kind = 4 ) n,iflag ! real ( kind = 8 ) x(n),fvec(n) ! integer ( kind = 4 ) 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 ( kind = 4 ) ldfjac integer ( kind = 4 ) lr integer ( kind = 4 ) n real ( kind = 8 ) actred real ( kind = 8 ) delta real ( kind = 8 ) diag(n) real ( kind = 8 ) dnrm2 real ( kind = 8 ) epsfcn real ( kind = 8 ) epsmch real ( kind = 8 ) factor external fcn real ( kind = 8 ) fjac(ldfjac,n) real ( kind = 8 ) fnorm real ( kind = 8 ) fnorm1 real ( kind = 8 ) fvec(n) integer ( kind = 4 ) i integer ( kind = 4 ) iflag integer ( kind = 4 ) info integer ( kind = 4 ) iopt integer ( kind = 4 ) iter integer ( kind = 4 ) iwa(1) integer ( kind = 4 ) j external jac logical jeval integer ( kind = 4 ) jm1 integer ( kind = 4 ) l integer ( kind = 4 ) maxfev integer ( kind = 4 ) ml integer ( kind = 4 ) mode integer ( kind = 4 ) mu integer ( kind = 4 ) ncfail integer ( kind = 4 ) ncsuc integer ( kind = 4 ) nfev integer ( kind = 4 ) njev integer ( kind = 4 ) nprint integer ( kind = 4 ) nslow1 integer ( kind = 4 ) nslow2 real ( kind = 8 ), parameter :: p001 = 0.001D+00 real ( kind = 8 ), parameter :: p0001 = 0.0001D+00 real ( kind = 8 ), parameter :: p1 = 0.1D+00 real ( kind = 8 ), parameter :: p5 = 0.5D+00 real ( kind = 8 ) pnorm real ( kind = 8 ) prered real ( kind = 8 ) qtf(n) real ( kind = 8 ) r(lr) real ( kind = 8 ) ratio logical sing real ( kind = 8 ) sum2 real ( kind = 8 ) temp real ( kind = 8 ) xnorm real ( kind = 8 ) wa1(n) real ( kind = 8 ) wa2(n) real ( kind = 8 ) wa3(n) real ( kind = 8 ) wa4(n) real ( kind = 8 ) x(n) real ( kind = 8 ) 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 go to 20 end if do j = 1, n if ( diag(j) <= 0.0D+00 ) then go to 300 end if end do 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 ! ! Code approximates 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 go to 50 end if 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 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 end if if ( info /= 0 ) then go to 300 end if ! ! Tests for termination and stringent tolerances. ! if ( maxfev <= nfev ) then info = 2 end if if ( p1 * max ( p1 * delta, pnorm ) <= epsmch * xnorm ) then info = 3 end if if ( nslow2 == 5 ) info = 4 if ( nslow1 == 10 ) info = 5 if ( info /= 0 ) then 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. ! ! 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 ( kind = 4 ) n,iflag ! real ( kind = 8 ) 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 ( kind = 4 ). ! ! 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 ( kind = 4 ) n,ldfjac,iflag ! real ( kind = 8 ) 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 ( kind = 4 ). ! ! if iopt=2, jac can be ignored (treat it as a dummy argument). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) input variable not less than ! (3*n**2+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 ( kind = 4 ) j,n,iopt,nprint,info,lwa,nwrite ! real ( kind = 8 ) tol,fnorm ! real ( kind = 8 ) x(9),fvec(9),wa(180) ! real ( kind = 8 ) 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 ( kind = 4 ) n,iflag ! real ( kind = 8 ) x(n),fvec(n) ! integer ( kind = 4 ) k ! real ( kind = 8 ) 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 ( kind = 4 ) lwa integer ( kind = 4 ) n real ( kind = 8 ) epsfcn real ( kind = 8 ), parameter :: factor = 100.0D+00 external fcn real ( kind = 8 ) fvec(n) integer ( kind = 4 ) index integer ( kind = 4 ) info integer ( kind = 4 ) iopt external jac integer ( kind = 4 ) lr integer ( kind = 4 ) maxfev integer ( kind = 4 ) ml integer ( kind = 4 ) mode integer ( kind = 4 ) mu integer ( kind = 4 ) nfev integer ( kind = 4 ) njev integer ( kind = 4 ) nprint real ( kind = 8 ) tol real ( kind = 8 ) wa(lwa) real ( kind = 8 ) x(n) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) X(N), the old iterate, "X[K-1]". ! ! Input, real ( kind = 8 ) F, the function value at the old iterate, "F(X)". ! ! Input, real ( kind = 8 ) G(N), the gradient at the old iterate. ! ! Input, real ( kind = 8 ) A(N,N), the Cholesky decomposition of the ! Hessian matrix in lower triangular part and diagonal. ! ! Input, real ( kind = 8 ) P(N), the Newton step. ! ! Output, real ( kind = 8 ) XPLS(N), the new iterate "X[K]". ! ! Output, real ( kind = 8 ) 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 ( kind = 4 ) n ! real x(n) ! real f ! ! Input, real ( kind = 8 ) SX(N), the diagonal scaling matrix for X. ! ! Input, real ( kind = 8 ) STEPMX, the maximum allowable step size. ! ! Input, real ( kind = 8 ) STEPTL, the relative step size at which ! successive iterates are considered close enough to terminate algorithm. ! ! Input/output, real ( kind = 8 ) DLT, the trust region radius. ! [retain value between successive calls]. ! ! Output, integer ( kind = 4 ) 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 = 8 ) SC(N), holds the current step. ! ! Workspace, real ( kind = 8 ) WRK1(N). ! ! Workspace, real ( kind = 8 ) WRK2(N). ! ! Workspace, real ( kind = 8 ) WRK3(N). ! ! Input, integer ( kind = 4 ) IPR, the device to which to send output. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) cln real ( kind = 8 ) dlt real ( kind = 8 ) eta real ( kind = 8 ) f external fcn real ( kind = 8 ) fpls real ( kind = 8 ) fplsp logical fstdog real ( kind = 8 ) g(n) integer ( kind = 4 ) ipr integer ( kind = 4 ) iretcd logical mxtake logical nwtake real ( kind = 8 ) p(n) real ( kind = 8 ) rnwtln real ( kind = 8 ) sc(n) real ( kind = 8 ) stepmx real ( kind = 8 ) steptl real ( kind = 8 ) sx(n) real ( kind = 8 ) wrk1(n) real ( kind = 8 ) wrk2(n) real ( kind = 8 ) wrk3(n) real ( kind = 8 ) x(n) real ( kind = 8 ) 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. ! ! Reference: ! ! Jorge More, Burton Garbow, Kenneth Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the order of the matrix R. ! ! Input, real ( kind = 8 ) R(LR), the upper triangular matrix R stored ! by rows. ! ! Input, integer ( kind = 4 ) LR, the size of the R array, which must be ! no less than (N*(N+1))/2. ! ! Input, real ( kind = 8 ) DIAG(N), the diagonal elements of the matrix D. ! ! Input, real ( kind = 8 ) QTB(N), the first N elements of the vector Q'* B. ! ! Input, real ( kind = 8 ) DELTA, is a positive upper bound on the ! euclidean norm of D*X(1:N). ! ! Output, real ( kind = 8 ) X(N), the desired convex combination of the ! Gauss-Newton direction and the scaled gradient direction. ! implicit none integer ( kind = 4 ) lr integer ( kind = 4 ) n real ( kind = 8 ) alpha real ( kind = 8 ) bnorm real ( kind = 8 ) delta real ( kind = 8 ) diag(n) real ( kind = 8 ) enorm real ( kind = 8 ) epsmch real ( kind = 8 ) gnorm integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) jj integer ( kind = 4 ) k integer ( kind = 4 ) l real ( kind = 8 ) qnorm real ( kind = 8 ) qtb(n) real ( kind = 8 ) r(lr) real ( kind = 8 ) sgnorm real ( kind = 8 ) sum2 real ( kind = 8 ) temp real ( kind = 8 ) wa1(n) real ( kind = 8 ) wa2(n) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) G(N), the gradient at the current iterate. ! ! Input, real ( kind = 8 ) A(NR,N), the Cholesky decomposition of the ! hessian in the lower triangle and diagonal. ! ! Input, real ( kind = 8 ) P(N), the Newton step. ! ! Input, real ( kind = 8 ) SX(N), the diagonal scaling matrix for X. ! ! Input, real ( kind = 8 ) RNWTLN, the Newton step length. ! ! Input/output, real ( kind = 8 ) 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 = 8 ) 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 = 8 ) V(N), workspace [retain value ! between successive calls] ! ! Workspace, real ( kind = 8 ) CLN, the cauchy length. ! [retain value between successive calls] ! ! Workspace, real ( kind = 8 ) ETA, [retain value between successive calls] ! ! Output, real ( kind = 8 ) SC(N), the current step. ! ! Input, integer ( kind = 4 ) IPR, the device to which to send output. ! ! Input, real ( kind = 8 ) STEPMX, the maximum allowable step size. ! ! Local variables: ! ! CLN, the length of cauchy step ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) alam real ( kind = 8 ) alpha real ( kind = 8 ) beta real ( kind = 8 ) cln real ( kind = 8 ) dlt real ( kind = 8 ) dot1 real ( kind = 8 ) dot2 real ( kind = 8 ) eta logical fstdog real ( kind = 8 ) g(n) integer ( kind = 4 ) i integer ( kind = 4 ) ipr integer ( kind = 4 ) j logical nwtake real ( kind = 8 ) p(n) real ( kind = 8 ) rnwtln real ( kind = 8 ) sc(n) real ( kind = 8 ) ssd(n) real ( kind = 8 ) stepmx real ( kind = 8 ) sx(n) real ( kind = 8 ) tmp real ( kind = 8 ) v(n) ! ! 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. ! ! 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 = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of A, which must ! be at least M. ! ! Input, integer ( kind = 4 ) M, the number of rows of A. ! ! Input, integer ( kind = 4 ) N, the number of columns of A. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) KR, the numerical rank. ! ! Output, integer ( kind = 4 ) 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 = 8 ) QRAUX(N), will contain extra information defining ! the QR factorization. ! ! Workspace, real ( kind = 8 ) WORK(N). ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) integer ( kind = 4 ) j integer ( kind = 4 ) jpvt(n) integer ( kind = 4 ) k integer ( kind = 4 ) kr integer ( kind = 4 ) m real ( kind = 8 ) qraux(n) real ( kind = 8 ) tol real ( kind = 8 ) 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. ! ! 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 = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of the array A. ! LDA must be at least N. ! ! Input, integer ( kind = 4 ) N, the number of rows of the matrix A. ! ! Input, integer ( kind = 4 ) P, the number of columns of the matrix A. ! ! Output, real ( kind = 8 ) QRAUX(P), contains further information required ! to recover the orthogonal part of the decomposition. ! ! Input/output, integer ( kind = 4 ) 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 = 8 ) WORK(P). WORK is not referenced if JOB == 0. ! ! Input, integer ( kind = 4 ) JOB, initiates column pivoting. ! 0, no pivoting is done. ! nonzero, pivoting is done. ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) n integer ( kind = 4 ) p real ( kind = 8 ) a(lda,p) integer ( kind = 4 ) jpvt(p) real ( kind = 8 ) qraux(p) real ( kind = 8 ) work(p) integer ( kind = 4 ) j integer ( kind = 4 ) job integer ( kind = 4 ) jp integer ( kind = 4 ) l integer ( kind = 4 ) lup integer ( kind = 4 ) maxj real ( kind = 8 ) maxnrm real ( kind = 8 ) nrmxl integer ( kind = 4 ) pl integer ( kind = 4 ) pu real ( kind = 8 ) ddot real ( kind = 8 ) dnrm2 logical swapj real ( kind = 8 ) t real ( kind = 8 ) 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. ! ! 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 = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of A. ! M <= LDA. ! ! Input, integer ( kind = 4 ) M, the number of rows of A. ! ! Input, integer ( kind = 4 ) N, the number of columns of A. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) KR, the numerical rank. ! ! Input, real ( kind = 8 ) 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 = 8 ) X(N), a least squares solution to the linear ! system. ! ! Output, real ( kind = 8 ) RSD(M), the residual, B - A*X. RSD may ! overwrite B. ! ! Workspace, integer ( kind = 4 ) 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 = 8 ) QRAUX(N), required if ITASK = 1. ! ! Workspace, real ( kind = 8 ) WORK(N), required if ITASK = 1. ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) IND, error code. ! 0: no error ! -1: LDA < N (fatal error) ! -2: N < 1 (fatal error) ! -3: ITASK < 1 (fatal error) ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) real ( kind = 8 ) b(m) integer ( kind = 4 ) ind integer ( kind = 4 ) itask integer ( kind = 4 ) jpvt(n) integer ( kind = 4 ) kr real ( kind = 8 ) qraux(n) real ( kind = 8 ) rsd(m) real ( kind = 8 ) tol real ( kind = 8 ) work(n) real ( kind = 8 ) 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. ! ! Parameters: ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) LDA, the leading dimension of A, which must ! be at least M. ! ! Input, integer ( kind = 4 ) M, the number of rows of A. ! ! Input, integer ( kind = 4 ) N, the number of columns of A. ! ! Input, integer ( kind = 4 ) KR, the rank of the matrix, as estimated ! by DQRANK. ! ! Input, real ( kind = 8 ) B(M), the right hand side of the linear system. ! ! Output, real ( kind = 8 ) X(N), a least squares solution to the ! linear system. ! ! Output, real ( kind = 8 ) RSD(M), the residual, B - A*X. RSD may ! overwite B. ! ! Input, integer ( kind = 4 ) 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 = 8 ) QRAUX(N), auxiliary information from DQRANK ! defining the QR factorization. ! implicit none integer ( kind = 4 ) lda integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) a(lda,n) real ( kind = 8 ) b(m) integer ( kind = 4 ) info integer ( kind = 4 ) j integer ( kind = 4 ) jpvt(n) integer ( kind = 4 ) k integer ( kind = 4 ) kr real ( kind = 8 ) qraux(n) real ( kind = 8 ) rsd(m) real ( kind = 8 ) t real ( kind = 8 ) 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. ! ! 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 = 8 ) A(LDA,P), contains the output of DQRDC. ! ! Input, integer ( kind = 4 ) LDA, the leading dimension of the array A. ! ! Input, integer ( kind = 4 ) N, the number of rows of the matrix AK. It ! must have the same value as N in DQRDC. ! ! Input, integer ( kind = 4 ) 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 = 8 ) QRAUX(P), the auxiliary output from DQRDC. ! ! Input, real ( kind = 8 ) Y(N), a vector to be manipulated by DQRSL. ! ! Output, real ( kind = 8 ) QY(N), contains Q * Y, if requested. ! ! Output, real ( kind = 8 ) QTY(N), contains Q' * Y, if requested. ! ! Output, real ( kind = 8 ) 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 = 8 ) 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 = 8 ) 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) k integer ( kind = 4 ) lda integer ( kind = 4 ) n real ( kind = 8 ) a(lda,*) real ( kind = 8 ) ab(n) real ( kind = 8 ) b(k) logical cab logical cb logical cqty logical cqy logical cr integer ( kind = 4 ) info integer ( kind = 4 ) j integer ( kind = 4 ) jj integer ( kind = 4 ) job integer ( kind = 4 ) ju integer ( kind = 4 ) kp1 real ( kind = 8 ) qraux(*) real ( kind = 8 ) qty(n) real ( kind = 8 ) qy(n) real ( kind = 8 ) rsd(n) real ( kind = 8 ) ddot real ( kind = 8 ) t real ( kind = 8 ) temp real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the number of entries in the vectors. ! ! Input/output, real ( kind = 8 ) X(*), one of the vectors to be rotated. ! ! Input, integer ( kind = 4 ) INCX, the increment between successive entries ! of X. ! ! Input/output, real ( kind = 8 ) Y(*), one of the vectors to be rotated. ! ! Input, integer ( kind = 4 ) INCY, the increment between successive elements ! of Y. ! ! Input, real ( kind = 8 ) C, S, parameters (presumably the cosine and ! sine of some angle) that define a plane rotation. ! implicit none real ( kind = 8 ) c integer ( kind = 4 ) i integer ( kind = 4 ) incx integer ( kind = 4 ) incy integer ( kind = 4 ) ix integer ( kind = 4 ) iy integer ( kind = 4 ) n real ( kind = 8 ) s real ( kind = 8 ) stemp real ( kind = 8 ) x(*) real ( kind = 8 ) 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. ! ! 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 = 8 ) SA, SB, ... ! ! Output, real ( kind = 8 ) C, S, ... ! implicit none real ( kind = 8 ) c real ( kind = 8 ) r real ( kind = 8 ) roe real ( kind = 8 ) s real ( kind = 8 ) sa real ( kind = 8 ) sb real ( kind = 8 ) scale real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the number of entries in the vector. ! ! Input, real ( kind = 8 ) SA, the multiplier. ! ! Input/output, real ( kind = 8 ) X(*), the vector to be scaled. ! ! Input, integer ( kind = 4 ) INCX, the increment between successive ! entries of X. ! implicit none integer ( kind = 4 ) i integer ( kind = 4 ) incx integer ( kind = 4 ) ix integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) sa real ( kind = 8 ) 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. ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of data values. ! ! Output, real ( kind = 8 ) R(N), the reconstructed data sequence. ! ! Input, real ( kind = 8 ) AZERO, the constant Fourier coefficient. ! ! Input, real ( kind = 8 ) A(N/2), B(N/2), the Fourier coefficients. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) a(n/2) real ( kind = 8 ) azero real ( kind = 8 ) b(n/2) integer ( kind = 4 ) i integer ( kind = 4 ) k real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r(n) real ( kind = 8 ) theta r(1:n) = azero do i = 1, n do k = 1, n/2 theta = real ( k * ( i - 1 ) * 2 ) * pi / real ( n, kind = 8 ) 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. ! ! Modified: ! ! 13 March 2001 ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of data values. ! ! Input, real ( kind = 8 ) R(N), the data to be transformed. ! ! Output, real ( kind = 8 ) AZERO, = sum ( 1 <= I <= N ) R(I) / N. ! ! Output, real ( kind = 8 ) A(N/2), B(N/2), the Fourier coefficients. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) a(1:n/2) real ( kind = 8 ) azero real ( kind = 8 ) b(1:n/2) integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ), parameter :: pi = 3.141592653589793D+00 real ( kind = 8 ) r(n) real ( kind = 8 ) theta azero = sum ( r(1:n) ) / real ( n, kind = 8 ) 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 = 8 ) 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 = 8 ) b(i) = b(i) / real ( n, kind = 8 ) 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 = 8 ) 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. ! ! 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 = 8 ) X(LDX,P). On input, the matrix whose ! singular value decomposition is to be computed. On output, the matrix ! has been destroyed. ! ! Input, integer ( kind = 4 ) LDX, the leading dimension of the array X. ! LDX must be at least N. ! ! Input, integer ( kind = 4 ) N, the number of rows of the matrix. ! ! Input, integer ( kind = 4 ) P, the number of columns of the matrix X. ! ! Output, real ( kind = 8 ) 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 = 8 ) E(P), ordinarily contains zeros. However see the ! discussion of INFO for exceptions. ! ! Output, real ( kind = 8 ) 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 ( kind = 4 ) LDU, the leading dimension of the array U. ! LDU must be at least N. ! ! Output, real ( kind = 8 ) 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 ( kind = 4 ) LDV, the leading dimension of the array V. ! LDV must be at least P. ! ! Workspace, real ( kind = 8 ) WORK(N). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) ldu integer ( kind = 4 ) ldv integer ( kind = 4 ) ldx integer ( kind = 4 ) n integer ( kind = 4 ) p real ( kind = 8 ) b real ( kind = 8 ) c real ( kind = 8 ) cs real ( kind = 8 ) e(p) real ( kind = 8 ) el real ( kind = 8 ) emm1 real ( kind = 8 ) f real ( kind = 8 ) g integer ( kind = 4 ) info integer ( kind = 4 ) iter integer ( kind = 4 ) j integer ( kind = 4 ) job integer ( kind = 4 ) jobu integer ( kind = 4 ) k integer ( kind = 4 ) kase integer ( kind = 4 ) kk integer ( kind = 4 ) l integer ( kind = 4 ) ll integer ( kind = 4 ) lls integer ( kind = 4 ) ls integer ( kind = 4 ) lu integer ( kind = 4 ) m integer ( kind = 4 ), parameter :: maxit = 30 integer ( kind = 4 ) mm integer ( kind = 4 ) mm1 integer ( kind = 4 ) mp1 integer ( kind = 4 ) nct integer ( kind = 4 ) nctp1 integer ( kind = 4 ) ncu integer ( kind = 4 ) nrt integer ( kind = 4 ) nrtp1 real ( kind = 8 ) s(*) real ( kind = 8 ) scale real ( kind = 8 ) ddot real ( kind = 8 ) shift real ( kind = 8 ) sl real ( kind = 8 ) sm real ( kind = 8 ) smm1 real ( kind = 8 ) sn real ( kind = 8 ) dnrm2 real ( kind = 8 ) t real ( kind = 8 ) t1 real ( kind = 8 ) test real ( kind = 8 ) u(ldu,*) real ( kind = 8 ) v(ldv,p) logical wantu logical wantv real ( kind = 8 ) work(n) real ( kind = 8 ) x(ldx,p) real ( kind = 8 ) 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 ) ). ! ! 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 = 8 ) f ! real ( kind = 8 ) x ! ! Input, real ( kind = 8 ) BOUND, the value of the finite endpoint of ! the integration range, if any, that is, if INF is 1 or -1. ! ! Input, integer ( kind = 4 ) INF, indicates the type of integration range. ! 1: ( BOUND, +Infinity), ! -1: ( -Infinity, BOUND), ! 2: ( -Infinity, +Infinity). ! ! Input, real ( kind = 8 ) EPSABS, the absolute accuracy requested. ! ! Input, real ( kind = 8 ) 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 = 8 ) RESULT, the estimated value of the integral. ! ! Output, real ( kind = 8 ) ABSERR, the estimate of the modulus of the ! absolute error, which should equal or exceed | I - RESULT |. ! ! Output, integer ( kind = 4 ) NEVAL, the number of integrand evaluations. ! ! on return ! ! ier - integer ( kind = 4 ) ! 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) ! ! 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 ( kind = 4 ) I, chooses the parameter to be returned. ! 1 <= I <= 5. ! ! Output, real R1MACH, the value of the chosen parameter. ! implicit none integer ( kind = 4 ) 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. ! ! Reference: ! ! Jorge More, Burton Garbow and Kenneth Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer ( kind = 4 ) M, the number of rows of S. ! ! Input, integer ( kind = 4 ) N, the number of columns of S. ! N must not exceed M. ! ! Input/output, real ( kind = 8 ) 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 ( kind = 4 ) LS, the length of the S array. ! LS must be at least (N*(2*M-N+1))/2. ! ! Input, real ( kind = 8 ) U(M), the U vector. ! ! Input/output, real ( kind = 8 ) 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 = 8 ) 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 ( kind = 4 ) ls integer ( kind = 4 ) m integer ( kind = 4 ) n real ( kind = 8 ) cos real ( kind = 8 ) cotan real ( kind = 8 ) giant integer ( kind = 4 ) i integer ( kind = 4 ) j integer ( kind = 4 ) jj integer ( kind = 4 ) l real ( kind = 8 ) s(ls) real ( kind = 8 ) sin logical sing real ( kind = 8 ) tan real ( kind = 8 ) tau real ( kind = 8 ) temp real ( kind = 8 ) u(m) real ( kind = 8 ) v(n) real ( kind = 8 ) 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_swap ( x, y ) !*****************************************************************************80 ! !! R8_SWAP swaps two R8's. ! ! Modified: ! ! 22 December 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real ( kind = 8 ) X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none real ( kind = 8 ) x real ( kind = 8 ) y real ( kind = 8 ) 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. ! ! Modified: ! ! 16 October 2006 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of entries of the vector. ! ! Input, real ( kind = 8 ) A(N), the vector to be printed. ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) a(n) integer ( kind = 4 ) i integer ( kind = 4 ) i_hi integer ( kind = 4 ) 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. ! ! Example: ! ! 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 ). ! ! Modified: ! ! 06 October 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of entries in the array. ! ! Input/output, real ( kind = 8 ) A(N), the array to be reversed. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) a(n) integer ( kind = 4 ) i do i = 1, n/2 call r8_swap ( a(i), a(n+1-i) ) end do return end subroutine r8vec_uniform_01 ( n, seed, r ) !*****************************************************************************80 ! !! R8VEC_UNIFORM_01 returns a unit pseudorandom R8VEC. ! ! Discussion: ! ! An R8VEC is a vector of R8's. ! ! For now, the input quantity SEED is an integer variable. ! ! Modified: ! ! 05 July 2006 ! ! Author: ! ! John Burkardt ! ! Reference: ! ! Paul Bratley, Bennett Fox, Linus Schrage, ! A Guide to Simulation, ! Springer Verlag, pages 201-202, 1983. ! ! Bennett Fox, ! Algorithm 647: ! Implementation and Relative Efficiency of Quasirandom ! Sequence Generators, ! ACM Transactions on Mathematical Software, ! Volume 12, Number 4, pages 362-376, 1986. ! ! Peter Lewis, Allen Goodman, James Miller ! A Pseudo-Random Number Generator for the System/360, ! IBM Systems Journal, ! Volume 8, pages 136-143, 1969. ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the number of entries in the vector. ! ! Input/output, integer ( kind = 4 ) SEED, the "seed" value, which ! should NOT be 0. On output, SEED has been updated. ! ! Output, real ( kind = 8 ) R(N), the vector of pseudorandom values. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) k integer ( kind = 4 ) seed real ( kind = 8 ) r(n) if ( seed == 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R8VEC_UNIFORM_01 - Fatal error!' write ( *, '(a)' ) ' Input value of SEED = 0.' stop end if do i = 1, n k = seed / 127773 seed = 16807 * ( seed - k * 127773 ) - k * 2836 if ( seed < 0 ) then seed = seed + 2147483647 end if r(i) = real ( seed, kind = 8 ) * 4.656612875D-10 end do return end subroutine radb2 ( ido, l1, cc, ch, wa1 ) !*****************************************************************************80 ! !! RADB2 is a lower level routine used by RFFTB1. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,2,l1) real ( kind = 8 ) ch(ido,l1,2) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,3,l1) real ( kind = 8 ) ch(ido,l1,3) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ), parameter :: taui = 0.866025403784439D+00 real ( kind = 8 ), parameter :: taur = -0.5D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,4,l1) real ( kind = 8 ) ch(ido,l1,4) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ), parameter :: sqrt2 = 1.414213562373095D+00 real ( kind = 8 ) ti1 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) tr1 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,5,l1) real ( kind = 8 ) ch(ido,l1,5) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) ci5 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 real ( kind = 8 ) cr5 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) di4 real ( kind = 8 ) di5 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 real ( kind = 8 ) dr4 real ( kind = 8 ) dr5 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ), parameter :: ti11 = 0.951056516295154D+00 real ( kind = 8 ), parameter :: ti12 = 0.587785252292473D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) ti5 real ( kind = 8 ), parameter :: tr11 = 0.309016994374947D+00 real ( kind = 8 ), parameter :: tr12 = -0.809016994374947D+00 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) tr5 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ip integer ( kind = 4 ) l1 real ( kind = 8 ) ai1 real ( kind = 8 ) ai2 real ( kind = 8 ) ar1 real ( kind = 8 ) ar1h real ( kind = 8 ) ar2 real ( kind = 8 ) ar2h real ( kind = 8 ) arg real ( kind = 8 ) c1(ido,l1,ip) real ( kind = 8 ) c2(idl1,ip) real ( kind = 8 ) cc(ido,ip,l1) real ( kind = 8 ) ch(ido,l1,ip) real ( kind = 8 ) ch2(idl1,ip) real ( kind = 8 ) dc2 real ( kind = 8 ) dcp real ( kind = 8 ) ds2 real ( kind = 8 ) dsp integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idij integer ( kind = 4 ) ik integer ( kind = 4 ) ipph integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) j2 integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) nbd real ( kind = 8 ) :: pi = 3.141592653589793D+00 real ( kind = 8 ) wa(*) arg = 2.0D+00 * pi / real ( ip, kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,l1,2) real ( kind = 8 ) ch(ido,2,l1) integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ) ti2 real ( kind = 8 ) tr2 real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,l1,3) real ( kind = 8 ) ch(ido,3,l1) real ( kind = 8 ) ci2 real ( kind = 8 ) cr2 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ), parameter :: taui = 0.866025403784439D+00 real ( kind = 8 ), parameter :: taur = -0.5D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,l1,4) real ( kind = 8 ) ch(ido,4,l1) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 real ( kind = 8 ), parameter :: hsqt2 = 0.7071067811865475D+00 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ) ti1 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) tr1 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) ido integer ( kind = 4 ) l1 real ( kind = 8 ) cc(ido,l1,5) real ( kind = 8 ) ch(ido,5,l1) real ( kind = 8 ) ci2 real ( kind = 8 ) ci3 real ( kind = 8 ) ci4 real ( kind = 8 ) ci5 real ( kind = 8 ) cr2 real ( kind = 8 ) cr3 real ( kind = 8 ) cr4 real ( kind = 8 ) cr5 real ( kind = 8 ) di2 real ( kind = 8 ) di3 real ( kind = 8 ) di4 real ( kind = 8 ) di5 real ( kind = 8 ) dr2 real ( kind = 8 ) dr3 real ( kind = 8 ) dr4 real ( kind = 8 ) dr5 integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) k real ( kind = 8 ), parameter :: ti11 = 0.951056516295154D+00 real ( kind = 8 ), parameter :: ti12 = 0.587785252292473D+00 real ( kind = 8 ) ti2 real ( kind = 8 ) ti3 real ( kind = 8 ) ti4 real ( kind = 8 ) ti5 real ( kind = 8 ), parameter :: tr11 = 0.309016994374947D+00 real ( kind = 8 ), parameter :: tr12 = -0.809016994374947D+00 real ( kind = 8 ) tr2 real ( kind = 8 ) tr3 real ( kind = 8 ) tr4 real ( kind = 8 ) tr5 real ( kind = 8 ) wa1(ido) real ( kind = 8 ) wa2(ido) real ( kind = 8 ) wa3(ido) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ip integer ( kind = 4 ) l1 real ( kind = 8 ) ai1 real ( kind = 8 ) ai2 real ( kind = 8 ) ar1 real ( kind = 8 ) ar1h real ( kind = 8 ) ar2 real ( kind = 8 ) ar2h real ( kind = 8 ) arg real ( kind = 8 ) c1(ido,l1,ip) real ( kind = 8 ) c2(idl1,ip) real ( kind = 8 ) cc(ido,ip,l1) real ( kind = 8 ) ch(ido,l1,ip) real ( kind = 8 ) ch2(idl1,ip) real ( kind = 8 ) dc2 real ( kind = 8 ) dcp real ( kind = 8 ) ds2 real ( kind = 8 ) dsp integer ( kind = 4 ) i integer ( kind = 4 ) ic integer ( kind = 4 ) idij integer ( kind = 4 ) ik integer ( kind = 4 ) ipph integer ( kind = 4 ) is integer ( kind = 4 ) j integer ( kind = 4 ) j2 integer ( kind = 4 ) jc integer ( kind = 4 ) k integer ( kind = 4 ) l integer ( kind = 4 ) lc integer ( kind = 4 ) nbd real ( kind = 8 ) :: pi = 3.141592653589793D+00 real ( kind = 8 ) wa(*) arg = 2.0D+00 * pi / real ( ip, kind = 8 ) 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 random_initialize ( seed ) !*****************************************************************************80 ! !! RANDOM_INITIALIZE initializes the FORTRAN90 random number seed. ! ! Discussion: ! ! If you don't initialize the random number generator, its behavior ! is not specified. If you initialize it simply by: ! ! call random_seed ( ) ! ! its behavior is not specified. On the DEC ALPHA, if that's all you ! do, the same random number sequence is returned. In order to actually ! try to scramble up the random number generator a bit, this routine ! goes through the tedious process of getting the size of the random ! number seed, making up values based on the current time, and setting ! the random number seed. ! ! Modified: ! ! 06 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer ( kind = 4 ) SEED, a seed value. ! implicit none integer ( kind = 4 ) date_time(8) integer ( kind = 4 ) i integer ( kind = 4 ) seed integer ( kind = 4 ), allocatable :: seed_vector(:) integer ( kind = 4 ) seed_size real ( kind = 8 ) t ! ! Initialize the random number seed. ! call random_seed ( ) ! ! Determine the size of the random number seed. ! call random_seed ( size = seed_size ) ! ! Allocate a seed of the right size. ! allocate ( seed_vector(seed_size) ) ! ! Get the current date and time. ! call date_and_time ( values = date_time ) ! ! Construct a slightly random value. ! seed = 0 do i = 1, 8 seed = ieor ( seed, date_time(i) ) end do ! ! Make slightly random assignments to SEED_VECTOR. ! do i = 1, seed_size seed_vector(i) = ieor ( seed, i ) end do ! ! Set the random number seed value. ! call random_seed ( put = seed_vector(1:seed_size) ) ! ! Free up the seed space. ! deallocate ( seed_vector ) do i = 1, 100 call random_number ( harvest = t ) end do return end subroutine result ( nr, n, x, f, g, a, p, itncnt, iflg, ipr ) !*****************************************************************************80 ! !! RESULT prints information about the optimization process. ! ! Parameters: ! ! Input, integer ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) X(N), the current iterate. ! ! Input, real ( kind = 8 ) F, the function value at X. ! ! Input, real ( kind = 8 ) G(N), the gradient at X. ! ! Input, real ( kind = 8 ) A(NR,N), the N by N Hessian matrix at X. ! ! Input, real ( kind = 8 ) P(N), the step taken. ! ! Input, integer ( kind = 4 ) ITNCNT, the iteration number. ! ! Input, integer ( kind = 4 ) IFLG, the flag controlling the amount ! of printout. ! ! Input, integer ( kind = 4 ) IPR, the device to which to send output. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) f real ( kind = 8 ) g(n) integer ( kind = 4 ) i integer ( kind = 4 ) iflg integer ( kind = 4 ) ipr integer ( kind = 4 ) itncnt real ( kind = 8 ) p(n) real ( kind = 8 ) 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 ) ! ! Modified: ! ! 11 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the argument of Runge's function. ! ! Output, real ( kind = 8 ) RUNGE, the value of Runge's function. ! implicit none real ( kind = 8 ) runge real ( kind = 8 ) 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 ) ! ! Modified: ! ! 11 November 1999 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ( kind = 8 ) X, the evaluation point. ! ! Output, real ( kind = 8 ) RUNGEP, the derivative of Runge's function. ! implicit none real ( kind = 8 ) rungep real ( kind = 8 ) 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. ! ! Parameters: ! ! Input, integer ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) X(N), the old iterate, X[K-1]. ! ! Input, real ( kind = 8 ) G(N), the gradient or an approximation, ! at the old iterate. ! ! Input/output, real ( kind = 8 ) 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 = 8 ) XPLS(N), the new iterate, X[K]. ! ! Input, real ( kind = 8 ) GPLSN(N), gradient, or an approximation, ! at the new iterate. ! ! Input, real ( kind = 8 ) EPSM, the machine epsilon. ! ! Input, integer ( kind = 4 ) ITNCNT, the iteration count. ! ! Input, real ( kind = 8 ) RNF, the relative noise in the optimization ! function FCN. ! ! Input, integer ( kind = 4 ) 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 = 8 ) S(N). ! ! Workspace, real ( kind = 8 ) Y(N). ! ! Workspace, real ( kind = 8 ) U(N). ! ! Workspace, real ( kind = 8 ) W(N). ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) alp real ( kind = 8 ) den1 real ( kind = 8 ) den2 real ( kind = 8 ) dnrm2 real ( kind = 8 ) epsm real ( kind = 8 ) g(n) real ( kind = 8 ) gpls(n) integer ( kind = 4 ) i integer ( kind = 4 ) iagflg integer ( kind = 4 ) itncnt integer ( kind = 4 ) j logical noupdt real ( kind = 8 ) reltol real ( kind = 8 ) rnf real ( kind = 8 ) s(n) logical skpupd real ( kind = 8 ) snorm2 real ( kind = 8 ) u(n) real ( kind = 8 ) w(n) real ( kind = 8 ) x(n) real ( kind = 8 ) xpls(n) real ( kind = 8 ) y(n) real ( kind = 8 ) 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. ! ! Parameters: ! ! Input, integer ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) X(N), the old iterate, X[K-1]. ! ! Input, real ( kind = 8 ) G(N), the gradient, or an approximate value, ! at the old iterate. ! ! Input/output, real ( kind = 8 ) 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 = 8 ) UDIAG(N), the diagonal entries of the hessian. ! ! Input, real ( kind = 8 ) XPLS(N), the new iterate, X[K]. ! ! Input, real ( kind = 8 ) GPLS(N), the gradient or an approximate value, at ! the new iterate ! ! Input, real ( kind = 8 ) EPSM, the machine epsilon. ! ! Input, integer ( kind = 4 ) ITNCNT, the iteration count. ! ! Input, real ( kind = 8 ) RNF, the relative noise in the optimization ! function. ! ! Input, integer ( kind = 4 ) 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 = 8 ) S(N). ! ! Workspace, real ( kind = 8 ) Y(N). ! ! Workspace, real ( kind = 8 ) T(N). ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) den1 real ( kind = 8 ) den2 real ( kind = 8 ) dnrm2 real ( kind = 8 ) epsm real ( kind = 8 ) g(n) real ( kind = 8 ) gam real ( kind = 8 ) gpls(n) integer ( kind = 4 ) i integer ( kind = 4 ) iagflg integer ( kind = 4 ) itncnt integer ( kind = 4 ) j logical noupdt real ( kind = 8 ) rnf real ( kind = 8 ) s(n) logical skpupd real ( kind = 8 ) snorm2 real ( kind = 8 ) t(n) real ( kind = 8 ) tol real ( kind = 8 ) udiag(n) real ( kind = 8 ) x(n) real ( kind = 8 ) xpls(n) real ( kind = 8 ) y(n) real ( kind = 8 ) 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 ) ) ! ! 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 ( kind = 4 ) 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 = 8 ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ) wsave(3*n+15) real ( kind = 8 ) 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 ) ) ! ! 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 ( kind = 4 ) 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 = 8 ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n real ( kind = 8 ) wsave(3*n+15) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the length of the array to be transformed. ! ! Output, real ( kind = 8 ) WSAVE(3*N+15), contains data, dependent on ! the value of N, which is necessary for the SINQF or SINQB routines. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) 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 ) ) ! ! 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 ( kind = 4 ) 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 = 8 ) X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n integer ( kind = 4 ) iw1 integer ( kind = 4 ) iw2 integer ( kind = 4 ) iw3 real ( kind = 8 ) wsave((5*n+30)/2) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to ! be transformed. ! ! Input/output, real ( kind = 8 ) WAR(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real ( kind = 8 ) WAS(N/2). ! ! Input, real ( kind = 8 ) XH(N). ! ! Input, real ( kind = 8 ) X(N+1). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) ifac(15) integer ( kind = 4 ) k integer ( kind = 4 ) ns2 real ( kind = 8 ), parameter :: sqrt3 = 1.73205080756888D+00 real ( kind = 8 ) t1 real ( kind = 8 ) t2 real ( kind = 8 ) war(n) real ( kind = 8 ) was(n/2) real ( kind = 8 ) x(n+1) real ( kind = 8 ) xh(n) real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) 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 = 8 ) WSAVE((5*N+30)/2), contains data, dependent ! on the value of N, which is necessary for the SINT routine. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) :: pi = 3.141592653589793D+00 real ( kind = 8 ) dt integer ( kind = 4 ) k real ( kind = 8 ) wsave((5*n+30)/2) if ( n <= 1 ) then return end if dt = pi / real ( n + 1, kind = 8 ) do k = 1, n/2 wsave(k) = 2.0D+00 * sin ( real ( k, kind = 8 ) * 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. ! ! Parameters: ! ! Input, integer ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n ! real x(n) ! real f ! ! Input, real ( kind = 8 ) FPLS, the function value at the new iterate. ! ! Output, real ( kind = 8 ) 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 = 8 ) SX(N), the diagonal scaling for X. ! ! Input, real ( kind = 8 ) RNOISE, the relative noise in the function. ! ! Workspace, real ( kind = 8 ) STEPSZ(N), used for the stepsize. ! ! Workspace, real ( kind = 8 ) ANBR(N), holds neighbors. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) anbr(n) external fcn real ( kind = 8 ) fhat real ( kind = 8 ) fpls integer ( kind = 4 ) i integer ( kind = 4 ) j real ( kind = 8 ) ov3 real ( kind = 8 ) rnoise real ( kind = 8 ) stepsz(n) real ( kind = 8 ) sx(n) real ( kind = 8 ) xpls(n) real ( kind = 8 ) xtmpi real ( kind = 8 ) 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 GNU LGPL license. ! ! Modified: ! ! 18 May 2013 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! None ! implicit none character ( len = 8 ) ampm integer ( kind = 4 ) d integer ( kind = 4 ) h integer ( kind = 4 ) m integer ( kind = 4 ) mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer ( kind = 4 ) n integer ( kind = 4 ) s integer ( kind = 4 ) values(8) integer ( kind = 4 ) 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. ! ! Parameters: ! ! Input, integer ( kind = 4 ) NR, the row dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) X(N), the old iterate X[K-1]. ! ! Input, real ( kind = 8 ) F, the function value at the old iterate. ! ! Input, real ( kind = 8 ) G(N), the gradient at the old iterate, or ! an approximate value of it. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n ! real ( kind = 8 ) x(n) ! real ( kind = 8 ) f ! ! Input, real ( kind = 8 ) SC(N), the current step. ! ! Input, real ( kind = 8 ) SX(N), the diagonal scaling matrix for X. ! ! Input, logical NWTAKE, is TRUE if a Newton step is taken. ! ! Input, real ( kind = 8 ) STEPMX, the maximum allowable step size. ! ! Input, real ( kind = 8 ) STEPTL, the relative step size at which successive ! iterates are considered close enough to terminate algorithm. ! ! Input/output, real ( kind = 8 ) DLT, the trust region radius. ! ! Input/output, integer ( kind = 4 ) 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 = 8 ) XPLSP(N), [value needs to be retained between ! succesive calls of k-th global step]. ! ! Worskpace, real ( kind = 8 ) FPLSP, [retain value between successive ! calls]. ! ! Output, real ( kind = 8 ) XPLS(N), the new iterate x[k]. ! ! Output, real ( kind = 8 ) FPLS, the function value at the new iterate. ! ! Output, logical MXTAKE, is TRUE if a step of maximum length was taken. ! ! Input, integer ( kind = 4 ) IPR, the device to which to send output. ! ! Input, integer ( kind = 4 ) METHOD, the algorithm to use. ! 1, line search, ! 2, double dogleg, ! 3, More-Hebdon. ! ! Input, real ( kind = 8 ) UDIAG(N), the diagonal of hessian in a(.,.) ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) nr real ( kind = 8 ) a(nr,n) real ( kind = 8 ) dlt real ( kind = 8 ) dltf real ( kind = 8 ) dltfp real ( kind = 8 ) dltmp real ( kind = 8 ) f external fcn real ( kind = 8 ) fpls real ( kind = 8 ) fplsp real ( kind = 8 ) g(n) integer ( kind = 4 ) i integer ( kind = 4 ) ipr integer ( kind = 4 ) iretcd integer ( kind = 4 ) j integer ( kind = 4 ) method logical mxtake logical nwtake real ( kind = 8 ) rln real ( kind = 8 ) sc(n) real ( kind = 8 ) slp real ( kind = 8 ) stepmx real ( kind = 8 ) steptl real ( kind = 8 ) sx(n) real ( kind = 8 ) temp real ( kind = 8 ) udiag(n) real ( kind = 8 ) x(n) real ( kind = 8 ) xpls(n) real ( kind = 8 ) xplsp(n) 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. ! ! 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 ( kind = 4 ) N, the dimension of the problem. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n ! real ( kind = 8 ) x(n) ! real ( kind = 8 ) f ! ! Output, real ( kind = 8 ) X(N), the local minimizer. ! ! Output, real ( kind = 8 ) F, the function value at X. ! ! Output, integer ( kind = 4 ) 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 = 8 ) W(LW). ! ! Input, integer ( kind = 4 ) LW, the size of the workspace vector W, which ! must be at least N * ( N + 10 ). ! implicit none integer ( kind = 4 ) lw integer ( kind = 4 ) n external d1fcn external d2fcn real ( kind = 8 ) dlt real ( kind = 8 ) epsm real ( kind = 8 ) f external fcn real ( kind = 8 ) fscale real ( kind = 8 ) gradtl integer ( kind = 4 ) ia integer ( kind = 4 ) iagflg integer ( kind = 4 ) iahflg integer ( kind = 4 ) iexp integer ( kind = 4 ) ig integer ( kind = 4 ) info integer ( kind = 4 ) ipr integer ( kind = 4 ) it integer ( kind = 4 ) itnlim integer ( kind = 4 ) iw1 integer ( kind = 4 ) iw2 integer ( kind = 4 ) iw3 integer ( kind = 4 ) iw4 integer ( kind = 4 ) iw5 integer ( kind = 4 ) iw6 integer ( kind = 4 ) iw7 integer ( kind = 4 ) iw8 integer ( kind = 4 ) lwmin integer ( kind = 4 ) method integer ( kind = 4 ) msg integer ( kind = 4 ) ndigit integer ( kind = 4 ) nr real ( kind = 8 ) stepmx real ( kind = 8 ) steptl real ( kind = 8 ) w(lw) real ( kind = 8 ) x(n) real ( kind = 8 ) 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. ! ! 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 = 8 ) UNI, a random number in the interval [0,1]. ! implicit none real ( kind = 8 ), save :: c = 362436.0D+00 / 16777216.0D+00 real ( kind = 8 ), parameter :: cd = 7654321.0D+00 / 16777216.0D+00 real ( kind = 8 ), parameter :: cm = 16777213.0D+00 / 16777216.0D+00 real ( kind = 8 ), parameter :: csave = 362436.0D+00 / 16777216.0D+00 integer ( kind = 4 ), save :: i = 17 integer ( kind = 4 ) i1 integer ( kind = 4 ) ii integer ( kind = 4 ) iseed integer ( kind = 4 ), save :: j = 5 integer ( kind = 4 ) j1 integer ( kind = 4 ) jj integer ( kind = 4 ), save :: k = 24 integer ( kind = 4 ) k1 integer ( kind = 4 ) kk integer ( kind = 4 ) l1 integer ( kind = 4 ) m1 real ( kind = 8 ) s real ( kind = 8 ) t real ( kind = 8 ), 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 = 8 ) uni real ( kind = 8 ) unib real ( kind = 8 ) 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. ! ! 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 = 8 ) return entry unib ( kk ) !*****************************************************************************80 ! !! UNIB ? ! if ( kk <= 24 ) then k = 24 else k = kk end if unib = real ( k, kind = 8 ) 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. ! ! 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 ( kind = 4 ) NMESSG, the actual number of characters ! in MESSG. If NMESSG is 0, no message is being supplied. ! implicit none character ( len = * ) messg integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) j4save integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) NMESSG, same as in the call to XERROR ! or XERRWV. ! ! Input, integer ( kind = 4 ) NERR, same as in the call to XERROR or XERRWV. ! ! Input, integer ( kind = 4 ) LEVEL, same as in the call to XERROR or XERRWV. ! ! Input/output, integer ( kind = 4 ) 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 ( kind = 4 ) kontrl integer ( kind = 4 ) level character ( len = * ) messg1 integer ( kind = 4 ) nerr integer ( kind = 4 ) nmessg return end subroutine xerdmp !*****************************************************************************80 ! !! XERDMP prints the error tables and then clears them. ! ! 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 ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) MAXNUM, the maximum number of times any one ! message is to be printed. ! implicit none integer ( kind = 4 ) j4save integer ( kind = 4 ) junk integer ( kind = 4 ) maxnum junk = j4save ( 4, maxnum, .true. ) return end subroutine xerprt ( messg, nmessg ) !*****************************************************************************80 ! !! XERPRT prints a message on each file indicated by xgetua. ! ! 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 ( kind = 4 ) NMESSG, the actual number of characters ! in MESSG. ! implicit none integer ( kind = 4 ) ichar integer ( kind = 4 ) iunit integer ( kind = 4 ) kunit integer ( kind = 4 ) last integer ( kind = 4 ) lenmes integer ( kind = 4 ) lun(5) character ( len = * ) messg integer ( kind = 4 ) nmessg integer ( kind = 4 ) nunit ! ! 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. ! ! Example: ! ! 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) ! ! 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 ( kind = 4 ) NERR, the error number associated with this ! message. NERR must not be zero. ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) level character ( len = * ) messg integer ( kind = 4 ) nerr integer ( kind = 4 ) 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 ( kind = 4 ) values and two real ! values may be printed along with the message. ! ! Example: ! ! 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) ! ! 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 ( kind = 4 ) NMESSG, the number of characters in MESSG. ! ! Input, integer ( kind = 4 ) NERR, the error number associated with ! this message. NERR must not be zero. ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) NI, the number of integer values to be ! printed. (0 to 2) ! ! Input, integer ( kind = 4 ) I1, I2, the first and second integer values. ! ! Input, integer ( kind = 4 ) NR, the number of real values to be ! printed. (0 to 2) ! ! Input, real ( kind = 8 ) R1, R2, the first and second real values. ! implicit none character ( len = 37 ) form integer ( kind = 4 ) i integer ( kind = 4 ) i1 integer ( kind = 4 ) i1mach integer ( kind = 4 ) i2 integer ( kind = 4 ) ifatal integer ( kind = 4 ) isizei integer ( kind = 4 ) isizef integer ( kind = 4 ) iunit integer ( kind = 4 ) j4save integer ( kind = 4 ) junk integer ( kind = 4 ) kdummy integer ( kind = 4 ) kount integer ( kind = 4 ) kunit integer ( kind = 4 ) lerr integer ( kind = 4 ) level character ( len = 20 ) lfirst integer ( kind = 4 ) lkntrl integer ( kind = 4 ) llevel integer ( kind = 4 ) lmessg integer ( kind = 4 ) lun(5) integer ( kind = 4 ) maxmes character ( len = * ) messg integer ( kind = 4 ) mkntrl integer ( kind = 4 ) nerr integer ( kind = 4 ) ni integer ( kind = 4 ) nmessg integer ( kind = 4 ) nr integer ( kind = 4 ) nunit real ( kind = 8 ) r1 real ( kind = 8 ) 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 = log10 ( real ( i1mach(9), kind = 8 ) ) + 1.0D+00 isizef = log10 ( real ( i1mach(10), kind = 8 )**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. ! ! 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 ( kind = 4 ) 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 ( kind = 4 ) NERR, as in XERROR. ! ! Input, integer ( kind = 4 ) LEVEL, as in XERROR. ! ! Output, integer ( kind = 4 ) 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 ( kind = 4 ) i integer ( kind = 4 ) i1mach integer ( kind = 4 ) icount integer ( kind = 4 ) ii integer ( kind = 4 ) iunit integer ( kind = 4 ), save, dimension ( 10 ) :: kount = (/ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) integer ( kind = 4 ), save :: kountx = 0 integer ( kind = 4 ) kunit integer ( kind = 4 ) level integer ( kind = 4 ), save, dimension ( 10 ) :: levtab integer ( kind = 4 ) lun(5) character ( len = 20 ) mes character ( len = * ) messg character ( len = 20 ), save, dimension ( 10 ) :: mestab integer ( kind = 4 ) nerr integer ( kind = 4 ), save, dimension ( 10 ) :: nertab integer ( kind = 4 ) nmessg integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) KONTRL, the current value of the error ! control flag. ! implicit none integer ( kind = 4 ) j4save integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) 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 ( kind = 4 ) 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 ( kind = 4 ) i integer ( kind = 4 ) index integer ( kind = 4 ) iunita(5) integer ( kind = 4 ) j4save integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) 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 ( kind = 4 ) iunit integer ( kind = 4 ) 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 ! ! 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 ( kind = 4 ) KONTRL, the desired value of the error ! control flag. ! implicit none integer ( kind = 4 ) j4save integer ( kind = 4 ) junk integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) IUNIT(N), unit numbers, which should normally ! be distinct. ! ! Input, integer ( kind = 4 ) N, the number of unit numbers provided ! in IUNIT. N must be between 1 and 5. ! implicit none integer ( kind = 4 ) n integer ( kind = 4 ) i integer ( kind = 4 ) index integer ( kind = 4 ) iunita(n) integer ( kind = 4 ) j4save integer ( kind = 4 ) 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. ! ! 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 ( kind = 4 ) IUNIT, the logical unit number to which error ! messages are to be sent. ! implicit none integer ( kind = 4 ) iunit integer ( kind = 4 ) j4save integer ( kind = 4 ) 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 ) ! ! 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 ( kind = 4 ) 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 = 8 ) 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 = 8 ) 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 ( kind = 4 ) n complex ( kind = 8 ) c(n) real ( kind = 8 ) 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. ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to be ! transformed. ! ! Input/output, complex ( kind = 8 ) 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 = 8 ) CH(N). ! ! Input, real ( kind = 8 ) WA(2*N). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n complex ( kind = 8 ) c(n) complex ( kind = 8 ) ch(n) integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ifac(15) integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) na integer ( kind = 4 ) nac integer ( kind = 4 ) nf real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) LDF, the leading dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the number of rows and columns in the ! matrix. ! ! Input/output, complex ( kind = 8 ) F(LDF,N), ! On input, an N by N array of complex values to be transformed. ! On output, the transformed values. ! ! Input, real ( kind = 8 ) WSAVE(4*N+15), a work array whose values ! depend on N, and which must be initialized by calling ZFFTI. ! implicit none integer ( kind = 4 ) ldf integer ( kind = 4 ) n complex ( kind = 8 ) f(ldf,n) integer ( kind = 4 ) i real ( kind = 8 ) 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 ) ! ! 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 ( kind = 4 ) 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 = 8 ) C(N). ! On input, the data sequence to be transformed. ! On output, the Fourier coefficients. ! ! Input, real ( kind = 8 ) 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 ( kind = 4 ) n complex ( kind = 8 ) c(n) real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to ! be transformed. ! ! Input/output, complex ( kind = 8 ) C(N). ! On input, the data sequence to be transformed. ! On output, the Fourier coefficients. ! ! Input, complex ( kind = 8 ) CH(N). ! ! Input, real ( kind = 8 ) WA(2*N). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n complex ( kind = 8 ) c(n) complex ( kind = 8 ) ch(n) integer ( kind = 4 ) idl1 integer ( kind = 4 ) ido integer ( kind = 4 ) ifac(15) integer ( kind = 4 ) ip integer ( kind = 4 ) iw integer ( kind = 4 ) ix2 integer ( kind = 4 ) ix3 integer ( kind = 4 ) ix4 integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) na integer ( kind = 4 ) nac integer ( kind = 4 ) nf real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) LDF, the leading dimension of the matrix. ! ! Input, integer ( kind = 4 ) N, the number of rows and columns in ! the matrix. ! ! Input/output, complex ( kind = 8 ) F(LDF,N), ! On input, an N by N array of complex values to be transformed. ! On output, the transformed values. ! ! Input, real ( kind = 8 ) WSAVE(4*N+15), a work array whose values depend ! on N, and which must be initialized by calling CFFTI. ! implicit none integer ( kind = 4 ) ldf integer ( kind = 4 ) n complex ( kind = 8 ) f(ldf,n) integer ( kind = 4 ) i real ( kind = 8 ) 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. ! ! 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 ( kind = 4 ) N, the length of the sequence to ! be transformed. ! ! Output, real ( kind = 8 ) WSAVE(4*N+15), contains data, dependent on ! the value of N, which is necessary for the CFFTF or CFFTB routines. ! implicit none integer ( kind = 4 ) n real ( kind = 8 ) 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. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer ( kind = 4 ) N, the length of the sequence to ! be transformed. ! ! Input, real ( kind = 8 ) WA(2*N). ! ! Input, integer ( kind = 4 ) 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 ( kind = 4 ) n real ( kind = 8 ) arg real ( kind = 8 ) argh real ( kind = 8 ) argld real ( kind = 8 ) fi integer ( kind = 4 ) i integer ( kind = 4 ) i1 integer ( kind = 4 ) ido integer ( kind = 4 ) ifac(15) integer ( kind = 4 ) ii integer ( kind = 4 ) ip integer ( kind = 4 ) j integer ( kind = 4 ) k1 integer ( kind = 4 ) l1 integer ( kind = 4 ) l2 integer ( kind = 4 ) ld integer ( kind = 4 ) nf real ( kind = 8 ) :: pi = 3.141592653589793D+00 real ( kind = 8 ) wa(2*n) call i8_factor ( n, ifac ) nf = ifac(2) argh = 2.0D+00 * pi / real ( n, kind = 8 ) 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 = 8 ) * 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