subroutine airy_values ( n, x, ax, ap, bx, bp ) ! !******************************************************************************* ! !! AIRY_VALUES returns some values of the Airy function for testing. ! ! ! Modified: ! ! 18 April 2001 ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. ! On input, if N is 0, the first test data is returned, and N is set ! to the index of the test data. On each subsequent call, N is ! incremented and that test data is returned. When there is no more ! test data, N is set to 0. ! ! Output, real X, the argument of the function. ! ! Output, real AX, AP, the value and derivative of the Airy AI function. ! ! Output, real BX, BP, the value and derivative of the Airy BI function. ! implicit none ! integer, parameter :: nmax = 11 ! real ap real, save, dimension ( nmax ) :: apvec = (/ & -0.25881940E+00, -0.25713042E+00, -0.25240547E+00, -0.24514636E+00, & -0.23583203E+00, -0.22491053E+00, -0.21279326E+00, -0.19985119E+00, & -0.18641286E+00, -0.17276384E+00, -0.15914744E+00 /) real ax real, save, dimension ( nmax ) :: axvec = (/ & 0.35502805E+00, 0.32920313E+00, 0.30370315E+00, 0.27880648E+00, & 0.25474235E+00, 0.23169361E+00, 0.20980006E+00, 0.18916240E+00, & 0.16984632E+00, 0.15188680E+00, 0.13529242E+00 /) real bp real, save, dimension ( nmax ) :: bpvec = (/ & 0.44828836E+00, 0.45151263E+00, 0.46178928E+00, 0.48004903E+00, & 0.50728168E+00, 0.54457256E+00, 0.59314448E+00, 0.65440592E+00, & 0.73000690E+00, 0.82190389E+00, 0.93243593E+00 /) real bx real, save, dimension ( nmax ) :: bxvec = (/ & 0.61492663E+00, 0.65986169E+00, 0.70546420E+00, 0.75248559E+00, & 0.80177300E+00, 0.85427704E+00, 0.91106334E+00, 0.97332866E+00, & 1.04242217E+00, 1.11987281E+00, 1.20742359E+00 /) real fx integer n real x real, save, dimension ( nmax ) :: xvec = (/ & 0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00, & 0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00, & 0.8E+00, 0.9E+00, 1.0E+00 /) ! if ( n < 0 ) then n = 0 end if n = n + 1 if ( n > nmax ) then n = 0 x = 0.0E+00 ax = 0.0E+00 ap = 0.0E+00 bx = 0.0E+00 bp = 0.0E+00 return end if x = xvec(n) ax = axvec(n) ap = apvec(n) bx = bxvec(n) bp = bpvec(n) return end function alngam ( x ) ! !******************************************************************************* ! !! ALNGAM computes the log of the absolute value of the Gamma function. ! ! ! Definition: ! ! The Gamma function is defined as ! ! GAMMA(Z) = INTEGRAL ( 0 <= T < Infinity) T**(Z-1) EXP ( -T ) DT ! ! If Z is a positive integer, GAMMA(Z) = (Z-1)!, the factorial. ! ! There is a special value: ! ! GAMMA(0.5) = SQRT ( PI ). ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Modified: ! ! 31 May 2000 ! ! Parameters: ! ! Input, real X, the argument of the gamma function. ! ! Output, real ALNGAM, the logarithm of the absolute value of GAMMA(X). ! implicit none ! real alngam real, save :: dxrel = 0.0E+00 real gamma real, parameter :: pi = 3.14159265358979323846264338327950288419716939937510E+00 real r9lgmc real sinpiy real, parameter :: sq2pil = 0.91893853320467274E+00 real, parameter :: sqpi2l = 0.22579135264472743E+00 real x real, save :: xmax = 0.0E+00 real y ! if ( xmax == 0.0E+00 ) then xmax = huge ( xmax ) / log ( huge ( xmax ) ) dxrel = sqrt ( epsilon ( dxrel ) ) end if y = abs ( x ) if ( y <= 10.0E+00 ) then alngam = log ( abs ( gamma ( x ) ) ) return end if if ( y > xmax ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ALNGAM - Fatal error!' write ( *, '(a)' ) ' |X| is so big that ALNGAM will overflow.' stop end if if ( x > 0.0E+00 ) then alngam = sq2pil + ( x - 0.5E+00 ) * log ( x ) - x + r9lgmc ( y ) return end if sinpiy = abs ( sin ( pi * y ) ) if ( sinpiy == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ALNGAM - Fatal error!' write ( *, '(a)' ) ' X is a negative integer.' stop end if if ( abs ( ( x - aint ( x - 0.5E+00 ) ) / x ) < dxrel ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'ALNGAM - Warning:' write ( *, '(a)' ) ' Answer has less than half usual precision.' write ( *, '(a)' ) ' X is very near a negative integer.' end if alngam = sqpi2l + ( x - 0.5E+00 ) * log ( y ) - x - log ( sinpiy ) & - r9lgmc ( y ) return end subroutine asyjy ( funjy, x, fnu, flgjy, in, y, wk, iflw ) ! !******************************************************************************* ! !! ASYJY computes high order Bessel functions J and Y. ! ! ! Description: ! ! ASYJY implements the uniform asymptotic expansion of ! the J and Y Bessel functions for FNU >= 35 and X > 0.0. ! ! 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. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Modified: ! ! 25 August 2001 ! ! Author: ! ! D E Amos ! ! Parameters: ! ! Input, external FUNJY, is the function JAIRY or YAIRY. ! ! Input, real X, the argument, which must be greater than 0. ! ! Input, real FNU, the order of the first Bessel function. ! FNU is generally at least 35. ! ! Input, real FLGJY, a selection flag ! 1.0E+00 gives the J function ! -1.0E+00 gives the Y function ! ! Input, integer IN, the number of functions desired, which should be ! 1 or 2. ! ! Output, real Y(IN), contains the desired function values. ! ! Output, integer IFLW, a flag indicating underflow or overflow ! return variables for BESJ only. ! ! Output, real 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 abw2 real akm real alfa(26,4) real alfa1(26,2) real alfa2(26,2) real ap real, parameter, dimension ( 8 ) :: ar = (/ & 8.35503472222222E-02, 1.28226574556327E-01, & 2.91849026464140E-01, 8.81627267443758E-01, 3.32140828186277E+00, & 1.49957629868626E+01, 7.89230130115865E+01, 4.74451538868264E+02 /) real asum real az real beta(26,5) real beta1(26,2) real beta2(26,2) real beta3(26,1) real br(10) real bsum real c(65) real, parameter :: con1 = 6.66666666666667E-01 real, parameter :: con2 = 3.33333333333333E-01 real, parameter :: con548 = 1.04166666666667E-01 real cr(10) real crz32 real dfi real elim real dr(10) real fi real flgjy real fn real fnu real fn2 external funjy real gama(26) integer i integer i1mach integer iflw integer in integer j integer jn integer jr integer ju integer k integer kb integer klast integer kmax(5) integer kp1 integer ks integer ksp1 integer kstemp integer l integer lr integer lrp1 real phi real rcz real rden real relb real rfn2 real rtz real rzden real sa real sb real suma real sumb real s1 real ta real tau real tb real tfn real tol real, save :: tols = -6.90775527898214E+00 real t2 real upol(10) real wk(*) real x real xx real y(*) real z real z32 real r1mach ! 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.45833333333333e-01,-9.87413194444444e-02, & -1.43312053915895e-01,-3.17227202678414e-01,-9.42429147957120e-01, & -3.51120304082635,-1.57272636203680e+01,-8.22814390971859e+01, & -4.92355370523671e+02,-3.31621856854797e+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.08333333333333e-01, 1.25000000000000e-01, & 3.34201388888889e-01, -4.01041666666667e-01, & 7.03125000000000e-02, -1.02581259645062, & 1.84646267361111, -8.91210937500000e-01, & 7.32421875000000e-02, 4.66958442342625, & -1.12070026162230e+01, 8.78912353515625, & -2.36408691406250, 1.12152099609375e-01, & -2.82120725582002e+01, 8.46362176746007e+01, & -9.18182415432400e+01, 4.25349987453885e+01, & -7.36879435947963, 2.27108001708984e-01, & 2.12570130039217e+02, -7.65252468141182e+02, & 1.05999045252800e+03, -6.99579627376133e+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.18190511744212e+02, -2.64914304869516e+01, & 5.72501420974731e-01, -1.91945766231841e+03, & 8.06172218173731e+03, -1.35865500064341e+04, & 1.16553933368645e+04, -5.30564697861340e+03, & 1.20090291321635e+03, -1.08090919788395e+02, & 1.72772750258446, 2.02042913309661e+04, & -9.69805983886375e+04, 1.92547001232532e+05, & -2.03400177280416e+05, 1.22200464983017e+05, & -4.11926549688976e+04, 7.10951430248936e+03, & -4.93915304773088e+02, 6.07404200127348, & -2.42919187900551e+05, 1.31176361466298e+06, & -2.99801591853811e+06, 3.76327129765640e+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.81356322658653e+06, 1.26836527332162e+06, & -3.31645172484564e+05, 4.52187689813627e+04, & -2.49983048181121e+03, 2.43805296995561e+01, & 3.28446985307204e+06, -1.97068191184322e+07, & 5.09526024926646e+07, -7.41051482115327e+07, & 6.63445122747290e+07, -3.75671766607634e+07, & 1.32887671664218e+07, -2.78561812808645e+06, & 3.08186404612662e+05, -1.38860897537170e+04, & 1.10017140269247e+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.44444444444444e-03,-9.22077922077922e-04, & -8.84892884892885e-05, 1.65927687832450e-04, 2.46691372741793e-04, & 2.65995589346255e-04, 2.61824297061501e-04, 2.48730437344656e-04, & 2.32721040083232e-04, 2.16362485712365e-04, 2.00738858762752e-04, & 1.86267636637545e-04, 1.73060775917876e-04, 1.61091705929016e-04, & 1.50274774160908e-04, 1.40503497391270e-04, 1.31668816545923e-04, & 1.23667445598253e-04, 1.16405271474738e-04, 1.09798298372713e-04, & 1.03772410422993e-04, 9.82626078369363e-05, 9.32120517249503e-05, & 8.85710852478712e-05, 8.42963105715700e-05, 8.03497548407791e-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.93735541354589e-04, 2.32241745182922e-04, & -1.41986273556691e-05,-1.16444931672049e-04,-1.50803558053049e-04,& -1.55121924918096e-04,-1.46809756646466e-04,-1.33815503867491e-04, & -1.19744975684254e-04,-1.06184319207974e-04,-9.37699549891194e-05, & -8.26923045588193e-05,-7.29374348155221e-05,-6.44042357721016e-05, & -5.69611566009369e-05,-5.04731044303562e-05,-4.48134868008883e-05, & -3.98688727717599e-05,-3.55400532972042e-05,-3.17414256609022e-05, & -2.83996793904175e-05,-2.54522720634871e-05,-2.28459297164725e-05, & -2.05352753106481e-05,-1.84816217627666e-05,-1.66519330021394e-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.54211971457744e-04,-1.56161263945159e-04, & 3.04465503594936e-05, 1.30198655773243e-04, 1.67471106699712e-04, & 1.70222587683593e-04, 1.56501427608595e-04, 1.36339170977445e-04, & 1.14886692029825e-04, 9.45869093034688e-05, 7.64498419250898e-05, & 6.07570334965197e-05, 4.74394299290509e-05, 3.62757512005344e-05, & 2.69939714979225e-05, 1.93210938247939e-05, 1.30056674793963e-05, & 7.82620866744497e-06, 3.59257485819352e-06, 1.44040049814252e-07, & -2.65396769697939e-06,-4.91346867098486e-06,-6.72739296091248e-06, & -8.17269379678658e-06,-9.31304715093561e-06,-1.02011418798016e-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.78194199201773e-04, 2.02471952761816e-04, & -6.37938506318862e-05,-2.38598230603006e-04,-3.10916256027362e-04, & -3.13680115247576e-04,-2.78950273791323e-04,-2.28564082619141e-04, & -1.75245280340847e-04,-1.25544063060690e-04,-8.22982872820208e-05, & -4.62860730588116e-05,-1.72334302366962e-05, 5.60690482304602e-06, & 2.31395443148287e-05, 3.62642745856794e-05, 4.58006124490189e-05, & 5.24595294959114e-05, 5.68396208545815e-05, 5.94349820393104e-05, & 6.06478527578422e-05, 6.08023907788436e-05, 6.01577894539460e-05, & 5.89199657344698e-05, 5.72515823777593e-05, 5.52804375585853e-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.79988721413553e-02, 5.59964911064388e-03, & 2.88501402231133e-03, 1.80096606761054e-03, 1.24753110589199e-03, & 9.22878876572938e-04, 7.14430421727287e-04, 5.71787281789705e-04, & 4.69431007606482e-04, 3.93232835462917e-04, 3.34818889318298e-04, & 2.88952148495752e-04, 2.52211615549573e-04, 2.22280580798883e-04, & 1.97541838033063e-04, 1.76836855019718e-04, 1.59316899661821e-04, & 1.44347930197334e-04, 1.31448068119965e-04, 1.20245444949303e-04, & 1.10449144504599e-04, 1.01828770740567e-04, 9.41998224204238e-05, & 8.74130545753834e-05, 8.13466262162801e-05, 7.59002269646219e-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.49282953213429e-03,-8.78204709546389e-04, & -5.02916549572035e-04,-2.94822138512746e-04,-1.75463996970783e-04, & -1.04008550460816e-04,-5.96141953046458e-05,-3.12038929076098e-05, & -1.26089735980230e-05,-2.42892608575730e-07, 8.05996165414274e-06, & 1.36507009262147e-05, 1.73964125472926e-05, 1.98672978842134e-05, & 2.14463263790823e-05, 2.23954659232457e-05, 2.28967783814713e-05, & 2.30785389811178e-05, 2.30321976080909e-05, 2.28236073720349e-05, & 2.25005881105292e-05, 2.20981015361991e-05, 2.16418427448104e-05, & 2.11507649256221e-05, 2.06388749782171e-05, 2.01165241997082e-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.52213076721293e-04, 4.47932581552385e-04, & 2.79520653992021e-04, 1.52468156198447e-04, 6.93271105657044e-05, & 1.76258683069991e-05,-1.35744996343269e-05,-3.17972413350427e-05, & -4.18861861696693e-05,-4.69004889379141e-05,-4.87665447413787e-05, & -4.87010031186735e-05,-4.74755620890087e-05,-4.55813058138628e-05, & -4.33309644511266e-05,-4.09230193157750e-05,-3.84822638603221e-05, & -3.60857167535411e-05,-3.37793306123367e-05,-3.15888560772110e-05, & -2.95269561750807e-05,-2.75978914828336e-05,-2.58006174666884e-05, & -2.41308356761280e-05,-2.25823509518346e-05,-2.11479656768913e-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.74617796559960e-04,-4.77864567147321e-04, & -3.20390228067038e-04,-1.61105016119962e-04,-4.25778101285435e-05, & 3.44571294294968e-05, 7.97092684075675e-05, 1.03138236708272e-04, & 1.12466775262204e-04, 1.13103642108481e-04, 1.08651634848774e-04, & 1.01437951597662e-04, 9.29298396593364e-05, 8.40293133016090e-05, & 7.52727991349134e-05, 6.69632521975731e-05, 5.92564547323195e-05, & 5.22169308826976e-05, 4.58539485165361e-05, 4.01445513891487e-05, & 3.50481730031328e-05, 3.05157995034347e-05, 2.64956119950516e-05, & 2.29363633690998e-05, 1.97893056664022e-05, 1.70091984636413e-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.36465810572578e-04, 8.72790805146194e-04, & 6.22614862573135e-04, 2.85998154194304e-04, 3.84737672879366e-06, & -1.87906003636972e-04,-2.97603646594555e-04,-3.45998126832656e-04, & -3.53382470916038e-04,-3.35715635775049e-04,-3.04321124789040e-04, & -2.66722723047613e-04,-2.27654214122820e-04,-1.89922611854562e-04, & -1.55058918599094e-04,-1.23778240761874e-04,-9.62926147717644e-05, & -7.25178327714425e-05,-5.22070028895634e-05,-3.50347750511901e-05, & -2.06489761035552e-05,-8.70106096849767e-06, 1.13698686675100e-06, & 9.16426474122779e-06, 1.56477785428873e-05, 2.08223629482467e-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.29960524947437e-01, 2.51984209978975e-01, & 1.54790300415656e-01, 1.10713062416159e-01, 8.57309395527395e-02, & 6.97161316958684e-02, 5.86085671893714e-02, 5.04698873536311e-02, & 4.42600580689155e-02, 3.93720661543510e-02, 3.54283195924455e-02, & 3.21818857502098e-02, 2.94646240791158e-02, 2.71581677112934e-02, & 2.51768272973862e-02, 2.34570755306079e-02, 2.19508390134907e-02, & 2.06210828235646e-02, 1.94388240897881e-02, 1.83810633800683e-02, & 1.74293213231963e-02, 1.65685837786612e-02, 1.57865285987918e-02, & 1.50729501494096e-02, 1.44193250839955e-02, 1.38184805735342e-02/ ! ta = epsilon ( ta ) tol = max ( ta, 1.0E-15 ) tb = r1mach(5) ju = i1mach(12) if ( flgjy /= 1.0E+00 ) then jr = i1mach(11) elim = 2.303E+00 * tb * ( real ( - ju ) - real ( jr ) ) else elim = 2.303E+00 * ( tb * real ( - ju ) - 3.0E+00 ) end if fn = fnu iflw = 0 do jn = 1, in xx = x / fn wk(1) = 1.0E+00 - xx * xx abw2 = abs ( wk(1) ) wk(2) = sqrt ( abw2 ) wk(7) = fn**con2 if ( abw2 > 0.27750E+00 ) 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.0E+00 ) then sa = 0.0E+00 else sa = tols / log ( abw2 ) end if sb = sa do i = 1, 5 akm = max ( sa, 2.0E+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 ( z > 0.0E+00 ) then if ( wk(4) > elim ) 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.0E+00 / fn2 rden = 1.0E+00 asum = 1.0E+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.0E+00 tau = 1.0E+00 / wk(2) t2 = 1.0E+00 / wk(1) ! ! Cases for (x/fn) > sqrt ( 1.2775 ) ! if ( wk(1) < 0.0E+00 ) then wk(3) = abs ( wk(2) - atan ( wk(2) ) ) wk(4) = wk(3) * fn rcz = -con1 / wk(4) z32 = 1.5E+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.0E+00 + wk(2) ) / xx ) - wk(2) ) wk(4) = wk(3) * fn rcz = con1 / wk(4) if ( wk(4) > elim ) then iflw = 1 return end if z32 = 1.5E+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.0E+00 asum = 1.0E+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 ( wk(1) > 0.0E+00 ) 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 ( wk(1) > 0.0E+00 ) 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 ) ! !******************************************************************************* ! !! 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: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the leading dimension of A. ! ! Input, integer N, the number of rows and columns in A. ! ! Input, real A(NR,N), the N by N matrix, containing the lower ! triangular matrix. A is not altered by this routine. ! ! Output, real X(N), the solution vector. ! ! Input, real B(N), the right hand side vector. ! implicit none ! integer n integer nr ! real a(nr,n) real b(n) integer i integer ip1 integer j real 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 function besi0 ( x ) ! !******************************************************************************* ! !! BESI0 computes the hyperbolic Bessel function of the first kind, order zero. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Modified: ! ! 25 August 2001 ! ! Parameters: ! ! Input, real X, the argument of the Bessel function. ! ! Output, real BESI0, the value of the Bessel function at X. ! implicit none ! real besi0 real besi0e real, parameter, dimension ( 12 ) :: bi0cs = (/ & -0.07660547252839144951E+00, 1.927337953993808270E+00, & 0.2282644586920301339E+00, 0.01304891466707290428E+00, & 0.00043442709008164874E+00, 0.00000942265768600193E+00, & 0.00000014340062895106E+00, 0.00000000161384906966E+00, & 0.00000000001396650044E+00, 0.00000000000009579451E+00, & 0.00000000000000053339E+00, 0.00000000000000000245E+00 /) real csevl integer inits integer, save :: nti0 = 0 real x real, save :: xmax = 0.0E+00 real, save :: xsml = 0.0E+00 real y ! if ( nti0 == 0 ) then nti0 = inits ( bi0cs, 12, 0.1E+00 * epsilon ( bi0cs ) ) xsml = 2.0E+00 * sqrt ( epsilon ( xsml ) ) xmax = log ( huge ( xmax ) ) end if y = abs ( x ) if ( y <= 3.0E+00 ) then if ( y > xsml ) then besi0 = 2.75E+00 + csevl ( y * y / 4.5E+00 - 1.0E+00, bi0cs, nti0 ) else besi0 = 1.0E+00 end if return end if if ( y > xmax ) 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 ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, real X, the argument of the Bessel function. ! ! Output, real BESI0E, the value of the Bessel function at X. ! implicit none ! real ai02cs(22) real ai0cs(21) real besi0e real bi0cs(12) real csevl integer inits integer, save :: ntai0 = 0 integer, save :: ntai02 = 0 integer, save :: nti0 = 0 real x real, save :: xsml = 0.0E+00 real y ! data bi0cs( 1) / -0.07660547252839144951E+00 / data bi0cs( 2) / 1.927337953993808270E+00 / data bi0cs( 3) / 0.2282644586920301339E+00 / data bi0cs( 4) / 0.01304891466707290428E+00 / data bi0cs( 5) / 0.00043442709008164874E+00 / data bi0cs( 6) / 0.00000942265768600193E+00 / data bi0cs( 7) / 0.00000014340062895106E+00 / data bi0cs( 8) / 0.00000000161384906966E+00 / data bi0cs( 9) / 0.00000000001396650044E+00 / data bi0cs(10) / 0.00000000000009579451E+00 / data bi0cs(11) / 0.00000000000000053339E+00 / data bi0cs(12) / 0.00000000000000000245E+00 / data ai0cs( 1) / 0.07575994494023796E+00 / data ai0cs( 2) / 0.00759138081082334E+00 / data ai0cs( 3) / 0.00041531313389237E+00 / data ai0cs( 4) / 0.00001070076463439E+00 / data ai0cs( 5) / -0.00000790117997921E+00 / data ai0cs( 6) / -0.00000078261435014E+00 / data ai0cs( 7) / 0.00000027838499429E+00 / data ai0cs( 8) / 0.00000000825247260E+00 / data ai0cs( 9) / -0.00000001204463945E+00 / data ai0cs(10) / 0.00000000155964859E+00 / data ai0cs(11) / 0.00000000022925563E+00 / data ai0cs(12) / -0.00000000011916228E+00 / data ai0cs(13) / 0.00000000001757854E+00 / data ai0cs(14) / 0.00000000000112822E+00 / data ai0cs(15) / -0.00000000000114684E+00 / data ai0cs(16) / 0.00000000000027155E+00 / data ai0cs(17) / -0.00000000000002415E+00 / data ai0cs(18) / -0.00000000000000608E+00 / data ai0cs(19) / 0.00000000000000314E+00 / data ai0cs(20) / -0.00000000000000071E+00 / data ai0cs(21) / 0.00000000000000007E+00 / data ai02cs( 1) / 0.05449041101410882E+00 / data ai02cs( 2) / 0.00336911647825569E+00 / data ai02cs( 3) / 0.00006889758346918E+00 / data ai02cs( 4) / 0.00000289137052082E+00 / data ai02cs( 5) / 0.00000020489185893E+00 / data ai02cs( 6) / 0.00000002266668991E+00 / data ai02cs( 7) / 0.00000000339623203E+00 / data ai02cs( 8) / 0.00000000049406022E+00 / data ai02cs( 9) / 0.00000000001188914E+00 / data ai02cs(10) / -0.00000000003149915E+00 / data ai02cs(11) / -0.00000000001321580E+00 / data ai02cs(12) / -0.00000000000179419E+00 / data ai02cs(13) / 0.00000000000071801E+00 / data ai02cs(14) / 0.00000000000038529E+00 / data ai02cs(15) / 0.00000000000001539E+00 / data ai02cs(16) / -0.00000000000004151E+00 / data ai02cs(17) / -0.00000000000000954E+00 / data ai02cs(18) / 0.00000000000000382E+00 / data ai02cs(19) / 0.00000000000000176E+00 / data ai02cs(20) / -0.00000000000000034E+00 / data ai02cs(21) / -0.00000000000000027E+00 / data ai02cs(22) / 0.00000000000000003E+00 / ! if ( nti0 == 0 ) then nti0 = inits ( bi0cs, 12, 0.1E+00 * epsilon ( bi0cs ) ) ntai0 = inits ( ai0cs, 21, 0.1E+00 * epsilon ( ai0cs ) ) ntai02 = inits ( ai02cs, 22, 0.1E+00 * epsilon ( ai02cs ) ) xsml = 2.0E+00 * sqrt ( epsilon ( xsml ) ) end if y = abs ( x ) if ( y <= xsml ) then besi0e = 1.0E+00 else if ( y <= 3.0E+00 ) then besi0e = exp ( -y ) * & ( 2.75E+00 + csevl ( y*y/4.5E+00 - 1.0E+00, bi0cs, nti0) ) else if ( y <= 8.0E+00 ) then besi0e = ( 0.375E+00 + & csevl ( ( 48.0E+00 / y - 11.0E+00 ) / 5.0E+00, ai0cs, ntai0) ) & / sqrt ( y ) else if ( y > 8.0E+00 ) then besi0e = ( 0.375E+00 + csevl ( 16.0E+00/y-1.0E+00, ai02cs, ntai02)) & / sqrt ( y ) end if return end subroutine besi0_values ( n, x, fx ) ! !******************************************************************************* ! !! BESI0_VALUES returns some values of the I0 Bessel function for testing. ! ! ! Modified: ! ! 19 April 2001 ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. ! On input, if N is 0, the first test data is returned, and N is set ! to the index of the test data. On each subsequent call, N is ! incremented and that test data is returned. When there is no more ! test data, N is set to 0. ! ! Output, real X, the argument of the function. ! ! Output, real FX, the value of the function. ! implicit none ! integer, parameter :: nmax = 20 ! real, save, dimension ( nmax ) :: bvec = (/ & 1.0000000E+00, 1.0100250E+00, 1.0404018E+00, 1.0920453E+00, & 1.1665149E+00, 1.2660658E+00, 1.3937256E+00, 1.5533951E+00, & 1.7499807E+00, 1.9895593E+00, 2.2795852E+00, 3.2898391E+00, & 4.8807925E+00, 7.3782035E+00, 11.301922E+00, 17.481172E+00, & 27.239871E+00, 67.234406E+00, 427.56411E+00, 2815.7167E+00 /) real fx integer n real x real, save, dimension ( nmax ) :: xvec = (/ & 0.0E+00, 0.2E+00, 0.4E+00, 0.6E+00, & 0.8E+00, 1.0E+00, 1.2E+00, 1.4E+00, & 1.6E+00, 1.8E+00, 2.0E+00, 2.5E+00, & 3.0E+00, 3.5E+00, 4.0E+00, 4.5E+00, & 5.0E+00, 6.0E+00, 8.0E+00, 10.0E+00 /) ! if ( n < 0 ) then n = 0 end if n = n + 1 if ( n > nmax ) then n = 0 x = 0.0E+00 fx = 0.0E+00 return end if x = xvec(n) fx = bvec(n) return end subroutine besj ( x, alpha, n, y, nz ) ! !******************************************************************************* ! !! BESJ computes an N member sequence of J Bessel functions. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! D. E. Amos, S. L. Daniel, M. K. Weston, ! SAND-75-0147 ! 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. ! ! F. W. J. Olver, ! Tables of Bessel Functions of Moderate or Large Orders, ! NPL Mathematical Tables, Vol. 6, ! Her Majesty's Stationery Office, London, 1962. ! ! Discussion: ! ! BESJ computes an N member sequence of J Bessel functions ! ! J(ALPHA+K-1) (X) ! ! for K=1,..,N for non-negative order ALPHA and X. ! ! A combination of the power series, the asymptotic expansion for X ! to infinity and the uniform asymptotic expansion for NU to infinity ! are applied over subdivisions of the (NU,X) plane. For values of ! (NU,X) not covered by one of these formulae, the order is ! incremented or decremented by integer values into a region where ! one of the formulas apply. ! ! Backward recursion is applied to reduce orders by integer values ! 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. ! ! Parameters: ! ! Input, real X, the argument of the Bessel function. ! X must be nonnegative. ! ! Input, real ALPHA, the order of the first member of the sequence. ! ALPHA must be at least 0.0. ! ! Input, integer N, the number of members in the sequence, ! N must be at least 1. ! ! Output, real Y(N), a vector whose first N components contain ! values for J(ALPHA+K-1)(X), K=1,...,N ! ! Output, integer NZ, the number of components of Y set to zero ! due to underflow. ! ! NZ=0, normal return, computation completed ! ! NZ /= 0, Y(N-NZ+1) through Y(N) were set to 0. ! implicit none ! integer n ! real ak real akm real alngam real alpha real ans real ap real arg real coef real dalpha real dfn real dtm real earg real elim1 real etx real fidal real flgjy real fn real fnf real fni real fnp1 real fnu real, parameter, dimension ( 2 ) :: fnulim = (/ 100.0E+00, 60.0E+00 /) real gln integer i integer i1 integer i1mach integer i2 integer ialp integer idalp integer iflw integer in integer, parameter :: inlim = 150 integer is external jairy integer k integer kk integer km integer kt integer nn integer ns integer nz real, parameter :: pdf = 0.785398163397448E+00 real, parameter :: pidt = 1.57079632679490E+00 real, parameter, dimension ( 4 ) :: pp = (/ & 8.72909153935547E+00, 2.65693932265030E-01, & 1.24578576865586E-01, 7.70133747430388E-04 /) real r1mach real rden real relb real, parameter :: rttp = 7.97884560802865E-01 real, parameter :: rtwo = 1.34839972492648E+00 real rtx real rzden real s real sa real sb real sxo2 real s1 real s2 real t real ta real tau real tb real temp(3) real tfn real tm real tol real tolln real trx real tx real t1 real t2 real wk(7) real x real xo2 real xo2l real 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.0E-15 ) i1 = i1mach(11) + 1 i2 = i1mach(12) tb = r1mach(5) elim1 = 2.303E+00 * ( real (-i2) * tb - 3.0E+00 ) ! ! TOLLN = -ln(tol) ! tolln = 2.303E+00 * tb * real ( i1 ) tolln = min ( tolln, 34.5388E+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 ) 730, 30, 80 30 continue if ( alpha < 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'BESJ - Fatal error!' write ( *, '(a)' ) ' ALPHA less than zero.' return end if if ( alpha == 0.0E+00 ) then y(1) = 1.0E+00 if ( n == 1 ) then return end if i1 = 2 else i1 = 1 end if 60 continue y(i1:n) = 0.0E+00 return 80 continue if ( alpha < 0.0E+00 ) then call xerror ( 'besj - order, alpha, less than zero.', 36, 2, 1) return end if ialp = int ( alpha ) fni = real ( ialp+n-1 ) fnf = alpha - real ( ialp ) dfn = fni + fnf fnu = dfn xo2 = x * 0.5E+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.0E+00 ) ) go to 90 ta = max ( 20.0E+00, fnu ) if ( x > ta ) go to 120 if ( x > 12.0E+00 ) go to 110 xo2l = log ( xo2 ) ns = int ( sxo2 - fnu ) + 1 go to 100 90 continue fn = fnu fnp1 = fn + 1.0E+00 xo2l = log ( xo2 ) is = kt if ( x <= 0.50E+00 ) then go to 330 end if ns = 0 100 continue fni = fni + real ( ns ) dfn = fni + fnf fn = dfn fnp1 = fn + 1.0E+00 is = kt if ( n-1+ns > 0 ) then is = 3 end if go to 330 110 continue ans = max ( 36.0E+00-fnu, 0.0E+00 ) ns = int ( ans ) fni = fni + real ( ns ) dfn = fni + fnf fn = dfn is = kt if ( n-1+ns > 0 ) then is = 3 end if go to 130 120 continue rtx = sqrt ( x ) tau = rtwo*rtx ta = tau + fnulim(kt) if ( fnu <= ta ) go to 480 fn = fnu is = kt ! ! Uniform asymptotic expansion for NU to infinity. ! 130 continue i1 = abs ( 3 - is ) i1 = max ( i1, 1 ) flgjy = 1.0E+00 call asyjy ( jairy, x, fn, flgjy, i1, temp(is), wk, iflw ) if ( iflw /= 0 ) go to 380 go to (320, 450, 620), is 310 continue temp(1) = temp(3) kt = 1 320 continue is = 2 fni = fni - 1.0E+00 dfn = fni + fnf fn = dfn if ( i1 == 2 ) go to 450 go to 130 ! ! Series for (x/2)**2<=nu+1 ! 330 continue gln = alngam ( fnp1 ) arg = fn * xo2l - gln if ( arg < (-elim1) ) go to 400 earg = exp ( arg ) 340 continue s = 1.0E+00 if ( x < tol ) go to 360 ak = 3.0E+00 t2 = 1.0E+00 t = 1.0E+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.0E+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.0E+00 dfn = fni + fnf fn = dfn is = 2 go to 340 ! ! Set underflow value and update parameters ! 380 continue y(nn) = 0.0E+00 nn = nn - 1 fni = fni - 1.0E+00 dfn = fni + fnf fn = dfn if ( nn-1 ) 440, 390, 130 390 kt = 2 is = 2 go to 130 400 y(nn) = 0.0E+00 nn = nn - 1 fnp1 = fn fni = fni - 1.0E+00 dfn = fni + fnf fn = dfn if ( nn-1 ) 440, 410, 420 410 continue kt = 2 is = 2 420 continue if ( sxo2 <= fnp1 ) go to 430 go to 130 430 arg = arg - xo2l + log ( fnp1 ) if ( arg < (-elim1) ) go to 400 go to 330 440 nz = n - nn return ! ! Backward recursion section ! 450 continue nz = n - nn if ( kt == 2 ) go to 470 ! ! 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.0E+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.0E+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 X > max ( 20, NU ), provided the last member ! of the sequence is also in the region. ! 480 continue in = int ( alpha - tau + 2.0E+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 ) dalpha = fidal + fnf arg = x - pidt * dalpha - pdf sa = sin(arg) sb = cos(arg) coef = rttp / rtx etx = 8.0E+00 * x 510 continue dtm = fidal + fidal dtm = dtm * dtm tm = 0.0E+00 if ( fidal == 0.0E+00 .and. abs ( fnf ) < tol ) then go to 520 end if tm = 4.0E+00 * fnf * ( fidal + fidal + fnf ) 520 continue trx = dtm - 1.0E+00 t2 = ( trx + tm ) / etx s2 = t2 relb = tol * abs ( t2 ) t1 = etx s1 = 1.0E+00 fn = 1.0E+00 ak = 8.0E+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.0E+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.0E+00 end do 540 continue temp(is) = coef * ( s1 * sb - s2 * sa ) if ( is == 2 ) go to 560 550 continue fidal = fidal + 1.0E+00 dalpha = fidal + fnf is = 2 tb = sa sa = -sb sb = tb go to 510 ! ! Forward recursion section ! 560 continue if ( kt == 2 ) go to 470 s1 = temp(1) s2 = temp(2) tx = 2.0E+00 / x tm = dalpha * tx if ( in == 0 ) then go to 580 end if ! ! Forward recur 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.0E+00-fn, 0.0E+00 ) km = int ( akm ) tfn = fn + real ( km ) ta = ( gln + tfn - 0.9189385332E+00 - 0.0833333333E+00 / tfn ) & / ( tfn + 0.5E+00 ) ta = xo2l - ta tb = - ( 1.0E+00 -1.5E+00 / tfn ) / tfn akm = tolln / ( - ta + sqrt ( ta * ta - tolln * tb ) ) + 1.5E+00 in = km + int ( akm ) go to 660 620 continue ! ! Computation of last order for asymptotic expansion normalization ! gln = wk(3) + wk(2) if ( wk(6) > 30.0E+00 ) then go to 640 end if rden = ( pp(4) * wk(6) + pp(3) ) * wk(6) + 1.0E+00 rzden = pp(1) + pp(2) * wk(6) ta = rzden / rden if ( wk(1) < 0.10E+00 ) go to 630 tb = gln / wk(5) go to 650 630 continue tb = ( 1.259921049E+00 + ( 0.1679894730E+00 + 0.0887944358E+00 & * wk(1) ) * wk(1) ) / wk(7) go to 650 640 continue ta = 0.5E+00 * tolln / wk(4) ta=( ( 0.0493827160E+00 * ta - 0.1111111111E+00 ) * ta & + 0.6666666667E+00 ) * ta * wk(6) if ( wk(1) < 0.10E+00 ) go to 630 tb = gln / wk(5) 650 continue in = int ( ta / tb + 1.5E+00 ) if ( in > inlim ) go to 310 660 continue dtm = fni + real ( in ) trx = 2.0E+00 / x tm = ( dtm + fnf ) * trx ta = 0.0E+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.0E+00 tm = ( dtm + fnf ) * trx end do ! ! Normalization. ! if ( kk /= 1 ) go to 690 ta = ( ta / tb ) * temp(3) tb = temp(3) kk = 2 in = ns if ( ns /= 0 ) then go to 670 end if 690 continue 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.0E+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.0E+00 tm = ( dtm + fnf ) * trx k = k - 1 end do return 730 continue call xerror( 'besj - x less than zero.', 24, 2, 1) return end subroutine besj0_values ( n, x, fx ) ! !******************************************************************************* ! !! BESJ0_VALUES returns some values of the J0 Bessel function for testing. ! ! ! Modified: ! ! 15 April 2001 ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. ! On input, if N is 0, the first test data is returned, and N is set ! to the index of the test data. On each subsequent call, N is ! incremented and that test data is returned. When there is no more ! test data, N is set to 0. ! ! Output, real X, the argument of the function. ! ! Output, real FX, the value of the function. ! implicit none ! integer, parameter :: nmax = 21 ! real, save, dimension ( nmax ) :: bvec = (/ & -0.1775968E+00, -0.3971498E+00, -0.2600520E+00, 0.2238908E+00, & 0.7651976E+00, 1.0000000E+00, 0.7651977E+00, 0.2238908E+00, & -0.2600520E+00, -0.3971498E+00, -0.1775968E+00, 0.1506453E+00, & 0.3000793E+00, 0.1716508E+00, -0.0903336E+00, -0.2459358E+00, & -0.1711903E+00, 0.0476893E+00, 0.2069261E+00, 0.1710735E+00, & -0.0142245E+00 /) real fx integer n real x real, save, dimension ( nmax ) :: xvec = (/ & -5.0E+00, -4.0E+00, -3.0E+00, -2.0E+00, & -1.0E+00, 0.0E+00, 1.0E+00, 2.0E+00, & 3.0E+00, 4.0E+00, 5.0E+00, 6.0E+00, & 7.0E+00, 8.0E+00, 9.0E+00, 10.0E+00, & 11.0E+00, 12.0E+00, 13.0E+00, 14.0E+00, & 15.0E+00 /) ! if ( n < 0 ) then n = 0 end if n = n + 1 if ( n > nmax ) then n = 0 x = 0.0E+00 fx = 0.0E+00 return end if x = xvec(n) fx = bvec(n) return end subroutine besj1_values ( n, x, fx ) ! !******************************************************************************* ! !! BESJ1_VALUES returns some values of the J1 Bessel function for testing. ! ! ! Modified: ! ! 15 April 2001 ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. ! On input, if N is 0, the first test data is returned, and N is set ! to the index of the test data. On each subsequent call, N is ! incremented and that test data is returned. When there is no more ! test data, N is set to 0. ! ! Output, real X, the argument of the function. ! ! Output, real FX, the value of the function. ! implicit none ! integer, parameter :: nmax = 21 ! real, save, dimension ( nmax ) :: bvec = (/ & 0.3275791E+00, 0.0660433E+00, -0.3390590E+00, -0.5767248E+00, & -0.4400506E+00, 0.0000000E+00, 0.4400506E+00, 0.5767248E+00, & 0.3390590E+00, -0.0660433E+00, -0.3275791E+00, -0.2766839E+00, & -0.0046828E+00, 0.2346364E+00, 0.2453118E+00, 0.0434728E+00, & -0.1767853E+00, -0.2234471E+00, -0.0703181E+00, 0.1333752E+00, & 0.2051040E+00 /) real fx integer n real x real, save, dimension ( nmax ) :: xvec = (/ & -5.0E+00, -4.0E+00, -3.0E+00, -2.0E+00, & -1.0E+00, 0.0E+00, 1.0E+00, 2.0E+00, & 3.0E+00, 4.0E+00, 5.0E+00, 6.0E+00, & 7.0E+00, 8.0E+00, 9.0E+00, 10.0E+00, & 11.0E+00, 12.0E+00, 13.0E+00, 14.0E+00, & 15.0E+00 /) ! if ( n < 0 ) then n = 0 end if n = n + 1 if ( n > nmax ) then n = 0 x = 0.0E+00 fx = 0.0E+00 return end if x = xvec(n) fx = bvec(n) return end subroutine besjn_values ( n, nu, x, fx ) ! !******************************************************************************* ! !! BESJN_VALUES returns some values of the JN Bessel function for testing. ! ! ! Modified: ! ! 16 April 2001 ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. ! On input, if N is 0, the first test data is returned, and N is set ! to the index of the test data. On each subsequent call, N is ! incremented and that test data is returned. When there is no more ! test data, N is set to 0. ! ! Output, integer NU, the order of the function. ! ! Output, real X, the argument of the function. ! ! Output, real FX, the value of the function. ! implicit none ! integer, parameter :: nmax = 20 ! real, save, dimension ( nmax ) :: bvec = (/ & 1.149034849E-01, 3.528340286E-01, 4.656511628E-02, 2.546303137E-01, & -5.971280079E-02, 2.497577302E-04, 7.039629756E-03, 2.611405461E-01, & -2.340615282E-01,-8.140024770E-02, 2.630615124E-10, 2.515386283E-07, & 1.467802647E-03, 2.074861066E-01,-1.138478491E-01, 3.873503009E-25, & 3.918972805E-19, 2.770330052E-11, 1.151336925E-05,-1.167043528E-01 /) real fx integer n integer nu real, save, dimension ( nmax ) :: nvec = (/ & 2, 2, 2, 2, & 2, 5, 5, 5, & 5, 5, 10, 10, & 10, 10, 10, 20, & 20, 20, 20, 20 /) real x real, save, dimension ( nmax ) :: xvec = (/ & 1.0E+00, 2.0E+00, 5.0E+00, 10.0E+00, & 50.0E+00, 1.0E+00, 2.0E+00, 5.0E+00, & 10.0E+00, 50.0E+00, 1.0E+00, 2.0E+00, & 5.0E+00, 10.0E+00, 50.0E+00, 1.0E+00, & 2.0E+00, 5.0E+00, 10.0E+00, 50.0E+00 /) ! if ( n < 0 ) then n = 0 end if n = n + 1 if ( n > nmax ) then n = 0 nu = 0 x = 0.0E+00 fx = 0.0E+00 return end if nu = nvec(n) x = xvec(n) fx = bvec(n) return end subroutine bp ( n, b, x ) ! !******************************************************************************* ! !! BP 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. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer N, should be 0 or greater. ! ! Input, real X, the point where the functions should be evaluated. ! ! Output, real B(0:N), the values of the Bernstein polynomials ! at the point X. ! implicit none ! integer n ! real b(0:n) integer i integer j real x ! if ( n == 0 ) then b(0) = 1.0E+00 else if ( n > 0 ) 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.0E+00 - x ) * b(j) end do if ( i == 1 ) then b(0) = 1.0E+00 - x else b(0) = ( 1.0E+00 - x ) * b(0) end if end do end if return end subroutine cfftb ( n, c, wsave ) ! !******************************************************************************* ! !! CFFTB computes the backward complex discrete Fourier transform. ! ! ! Discussion: ! ! This process is sometimes called Fourier synthesis. ! ! CFFTB computes a complex periodic sequence from its Fourier coefficients. ! ! A call of CFFTF followed by a call of CFFTB will multiply the ! sequence by N. In other words, the transforms are not normalized. ! ! The array WSAVE must be initialized by CFFTI. ! ! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! The method is more efficient when N is the product of small primes. ! ! Input/output, complex 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 WSAVE(4*N+15). The array must be initialized by calling ! CFFTI. A different WSAVE array must be used for each different ! value of N. ! implicit none ! integer n ! complex c(n) real wsave(4*n+15) ! if ( n <= 1 ) then return end if call cfftb1 ( n, c, wsave(1), wsave(2*n+1), wsave(4*n+1) ) return end subroutine cfftb1 ( n, c, ch, wa, ifac ) ! !******************************************************************************* ! !! CFFTB1 is a lower-level routine used by CFFTB. ! ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! ! Input/output, complex 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 CH(N). ! ! Input, real WA(2*N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer n ! complex c(n) complex ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer l1 integer l2 integer na integer nac integer nf real 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 cfftb_2d ( ldf, n, f, wsave ) ! !******************************************************************************* ! !! CFFTB_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 CFFTB_2D followed by a call ! to CFFTF_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 CFFTF_2D or CFFTB_2D, it is necessary to initialize ! the array WSAVE by calling CFFTI. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Modified: ! ! 12 March 2001 ! ! Parameters: ! ! Input, integer LDF, the leading dimension of the matrix. ! ! Input, integer N, the number of rows and columns in the matrix. ! ! Input/output, complex F(LDF,N), ! On input, an N by N array of complex values to be transformed. ! On output, the transformed values. ! ! Input, real WSAVE(4*N+15), a work array whose values depend on N, ! and which must be initialized by calling CFFTI. ! implicit none ! integer ldf integer n ! complex f(ldf,n) integer i real wsave(4*n+15) ! ! Row transforms: ! f(1:n,1:n) = transpose ( f(1:n,1:n) ) do i = 1, n call cfftb ( 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 cfftb ( n, f(1,i), wsave ) end do return end subroutine cfftf ( n, c, wsave ) ! !******************************************************************************* ! !! CFFTF computes the forward complex discrete Fourier transform. ! ! ! Discussion: ! ! This process is sometimes called Fourier analysis. ! ! CFFTF 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 CFFTF ! followed by a call of CFFTB will multiply the sequence by N. ! ! The array WSAVE must be initialized by calling CFFTI. ! ! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! The method is more efficient when N is the product of small primes. ! ! Input/output, complex C(N). ! On input, the data sequence to be transformed. ! On output, the Fourier coefficients. ! ! Input, real WSAVE(4*N+15). The array must be initialized by calling ! CFFTI. A different WSAVE array must be used for each different ! value of N. ! implicit none ! integer n ! complex c(n) real wsave(4*n+15) ! if ( n <= 1 ) then return end if call cfftf1 ( n, c, wsave(1), wsave(2*n+1), wsave(4*n+1) ) return end subroutine cfftf1 ( n, c, ch, wa, ifac ) ! !******************************************************************************* ! !! CFFTF1 is a lower level routine used by CFFTF. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! ! Input/output, complex C(N). ! On input, the data sequence to be transformed. ! On output, the Fourier coefficients. ! ! Input, complex CH(N). ! ! Input, real WA(2*N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer n ! complex c(n) complex ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer l1 integer l2 integer na integer nac integer nf real 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 cfftf_2d ( ldf, n, f, wsave ) ! !******************************************************************************* ! !! CFFTF_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 CFFTF_2D, ! followed by a call to CFFTB_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 CFFTF_2D or CFFTB_2D, it is necessary to initialize ! the array WSAVE by calling CFFTI. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Modified: ! ! 12 March 2001 ! ! Parameters: ! ! Input, integer LDF, the leading dimension of the matrix. ! ! Input, integer N, the number of rows and columns in the matrix. ! ! Input/output, complex F(LDF,N), ! On input, an N by N array of complex values to be transformed. ! On output, the transformed values. ! ! Input, real WSAVE(4*N+15), a work array whose values depend on N, ! and which must be initialized by calling CFFTI. ! implicit none ! integer ldf integer n ! complex f(ldf,n) integer i real wsave(4*n+15) ! ! Row transforms: ! f(1:n,1:n) = transpose ( f(1:n,1:n) ) do i = 1, n call cfftf ( 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 cfftf ( n, f(1,i), wsave ) end do return end subroutine cffti ( n, wsave ) ! !******************************************************************************* ! !! CFFTI initializes WSAVE, used in CFFTF and CFFTB. ! ! ! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! ! Output, real WSAVE(4*N+15), contains data, dependent on the value ! of N, which is necessary for the CFFTF or CFFTB routines. ! implicit none ! integer n ! real wsave(4*n+15) ! if ( n <= 1 ) then return end if call cffti1 ( n, wsave(2*n+1), wsave(4*n+1) ) return end subroutine cffti1 ( n, wa, ifac ) ! !******************************************************************************* ! !! CFFTI1 is a lower level routine used by CFFTI. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! ! Input, real WA(2*N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer n ! real arg real argh real argld real fi integer i integer i1 integer ib integer ido integer ifac(15) integer ii integer ip integer j integer k1 integer l1 integer l2 integer ld integer nf real pi real wa(2*n) ! call i_factor ( n, ifac ) nf = ifac(2) argh = 2.0E+00 * pi() / real ( n ) 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.0E+00 wa(i) = 0.0E+00 ld = ld + l1 fi = 0.0E+00 argld = real ( ld ) * argh do ii = 4, 2*ido+2, 2 i = i + 2 fi = fi + 1.0E+00 arg = fi * argld wa(i-1) = cos ( arg ) wa(i) = sin ( arg ) end do if ( ip > 5 ) then wa(i1-1) = wa(i-1) wa(i1) = wa(i) end if end do l1 = l2 end do return end subroutine chfdv ( x1, x2, f1, f2, d1, d2, ne, xe, fe, de, next, ierr ) ! !******************************************************************************* ! !! CHFDV evaluates a cubic polynomial and its derivative given in Hermite form. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Discussion: ! ! CHFDV evaluates a cubic polynomial given in Hermite form and its ! first derivative at an array of points. While designed for ! use by PCHFD, 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. ! ! If only function values are required, use CHFEV instead. ! ! Parameters: ! ! Input, real X1, X2, the endpoints of the interval of definition of ! the cubic. X1 and X2 must be distinct. ! ! Input, real F1, F2, the values of the function at X1 and X2, respectively. ! ! Input, real D1, D2, the derivative values at the ends of the interval. ! ! Input, integer NE, the number of evaluation points. ! ! Input, real 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 FE(NE), DE(NE), the values of the cubic function and ! its derivative at the points XE(*). ! ! Output, integer NEXT(2), indicates the number of extrapolation points: ! NEXT(1) = number of evaluation points to left of interval. ! NEXT(2) = number of evaluation points to right of interval. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, NE < 1. ! -2, X1 == X2. ! implicit none ! integer ne ! real c2 real c2t2 real c3 real c3t3 real d1 real d2 real de(ne) real del1 real del2 real delta real f1 real f2 real fe(ne) real h integer i integer ierr integer next(2) real x real x1 real x2 real xe(ne) real xma real 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.0E+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.0E+00, h ) xma = max ( 0.0E+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 ( x > xma ) 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 ) ! !******************************************************************************* ! !! CHFEV evaluates a cubic polynomial given in Hermite form. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Purpose: ! ! Evaluate 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. ! ! Description: ! ! CHFEV evaluates the cubic polynomial determined by function values ! f1, f2 and derivatives d1, d2 on interval (x1,x2) at the points ! XE(1:NE). ! ! Parameters: ! ! Input, real X1, X2, the endpoints of the interval of definition of ! the cubic. X1 and X2 must be distinct. ! ! Input, real F1, F2, the values of the function at X1 and X2, respectively. ! ! Input, real D1, D2, the derivative values at the ends of the interval. ! ! Input, integer NE, the number of evaluation points. ! ! Input, real 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 FE(NE), the values of the cubic function at the points XE(*). ! ! Output, integer NEXT(2), indicates the number of extrapolation points: ! NEXT(1) = number of evaluation points to left of interval. ! NEXT(2) = number of evaluation points to right of interval. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, NE < 1. ! -2, X1 == X2. ! implicit none ! integer ne ! real c2 real c3 real d1 real d2 real del1 real del2 real delta real f1 real f2 real fe(ne) real h integer i integer ierr integer next(2) real x real x1 real x2 real xe(ne) real xma real 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.0E+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.0E+00, h ) xma = max ( 0.0E+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 extrapolation points. ! if ( x < xmi ) then next(1) = next(1) + 1 end if if ( x > xma ) then next(2) = next(2) + 1 end if end do return end function chfiv ( x1, x2, f1, f2, d1, d2, a, b, ierr ) ! !******************************************************************************* ! !! CHFIV evaluates the integral of a cubic polynomial in Hermite form. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Discussion: ! ! CHFIV is called by PCHIA to evaluate the integral of a single cubic (in ! Hermite form) over an arbitrary interval (A,B). ! ! Parameters: ! ! Output, real VALUE, the value of the requested integral. ! ! Input, real X1, X2, the endpoints of the interval of definition of ! the cubic. X1 and X2 must be distinct. ! ! Input, real F1, F2, the values of the function at X1 and X2, respectively. ! ! Input, real D1, D2, the derivative values at the ends of the interval. ! ! Input, real A, B, the endpoints of interval of integration. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, X1 == X2. ! implicit none ! real a real b real chfiv real d1 real d2 real dterm real f1 real f2 real fterm real h integer ierr real phia1 real phia2 real phib1 real phib2 real psia1 real psia2 real psib1 real psib2 real ta1 real ta2 real tb1 real tb2 real ua1 real ua2 real ub1 real ub2 real x1 real x2 ! ! Check input. ! if ( x1 == x2 ) then ierr = -1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CHFEV - 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**3 phia1 = ua1 * ( 2.0E+00 - ta1 ) psia1 = ua1 * ( 3.0E+00 * ta1 - 4.0E+00 ) ua2 = ta2**3 phia2 = ua2 * ( 2.0E+00 - ta2) psia2 = -ua2 * ( 3.0E+00 * ta2 - 4.0E+00 ) ub1 = tb1**3 phib1 = ub1 * ( 2.0E+00 - tb1 ) psib1 = ub1 * ( 3.0E+00 * tb1 - 4.0E+00 ) ub2 = tb2**3 phib2 = ub2 * ( 2.0E+00 - tb2 ) psib2 = -ub2 * ( 3.0E+00 * tb2 - 4.0E+00 ) fterm = f1 * ( phia2 - phib2 ) + f2 * ( phib1 - phia1 ) dterm = ( d1 * ( psia2 - psib2 ) + d2 * ( psib1 - psia1 ) ) * ( h / 6.0E+00 ) chfiv = 0.5E+00 * h * ( fterm + dterm ) return end function chfmc ( d1, d2, delta ) ! !******************************************************************************* ! !! CHFMC determines the monotonicity properties of a cubic polynomial. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Discussion: ! ! CHFMC is called by PCHMC to determine the monotonicity properties ! of the cubic with boundary derivative values D1, D2 and chord ! slope DELTA. ! ! Parameters: ! ! Input, real D1, D2, the derivative values at the ends of the interval. ! ! Input, real DELTA, the data slope over that interval. ! ! Output, integer ISMON, 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 a real b integer chfmc real d1 real d2 real delta real eps integer ismon integer itrue real phi ! eps = 10.0E+00 * epsilon ( eps ) ! ! Make the check. ! if ( delta == 0.0E+00 ) then if ( d1 == 0.0E+00 .and. d2 == 0.0E+00 ) then ismon = 0 else ismon = 2 end if else itrue = sign ( 1.0E+00, delta) a = d1 / delta b = d2 / delta if ( a < 0.0E+00 .or. b < 0.0E+00 ) then ismon = 2 else if ( a <= 3.0E+00 - eps .and. b <= 3.0E+00 -eps ) then ! ! Inside square (0,3)x(0,3) implies OK. ! ismon = itrue else if ( a > 4.0E+00 + eps .and. b > 4.0E+00 + eps ) then ! ! Outside square (0,4)x(0,4) implies nonmonotonic. ! ismon = 2 else ! ! Must check against boundary of ellipse. ! a = a - 2.0E+00 b = b - 2.0E+00 phi = ( ( a * a + b * b ) + a * b ) - 3.0E+00 if ( phi < -eps ) then ismon = itrue else if ( phi > eps ) 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 ) ! !******************************************************************************* ! !! 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: ! ! More, Garbow and Hillstrom, ! User Guide for MINPACK-1, ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer M, is the number of functions. ! ! Input, integer N, is the number of variables. ! ! Input, real X(N), the point at which the jacobian is to be evaluated. ! ! Input, real FVEC(M), is used only when MODE = 2. ! In that case, it should contain the function values at X. ! ! Input, real FJAC(LDFJAC,N), an M by N array. When MODE = 2, ! FJAC(I,J) should contain the value of dF(I)/dX(J). ! ! Input, integer LDFJAC, the leading dimension of the array FJAC. ! LDFJAC must be at least M. ! ! Output, real XP(N), on output with MODE = 1, is a neighboring point ! of X, at which the function is to be evaluated. ! ! Input, real FVECP(M), on input with MODE = 2, is the function value ! at XP. ! ! Input, integer MODE, should be set to 1 on the first call, and ! 2 on the second. ! ! Output, real 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.0E+00, the I-th gradient is correct, ! = 0.0E+00, the I-th gradient is incorrect. ! > 0.5E+00, the I-th gradient is probably correct. ! < 0.5E+00, the I-th gradient is probably incorrect. ! implicit none ! integer ldfjac integer m integer n ! real eps real epsf real epslog real epsmch real err(m) real fjac(ldfjac,n) real fvec(m) real fvecp(m) integer i integer j integer mode real temp real x(n) real 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.0E+00 ) then temp = eps end if xp(j) = x(j) + temp end do ! ! MODE = 2. ! else if ( mode == 2 ) then epsf = 100.0E+00 * epsmch epslog = log10 ( eps ) err = 0.0E+00 do j = 1, n temp = abs ( x(j) ) if ( temp == 0.0E+00 ) then temp = 1.0E+00 end if err(1:m) = err(1:m) + temp * fjac(1:m,j) end do do i = 1, m temp = 1.0E+00 if ( fvec(i) /= 0.0E+00 .and. fvecp(i) /= 0.0E+00 .and. & abs ( fvecp(i) - fvec(i)) >= epsf * abs ( fvec(i) ) ) then temp = eps * abs ( ( fvecp(i) - fvec(i) ) / eps - err(i) ) & / ( abs ( fvec(i) ) + abs ( fvecp(i) ) ) end if err(i) = 1.0E+00 if ( temp > epsmch .and. temp < eps ) then err(i) = ( log10 ( temp ) - epslog ) / epslog end if if ( temp >= eps ) then err(i) = 0.0E+00 end if end do end if return end subroutine chlhsn ( nr, n, a, epsm, sx, udiag ) ! !******************************************************************************* ! !! 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 MU >= 0 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 MU>0 ! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input/output, real A(NR,N), contains an N by N matrix. ! On input, A is the model hessian. Only the lower triangular part and ! diagonal are stored. On output, A contains the factor L of the ! LL+ decomposition of the perturbed model hessian in the lower triangular ! part and diagonal, and contains the hessian in the upper triangular part ! and UDIAG. ! ! Input, real EPSM, the machine epsilon. ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Output, real 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 n integer nr ! real a(nr,*) real addmax real amu real diagmx real diagmn real epsm real evmax real evmin integer i integer j real offmax real offro real offrow real posmax real sdd real sx(n) real tol real 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 ( a(i,i) > diagmx ) then diagmx = a(i,i) end if end do posmax = max ( diagmx, 0.0E+00 ) if ( diagmn > posmax * tol ) go to 100 amu = tol * ( posmax - diagmn ) - diagmn ! ! Find the largest off-diagonal element of A. ! if ( amu == 0.0E+00 ) then offmax = 0.0E+00 do i = 2, n do j = 1, i-1 if ( abs ( a(i,j) ) > offmax ) then offmax = abs ( a(i,j) ) end if end do end do amu = offmax if ( amu == 0.0E+00 ) then amu = 1.0E+00 else amu = amu * ( 1.0 + 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 ! ! Step2 ! ! Copy lower triangular part of A to upper triangular part ! and diagonal of A to udiag ! 100 continue 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, addmax>0. perturb "a" so that it is safely ! diagonally dominant and find ll+ decomposition ! if ( addmax <= 0.0E+00 ) go to 170 ! ! 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.0E+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.0E+00, tol, addmax ) ! ! Unscale the hessian and Cholesky decomposition matrix. ! 170 continue 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 ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input/output, real 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 DIAGMX, the maximum diagonal element of A. ! ! Input, real TOL, a tolerance. ! ! Output, real 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 n integer nr ! real a(nr,n) real addmax real aminl real amnlsq real diagmx integer i integer j integer k real offmax real sum2 real temp real tol ! addmax = 0.0E+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 ( temp >= amnlsq ) then a(j,j) = sqrt ( temp ) ! ! Find maximum off-diagonal element in column. ! else offmax = 0.0E+00 do i = j+1, n if ( abs ( a(i,j) ) > offmax ) 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.0E+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 ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array X. The method is ! more efficient when N is the product of small primes. ! ! Input/output, real 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 n ! real, parameter :: tsqrt2 = 2.82842712474619E+00 real wsave(3*n+15) real x(n) real x1 ! if ( n < 2 ) then x(1) = 4.0E+00 * x(1) else if ( n == 2 ) then x1 = 4.0E+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 ) ! !******************************************************************************* ! !! COSQB1 is a lower level routine used by COSQB. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array. ! ! Input/output, real X(N). ! On input, the cosine series coefficients. ! On output, the corresponding data vector. ! ! Input, real W(N). ! ! Input, real XH(2*N+15). ! implicit none ! integer n ! integer i integer k integer kc integer ns2 real w(n) real x(n) real xh(2*n+15) real 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.0E+00 * x(n) end if call rfftb ( 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.0E+00 * x(1) return end subroutine cosqf ( n, x, wsave ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array X. The method is ! more efficient when N is the product of small primes. ! ! Input/output, real X(N). ! On input, the data to be transformed. ! On output, the transformed data. ! ! 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 n ! real, parameter :: sqrt2 = 1.4142135623731E+00 real tsqx real wsave(3*n+15) real 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 ) ! !******************************************************************************* ! !! COSQF1 is a lower level routine used by COSQF. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Input/output, real X(N). ! On input, the data to be transformed. ! On output, the transformed data. ! ! Input, real W(N). ! ! Input, real XH(2*N+15). ! implicit none ! integer n ! integer i integer k integer kc integer ns2 real w(n) real x(n) real xh(2*n+15) real 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 rfftf ( 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 ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. The method ! is more efficient when N is the product of small primes. ! ! Output, real WSAVE(3*N+15), contains data, depending on N, and ! required by the COSQB and COSQF algorithms. ! implicit none ! integer n ! real dt integer k real pi real wsave(3*n+15) ! dt = 0.5E+00 * pi() / real ( n ) do k = 1, n wsave(k) = cos ( real ( k ) * dt ) end do call rffti ( n, wsave(n+1) ) return end subroutine cost ( n, x, wsave ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. The ! method is more efficient when N-1 is the product of small primes. ! ! Input/output, real X(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real 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 n ! real c1 integer i integer k integer kc integer ns2 real t1 real t2 real tx2 real wsave(3*n+15) real x(n) real x1h real x1p3 real xi real 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 rfftf ( 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 ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. The ! method is more efficient when N-1 is the product of small primes. ! ! Output, real WSAVE(3*N+15), contains data, depending on N, and ! required by the COST algorithm. ! implicit none ! integer n ! real dt integer k real pi real wsave(3*n+15) ! if ( n <= 3 ) then return end if dt = pi ( ) / real ( n - 1 ) do k = 2, ( n / 2 ) wsave(k) = 2.0E+00 * sin ( real ( k - 1 ) * dt ) wsave(n+1-k) = 2.0E+00 * cos ( real ( k - 1 ) * dt ) end do call rffti ( n-1, wsave(n+1) ) return end function csevl ( x, cs, n ) ! !******************************************************************************* ! !! CSEVL evaluates an N term Chebyshev series. ! ! ! Reference: ! ! R Broucke, ! Algorithm 446, ! Communications of the ACM, ! Volume 16, page 254, 1973. ! ! Fox and Parker, ! Chebyshev Polynomials in Numerical Analysis, ! Oxford Press, page 56. ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, real X, the value at which the series is to be evaluated. ! ! Input, real CS(N), the array of N terms of a Chebyshev series. ! In evaluating CS, only half the first coefficient is summed. ! ! Input, integer N, the number of terms in array CS. ! ! Output, real CSEVL, the value of the Chebyshev series. ! implicit none ! integer n ! real b0 real b1 real b2 real cs(n) real csevl integer i real 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 ( n > 1000 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'CSEVL - Fatal error!' write ( *, '(a)' ) ' The number of terms is more than 1000.' stop end if if ( x < -1.0E+00 .or. x > 1.0E+00 ) 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.0E+00 b0 = 0.0E+00 do i = n, 1, -1 b2 = b1 b1 = b0 b0 = 2.0E+00 * x * b1 - b2 + cs(i) end do csevl = 0.5E+00 * ( b0 - b2 ) return end subroutine cvec_random ( alo, ahi, n, a ) ! !******************************************************************************* ! !! CVEC_RANDOM returns a random complex vector in a given range. ! ! ! Modified: ! ! 08 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real ALO, AHI, the range allowed for the entries. ! ! Input, integer N, the number of entries in the vector. ! ! Output, complex A(N), the vector of randomly chosen values. ! implicit none ! integer n ! complex a(n) real ahi real ai real alo real ar integer i ! do i = 1, n call r_random ( alo, ahi, ar ) call r_random ( alo, ahi, ai ) a(i) = cmplx ( ar, ai ) end do return end subroutine d1fcn ( n, x, g ) ! !******************************************************************************* ! !! 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 N, the dimension of X, and order of A. ! ! Input, real X(N), the point at which the gradient is to be evaluated. ! ! Output, real G(N), the gradient vector.. ! implicit none ! integer n ! real g(n) real 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 ) ! !******************************************************************************* ! !! D1MACH returns double precision machine constants. ! ! ! Assuming that the internal representation of a double precision 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). ! ! To alter this function for a particular environment, the desired set of DATA ! statements should be activated by removing the C from column 1. On rare ! machines, a STATIC statement may need to be added, but probably more systems ! prohibit than require it. ! ! For IEEE-arithmetic machines (binary standard), one of the first two sets of ! constants below should be appropriate. ! ! Where possible, octal or hexadecimal constants have been used to specify the ! constants exactly, which has in some cases required the use of EQUIVALENCED ! integer arrays. ! implicit none ! double precision d1mach integer diver(4) double precision dmach(5) integer i integer large(4) integer log10(4) integer right(4) integer small(4) ! equivalence (dmach(1),small(1)) equivalence (dmach(2),large(1)) equivalence (dmach(3),right(1)) equivalence (dmach(4),diver(1)) equivalence (dmach(5),log10(1)) ! ! IEEE arithmetic machines, such as the ATT 3B series and ! Motorola 68000 based machines such as the SUN 3 and ATT PC ! 7300, and the SGI Iris, in which the most significant byte is ! stored first. ! data small(1),small(2) / 1048576, 0 / data large(1),large(2) / 2146435071, -1 / data right(1),right(2) / 1017118720, 0 / data diver(1),diver(2) / 1018167296, 0 / data log10(1),log10(2) / 1070810131, 1352628735 / ! ! IEEE arithmetic machines and 8087-based micros, such as the IBM PC, ! ATT 6300, DEC PMAX, DEC ALPHA, NEXT, in which the most ! significant byte is stored last. ! ! data small(1),small(2) / 0, 1048576 / ! data large(1),large(2) / -1, 2146435071 / ! data right(1),right(2) / 0, 1017118720 / ! data diver(1),diver(2) / 0, 1018167296 / ! data log10(1),log10(2) / 1352628735, 1070810131 / ! ! ALLIANT FX/8 UNIX FORTRAN compiler. ! ! data dmach(1) / 2.22507385850721D-308 / ! data dmach(2) / 1.79769313486231D+308 / ! data dmach(3) / 1.1101827117665D-16 / ! data dmach(4) / 2.2203654423533D-16 / ! data dmach(5) / 3.01029995663981E-1 / ! ! AMDAHL machines. ! ! data small(1),small(2) / 1048576, 0 / ! data large(1),large(2) / 2147483647, -1 / ! data right(1),right(2) / 856686592, 0 / ! data diver(1),diver(2) / 873463808, 0 / ! data log10(1),log10(2) / 1091781651, 1352628735 / ! ! BURROUGHS 1700 system. ! ! data small(1) / ZC00800000 / ! data small(2) / Z000000000 / ! ! data large(1) / ZDFFFFFFFF / ! data large(2) / ZFFFFFFFFF / ! ! data right(1) / ZCC5800000 / ! data right(2) / Z000000000 / ! ! data diver(1) / ZCC6800000 / ! data diver(2) / Z000000000 / ! ! data log10(1) / ZD00E730E7 / ! data log10(2) / ZC77800DC0 / ! ! BURROUGHS 5700 system. ! ! data small(1) / O1771000000000000 / ! data small(2) / O0000000000000000 / ! ! data large(1) / O0777777777777777 / ! data large(2) / O0007777777777777 / ! ! data right(1) / O1461000000000000 / ! data right(2) / O0000000000000000 / ! ! data diver(1) / O1451000000000000 / ! data diver(2) / O0000000000000000 / ! ! data log10(1) / O1157163034761674 / ! data log10(2) / O0006677466732724 / ! ! BURROUGHS 6700/7700 systems. ! ! data small(1) / O1771000000000000 / ! data small(2) / O7770000000000000 / ! ! data large(1) / O0777777777777777 / ! data large(2) / O7777777777777777 / ! ! data right(1) / O1461000000000000 / ! data right(2) / O0000000000000000 / ! ! data diver(1) / O1451000000000000 / ! data diver(2) / O0000000000000000 / ! ! data log10(1) / O1157163034761674 / ! data log10(2) / O0006677466732724 / ! ! CDC CYBER 170/180 series using NOS ! ! data small(1) / O"00604000000000000000" / ! data small(2) / O"00000000000000000000" / ! ! data large(1) / O"37767777777777777777" / ! data large(2) / O"37167777777777777777" / ! ! data right(1) / O"15604000000000000000" / ! data right(2) / O"15000000000000000000" / ! ! data diver(1) / O"15614000000000000000" / ! data diver(2) / O"15010000000000000000" / ! ! data log10(1) / O"17164642023241175717" / ! data log10(2) / O"16367571421742254654" / ! ! CDC CYBER 170/180 series using NOS/VE ! ! data small(1) / Z"3001800000000000" / ! data small(2) / Z"3001000000000000" / ! ! data large(1) / Z"4FFEFFFFFFFFFFFE" / ! data large(2) / Z"4FFE000000000000" / ! ! data right(1) / Z"3FD2800000000000" / ! data right(2) / Z"3FD2000000000000" / ! ! data diver(1) / Z"3FD3800000000000" / ! data diver(2) / Z"3FD3000000000000" / ! ! data log10(1) / Z"3FFF9A209A84FBCF" / ! data log10(2) / Z"3FFFF7988F8959AC" / ! ! CDC CYBER 200 series ! ! data small(1) / X'9000400000000000' / ! data small(2) / X'8FD1000000000000' / ! ! data large(1) / X'6FFF7FFFFFFFFFFF' / ! data large(2) / X'6FD07FFFFFFFFFFF' / ! ! data right(1) / X'FF74400000000000' / ! data right(2) / X'FF45000000000000' / ! ! data diver(1) / X'FF75400000000000' / ! data diver(2) / X'FF46000000000000' / ! ! data log10(1) / X'FFD04D104D427DE7' / ! data log10(2) / X'FFA17DE623E2566A' / ! ! CDC 6000/7000 series using FTN4. ! ! data small(1) / 00564000000000000000B / ! data small(2) / 00000000000000000000B / ! ! data large(1) / 37757777777777777777B / ! data large(2) / 37157777777777777774B / ! ! data right(1) / 15624000000000000000B / ! data right(2) / 00000000000000000000B / ! ! data diver(1) / 15634000000000000000B / ! data diver(2) / 00000000000000000000B / ! ! data log10(1) / 17164642023241175717B / ! data log10(2) / 16367571421742254654B / ! ! CDC 6000/7000 series using FTN5. ! ! data small(1) / O"00564000000000000000" / ! data small(2) / O"00000000000000000000" / ! ! data large(1) / O"37757777777777777777" / ! data large(2) / O"37157777777777777774" / ! ! data right(1) / O"15624000000000000000" / ! data right(2) / O"00000000000000000000" / ! ! data diver(1) / O"15634000000000000000" / ! data diver(2) / O"00000000000000000000" / ! ! data log10(1) / O"17164642023241175717" / ! data log10(2) / O"16367571421742254654" / ! ! CONVEX C-1 ! ! data small(1),small(2) / '00100000'X, '00000000'X / ! data large(1),large(2) / '7FFFFFFF'X, 'FFFFFFFF'X / ! data right(1),right(2) / '3CC00000'X, '00000000'X / ! data diver(1),diver(2) / '3CD00000'X, '00000000'X / ! data log10(1),log10(2) / '3FF34413'X, '509F79FF'X / ! ! CONVEX C-120 (native mode) with or without -R8 option ! ! data dmach(1) / 5.562684646268007D-309 / ! data dmach(2) / 8.988465674311577D+307 / ! data dmach(3) / 1.110223024625157D-016 / ! data dmach(4) / 2.220446049250313D-016 / ! data dmach(5) / 3.010299956639812D-001 / ! ! CONVEX C-120 (IEEE mode) with or without -R8 option ! ! data dmach(1) / 2.225073858507202D-308 / ! data dmach(2) / 1.797693134862315D+308 / ! data dmach(3) / 1.110223024625157D-016 / ! data dmach(4) / 2.220446049250313D-016 / ! data dmach(5) / 3.010299956639812D-001 / ! ! CRAY 1, 2, XMP and YMP. ! ! data small(1) / 201354000000000000000B / ! data small(2) / 000000000000000000000B / ! ! data large(1) / 577767777777777777777B / ! data large(2) / 000007777777777777776B / ! ! data right(1) / 376434000000000000000B / ! data right(2) / 000000000000000000000B / ! ! data diver(1) / 376444000000000000000B / ! data diver(2) / 000000000000000000000B / ! ! data log10(1) / 377774642023241175717B / ! data log10(2) / 000007571421742254654B / ! ! DATA GENERAL ECLIPSE S/200 ! Note - It may be appropriate to include the line: STATIC dmach(5) ! ! data small /20K,3*0/ ! data large /77777K,3*177777K/ ! data right /31420K,3*0/ ! data diver /32020K,3*0/ ! data log10 /40423K,42023K,50237K,74776K/ ! ! ELXSI 6400, assuming REAL*8 is the default DOUBLE PRECISION type. ! ! data small(1), small(2) / '00100000'X,'00000000'X / ! data large(1), large(2) / '7FEFFFFF'X,'FFFFFFFF'X / ! data right(1), right(2) / '3CB00000'X,'00000000'X / ! data diver(1), diver(2) / '3CC00000'X,'00000000'X / ! data log10(1), diver(2) / '3FD34413'X,'509F79FF'X / ! ! HARRIS 220 ! ! data small(1),small(2) / '20000000, '00000201 / ! data large(1),large(2) / '37777777, '37777577 / ! data right(1),right(2) / '20000000, '00000333 / ! data diver(1),diver(2) / '20000000, '00000334 / ! data log10(1),log10(2) / '23210115, '10237777 / ! ! HARRIS SLASH 6 and SLASH 7 ! ! data small(1),small(2) / '20000000, '00000201 / ! data large(1),large(2) / '37777777, '37777577 / ! data right(1),right(2) / '20000000, '00000333 / ! data diver(1),diver(2) / '20000000, '00000334 / ! data log10(1),log10(2) / '23210115, '10237777 / ! ! HONEYWELL DPS 8/70 and 600/6000 series. ! ! data small(1),small(2) / O402400000000, O000000000000 / ! data large(1),large(2) / O376777777777, O777777777777 / ! data right(1),right(2) / O604400000000, O000000000000 / ! data diver(1),diver(2) / O606400000000, O000000000000 / ! data log10(1),log10(2) / O776464202324, O117571775714 / ! ! HP 2100, three word double precision option with FTN4. ! ! data small(1), small(2), small(3) / 40000B, 0, 1 / ! data large(1), large(2), large(3) / 77777B, 177777B, 177776B / ! data right(1), right(2), right(3) / 40000B, 0, 265B / ! data diver(1), diver(2), diver(3) / 40000B, 0, 276B / ! data log10(1), log10(2), log10(3) / 46420B, 46502B, 77777B / ! ! HP 2100, four word double precision option with FTN4. ! ! data small(1), small(2) / 40000B, 0 / ! data small(3), small(4) / 0, 1 / ! data large(1), large(2) / 77777B, 177777B / ! data large(3), large(4) / 177777B, 177776B / ! data right(1), right(2) / 40000B, 0 / ! data right(3), right(4) / 0, 225B / ! data diver(1), diver(2) / 40000B, 0 / ! data diver(3), diver(4) / 0, 227B / ! data log10(1), log10(2) / 46420B, 46502B / ! data log10(3), log10(4) / 76747B, 176377B / ! ! HP 9000 ! ! d1mach(1) = 2.8480954D-306 ! d1mach(2) = 1.40444776D+306 ! d1mach(3) = 2.22044605D-16 ! d1mach(4) = 4.44089210D-16 ! d1mach(5) = 3.01029996D-1 ! ! data small(1), small(2) / 00040000000B, 00000000000B / ! data large(1), large(2) / 17737777777B, 37777777777B / ! data right(1), right(2) / 07454000000B, 00000000000B / ! data diver(1), diver(2) / 07460000000B, 00000000000B / ! data log10(1), log10(2) / 07764642023B, 12047674777B / ! ! IBM 360/370 series, XEROX SIGMA 5/7/9, SEL SYSTEMS 85/86, PERKIN ELMER 3230, ! and PERKIN ELMER (INTERDATA) 3230. ! ! data small(1),small(2) / Z00100000, Z00000000 / ! data large(1),large(2) / Z7FFFFFFF, ZFFFFFFFF / ! data right(1),right(2) / Z33100000, Z00000000 / ! data diver(1),diver(2) / Z34100000, Z00000000 / ! data log10(1),log10(2) / Z41134413, Z509F79FF / ! ! IBM PC - Microsoft FORTRAN ! ! data small(1), small(2) / #00000000, #00100000 / ! data large(1), large(2) / #FFFFFFFF, #7FEFFFFF / ! data right(1), right(2) / #00000000, #3CA00000 / ! data diver(1), diver(2) / #00000000, #3CB00000 / ! data log10(1), log10(2) / #509F79FF, #3FD34413 / ! ! IBM PC - Professional FORTRAN and Lahey FORTRAN ! ! data small(1), small(2) / Z'00000000', Z'00100000' / ! data large(1), large(2) / Z'FFFFFFFF', Z'7FEFFFFF' / ! data right(1), right(2) / Z'00000000', Z'3CA00000' / ! data diver(1), diver(2) / Z'00000000', Z'3CB00000' / ! data log10(1), log10(2) / Z'509F79FF', Z'3FD34413' / ! ! INTERDATA 8/32 with the UNIX system FORTRAN 77 compiler. ! For the INTERDATA FORTRAN VII compiler, replace the Z's specifying hex ! constants with Y's. ! ! data small(1),small(2) / Z'00100000', Z'00000000' / ! data large(1),large(2) / Z'7EFFFFFF', Z'FFFFFFFF' / ! data right(1),right(2) / Z'33100000', Z'00000000' / ! data diver(1),diver(2) / Z'34100000', Z'00000000' / ! data log10(1),log10(2) / Z'41134413', Z'509F79FF' / ! ! PDP-10 (KA processor). ! ! data small(1),small(2) / "033400000000, "000000000000 / ! data large(1),large(2) / "377777777777, "344777777777 / ! data right(1),right(2) / "113400000000, "000000000000 / ! data diver(1),diver(2) / "114400000000, "000000000000 / ! data log10(1),log10(2) / "177464202324, "144117571776 / ! ! PDP-10 (KI processor). ! ! data small(1),small(2) / "000400000000, "000000000000 / ! data large(1),large(2) / "377777777777, "377777777777 / ! data right(1),right(2) / "103400000000, "000000000000 / ! data diver(1),diver(2) / "104400000000, "000000000000 / ! data log10(1),log10(2) / "177464202324, "047674776746 / ! ! PDP-11 FORTRANS supporting 32-bit integers (integer version). ! ! data small(1),small(2) / 8388608, 0 / ! data large(1),large(2) / 2147483647, -1 / ! data right(1),right(2) / 612368384, 0 / ! data diver(1),diver(2) / 620756992, 0 / ! data log10(1),log10(2) / 1067065498, -2063872008 / ! ! PDP-11 FORTRANS supporting 32-bit integers (octal version) ! ! data small(1),small(2) / O00040000000, O00000000000 / ! data large(1),large(2) / O17777777777, O37777777777 / ! data right(1),right(2) / O04440000000, O00000000000 / ! data diver(1),diver(2) / O04500000000, O00000000000 / ! data log10(1),log10(2) / O07746420232, O20476747770 / ! ! PDP-11 FORTRANS supporting 16-bit integers (integer version). ! ! data small(1),small(2) / 128, 0 / ! data small(3),small(4) / 0, 0 / ! ! data large(1),large(2) / 32767, -1 / ! data large(3),large(4) / -1, -1 / ! ! data right(1),right(2) / 9344, 0 / ! data right(3),right(4) / 0, 0 / ! ! data diver(1),diver(2) / 9472, 0 / ! data diver(3),diver(4) / 0, 0 / ! ! data log10(1),log10(2) / 16282, 8346 / ! data log10(3),log10(4) / -31493, -12296 / ! ! PDP-11 FORTRANS supporting 16-bit integers (octal version). ! ! data small(1),small(2) / O000200, O000000 / ! data small(3),small(4) / O000000, O000000 / ! ! data large(1),large(2) / O077777, O177777 / ! data large(3),large(4) / O177777, O177777 / ! ! data right(1),right(2) / O022200, O000000 / ! data right(3),right(4) / O000000, O000000 / ! ! data diver(1),diver(2) / O022400, O000000 / ! data diver(3),diver(4) / O000000, O000000 / ! ! data log10(1),log10(2) / O037632, O020232 / ! data log10(3),log10(4) / O102373, O147770 / ! ! PRIME 50 series systems with 32-bit integers and 64V MODE instructions, ! supplied by Igor Bray. ! ! data small(1),small(2) / :10000000000, :00000100001 / ! data large(1),large(2) / :17777777777, :37777677775 / ! data right(1),right(2) / :10000000000, :00000000122 / ! data diver(1),diver(2) / :10000000000, :00000000123 / ! data log10(1),log10(2) / :11504046501, :07674600177 / ! ! SEQUENT BALANCE 8000 ! ! data small(1),small(2) / $00000000, $00100000 / ! data large(1),large(2) / $FFFFFFFF, $7FEFFFFF / ! data right(1),right(2) / $00000000, $3CA00000 / ! data diver(1),diver(2) / $00000000, $3CB00000 / ! data log10(1),log10(2) / $509F79FF, $3FD34413 / ! ! SUN Microsystems UNIX F77 compiler. ! ! data dmach(1) / 2.22507385850720D-308 / ! data dmach(2) / 1.79769313486231D+308 / ! data dmach(3) / 1.1101827117665D-16 / ! data dmach(4) / 2.2203654423533D-16 / ! data dmach(5) / 3.01029995663981D-1 / ! ! SUN 3 (68881 or FPA) ! ! data small(1),small(2) / X'00100000', X'00000000' / ! data large(1),large(2) / X'7FEFFFFF', X'FFFFFFFF' / ! data right(1),right(2) / X'3CA00000', X'00000000' / ! data diver(1),diver(2) / X'3CB00000', X'00000000' / ! data log10(1),log10(2) / X'3FD34413', X'509F79FF' / ! ! UNIVAC 1100 series. ! ! data small(1),small(2) / O000040000000, O000000000000 / ! data large(1),large(2) / O377777777777, O777777777777 / ! data right(1),right(2) / O170540000000, O000000000000 / ! data diver(1),diver(2) / O170640000000, O000000000000 / ! data log10(1),log10(2) / O177746420232, O411757177572 / ! ! VAX/ULTRIX F77 compiler ! ! data small(1),small(2) / 128, 0 / ! data large(1),large(2) / -32769, -1 / ! data right(1),right(2) / 9344, 0 / ! data diver(1),diver(2) / 9472, 0 / ! data log10(1),log10(2) / 546979738, -805796613 / ! ! VAX/ULTRIX F77 compiler, G floating ! ! data small(1), small(2) / 16, 0 / ! data large(1), large(2) / -32769, -1 / ! data right(1), right(2) / 15552, 0 / ! data diver(1), diver(2) / 15568, 0 / ! data log10(1), log10(2) / 1142112243, 2046775455 / ! ! VAX-11 with FORTRAN IV-PLUS compiler ! ! data small(1),small(2) / Z00000080, Z00000000 / ! data large(1),large(2) / ZFFFF7FFF, ZFFFFFFFF / ! data right(1),right(2) / Z00002480, Z00000000 / ! data diver(1),diver(2) / Z00002500, Z00000000 / ! data log10(1),log10(2) / Z209A3F9A, ZCFF884FB / ! ! VAX/VMS version 2.2 ! ! data small(1),small(2) / '80'X, '0'X / ! data large(1),large(2) / 'FFFF7FFF'X, 'FFFFFFFF'X / ! data right(1),right(2) / '2480'X, '0'X / ! data diver(1),diver(2) / '2500'X, '0'X / ! data log10(1),log10(2) / '209A3F9A'X, 'CFF884FB'X / ! ! VAX/VMS 11/780 ! ! data small(1), small(2) / Z00000080, Z00000000 / ! data large(1), large(2) / ZFFFF7FFF, ZFFFFFFFF / ! data right(1), right(2) / Z00002480, Z00000000 / ! data diver(1), diver(2) / Z00002500, Z00000000 / ! data log10(1), log10(2) / Z209A3F9A, ZCFF884FB / ! ! VAX/VMS 11/780 (G-FLOATING) ! ! data small(1), small(2) / Z00000010, Z00000000 / ! data large(1), large(2) / ZFFFF7FFF, ZFFFFFFFF / ! data right(1), right(2) / Z00003CC0, Z00000000 / ! data diver(1), diver(2) / Z00003CD0, Z00000000 / ! data log10(1), log10(2) / Z44133FF3, Z79FF509F / ! if ( i < 1 .or. i > 5 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D1MACH - Fatal error!' write ( *, '(a,i6)' ) 'I is out of bounds:', i d1mach = 0.0d0 stop else d1mach = dmach(i) end if return end subroutine d2fcn ( nr, n, x, a ) ! !******************************************************************************* ! !! 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 NR, the leading dimension of A, which must be at ! least N. ! ! Input, integer N, the dimension of X, and order of A. ! ! Input, real X(N), the point at which the Hessian matrix is to be ! evaluated. ! ! Output, real A(NR,N), the N by N Hessian matrix. ! implicit none ! integer n integer nr ! real a(nr,n) real 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 subroutine dfault ( n, x, typsiz, fscale, method, iexp, msg, ndigit, itnlim, & iagflg, iahflg, ipr, dlt, gradtl, stepmx, steptl ) ! !******************************************************************************* ! !! DFAULT sets default values for the optimization algorithm. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), an initial guess for the solution, used to compute ! a maximum stepsize. ! ! Output, real TYPSIZ(N), a typical size for each component of X. ! ! Output, real FSCALE, an estimate of the scale of the minimization function. ! ! Output, integer METHOD, specifies the algorithm to use to solve the ! minimization problem. ! ! Output, integer IEXP, set to 0 if minimization function not expensive ! to evaluate. ! ! Output, integer MSG, a message to inhibit certain automatic checks ! and output. ! ! Output, integer NDIGIT, the number of good digits in minimization function. ! ! Output, integer ITNLIM, the maximum number of allowable iterations. ! ! Output, integer IAGFLG, set to 0, meaning the analytic gradient is ! not supplied. ! ! Output, integer IAHFLG, set to 0, meaning the analytic hessian is ! not supplied. ! ! Output, integer IPR, the device to which to send output. ! ! Output, real DLT, the trust region radius. ! ! Output, real GRADTL, a tolerance at which the gradient is considered ! close enough to zero to terminate algorithm. ! ! Output, real STEPMX, the maximum stepsize, set to 0.0 to trip ! the default maximum in OPTCHK. ! ! Output, real STEPTL, a tolerance at which successive iterates are ! considered close enough to terminate the algorithm. ! implicit none ! integer n ! real dlt real epsm real fscale real gradtl integer i1mach integer iagflg integer iahflg integer iexp integer ipr integer itnlim integer method integer msg integer ndigit real stepmx real steptl real typsiz(n) real x(n) ! ! Typical size of X and minimization function. ! typsiz(1:n) = 1.0E+00 fscale = 1.0E+00 ! ! Tolerances. ! dlt = -1.0E+00 epsm = epsilon ( epsm ) gradtl = epsm**(1.0E+00/3.0E+00) stepmx = 0.0E+00 steptl = sqrt ( epsm ) ! ! Flags. ! method = 1 iexp = 1 msg = 9 ndigit = -1 itnlim = 150 iagflg = 0 iahflg = 0 ipr = 6 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 ) ! !******************************************************************************* ! !! DOGDRV finds the next Newton iterate by the double dogleg method. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), the old iterate, "X[K-1]". ! ! Input, real F, the function value at the old iterate, "F(X)". ! ! Input, real G(N), the gradient at the old iterate. ! ! Input, real A(N,N), the Cholesky decomposition of the Hessian matrix ! in lower triangular part and diagonal. ! ! Input, real P(N), the Newton step. ! ! Output, real XPLS(N), the new iterate "X[K]". ! ! Output, real FPLS, the function value at the new iterate, F(XPLS). ! ! Input, external FCN, the name of the subroutine to evaluate the function, ! of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real x(n) ! real f ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input, real STEPMX, the maximum allowable step size. ! ! Input, real STEPTL, the relative step size at which successive iterates ! are considered close enough to terminate algorithm. ! ! Input/output, real DLT, the trust region radius. ! [retain value between successive calls]. ! ! Output, integer IRETCD, the return code. ! 0, satisfactory XPLS found ! 1, failed to find satisfactory XPLS sufficiently distinct from X. ! ! Output, logical MXTAKE, TRUE if a step of maximum length was used. ! ! Workspace, real SC(N), holds the current step. ! ! Workspace, real WRK1(N). ! ! Workspace, real WRK2(N). ! ! Workspace, real WRK3(N). ! ! Input, integer IPR, the device to which to send output. ! implicit none ! integer n integer nr ! real a(nr,n) real cln real dlt real eta real f external fcn real fpls real fplsp logical fstdog real g(n) integer i integer ipr integer iretcd logical mxtake logical nwtake real p(n) real rnwtln real sc(n) real stepmx real steptl real sx(n) real tmp real wrk1(n) real wrk2(n) real wrk3(n) real x(n) real 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 ) ! !******************************************************************************* ! !! 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: ! ! More, Garbow and Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer N, the order of the matrix R. ! ! Input, real R(LR), the upper triangular matrix R stored by rows. ! ! Input, integer LR, the size of the R array, which must be no less ! than (N*(N+1))/2. ! ! Input, real DIAG(N), the diagonal elements of the matrix D. ! ! Input, real QTB(N), the first N elements of the vector Q'* B. ! ! Input, real DELTA, is a positive upper bound on the euclidean norm ! of D*X(1:N). ! ! Output, real X(N), the desired convex combination of the Gauss-Newton ! direction and the scaled gradient direction. ! implicit none ! integer lr integer n ! real alpha real bnorm real delta real diag(n) real enorm real epsmch real gnorm integer i integer j integer jj integer k integer l real qnorm real qtb(n) real r(lr) real sgnorm real sum2 real temp real wa1(n) real wa2(n) real 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.0E+00 do i = j+1, n sum2 = sum2 + r(l) * x(i) l = l + 1 end do temp = r(jj) if ( temp == 0.0E+00 ) then l = j do i = 1, j temp = max ( temp, abs ( r(l)) ) l = l + n - i end do if ( temp == 0.0E+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.0E+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.0E+00 alpha = delta / qnorm if ( gnorm /= 0.0E+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.0E+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.0E+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.0E+00 - ( delta / qnorm )**2 ) & * ( 1.0E+00 - ( sgnorm / delta )**2 ) ) alpha = ( ( delta / qnorm ) * ( 1.0E+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.0E+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 ) ! !******************************************************************************* ! !! DOGSTP finds a new step by the double dogleg algorithm. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real G(N), the gradient at the current iterate. ! ! Input, real A(NR,N), the Cholesky decomposition of the hessian in ! the lower triangle and diagonal. ! ! Input, real P(N), the Newton step. ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input, real RNWTLN, the Newton step length. ! ! Input/output, real 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 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 V(N), workspace [retain value between successive calls] ! ! Workspace, real CLN, the cauchy length. ! [retain value between successive calls] ! ! Workspace, real ETA, [retain value between successive calls] ! ! Output, real SC(N), the current step. ! ! Input, integer IPR, the device to which to send output. ! ! Input, real STEPMX, the maximum allowable step size. ! ! Local variables: ! ! CLN, the length of cauchy step ! implicit none ! integer n integer nr ! real a(nr,*) real alam real alpha real beta real cln real dlt real dot1 real dot2 real eta logical fstdog real g(n) integer i integer ipr integer j logical nwtake real p(n) real rnwtln real sc(n) real ssd(n) real stepmx real sx(n) real tmp real 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.0E+00 do i = 1, n tmp = 0.0E+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.2E+00 + ( 0.8E+00 * alpha * alpha ) / & ( - beta * dot_product ( g, p ) ) v(1:n) = eta * sx(1:n) * p(1:n) - ssd(1:n) if ( dlt == - 1.0E+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 ( cln >= dlt ) 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 ea ( newflg, svalue, limexp, result, abserr, epstab, ierr ) ! !******************************************************************************* ! !! EA performs extrapolation to accelerate the convergence of a sequence. ! ! ! Discussion: ! ! Given a slowly convergent sequence, this routine attempts ! to extrapolate nonlinearly to a better estimate of the ! sequence's limiting value, thus improving the rate of ! convergence. ! ! The routine is based on the epsilon algorithm of P. Wynn. ! ! An estimate of the absolute error is also given. ! ! The routine can be called repeatedly, using the results of ! previous calls to efficiently compute new values. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, logical NEWFLG, is TRUE if this is the first call for this ! data. ! ! Input, real SVALUE, ? ! ! Input, integer LIMEXP, the size of the epsilon table that can be ! generated. LIMEXP must be at least 3. ! ! Output, real RESULT, the estimate of the sequence's limiting value. ! ! Output, real ABSERR, an estimate of the absolute error. ! ! Input/output, real EPSTAB(), ? ! ! Output, integer IERR, error flag. ! 0, no error occurred. ! Nonzero, an error occurred. ! implicit none ! real abserr real delta1 real delta2 real delta3 real eprn real epstab(*) real error real err1 real err2 real err3 real e0 real e1 real e2 real e3 integer i integer ib integer ib2 integer ie integer ierr integer in integer k1 integer k2 integer k3 integer limexp integer n integer newelm integer num integer nres logical newflg real relpr real res real result real res3la(3) real r1mach real ss real svalue real tol1 real tol2 real tol3 ! if ( limexp < 3 ) then ierr = 1 call xerror('limexp is less than 3',21,1,1) return end if ierr = 0 res3la(1) = epstab(limexp+5) res3la(2) = epstab(limexp+6) res3la(3) = epstab(limexp+7) result = svalue if ( newflg ) then n = 1 nres = 0 newflg = .false. epstab(n) = svalue abserr = abs ( result ) go to 100 else n = int ( epstab(limexp+3) ) nres = int ( epstab(limexp+4) ) if ( n == 2 ) then epstab(n) = svalue abserr = 6.0E+00 * abs ( result - epstab(1) ) go to 100 end if end if epstab(n) = svalue relpr = epsilon ( relpr ) eprn = 10.0E+00 * relpr epstab(n+2) = epstab(n) newelm = ( n - 1 ) / 2 num = n k1 = n do i = 1, newelm k2 = k1 - 1 k3 = k1 - 2 res = epstab(k1+2) e0 = epstab(k3) e1 = epstab(k2) e2 = res delta2 = e2 - e1 err2 = abs ( delta2 ) tol2 = max ( abs ( e2 ), abs ( e1 ) ) * relpr delta3 = e1 - e0 err3 = abs ( delta3 ) tol3 = max ( abs ( e1 ), abs ( e0 ) ) * relpr ! ! If e0, e1 and e2 are equal to within machine accuracy, ! convergence is assumed. ! if ( err2 <= tol2 .and. err3 <= tol3 ) then result = res abserr = err2 + err3 go to 50 end if if ( i /= 1 ) then e3 = epstab(k1) epstab(k1) = e1 delta1 = e1 - e3 err1 = abs ( delta1 ) tol1 = max ( abs ( e1 ), abs ( e3 ) ) * relpr ! ! If two elements are very close to each other, omit ! a part of the table by adjusting the value of N. ! if ( err1 <= tol1 .or. err2 <= tol2 .or. err3 <= tol3 ) then go to 20 end if ss = 1.0E+00 / delta1 + 1.0E+00 / delta2 - 1.0E+00 / delta3 else epstab(k1) = e1 if ( err2 <= tol2 .or. err3 <= tol3 ) go to 20 ss = 1.0E+00 / delta2 - 1.0E+00 / delta3 end if ! ! Test to detect irregular behavior in the table, and ! eventually omit a part of the table adjusting the value of N. ! if ( abs ( ss * e1 ) > 0.1E-03 ) go to 30 20 continue n = i + i - 1 if ( nres == 0 ) then abserr = err2 + err3 result = res else if ( nres == 1 ) then result = res3la(1) else if ( nres == 2 ) then result = res3la(2) else result = res3la(3) end if go to 50 ! ! Compute a new element and eventually adjust the value of RESULT. ! 30 continue res = e1 + 1.0E+00 / ss epstab(k1) = res k1 = k1-2 if ( nres == 0 ) then abserr = err2 + abs ( res - e2 ) + err3 result = res go to 40 else if ( nres == 1 ) then error = 6.0E+00 * ( abs ( res - res3la(1) ) ) else if ( nres == 2 ) then error = 2.0E+00 * ( abs ( res - res3la(2) ) + abs ( res - res3la(1) ) ) else error = abs ( res - res3la(3) ) + abs ( res - res3la(2) ) & + abs ( res - res3la(1) ) end if if ( error <= 10.0E+00 * abserr ) then abserr = error result = res end if 40 continue end do ! ! Compute error estimate. ! if ( nres == 1 ) then abserr = 6.0E+00 * ( abs ( result - res3la(1) ) ) else if ( nres == 2 ) then abserr = 2.0E+00 * abs ( result - res3la(2) ) + abs ( result - res3la(1) ) else if ( nres > 2 ) then abserr = abs ( result - res3la(3) ) + abs ( result - res3la(2) ) & + abs ( result - res3la(1) ) end if ! ! Shift the table. ! 50 continue if ( n == limexp ) then n = 2*(limexp/2) - 1 end if ib = 1 if ( (num/2)*2 == num ) then ib = 2 end if ie = newelm+1 do i = 1, ie ib2 = ib+2 epstab(ib) = epstab(ib2) ib = ib2 end do if ( num /= n ) then in = num - n + 1 do i = 1, n epstab(i) = epstab(in) in = in + 1 end do end if ! ! Update RES3LA. ! if ( nres == 0 ) then res3la(1) = result else if ( nres == 1 ) then res3la(2) = result else if ( nres == 2 ) then res3la(3) = result else res3la(1) = res3la(2) res3la(2) = res3la(3) res3la(3) = result end if 90 continue abserr = max ( abserr, eprn * abs ( result ) ) nres = nres + 1 100 continue n = n + 1 epstab(limexp+3) = real ( n ) epstab(limexp+4) = real ( nres ) epstab(limexp+5) = res3la(1) epstab(limexp+6) = res3la(2) epstab(limexp+7) = res3la(3) 110 continue return end function enorm ( n, x ) ! !******************************************************************************* ! !! ENORM computes the Euclidean norm of a vector. ! ! ! Discussion: ! ! The Euclidean norm is computed by accumulating the sum of ! squares in three different sums. The sums of squares for the ! small and large components are scaled so that no overflows ! occur. Non-destructive underflows are permitted. Underflows ! and overflows do not occur in the computation of the unscaled ! sum of squares for the intermediate components. ! ! The definitions of small, intermediate and large components ! depend on two constants, RDWARF and RGIANT. The main ! restrictions on these constants are that RDWARF**2 not ! underflow and RGIANT**2 not overflow. ! ! Reference: ! ! More, Garbow and Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer N, is the length of the vector. ! ! Input, real X(N), the vector whose norm is desired. ! ! Output, real ENORM, the Euclidean norm of the vector. ! implicit none ! integer n ! real agiant real enorm integer i real rdwarf real rgiant real s1 real s2 real s3 real x(n) real xabs real x1max real x3max ! rdwarf = sqrt ( tiny ( rdwarf ) ) rgiant = sqrt ( huge ( rgiant ) ) s1 = 0.0E+00 s2 = 0.0E+00 s3 = 0.0E+00 x1max = 0.0E+00 x3max = 0.0E+00 agiant = rgiant / real ( n ) do i = 1, n xabs = abs ( x(i) ) if ( xabs <= rdwarf ) then if ( xabs > x3max ) then s3 = 1.0E+00 + s3 * ( x3max / xabs )**2 x3max = xabs else if ( xabs /= 0.0E+00 ) then s3 = s3 + ( xabs / x3max )**2 end if else if ( xabs >= agiant ) then if ( xabs > x1max ) then s1 = 1.0E+00 + s1 * ( x1max / xabs )**2 x1max = xabs else s1 = s1 + ( xabs / x1max )**2 end if else s2 = s2 + xabs**2 end if end do ! ! Calculation of norm. ! if ( s1 /= 0.0E+00 ) then enorm = x1max * sqrt ( s1 + ( s2 / x1max ) / x1max ) else if ( s2 /= 0.0E+00 ) then if ( s2 >= x3max ) then enorm = sqrt ( s2 * ( 1.0E+00 + ( x3max / s2 ) * ( x3max * s3 ) ) ) else enorm = sqrt ( x3max * ( ( s2 / x3max ) + ( x3max * s3 ) ) ) end if else enorm = x3max * sqrt ( s3 ) end if return end function erf ( x ) ! !******************************************************************************* ! !! ERF computes the error function. ! ! ! Definition: ! ! ERF(X) = ( 2 / SQRT ( PI ) ) * Integral ( 0 <= T <= X ) EXP ( -T**2 ) dT ! ! Modified: ! ! 25 August 2001 ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, real X, the argument of the error function. ! ! Output, real ERF, the value of the error function at X. ! implicit none ! real, parameter :: sqrtpi = 1.7724538509055160E+00 ! real csevl real erf real erfc real, parameter, dimension ( 13 ) :: erfcs = (/ & -0.049046121234691808E+00, -0.14226120510371364E+00, & 0.010035582187599796E+00, -0.000576876469976748E+00, & 0.000027419931252196E+00, -0.000001104317550734E+00, & 0.000000038488755420E+00, -0.000000001180858253E+00, & 0.000000000032334215E+00, -0.000000000000799101E+00, & 0.000000000000017990E+00, -0.000000000000000371E+00, & 0.000000000000000007E+00 /) integer inits integer, save :: nterf = 0 real r1mach real, save :: sqeps = 0.0E+00 real x real, save :: xbig = 0.0E+00 real y ! if ( nterf == 0 ) then nterf = inits ( erfcs, 13, 0.1E+00 * epsilon ( erfcs ) ) xbig = sqrt ( - log ( sqrtpi * epsilon ( xbig ) ) ) sqeps = sqrt ( 2.0E+00 * epsilon ( sqeps ) ) end if y = abs ( x ) if ( y <= sqeps ) then erf = 2.0E+00 * x / sqrtpi else if ( y <= 1.0E+00 ) then erf = x * ( 1.0E+00 + csevl ( 2.0E+00 * x**2 - 1.0E+00, erfcs, nterf ) ) else if ( y <= xbig ) then erf = sign ( 1.0E+00 - erfc ( y ), x ) else erf = sign ( 1.0E+00, x ) end if return end subroutine erf_values ( n, x, fx ) ! !******************************************************************************* ! !! ERF_VALUES returns some values of the ERF or "error" function for testing. ! ! ! Modified: ! ! 17 April 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. ! On input, if N is 0, the first test data is returned, and N is set ! to the index of the test data. On each subsequent call, N is ! incremented and that test data is returned. When there is no more ! test data, N is set to 0. ! ! Output, real X, the argument of the function. ! ! Output, real FX, the value of the function. ! implicit none ! integer, parameter :: nmax = 21 ! real, save, dimension ( nmax ) :: bvec = (/ & 0.0000000000E+00, 0.1124629160E+00, 0.2227025892E+00, 0.3286267595E+00, & 0.4283923550E+00, 0.5204998778E+00, 0.6038560908E+00, 0.6778011938E+00, & 0.7421009647E+00, 0.7969082124E+00, 0.8427007929E+00, 0.8802050696E+00, & 0.9103139782E+00, 0.9340079449E+00, 0.9522851198E+00, 0.9661051465E+00, & 0.9763483833E+00, 0.9837904586E+00, 0.9890905016E+00, 0.9927904292E+00, & 0.9953222650E+00 /) real fx integer n real x real, save, dimension ( nmax ) :: xvec = (/ & 0.0E+00, 0.1E+00, 0.2E+00, 0.3E+00, & 0.4E+00, 0.5E+00, 0.6E+00, 0.7E+00, & 0.8E+00, 0.9E+00, 1.0E+00, 1.1E+00, & 1.2E+00, 1.3E+00, 1.4E+00, 1.5E+00, & 1.6E+00, 1.7E+00, 1.8E+00, 1.9E+00, & 2.0E+00 /) ! if ( n < 0 ) then n = 0 end if n = n + 1 if ( n > nmax ) then n = 0 x = 0.0E+00 fx = 0.0E+00 return end if x = xvec(n) fx = bvec(n) return end function erfc ( x ) ! !******************************************************************************* ! !! ERFC computes the complementary error function. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Modified: ! ! 26 August 2001 ! ! Parameters: ! ! Input, real X, the argument of the error function. ! ! Output, real ERFC, the value of the complementary error function at X. ! implicit none ! real csevl real erfc real, parameter, dimension ( 13 ) :: erfcs = (/ & -0.049046121234691808E+00, -0.14226120510371364E+00, & 0.010035582187599796E+00, -0.000576876469976748E+00, & 0.000027419931252196E+00, -0.000001104317550734E+00, & 0.000000038488755420E+00, -0.000000001180858253E+00, & 0.000000000032334215E+00, -0.000000000000799101E+00, & 0.000000000000017990E+00, -0.000000000000000371E+00, & 0.000000000000000007E+00 /) real, parameter, dimension ( 24 ) :: erfccs = (/ & 0.0715179310202925E+00, & -0.026532434337606719E+00, & 0.001711153977920853E+00, & -0.000163751663458512E+00, & 0.000019871293500549E+00, & -0.000002843712412769E+00, & 0.000000460616130901E+00, & -0.000000082277530261E+00, & 0.000000015921418724E+00, & -0.000000003295071356E+00, & 0.000000000722343973E+00, & -0.000000000166485584E+00, & 0.000000000040103931E+00, & -0.000000000010048164E+00, & 0.000000000002608272E+00, & -0.000000000000699105E+00, & 0.000000000000192946E+00, & -0.000000000000054704E+00, & 0.000000000000015901E+00, & -0.000000000000004729E+00, & 0.000000000000001432E+00, & -0.000000000000000439E+00, & 0.000000000000000138E+00, & -0.000000000000000048E+00 /) real, parameter, dimension ( 23 ) :: erc2cs = (/ & -0.069601346602309501E+00, & -0.041101339362620893E+00, & 0.003914495866689626E+00, & -0.000490639565054897E+00, & 0.000071574790013770E+00, & -0.000011530716341312E+00, & 0.000001994670590201E+00, & -0.000000364266647159E+00, & 0.000000069443726100E+00, & -0.000000013712209021E+00, & 0.000000002788389661E+00, & -0.000000000581416472E+00, & 0.000000000123892049E+00, & -0.000000000026906391E+00, & 0.000000000005942614E+00, & -0.000000000001332386E+00, & 0.000000000000302804E+00, & -0.000000000000069666E+00, & 0.000000000000016208E+00, & -0.000000000000003809E+00, & 0.000000000000000904E+00, & -0.000000000000000216E+00, & 0.000000000000000052E+00 /) real eta integer inits integer, save :: nterc2 = 0 integer, save :: nterf = 0 integer, save :: nterfc = 0 real r1mach real, save :: sqeps = 0.0E+00 real, parameter :: sqrtpi = 1.7724538509055160E+00 real x real, save :: xmax = 0.0E+00 real, save :: xsml = 0.0E+00 real y ! if ( nterf == 0 ) then eta = 0.1E+00 * epsilon ( eta ) nterf = inits ( erfcs, 13, eta ) nterfc = inits ( erfccs, 24, eta ) nterc2 = inits ( erc2cs, 23, eta ) xsml = -sqrt ( - log ( sqrtpi * epsilon ( xsml ) ) ) xmax = sqrt ( - log ( sqrtpi * tiny ( xmax ) ) ) xmax = xmax - 0.5E+00 * log ( xmax ) / xmax - 0.01E+00 sqeps = sqrt ( 2.0E+00 * epsilon ( sqeps ) ) end if if ( x <= xsml ) then erfc = 2.0E+00 return end if if ( x > xmax ) then call xerror ( 'erfc x so big erfc underflows', 32, 1, 1) erfc = 0.0E+00 return end if y = abs ( x ) ! ! erfc(x) = 1.0E+00 - erf(x) for -1. <= x <= 1. ! if ( y <= 1.0E+00 ) then if ( y < sqeps ) then erfc = 1.0E+00 - 2.0E+00 * x / sqrtpi else if ( y >= sqeps ) then erfc = 1.0E+00 - x * ( 1.0E+00 + & csevl ( 2.0E+00 *x*x-1.0E+00, erfcs, nterf ) ) end if return end if ! ! erfc(x) = 1.0E+00 - erf(x) for 1 < abs ( x ) <= xmax ! y = y * y if ( y <= 4.0E+00 ) then erfc = exp ( -y ) / abs ( x ) * ( 0.5E+00 & + csevl ( ( 8.0E+00 / y - 5.0E+00 ) / 3.0E+00, erc2cs, nterc2 ) ) else erfc = exp ( -y ) / abs ( x ) * ( 0.5E+00 & + csevl ( 8.0E+00 / y - 1.0E+00, erfccs, nterfc ) ) end if if ( x < 0.0E+00 ) then erfc = 2.0E+00 - erfc end if return end subroutine ezfftb ( n, r, azero, a, b, wsave ) ! !******************************************************************************* ! !! EZFFTB computes a real periodic sequence from its Fourier coefficients. ! ! ! Discussion: ! ! This process is sometimes called Fourier synthesis. ! ! EZFFTB is a simplified but slower version of RFFTB. ! ! The transform is defined by: ! ! R(I) = AZERO + sum ( 1 <= K <= N/2 ) ! ! A(K) * cos ( K * ( I - 1 ) * 2 * PI / N ) ! + B(K) * sin ( K * ( I - 1 ) * 2 * PI / N ) ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the output array. The ! method is more efficient when N is the product of small primes. ! ! Output, real R(N), the reconstructed data sequence. ! ! Input, real AZERO, the constant Fourier coefficient. ! ! Input, real A(N/2), B(N/2), the Fourier coefficients. ! ! Input, real WSAVE(3*N+15), a work array. The WSAVE array must be ! initialized by calling EZFFFTI. A different WSAVE array must be used ! for each different value of N. ! implicit none ! integer n ! real a(n/2) real azero real b(n/2) integer i integer ns2 real r(n) real wsave(3*n+15) ! if ( n < 2 ) then r(1) = azero else if ( n == 2 ) then r(1) = azero + a(1) r(2) = azero - a(1) else ns2 = ( n - 1 ) / 2 do i = 1, ns2 r(2*i) = 0.5E+00 * a(i) r(2*i+1) = -0.5E+00 * b(i) end do r(1) = azero if ( mod ( n, 2 ) == 0 ) then r(n) = a(ns2+1) end if call rfftb ( n, r, wsave(n+1) ) end if return end subroutine ezfftf ( n, r, azero, a, b, wsave ) ! !******************************************************************************* ! !! EZFFTF computes the Fourier coefficients of a real periodic sequence. ! ! ! Discussion: ! ! This process is sometimes called Fourier analysis. ! ! EZFFTF is a simplified but slower version of RFFTF. ! ! The transform is defined by: ! ! AZERO = sum ( 1 <= I <= N ) R(I) / N, ! ! and, for K = 1 to (N-1)/2, ! ! A(K) = sum ( 1 <= I <= N ) ! ( 2 / N ) * R(I) * cos ( K * ( I - 1 ) * 2 * PI / N ) ! ! and, if N is even, then ! ! A(N/2) = sum ( 1 <= I <= N ) (-1) **(I-1) * R(I) / N ! ! For K = 1 to (N-1)/2, ! ! B(K) = sum ( 1 <= I <= N ) ! ( 2 / N ) * R(I) * sin ( K * ( I - 1 ) * 2 * PI / N ) ! ! and, if N is even, then ! ! B(N/2) = 0. ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. The ! method is more efficient when N is the product of small primes. ! ! Input, real R(N), the sequence to be transformed. ! ! Input, real WSAVE(3*N+15), a work array. The WSAVE array must be ! initialized by calling EZFFTI. A different WSAVE array must be used ! for each different value of N. ! ! Output, real AZERO, the constant Fourier coefficient. ! ! Output, real A(N/2), B(N/2), the Fourier coefficients. ! implicit none ! integer n ! real a(n/2) real azero real b(n/2) real cf integer i integer ns2 real r(n) real wsave(3*n+15) ! if ( n < 2 ) then azero = r(1) else if ( n == 2 ) then azero = 0.5E+00 * ( r(1) + r(2) ) a(1) = 0.5E+00 * ( r(1) - r(2) ) else wsave(1:n) = r(1:n) call rfftf ( n, wsave(1), wsave(n+1) ) cf = 2.0E+00 / real ( n ) azero = 0.5E+00 * cf * wsave(1) ns2 = ( n + 1 ) / 2 do i = 1, ns2-1 a(i) = cf * wsave(2*i) b(i) = -cf * wsave(2*i+1) end do if ( mod ( n, 2 ) /= 1 ) then a(ns2) = 0.5E+00 * cf * wsave(n) b(ns2) = 0.0E+00 end if end if return end subroutine ezffti ( n, wsave ) ! !******************************************************************************* ! !! EZFFTI initializes WSAVE, used in EZFFTF and EZFFTB. ! ! ! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. The ! method is more efficient when N is the product of small primes. ! ! Output, real WSAVE(3*N+15), contains data, dependent on the value ! of N, which is necessary for the EZFFTF or EZFFTB routines. ! implicit none ! integer n ! real wsave(3*n+15) ! if ( n <= 1 ) then return end if call ezffti1 ( n, wsave(2*n+1), wsave(3*n+1) ) return end subroutine ezffti1 ( n, wa, ifac ) ! !******************************************************************************* ! !! EZFFTI1 is a lower level routine used by EZFFTI. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Output, real WA(N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer n ! real arg1 real argh real ch1 real ch1h real dch1 real dsh1 integer i integer ib integer ido integer ifac(15) integer ii integer ip integer is integer j integer k1 integer l1 integer l2 integer nf real pi real sh1 real wa(n) ! call i_factor ( n, ifac ) nf = ifac(2) argh = 2.0E+00 * pi() / real ( n ) is = 0 l1 = 1 do k1 = 1, nf-1 ip = ifac(k1+2) l2 = l1 * ip ido = n / l2 arg1 = real ( l1 ) * argh ch1 = 1.0E+00 sh1 = 0.0E+00 dch1 = cos ( arg1 ) dsh1 = sin ( arg1 ) do j = 1, ip-1 ch1h = dch1 * ch1 - dsh1 * sh1 sh1 = dch1 * sh1 + dsh1 * ch1 ch1 = ch1h i = is + 2 wa(i-1) = ch1 wa(i) = sh1 do ii = 5, ido, 2 i = i + 2 wa(i-1) = ch1 * wa(i-3) - sh1 * wa(i-2) wa(i) = ch1 * wa(i-2) + sh1 * wa(i-3) end do is = is + ido end do l1 = l2 end do return end subroutine fdjac1 ( fcn, n, x, fvec, fjac, ldfjac, iflag, ml, mu, epsfcn ) ! !******************************************************************************* ! !! FDJAC1 estimates an N by N jacobian matrix using forward differences. ! ! ! Discussion: ! ! This subroutine computes a forward-difference approximation ! to the N by N jacobian matrix associated with a specified ! problem of N functions in N variables. If the jacobian has ! a banded form, then function evaluations are saved by only ! approximating the nonzero terms. ! ! Reference: ! ! More, Garbow and Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, external FCN, the name of the user-supplied subroutine which ! calculates the functions. The routine should have the form: ! ! subroutine fcn ( n, x, fvec, iflag ) ! ! integer n ! ! real fvec(n) ! integer iflag ! real x(n) ! ! The value of IFLAG should not be changed by FCN unless ! the user wants to terminate execution of the routine. ! In this case set IFLAG to a negative integer. ! ! Input, integer N, the number of functions and variables. ! ! Input, real X(N), the point where the jacobian is evaluated. ! ! Input, real FVEC(N), the functions evaluated at X. ! ! Output, real FJAC(LDFJAC,N), the N by N approximate jacobian matrix. ! ! Input, integer LDFJAC, the leading dimension of FJAC, which must ! not be less than N. ! ! Output, integer IFLAG, is an error flag returned by FCN. If FCN ! returns a nonzero value of IFLAG, then this routine returns immediately ! to the calling program, with the value of IFLAG. ! ! Input, integer ML, MU, specify the number of subdiagonals and ! superdiagonals within the band of the jacobian matrix. If the ! jacobian is not banded, set ML and MU to N-1. ! ! Input, real EPSFCN, is used in determining a suitable step length 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 precision, it is assumed that the ! relative errors in the functions are of the order of the machine ! precision. ! implicit none ! integer ldfjac integer n ! real eps real epsfcn real epsmch external fcn real fjac(ldfjac,n) real fvec(n) real h integer i integer iflag integer j integer k integer ml integer msum integer mu real temp real wa1(n) real wa2(n) real x(n) ! epsmch = epsilon ( epsmch ) eps = sqrt ( max ( epsfcn, epsmch ) ) msum = ml + mu + 1 ! ! Computation of dense approximate jacobian. ! if ( msum >= n ) then do j = 1, n temp = x(j) h = eps * abs ( temp ) if ( h == 0.0E+00 ) then h = eps end if x(j) = temp + h call fcn ( n, x, wa1, iflag ) if ( iflag < 0 ) then exit end if x(j) = temp fjac(1:n,j) = ( wa1(1:n) - fvec(1:n) ) / h end do else ! ! Computation of banded approximate jacobian. ! do k = 1, msum do j = k, n, msum wa2(j) = x(j) h = eps * abs ( wa2(j) ) if ( h == 0.0E+00 ) then h = eps end if x(j) = wa2(j) + h end do call fcn ( n, x, wa1, iflag ) if ( iflag < 0 ) then exit end if do j = k, n, msum x(j) = wa2(j) h = eps * abs ( wa2(j) ) if ( h == 0.0E+00 ) then h = eps end if fjac(1:n,j) = 0.0E+00 do i = 1, n if ( i >= j - mu .and. i <= j + ml ) then fjac(i,j) = ( wa1(i) - fvec(i) ) / h end if end do end do end do end if return end function fmin ( ax, bx, f, tol ) ! !******************************************************************************* ! !! FMIN seeks a minimizer of a scalar function of a scalar variable. ! ! ! Discussion: ! ! FMIN seeks an approximation to the point where F attains a minimum on ! the interval (AX,BX). ! ! The method used is a combination of golden section search and ! successive parabolic interpolation. Convergence is never much ! slower than that for a Fibonacci search. If F has a continuous ! second derivative which is positive at the minimum (which is not ! at AX or BX), then convergence is superlinear, and usually of the ! order of about 1.324.... ! ! The function F is never evaluated at two points closer together ! than EPS * ABS ( FMIN ) + (TOL/3), where EPS is approximately the ! square root of the relative machine precision. If F is a unimodal ! function and the computed values of F are always unimodal when ! separated by at least EPS * ABS ( XSTAR ) + (TOL/3), then FMIN ! approximates the abcissa of the global minimum of F on the ! interval AX, BX with an error less than 3 * EPS * ABS ( FMIN ) + TOL. ! If F is not unimodal, then FMIN may approximate a local, but ! perhaps non-global, minimum to the same accuracy. ! ! Reference: ! ! Richard Brent, ! Algorithms for Minimization without Derivatives, ! Prentice Hall, 1973. ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters ! ! Input/output, real AX, BX. On input, the left and right endpoints ! of the initial interval. On output, the lower and upper bounds for ! the minimizer. ! ! Input, external F, a real function of the form ! function f ( x ) ! real f ! real x ! which evaluates F(X) for any X in the interval (AX,BX). ! ! Input, real TOL, the desired length of the interval of uncertainty of the ! final result ( >= 0.0) ! ! Output, real FMIN, the abcissa approximating the minimizer of f. ! implicit none ! real a real ax real b real bx real c real d real e real eps real, external :: f real fmin real fu real fv real fw real fx real p real q real r real tol real tol1 real tol2 real u real v real w real x real xm ! c = 0.5E+00 * ( 3.0E+00 - sqrt ( 5.0E+00 ) ) ! ! C is the squared inverse of the golden ratio. ! ! EPS is the square root of the relative machine precision. ! eps = sqrt ( epsilon ( eps ) ) ! ! Initialization. ! a = ax b = bx v = a + c * ( b - a ) w = v x = v e = 0.0E+00 fx = f(x) fv = fx fw = fx ! ! Main loop starts here. ! 20 continue xm = 0.5E+00 * ( a + b ) tol1 = eps * abs ( x ) + tol / 3.0E+00 tol2 = 2.0E+00 * tol1 ! ! Check the stopping criterion. ! if ( abs ( x - xm ) <= ( tol2 - 0.5E+00 * ( b - a ) ) ) then fmin = x return end if ! ! Is golden-section necessary? ! if ( abs ( e ) <= tol1 ) then go to 40 end if ! ! Fit a parabola. ! r = ( x - w ) * ( fx - fv ) q = ( x - v ) * ( fx - fw ) p = ( x - v ) * q - ( x - w ) * r q = 2.0E+00 * ( q - r ) if ( q > 0.0E+00 ) then p = -p end if q = abs ( q ) r = e e = d ! ! Is a parabola acceptable? ! 30 continue if ( abs ( p ) >= abs ( 0.5E+00 * q * r ) ) then go to 40 end if if ( p <= q * ( a - x ) ) then go to 40 end if if ( p >= q * ( b - x ) ) then go to 40 end if ! ! A parabolic interpolation step ! d = p / q u = x + d ! ! F must not be evaluated too close to AX or BX. ! if ( ( u - a ) < tol2 ) then d = sign ( tol1, xm - x ) end if if ( ( b - u ) < tol2 ) then d = sign ( tol1, xm - x ) end if go to 50 ! ! A golden-section step. ! 40 continue if ( x >= xm ) then e = a - x else e = b - x end if d = c * e ! ! F must not be evaluated too close to X. ! 50 continue if ( abs ( d ) >= tol1 ) then u = x + d end if if ( abs ( d ) < tol1 ) then u = x + sign ( tol1, d ) end if fu = f(u) ! ! Update a, b, v, w, and x ! if ( fu <= fx ) then if ( u >= x ) then a = x else b = x end if v = w fv = fw w = x fw = fx x = u fx = fu go to 20 end if 60 continue if ( u < x ) then a = u else b = u end if if ( fu <= fw ) then go to 70 end if if ( w == x ) then go to 70 end if if ( fu <= fv ) then go to 80 end if if ( v == x ) then go to 80 end if if ( v == w ) then go to 80 end if go to 20 70 continue v = w fv = fw w = u fw = fu go to 20 80 continue v = u fv = fu go to 20 end subroutine forslv ( nr, n, a, x, b ) ! !******************************************************************************* ! !! FORSLV solves A*x=b where A is lower triangular matrix. ! ! ! Discussion: ! ! If B is no longer required by calling routine, ! then vectors B and X may share the same storage. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real A(NR,N), the N by N lower triangular matrix. ! ! Output, real X(N), the solution. ! ! Input, real B(N), the right hand side. ! implicit none ! integer n integer nr ! real a(nr,n) real b(n) integer i real x(n) ! x(1) = b(1) / a(1,1) do i = 2, n x(i) = ( b(i) - dot_product ( a(i,1:i-1), x(1:i-1) ) ) / a(i,i) end do return end subroutine fstocd ( n, x, fcn, sx, rnoise, g ) ! !******************************************************************************* ! !! FSTOCD approximates the gradient of a function using central differences. ! ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), the point at which the gradient is to be approximated. ! ! Input, external FCN, the name of the subroutine to evaluate the function, ! of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real x(n) ! real f ! ! Input, real SX(N), the scaling factors for X. ! ! Input, real RNOISE, the relative noise in FCN [F(X)]. ! ! Output, real G(N), a central difference approximation to the gradient. ! implicit none ! integer n ! external fcn real fminus real fplus real g(n) integer i real rnoise real stepi real sx(n) real third real x(n) real xtempi ! ! Find I-th stepsize, evaluate two neighbors in direction of I-th ! unit vector, and evaluate I-th component of gradient. ! third = 1.0E+00 / 3.0E+00 do i = 1, n stepi = rnoise**third * max ( abs ( x(i) ), 1.0E+00 / sx(i) ) xtempi = x(i) x(i) = xtempi + stepi call fcn ( n, x, fplus ) x(i) = xtempi - stepi call fcn ( n, x, fminus ) x(i) = xtempi g(i) = ( fplus - fminus ) / ( 2.0E+00 * stepi ) end do return end subroutine fstofd ( nr, m, n, xpls, fcn, fpls, a, sx, rnoise, fhat, icase ) ! !******************************************************************************* ! !! FSTOFD approximates a derivative by a first order approximation. ! ! ! Discussion: ! ! The routine finds the first order forward finite difference ! approximation A to the first derivative of the function defined ! by the subprogram "fname" evaluated at the new iterate "xpls". ! ! For optimization, use this routine to estimate: ! ! * the first derivative (gradient) of the optimization function "fcn" ! if no analytic user routine has been supplied; ! ! * the second derivative (hessian) of the optimization function ! if no analytic user routine has been supplied for the hessian but ! one has been supplied for the gradient ("fcn") and if the ! optimization function is inexpensive to evaluate. ! ! m=1 (optimization) algorithm estimates the gradient of the function ! (fcn). fcn(x) # f: r(n)-->r(1) ! ! m=n (systems) algorithm estimates the jacobian of the function ! fcn(x) # f: r(n)-->r(n). ! ! m=n (optimization) algorithm estimates the hessian of the optimizatio ! function, where the hessian is the first derivative of "fcn" ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix A. ! ! Input, integer M, the number of rows in A. ! ! Input, integer N, the number of columns in A, and the dimension ! of the problem. ! ! Input, real XPLS(N), the point at which the derivative is ! to be estimated. ! ! Input, external FCN, the name of the subroutine to evaluate ! the function, of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real x(n) ! real f ! ! Input, real FPLS(M). ! If M is 1, (optimization), then this is the function value at ! the new iterate. ! If M = N for optimization, then this is the value of the first ! derivative of the function. ! If M = N for nonlinear systems, then this is the value ! of the associated minimization function. ! ! Output, real A(NR,N), the N by N finite difference approximation. ! Only the lower triangular matrix and diagonal are computed. ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input, real RNOISE, the relative noise or inaccuracy in the ! function value FCN. ! ! Workspace, real FHAT(M). ! ! Input, integer ICASE, problem specifier: ! 1, optimization (gradient) ! 2, systems ! 3, optimization (hessian) ! ! Local variables: ! ! real STEPSZ, the stepsize in the j-th variable direction ! implicit none ! integer m integer n integer nr ! real a(nr,n) external fcn real fhat(m) real fpls(m) integer i integer icase integer j real rnoise real stepsz real sx(n) real xpls(n) real xtmpj ! ! Find the J-th column of A. ! Each column is derivative of f(fcn) with respect to xpls(j). ! do j = 1, n stepsz = sqrt ( rnoise ) * max ( abs ( xpls(j) ), 1.0E+00 / sx(j) ) xtmpj = xpls(j) xpls(j) = xtmpj + stepsz call fcn ( n, xpls, fhat ) xpls(j) = xtmpj a(1:m,j) = ( fhat(1:m) - fpls(1:m) ) / stepsz end do if ( icase /= 3 ) then return end if ! ! If computing the hessian, A must be symmetric. ! do j = 1, n-1 do i = j+1, m a(i,j) = ( a(i,j) + a(j,i) ) / 2.0E+00 end do end do return end subroutine fzero ( f, b, c, r, re, ae, iflag ) ! !******************************************************************************* ! !! FZERO searches for a zero of a function F(X) in a given interval. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! L F Shampine and H A Watts, ! FZERO, a Root-Solving Code, ! sc-tm-70-631, September 1970. ! ! T J Dekker, ! Finding a Zero by Means of Successive Linear Interpolation, ! 'Constructive Aspects of the Fundamental Theorem of Algebra', ! edited by B. Dejon, P. Henrici, 1969. ! ! Discussion: ! ! FZERO searches for a zero of a function F(X) 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 ). ! The method used is an efficient combination of bisection ! and the secant rule. ! ! Parameters: ! ! Input, real, external F, the name of the function. ! This name must be in an external statement in the calling ! program. F must be a function of one real argument. ! ! Input/output, real B, one end of the interval (B,C). The ! value returned for B usually is the better approximation to ! a zero of F. ! ! Input/output, real C, the other end of the interval (B,C). ! ! Input, real R, a (better) guess of a zero of F which could help in ! speeding up convergence. If F(B) and F(R) have opposite signs, a root will ! be found in the interval (B,R); if not, but F(R) and F(C) have opposite ! signs, a root will be found in the interval (R,C); otherwise, the interval ! (B,C) will be searched for a possible root. When no better guess is known, ! it is recommended that R be set to B or C; because if R is ! not interior to the interval (B,C), it will be ignored. ! ! Input, real RE, the relative error used for RW in the stopping ! criterion. If the input RE is less than machine precision, ! then RW is set to approximately machine precision. ! ! Input, real 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. ! ! Output, integer IFLAG, a status code. The user must check IFLAG ! after each call. Control returns to the user in all cases. ! ! 1, B is within the requested tolerance of a zero. ! the interval (b,c) collapsed to the requested ! tolerance, the function changes sign in (b,c), and ! f(x) decreased in magnitude as (b,c) collapsed. ! ! 2, F(B) = 0. however, the interval (b,c) may not have ! collapsed to the requested tolerance. ! ! 3, B may be near a singular point of f(x). ! the interval (b,c) collapsed to the requested tolerance and ! the function changes sign in (b,c), but ! f(x) increased in magnitude as (b,c) collapsed,i.e. ! ABS ( f(b out) ) > max ( ABS ( f(b in) ), ABS ( f(c in) ) ) ! ! 4, no change in sign of f(x) was found although the ! interval (b,c) collapsed to the requested tolerance. ! the user must examine this case and decide whether ! b is near a local minimum of f(x), or B is near a ! zero of even multiplicity, or neither of these. ! ! 5, too many (> 500) function evaluations used. ! implicit none ! real a real acbs real acmb real ae real aw real b real c real cmb real er real, external :: f real fa real fb real fc real fx real fz integer ic integer iflag integer kount real p real q real r real re real rw real t real tol real z ! er = 2.0E+00 * epsilon ( er ) ! ! Initialize. ! z = r if ( r <= min ( b, c ) .or. r >= max ( b, c ) ) then z = c end if rw = max ( re, er ) aw = max ( ae, 0.0E+00 ) ic = 0 t = z fz = f(t) fc = fz t = b fb = f(t) kount = 2 if ( sign ( 1.0E+00, fz ) == sign ( 1.0E+00, fb ) ) then go to 1 end if c = z go to 2 1 continue if ( z /= c ) then t=c fc=f(t) kount=3 if ( sign ( 1.0E+00, fz ) /= sign ( 1.0E+00, fc ) ) then b = z fb = fz end if end if 2 continue a = c fa = fc acbs = abs ( b - c ) fx= max ( abs ( fb ), abs ( fc ) ) 3 continue ! ! Interchange ! if ( abs ( fc ) < abs ( fb ) ) then a = b fa = fb b = c fb = fc c = a fc = fa end if cmb = 0.5E+00 * ( c - b ) acmb = abs ( cmb ) tol = rw * abs ( b ) + aw ! ! Test stopping criterion and function count. ! if ( acmb <= tol ) then go to 10 end if if ( fb == 0.0E+00 ) then go to 11 end if if ( kount >= 500 ) then go to 14 end if ! ! Calculate new iterate implicitly as b+p/q ! where we arrange p >= 0. ! The implicit form is used to prevent overflow. ! p = ( b - a ) * fb q = fa - fb if ( p < 0.0E+00 ) then p = -p q = -q end if ! ! Update A and check for satisfactory reduction ! in the size of the bracketing interval. ! If not, perform bisection. ! 5 continue a = b fa = fb ic = ic + 1 if ( ic < 4 ) then go to 6 end if if ( 8.0E+00 * acmb >= acbs ) then b = b + cmb go to 9 end if ic = 0 acbs = acmb ! ! Test for too small a change ! 6 continue if ( p > abs ( q ) * tol ) then go to 7 end if ! ! Increment by tolerance ! b = b + sign ( tol, cmb ) go to 9 ! ! Root ought to be between b and (c+b)/2. ! 7 continue ! ! Use the secant rule or bisection. ! if ( p < cmb * q ) then b = b + p / q else b = b + cmb end if ! ! Have completed computation for new iterate B. ! 9 continue t = b fb = f(t) kount = kount+1 ! ! Decide whether next step is interpolation or extrapolation. ! if ( sign ( 1.0E+00, fb ) == sign ( 1.0E+00, fc ) ) then c = a fc = fa end if go to 3 ! ! Finished. Process results for proper setting of IFlAG. ! 10 continue if ( sign ( 1.0E+00, fb ) == sign ( 1.0E+00, fc ) ) then go to 13 end if if ( abs ( fb ) > fx ) then iflag = 3 return end if iflag = 1 return 11 continue iflag = 2 return 12 continue iflag = 3 return 13 continue iflag = 4 return 14 continue iflag = 5 return end subroutine gamlim ( xmin, xmax ) ! !******************************************************************************* ! !! GAMLIM computes the minimum and maximum bounds for X in GAMMA(X). ! ! ! Discussion: ! ! GAMLIM calculates the minimum and maximum legal bounds for X in GAMMA(X). ! ! Modified: ! ! 11 August 2001 ! ! Parameters: ! ! Output, real XMIN, the minimum legal value of X in GAMMA(X). ! Any smaller value might result in underflow. ! ! Output, real XMAX, the maximum legal value of X in GAMMA(X). ! Any larger value will cause overflow. ! implicit none ! real alnbig real alnsml logical converged integer i real r1mach real xln real xmax real xmin real xold ! alnsml = log ( tiny ( alnsml ) ) xmin = -alnsml converged = .false. do i = 1, 10 xold = xmin xln = log ( xmin ) xmin = xmin - xmin * & ( ( xmin + 0.5E+00 ) * xln - xmin - 0.2258E+00 + alnsml ) & / ( xmin * xln + 0.5E+00 ) if ( abs ( xmin - xold ) < 0.005E+00 ) then converged = .true. exit end if end do if ( .not. converged ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GAMLIM - Fatal error!' write ( *, '(a)' ) ' Unable to determine XMIN.' stop end if xmin = -xmin + 0.01E+00 alnbig = log ( huge ( alnbig ) ) xmax = alnbig converged = .false. do i = 1, 10 xold = xmax xln = log ( xmax ) xmax = xmax - xmax * & ( ( xmax - 0.5E+00 ) * xln - xmax + 0.9189E+00 - alnbig ) & / ( xmax * xln - 0.5E+00 ) if ( abs ( xmax - xold ) < 0.005E+00 ) then converged = .true. exit end if end do if ( .not. converged ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GAMLIM - Fatal error!' write ( *, '(a)' ) ' Unable to determine XMAX.' stop end if xmax = xmax - 0.01E+00 xmin = max ( xmin, -xmax + 1.0E+00 ) return end function gamma ( x ) ! !******************************************************************************* ! !! GAMMA computes the gamma function. ! ! ! Parameters: ! ! Input, real X, the argument of the gamma function, which must not ! be 0, -1, or any other negative integral value. ! ! Output, real GAMMA, the value of the gamma function of X. ! implicit none ! real csevl real, save :: dxrel = 0.0E+00 real gamma real, parameter, dimension ( 23 ) :: gcs = (/ & 0.008571195590989331E+00, & 0.004415381324841007E+00, & 0.05685043681599363E+00, & -0.004219835396418561E+00, & 0.001326808181212460E+00, & -0.0001893024529798880E+00, & 0.0000360692532744124E+00, & -0.0000060567619044608E+00, & 0.0000010558295463022E+00, & -0.0000001811967365542E+00, & 0.0000000311772496471E+00, & -0.0000000053542196390E+00, & 0.0000000009193275519E+00, & -0.0000000001577941280E+00, & 0.0000000000270798062E+00, & -0.0000000000046468186E+00, & 0.0000000000007973350E+00, & -0.0000000000001368078E+00, & 0.0000000000000234731E+00, & -0.0000000000000040274E+00, & 0.0000000000000006910E+00, & -0.0000000000000001185E+00, & 0.0000000000000000203E+00 /) integer i integer inits integer n integer, save :: ngcs = 0 real, parameter :: pi = & 3.14159265358979323846264338327950288419716939937510E+00 real r1mach real r9lgmc real sinpiy real, parameter :: sq2pil = 0.91893853320467274E+00 real x real, save :: xmax = 0.0E+00 real, save :: xmin = 0.0E+00 real y ! ! Initialize. Find legal bounds for X, and determine the number of ! terms in the series required to attain an accuracy ten times better ! than machine precision. ! if ( ngcs == 0 ) then ngcs = inits ( gcs, 23, 0.1E+00 * epsilon ( gcs ) ) call gamlim ( xmin, xmax ) dxrel = sqrt ( epsilon ( dxrel ) ) end if y = abs ( x ) if ( y > 10.0E+00 ) then go to 50 end if ! ! Compute gamma(x) for abs ( x ) <= 10.0. reduce interval and ! find gamma(1+y) for 0 <= y < 1. ! n = x if ( x < 0.0E+00 ) then n = n - 1 end if y = x - real ( n ) n = n - 1 gamma = 0.9375E+00 + csevl ( 2.0E+00*y-1.0E+00, gcs, ngcs ) if ( n == 0 ) then return else if ( n < 0 ) then n = -n if ( x == 0.0E+00 ) then call xerror ( 'gamma x is 0', 14, 4, 2) end if if ( x < 0.0E+00 .and. x + real ( n - 2 ) == 0.0E+00 ) then call xerror ( 'gamma x is a negative integer', 31, 4, 2) end if if ( x < (-0.5E+00) .and. & abs ( ( x - aint ( x - 0.5E+00) ) / x ) < dxrel ) then call xerror ( & 'gamma answer lt half precision because x too near negative integer', & 68, 1, 1) end if do i = 1, n gamma = gamma / ( x + real ( i - 1 ) ) end do return else do i = 1, n gamma = ( y + real ( i ) ) * gamma end do return end if ! ! Compute gamma(x) for abs ( x ) > 10.0. recall y = abs ( x ). ! 50 continue if ( x > xmax ) then call xerror ( 'gamma x so big gamma overflows', 32, 3, 2) end if gamma = 0.0E+00 if ( x < xmin ) then call xerror ( 'gamma x so small gamma underflows', 35, 2, 1) return end if gamma = exp ( ( y - 0.5E+00 ) * log ( y ) - y + sq2pil + r9lgmc ( y ) ) if ( x > 0.0E+00 ) then return end if if ( abs ( ( x - aint ( x - 0.5E+00 ) ) / x ) < dxrel ) then call xerror ( & 'gamma answer lt half precision, x too near negative integer', & 61, 1, 1) end if sinpiy = sin ( pi * y ) if ( sinpiy == 0.0E+00 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'GAMMA - Fatal error!' write ( *, '(a)' ) ' The argument X is a negative integer.' stop end if gamma = -pi / ( y * sinpiy * gamma ) return end subroutine gamma_values ( n, x, fx ) ! !******************************************************************************* ! !! GAMMA_VALUES returns some values of the Gamma function for testing. ! ! ! Modified: ! ! 17 April 2001 ! ! Reference: ! ! Milton Abramowitz and Irene Stegun, ! Handbook of Mathematical Functions, ! US Department of Commerce, 1964. ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer N. ! On input, if N is 0, the first test data is returned, and N is set ! to the index of the test data. On each subsequent call, N is ! incremented and that test data is returned. When there is no more ! test data, N is set to 0. ! ! Output, real X, the argument of the function. ! ! Output, real FX, the value of the function. ! implicit none ! integer, parameter :: nmax = 18 ! real, save, dimension ( nmax ) :: bvec = (/ & 4.590845E+00, 2.218160E+00, 1.489192E+00, 1.164230E+00, & 1.0000000000E+00, 0.9513507699E+00, 0.9181687424E+00, 0.8974706963E+00, & 0.8872638175E+00, 0.8862269255E+00, 0.8935153493E+00, 0.9086387329E+00, & 0.9313837710E+00, 0.9617658319E+00, 1.0000000000E+00, 3.6288000E+05, & 1.2164510E+17, 8.8417620E+30 /) real fx integer n real x real, save, dimension ( nmax ) :: xvec = (/ & 0.2E+00, 0.4E+00, 0.6E+00, 0.8E+00, & 1.0E+00, 1.1E+00, 1.2E+00, 1.3E+00, & 1.4E+00, 1.5E+00, 1.6E+00, 1.7E+00, & 1.8E+00, 1.9E+00, 2.0E+00, 10.0E+00, & 20.0E+00, 30.0E+00 /) ! if ( n < 0 ) then n = 0 end if n = n + 1 if ( n > nmax ) then n = 0 x = 0.0E+00 fx = 0.0E+00 return end if x = xvec(n) fx = bvec(n) return end subroutine gl15t ( f, a, b, xl, xr, r, ae, ra, rasc, fmin, fmax ) ! !******************************************************************************* ! !! GL15T estimates the integral of a function over a finite interval. ! ! ! Discussion: ! ! GL15T is a utility routine for Q1DAX, and is not called directly ! by the user. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, external F, the name of the routine that evaluates the function, ! of the form ! ! function f ( x ) ! real f ! real x ! ! The function G(X) is defined to be ! ! G(X) = F(PHI(X)) * PHIP(X) ! ! where PHI(X) is the cubic given by the arithmetic statement function ! below and PHIP(X) is its derivative. ! ! Input, real A, B, the lower and upper limits of integration. ! ! Input, double precision XL, XR, the lower and upper limits of the ! parent interval of which [A,B] is a part. ! ! Output, real R, approximation to the integral I. R is computed by ! applying the 15-point Kronrod rule RESK obtained by optimal ! addition of abscissae to the 7-point Gauss rule RESG. ! ! Output, real AE, estimate of the modulus of the absolute error, ! which should not exceed abs ( I - R ). ! ! Output, real RA, approximation to the integral J. ! ! Output, real RASC, approximation to the integral of ABS ( G - I / (B-A) ) ! over (A,B). ! ! Output, real FMAX, FMIN, the maximum and minimum values of the ! function F(X) encountered during the computation. ! ! Local variables: ! ! centr - mid point of the interval ! hlgth - half-length of the interval ! absc - abscissa ! fval* - function value ! resg - r of the 7-point Gauss formula ! resk - r of the 15-point Kronrod formula ! reskh - approximation to the mean value of f over (a,b), i.e. to i/(b-a) ! implicit none ! real a double precision absc real ae real b double precision centr real dhlgth real, save :: epmach = 0.0E+00 real, external :: f real fc real fmax real fmin real fsum real fv1(7) real fv2(7) real fval1 real fval2 real hlgth integer j integer jtw integer jtwm1 real phi real phip real phiu real r real r1mach real ra real rasc real resg real resk real reskh real sl real sr double precision u real, save :: uflow = 0.0E+00 real, parameter, dimension ( 4 ) :: wg = (/ & 0.129484966168869693270611432679082E+00, & 0.279705391489276667901467771423780E+00, & 0.381830050505118944950369775488975E+00, & 0.417959183673469387755102040816327E+00 /) real, parameter, dimension ( 8 ) :: wgk = (/ & 0.022935322010529224963732008058970E+00, & 0.063092092629978553290700663189204E+00, & 0.104790010322250183839876322541518E+00, & 0.140653259715525918745189590510238E+00, & 0.169004726639267902826583426598550E+00, & 0.190350578064785409913256402421014E+00, & 0.204432940075298892414161999234649E+00, & 0.209482141084727828012999174891714E+00 /) real, parameter, dimension ( 8 ) :: xgk = (/ & 0.991455371120812639206854697526329E+00, & 0.949107912342758524526189684047851E+00, & 0.864864423359769072789712788640926E+00, & 0.741531185599394439863864773280788E+00, & 0.586087235467691130294144838258730E+00, & 0.405845151377397166906606412076961E+00, & 0.207784955007898467600689403773245E+00, & 0.000000000000000000000000000000000E+00 /) double precision xl double precision xr ! ! Statement functions (ugh) ! phi ( u ) = xr - ( xr - xl ) * u * u * ( 2.0E+00 * u + 3.0E+00 ) phip ( u ) = -6.0E+00 * u * ( u + 1.0E+00 ) if ( epmach == 0.0E+00 ) then epmach = epsilon ( 1.0E+00 ) uflow = tiny ( uflow ) end if if ( xl < xr ) then sl = real ( xl ) sr = real ( xr ) else sl = real ( xr ) sr = real ( xl ) end if hlgth = 0.5E+00 * ( b - a ) centr = a + hlgth dhlgth = abs ( hlgth ) ! ! Compute the 15-point Kronrod approximation to ! the integral, and estimate the absolute error. ! u = ( centr - xr ) / ( xr - xl ) phiu = phi(u) if ( phiu <= sl .or. phiu >= sr ) then phiu = centr end if fmin = f(phiu) fmax = fmin fc = fmin * phip(u) resg = fc * wg(4) resk = fc * wgk(8) ra = abs ( resk ) do j = 1, 3 jtw = j * 2 absc = hlgth * xgk(jtw) u = ( centr - absc - xr ) / ( xr - xl ) phiu = phi(u) if ( phiu <= sl .or. phiu >= sr ) then phiu = centr end if fval1 = f(phiu) fmax = max ( fmax, fval1 ) fmin = min ( fmin, fval1 ) fval1 = fval1 * phip(u) u = ( centr + absc - xr ) / ( xr - xl ) phiu = phi(u) if ( phiu <= sl .or. phiu >= sr ) then phiu = centr end if fval2 = f(phiu) fmax = max ( fmax, fval2 ) fmin = min ( fmin, fval2 ) fval2 = fval2 * phip(u) fv1(jtw) = fval1 fv2(jtw) = fval2 fsum = fval1 + fval2 resg = resg + wg(j) * fsum resk = resk + wgk(jtw) * fsum ra = ra + wgk(jtw) * ( abs ( fval1 ) + abs ( fval2 ) ) end do do j = 1, 4 jtwm1 = j * 2-1 absc = hlgth * xgk(jtwm1) u = ( centr - absc - xr ) / ( xr - xl ) phiu = phi(u) if ( phiu <= sl .or. phiu >= sr ) then phiu = centr end if fval1 = f(phiu) fmax = max ( fmax, fval1 ) fmin = min ( fmin, fval1 ) fval1 = fval1 * phip(u) u = ( centr + absc - xr ) / ( xr - xl ) phiu = phi(u) if ( phiu <= sl .or. phiu >= sr ) then phiu = centr end if fval2 = f(phiu) fmax = max ( fmax, fval2 ) fmin = min ( fmin, fval2 ) fval2 = fval2 * phip(u) fv1(jtwm1) = fval1 fv2(jtwm1) = fval2 fsum = fval1 + fval2 resk = resk + wgk(jtwm1) * fsum ra = ra + wgk(jtwm1) * ( abs ( fval1 ) + abs ( fval2 ) ) end do reskh = resk * 0.5E+00 rasc = wgk(8) * abs ( fc - reskh ) do j = 1, 7 rasc = rasc + wgk(j) * ( abs ( fv1(j) - reskh ) + abs ( fv2(j) - reskh ) ) end do r = resk * hlgth ra = ra * dhlgth rasc = rasc * dhlgth ae = abs ( ( resk - resg ) * hlgth ) if ( rasc /= 0.0E+00 .and. ae /= 0.0E+00 ) then ae = rasc * min ( 1.0E+00, ( 0.2E+03 * ae / rasc )**1.5E+00 ) end if if ( ra > uflow / ( 0.5E+02 * epmach ) ) then ae = max ( ( epmach * 0.5E+02 ) * ra, ae ) end if return end subroutine grdchk ( n, x, fcn, f, g, typsiz, sx, fscale, rnf, analtl, & wrk1, msg, ipr ) ! !******************************************************************************* ! !! GRDCHK checks an analytic gradient against an estimated gradient. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), a point at which the gradient is to be checked. ! ! Input, external FCN, the name of the subroutine that evaluates ! the optimization function, of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real f ! real x(n) ! ! Input, real F, the function value at X. ! ! Input, real G(N), the gradient value at X. ! ! Input, real TYPSIZ(N), a typical size for each component of X. ! ! Input, real SX(N), the diagonal scaling values: SX(1:N)=1.0/TYPSIZ(1:N) ! ! Input, real FSCALE, an estimate of the scale of the objective function ! FCN. ! ! Input, real RNF, the relative noise in the optimization function FCN. ! ! Input, real ANALTL, a tolerance for comparison of estimated and ! analytical gradients ! ! Workspace, real WRK1(N). ! ! Output, integer MSG, message or error code. ! 0: no error detected. ! -21: probable coding error of gradient ! ! Input, integer IPR, the device to which to send output. ! implicit none ! integer n ! real analtl real f external fcn real fscale real g(n) real gs integer i integer ipr integer ker integer msg real rnf real sx(n) real typsiz(n) real wrk real wrk1(n) real x(n) ! msg = 0 ! ! Compute the first order finite difference gradient; ! compare it to the analytic gradient. ! call fstofd ( 1, 1, n, x, fcn, f, wrk1, sx, rnf, wrk, 1 ) ker = 0 do i = 1, n gs = max ( abs ( f ), fscale ) / max ( abs ( x(i) ), typsiz(i) ) if ( abs ( g(i) - wrk1(i) ) > max ( abs ( g(i) ), gs ) * analtl ) then ker = 1 end if end do if ( ker /= 0 ) then write ( ipr, * ) ' ' write ( ipr, * ) 'GRDCHK - probable error in analytic gradient.' write ( ipr, * ) ' ' write ( ipr, * ) ' grdchk comp analytic est' write ( ipr, 902 ) ( i, g(i), wrk1(i), i = 1, n ) msg = -21 end if return 902 format(' grdchk ',i5,3x,e20.13,3x,e20.13) end subroutine heschk ( nr, n, x, fcn, d1fcn, d2fcn, f, g, a, typsiz, sx, rnf, & analtl, iagflg, udiag, wrk1, wrk2, msg, ipr ) ! !******************************************************************************* ! !! HESCHK checks an analytic hessian against a computed estimate. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), a point at which the Hessian is to be checked. ! ! Input, external FCN, the name of the subroutine that evaluates ! the optimization function, of the form: ! ! subroutine fcn ( n, x, f ) ! integer n ! real f ! real x(n) ! ! Input, external D1FCN, the name of the subroutine to evaluate the ! gradient of the function, of the form: ! ! subroutine d1fcn ( n, x, g ) ! integer n ! real g(n) ! real x(n) ! ! Input, external D2FCN, the name of the subroutine to evaluate the ! Hessian of the function, of the form: ! ! subroutine d2fcn ( nr, n, x, h ) ! integer nr ! integer n ! real h(nr,n) ! real x(n) ! ! Input, real F, the function value at X. ! ! Output, real G(N), the value of the gradient at X. ! ! Output, real A(NR,N), the analytic Hessian matrix will be stored ! in the lower triangle and diagonal. ! ! Input, real TYPSIZ(N), a typical size for each component of X. ! ! Input, real SX(N), the diagonal scaling matrix. ! ! Input, real RNF, the relative noise in the optimization ! function FCN. ! ! Input, real ANALTL, a tolerance for comparison of the estimated and ! analytic gradients. ! ! Input, integer IAGFLG, is 1 if the analytic gradient is supplied. ! ! Workspace, real UDIAG(N). ! ! Workspace, real WRK1(N). ! ! Workspace, real WRK2(N). ! ! Input/output, integer MSG, message or error code ! on input : if =1xx do not compare analytic + estimated hessian. ! on output: =-22, probable coding error of hessian. ! ! Input, integer IPR, the device to which to send output. ! implicit none ! integer n integer nr ! real a(nr,n) real analtl external d1fcn external d2fcn real f external fcn real g(n) real hs integer i integer iagflg integer ipr integer j integer ker integer msg real rnf real sx(n) real typsiz(n) real udiag(n) real wrk1(n) real wrk2(n) real x(n) ! ! Compute the finite difference approximation A to the hessian. ! if ( iagflg == 1 ) then call fstofd ( nr, n, n, x, d1fcn, g, a, sx, rnf, wrk1, 3 ) else call sndofd ( nr, n, x, fcn, f, a, sx, rnf, wrk1, wrk2 ) end if ker = 0 ! ! 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 ! ! Compute analytic hessian and compare to finite difference approximation. ! call d2fcn ( nr, n, x, a ) do j = 1, n hs = max ( abs ( g(j) ), 1.0E+00 ) / max ( abs ( x(j) ), typsiz(j) ) if ( abs ( a(j,j) - udiag(j) ) > max ( abs ( udiag(j) ), hs ) * analtl ) then ker = 1 end if do i = j+1, n if ( abs ( a(i,j) - a(j,i) ) > max ( abs ( a(i,j) ), hs ) * analtl ) then ker = 1 end if end do end do if ( ker /= 0 ) then write(ipr,901) do i = 1, n do j = 1, i-1 write(ipr,902) i,j,a(i,j),a(j,i) end do write(ipr,902) i,i,a(i,i),udiag(i) end do msg = -22 end if return 901 format('heschk probable error in coding of analytic hessian.'/ & 'heschk row col',14x,'analytic',14x,'(estimate)') 902 format('heschk ',2i5,2x,e20.13,2x,'(',e20.13,')') end subroutine hookdr ( nr, n, x, f, g, a, udiag, p, xpls, fpls, fcn, sx, stepmx, & steptl, dlt, iretcd, mxtake, amu, dltp, phi, phip0, sc, xplsp, wrk0, epsm, & itncnt, ipr ) ! !******************************************************************************* ! !! HOOKDR finds the next Newton iterate by the More-Hebdon method. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), the old iterate, "X[K-1]". ! ! Input, real F, the function value at the old iterate. ! ! Input, real G(N), the gradient or an approximation, at the old iterate. ! ! Input, real A(NR,N), the Cholesky decomposition of hessian in lower ! triangular part and diagonal. Hessian in upper triangular part and UDIAG. ! ! Input, real UDIAG(N), the diagonal of the hessian matrix. ! ! Input, real P(N), the Newton step. ! ! Output, real XPLS(N), the new iterate X[K]. ! ! Output, real FPLS, the function value at the new iterate. ! ! Input, external FCN, the name of the subroutine to evaluate the function, ! of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real x(n) ! real f ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input, real STEPMX, the maximum allowable step size. ! ! Input, real STEPTL, the relative step size at which successive ! iterates are considered close enough to terminate algorithm. ! ! Input/output, real DLT, the trust region radius. ! ! Output, integer IRETCD, return code ! 0, satisfactory xpls found ! 1, failed to find satisfactory xpls sufficiently distinct from x. ! ! Output, logical MXTAKE, is TRUE if a step of maximum length was used. ! ! Workspace, real AMU, [retain value between successive calls] ! ! Workspace, real DLTP, [retain value between successive calls] ! ! Workspace, real PHI, [retain value between successive calls] ! ! Workspace, real PHIP0, [retain value between successive calls] ! ! Workspace, real SC(N). ! ! Workspace, real XPLSP(N). ! ! Workspace, real WRK0(N). ! ! Input, real EPSM, the machine epsilon ! ! Input, integer ITNCNT, the iteration count. ! ! Input, integer IPR, the device to which to send output. ! implicit none ! integer n integer nr ! real a(nr,n) real alpha real amu real beta real dlt real dltp real epsm real f external fcn real fpls real fplsp logical fstime real g(n) integer i integer ipr integer iretcd integer itncnt integer j logical mxtake logical nwtake real p(n) real phi real phip0 real rnwtln real sc(n) real stepmx real steptl real sx(n) real tmp real udiag(n) real x(n) real xpls(n) real xplsp(n) real wrk0(n) ! iretcd = 4 fstime = .true. rnwtln = sqrt ( sum ( sx(1:n)**2 * p(1:n)**2 ) ) ! ! If first iteration and trust region not provided by user, ! compute initial trust region. ! if ( itncnt <= 1 ) then amu = 0.0E+00 if ( dlt == -1.0E+00 ) then alpha = sum ( ( g(1:n) / sx(1:n) )**2 ) beta = 0.0E+00 do i = 1, n tmp = 0.0E+00 do j = i, n tmp = tmp + ( a(j,i) * g(j) ) / ( sx(j) * sx(j) ) end do beta = beta + tmp * tmp end do dlt = alpha * sqrt ( alpha ) / beta dlt = min ( dlt, stepmx ) end if end if ! ! Find the new step by More-Hebdon algorithm. ! do call hookst ( nr, n, g, a, udiag, p, sx, rnwtln, dlt, amu, dltp, phi, & phip0, fstime, sc, nwtake, wrk0, epsm, ipr ) dltp = dlt ! ! Check the new point and update trust region. ! call tregup ( nr, n, x, f, g, a, fcn, sc, sx, nwtake, stepmx, steptl, & dlt, iretcd, xplsp, fplsp, xpls, fpls, mxtake, ipr, 3, udiag ) if ( iretcd <= 1 ) then exit end if end do return end subroutine hookst ( nr, n, g, a, udiag, p, sx, rnwtln, dlt, amu, & dltp, phi, phip0, fstime, sc, nwtake, wrk0, epsm, ipr ) ! !******************************************************************************* ! !! HOOKST finds the new step by the More-Hebdon algorithm. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real G(N), the gradient at the current iterate. ! ! Input, real A(NR,N), an N by N array. It contains the ! Cholesky decomposition of the hessian in the lower triangular ! part and diagonal; the hessian or approximation in the upper ! triangular part. ! ! Input, real UDIAG(N), the diagonal of the hessian. whose lower ! triangular part is stored in A. ! ! Input, real P(N), the Newton step. ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input, real RNWTLN, the Newton step length. ! ! Input/output, real DLT, the trust region radius. ! ! Workspace, real AMU, [retain value between successive calls] ! ! Input, real DLTP, the trust region radius at last exit from this ! routine. ! ! Workspace, real PHI, [retain value between successive calls] ! ! Workspace, real PHIP0, [retain value between successive calls] ! ! Input/output, logical FSTIME, TRUE if first entry to this routine ! during k-th iteration. ! ! Output, real SC(N), the current step. ! ! Output, logical NWTAKE, is TRUE if a Newton step taken. ! ! Workspace, real WRK0(N). ! ! Input, real EPSM, the machine epsilon. ! ! Input, integer IPR, the device to which to send output. ! implicit none ! integer n integer nr ! real a(nr,n) real addmax real, parameter :: alo = 0.75E+00 real amu real amulo real amuup real dlt real dltp logical done real epsm logical fstime real g(n) real, parameter :: hi = 1.50E+00 integer i integer ipr integer j logical nwtake real p(n) real phi real phip real phip0 real rnwtln real sc(n) real snrm2 real stepln real sx(n) real udiag(n) real wrk0(n) ! ! Take a Newton step? ! if ( rnwtln <= hi * dlt ) then nwtake = .true. sc(1:n) = p(1:n) dlt = min ( dlt, rnwtln ) amu = 0.0E+00 return end if ! ! Newton step not taken. ! nwtake = .false. if ( amu > 0.0E+00 ) then amu = amu - ( phi + dltp ) * ( ( dltp - dlt ) + phi ) / ( dlt * phip ) end if phi = rnwtln - dlt if ( fstime ) then wrk0(1:n) = sx(1:n) * sx(1:n) * p(1:n) ! ! Solve L * Y = (SX**2)*P ! call forslv ( nr, n, a, wrk0, wrk0 ) phip0 = -snrm2 ( n, wrk0, 1 )**2 / rnwtln fstime = .false. end if phip = phip0 amulo = -phi / phip amuup = 0.0E+00 do i = 1, n amuup = amuup + ( g(i) * g(i) ) / ( sx(i) * sx(i) ) end do amuup = sqrt ( amuup ) / dlt done = .false. ! ! Test the value of amu; generate next amu if necessary ! 100 continue if ( done ) then return end if if ( amu < amulo .or. amu > amuup ) then amu = max ( sqrt ( amulo * amuup ), amuup * 1.0E-03 ) end if ! ! Copy (h,udiag) to L ! where h <-- h + amu*(sx**2) [do not actually change (h,udiag)] ! do j = 1, n a(j,j) = udiag(j) + amu * sx(j) * sx(j) a(j+1:n,j) = a(j,j+1:n) end do ! ! Factor h=l(l+) ! call choldc ( nr, n, a, 0.0E+00, sqrt ( epsm ), addmax ) ! ! Solve h*p = l(l+) * sc = -g ! wrk0(1:n) = -g(1:n) call lltslv ( nr, n, a, sc, wrk0 ) ! ! Reset H. Note since udiag has not been destroyed we need do ! nothing here. H is in the upper part and in udiag, still intact ! stepln = sqrt ( dot_product ( sx(1:n)**2, sc(1:n)**2 ) ) phi = stepln - dlt wrk0(1:n) = sx(1:n)**2 * sc(1:n) call forslv ( nr, n, a, wrk0, wrk0 ) phip = -snrm2 ( n, wrk0, 1 )**2 / stepln if ( ( alo * dlt > stepln .or. stepln > hi * dlt ) .and. & ( amuup - amulo > 0.0E+00 ) ) then go to 170 end if ! ! SC is acceptable hookstep ! done = .true. go to 100 ! ! SC not acceptable hookstep. Select new amu ! 170 continue amulo = max ( amulo, amu - ( phi / phip ) ) if ( phi < 0.0E+00 ) then amuup = min ( amuup, amu ) end if amu = amu - ( stepln * phi ) / ( dlt * phip ) go to 100 end subroutine hsnint ( nr, n, a, sx, method ) ! !******************************************************************************* ! !! HSNINT provides initial hessian when using secant updates. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Output, real A(NR,N), the initial N by N Hessian. Only the ! lower triangle of the matrix is assigned values. ! ! Input, real SX(N), the scaling factors for X. ! ! Input, integer METHOD, specifies the algorithm to use to solve ! the minimization problem. ! 1 or 2: factored secant method used ! 3: unfactored secant method used ! implicit none ! integer n integer nr ! real a(nr,n) integer j integer method real sx(n) ! do j = 1, n if ( method == 3 ) then a(j,j) = sx(j)**2 else a(j,j) = sx(j) end if a(j+1:n,j) = 0.0E+00 end do return end subroutine i_swap ( i, j ) ! !******************************************************************************* ! !! I_SWAP swaps two integer values. ! ! ! Modified: ! ! 30 November 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, integer I, J. On output, the values of I and ! J have been interchanged. ! implicit none ! integer i integer j integer k ! k = i i = j j = k return end function i1mach ( i ) ! !******************************************************************************* ! !! I1MACH returns integer machine constants. ! ! ! I/O unit numbers. ! ! I1MACH(1) = the standard input unit. ! I1MACH(2) = the standard output unit. ! I1MACH(3) = the standard punch unit. ! I1MACH(4) = the standard error message unit. ! ! Words. ! ! I1MACH(5) = the number of bits per integer storage unit. ! I1MACH(6) = the number of characters per integer storage unit. ! ! Integers. ! ! Assume integers are represented in the S digit base A form: ! ! Sign * (X(S-1)*A**(S-1) + ... + X(1)*A + X(0)) ! where 0<=X(I) 16 )then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I1MACH - Fatal error!' write ( *, '(a,i6)' ) ' I is out of bounds:', i i1mach = 0 stop else i1mach = imach(i) end if return end subroutine i_factor ( n, ifac ) ! !******************************************************************************* ! !! I_FACTOR factors an integer. ! ! ! Modified: ! ! 14 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the number to be factored. ! ! Output, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer i integer ib integer ifac(15) integer j integer n integer nf integer nl integer nq integer nr integer ntry ! ifac(1) = n nf = 0 nl = n if ( n == 0 ) then nf = 1 ifac(2) = nf ifac(2+nf) = 0 return end if if ( n < 1 ) then nf = nf + 1 ifac(2+nf) = -1 nl = - n end if if ( nl == 1 ) then nf = nf + 1 ifac(2) = nf ifac(2+nf) = 1 return end if j = 0 do while ( nl > 1 ) j = j + 1 ! ! Choose a trial divisor, NTRY. ! if ( j == 1 ) then ntry = 4 else if ( j == 2 ) then ntry = 2 else if ( j == 3 ) then ntry = 3 else if ( j == 4 ) then ntry = 5 else ntry = ntry + 2 end if ! ! Divide by the divisor as many times as possible. ! do nq = nl / ntry nr = nl - ntry * nq if ( nr /= 0 ) then exit end if nl = nq nf = nf + 1 ! ! Make sure factors of 2 appear in the front of the list. ! if ( ntry /= 2 ) then ifac(2+nf) = ntry else do i = nf, 2, -1 ifac(i+2) = ifac(i+1) end do ifac(3) = 2 end if end do end do ifac(2) = nf return end function inits ( os, nos, eta ) ! !******************************************************************************* ! !! INITS estimates the order of an orthogonal series for a given accuracy. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, real OS(NOS), the coefficients in the series. ! ! Input, integer NOS, the number of coefficients. ! ! Input, real ETA, the requested accuracy of the series. ! Ordinarily, ETA will be chosen to be one-tenth machine precision. ! ! Output, integer INITS, the order of the series guaranteeing the ! given accuracy. ! implicit none ! integer nos ! real err real eta integer i integer ii integer inits real os(nos) ! if ( nos < 1 ) then call xerror ( 'inits number of coefficients lt 1', 35, 2, 2) end if err = 0.0E+00 i = 0 do ii = 1, nos i = nos + 1 - ii err = err + abs ( os(i) ) if ( err > eta ) then i = nos + 1 - ii exit end if end do if ( i == 0 ) then i = nos call xerror ( 'inits eta may be too small', 28, 1, 2) end if inits = i return end function isamax ( n, x, incx ) ! !******************************************************************************* ! !! ISAMAX finds the index of the vector element of maximum absolute value. ! ! ! Modified: ! ! 08 April 1999 ! ! Reference: ! ! Lawson, Hanson, Kincaid, Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector to be examined. ! ! Input, integer INCX, the increment between successive entries of SX. ! ! Output, integer ISAMAX, the index of the element of SX of maximum ! absolute value. ! implicit none ! integer i integer incx integer isamax integer ix integer n real samax real x(*) ! if ( n <= 0 ) then isamax = 0 else if ( n == 1 ) then isamax = 1 else if ( incx == 1 ) then isamax = 1 samax = abs ( x(1) ) do i = 2, n if ( abs ( x(i) ) > samax ) then isamax = i samax = abs ( x(i) ) end if end do else if ( incx >= 0 ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if isamax = 1 samax = abs ( x(ix) ) ix = ix + incx do i = 2, n if ( abs ( x(ix) ) > samax ) then isamax = i samax = abs ( x(ix) ) end if ix = ix + incx end do end if return end function j4save ( iwhich, ivalue, iset ) ! !******************************************************************************* ! !! J4SAVE saves variables needed by the library error handling routines. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! R E Jones, D K Kahaner, ! XERROR, The SLATEC Error Handling Package, ! SAND82-0800, Sandia Laboratories, 1982. ! ! Author: ! ! Ron Jones ! ! Parameters: ! ! Input, integer IWHICH, the index of the item desired. ! 1, the current error number. ! 2, the current error control flag. ! 3, the current unit number to which error messages are sent. ! (0 means use standard.) ! 4, the maximum times any message is printed (as set by xermax). ! 5, the number of units to which each error message is written. ! 6, the 2nd unit for error messages. ! 7, the 3rd unit for error messages. ! 8, the 4th unit for error messages. ! 9, the 5th unit for error messages. ! ! Input, integer IVALUE, the value to be set for the IWHICH-th parameter, ! if ISET is TRUE. ! ! Input, logical ISET. ! TRUE: the IWHICH-th parameter will be given the value, IVALUE. ! ! Output, integer J4SAVE, the old value of the IWHICH-th parameter. ! implicit none ! integer, save, dimension ( 9 ) :: iparam = (/ 0, 2, 0, 10, 1, 0, 0, 0, 0 /) logical iset integer ivalue integer iwhich integer j4save ! j4save = iparam(iwhich) if ( iset ) then iparam(iwhich) = ivalue end if return end function inbin ( x, nbins, xmin, xmax, width ) ! !******************************************************************************* ! !! INBIN takes a real value X and finds the correct bin for it. ! ! ! Discussion: ! ! Values below XMIN come back in 1. Values above XMAX come back ! in NBINS. ! ! Parameters: ! ! Input, real X, a value to be binned. ! ! Input, integer NBINS, the number of bins. ! ! Input, real XMIN, XMAX, the minimum and maximum bin limits. ! ! Input, real WIDTH, the width of each bin. ! ! Output, integer INBIN, the index of the bin containing X. ! implicit none ! integer inbin integer nbins real width real x real xmax real xmin ! if ( x < xmin ) then inbin = 1 else if ( x >= xmax ) then inbin = nbins else inbin = 2 + int ( ( x - xmin ) / width ) end if return end subroutine jairy ( x, rx, c, ai, dai ) ! !******************************************************************************* ! !! JAIRY computes the Airy function and its derivative. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Author: ! ! D E Amos, ! S L Daniel, ! M K Weston. ! ! Parameters: ! ! Input, real X, the argument. ! ! Input, real RX, sqrt ( abs ( X ) ). ! ! Input, real C, = 2 * ( ABS ( X )**1.5 ) / 3, computed by ASYJY. ! ! Output, real AI, the value of the Airy function. ! ! Output, real DAI, the derivative of the Airy function. ! implicit none ! real a(15) real ai real ajn(19) real ajp(19) real, parameter, dimension ( 14 ) :: ak1 = (/ & 2.20423090987793E-01,-1.25290242787700E-01, 1.03881163359194E-02, & 8.22844152006343E-04,-2.34614345891226E-04, 1.63824280172116E-05, & 3.06902589573189E-07,-1.29621999359332E-07, 8.22908158823668E-09, & 1.53963968623298E-11, -3.39165465615682E-11, 2.03253257423626E-12, & -1.10679546097884E-14, -5.16169497785080E-15 /) real ak2(23) real ak3(14) real b(15) real c real ccv real, parameter :: con2 = 5.03154716196777E+00 real, parameter :: con3 = 3.80004589867293E-01 real, parameter :: con4 = 8.33333333333333E-01 real, parameter :: con5 = 8.66025403784439E-01 real cv real da(15) real dai real dajn(19) real dajp(19) real dak1(14) real dak2(24) real dak3(14) real db(15) real ec real e1 real e2 real, parameter :: fpi12 = 1.30899693899575E+00 real f1 real f2 integer i integer j integer, parameter :: m1 = 12 integer m1d integer, parameter :: m2 = 21 integer m2d integer, parameter :: m3 = 17 integer m3d integer, parameter :: m4 = 13 integer m4d integer, parameter :: n1 = 14 integer n1d integer, parameter :: n2 = 23 integer n2d integer, parameter :: n3 = 19 integer n3d integer, parameter :: n4 = 15 integer n4d real rtrx real rx real scv real t real temp1 real temp2 real tt real x ! data ak2(1), ak2(2), ak2(3), ak2(4), ak2(5), ak2(6), ak2(7), & ak2(8), ak2(9), ak2(10),ak2(11),ak2(12),ak2(13),ak2(14), & ak2(15),ak2(16),ak2(17),ak2(18),ak2(19),ak2(20),ak2(21), & ak2(22),ak2(23) / 2.74366150869598e-01, 5.39790969736903e-03, & -1.57339220621190e-03, 4.27427528248750e-04,-1.12124917399925e-04, & 2.88763171318904e-05,-7.36804225370554e-06, 1.87290209741024e-06, & -4.75892793962291e-07, 1.21130416955909e-07,-3.09245374270614e-08, & 7.92454705282654e-09,-2.03902447167914e-09, 5.26863056595742e-10, & -1.36704767639569e-10, 3.56141039013708e-11,-9.31388296548430e-12, & 2.44464450473635e-12,-6.43840261990955e-13, 1.70106030559349e-13, & -4.50760104503281e-14, 1.19774799164811e-14,-3.19077040865066e-15/ data ak3(1), ak3(2), ak3(3), ak3(4), ak3(5), ak3(6), ak3(7), & ak3(8), ak3(9), ak3(10),ak3(11),ak3(12),ak3(13), & ak3(14) / 2.80271447340791e-01,-1.78127042844379e-03, & 4.03422579628999e-05,-1.63249965269003e-06, 9.21181482476768e-08, & -6.52294330229155e-09, 5.47138404576546e-10,-5.24408251800260e-11, & 5.60477904117209e-12,-6.56375244639313e-13, 8.31285761966247e-14, & -1.12705134691063e-14, 1.62267976598129e-15,-2.46480324312426e-16/ data ajp(1), ajp(2), ajp(3), ajp(4), ajp(5), ajp(6), ajp(7), & ajp(8), ajp(9), ajp(10),ajp(11),ajp(12),ajp(13),ajp(14), & ajp(15),ajp(16),ajp(17),ajp(18), & ajp(19) / 7.78952966437581e-02,-1.84356363456801e-01, & 3.01412605216174e-02, 3.05342724277608e-02,-4.95424702513079e-03, & -1.72749552563952e-03, 2.43137637839190e-04, 5.04564777517082e-05, & -6.16316582695208e-06,-9.03986745510768e-07, 9.70243778355884e-08, & 1.09639453305205e-08,-1.04716330588766e-09,-9.60359441344646e-11, & 8.25358789454134e-12, 6.36123439018768e-13,-4.96629614116015e-14, & -3.29810288929615e-15, 2.35798252031104e-16/ data ajn(1), ajn(2), ajn(3), ajn(4), ajn(5), ajn(6), ajn(7), & ajn(8), ajn(9), ajn(10),ajn(11),ajn(12),ajn(13),ajn(14), & ajn(15),ajn(16),ajn(17),ajn(18), & ajn(19) / 3.80497887617242e-02,-2.45319541845546e-01, & 1.65820623702696e-01, 7.49330045818789e-02,-2.63476288106641e-02, & -5.92535597304981e-03, 1.44744409589804e-03, 2.18311831322215e-04, & -4.10662077680304e-05,-4.66874994171766e-06, 7.15218807277160e-07, & 6.52964770854633e-08,-8.44284027565946e-09,-6.44186158976978e-10, & 7.20802286505285e-11, 4.72465431717846e-12,-4.66022632547045e-13, & -2.67762710389189e-14, 2.36161316570019e-15/ data a(1), a(2), a(3), a(4), a(5), a(6), a(7), & a(8), a(9), a(10), a(11), a(12), a(13), a(14), & a(15) / 4.90275424742791e-01, 1.57647277946204e-03, & -9.66195963140306e-05, 1.35916080268815e-07, 2.98157342654859e-07, & -1.86824767559979e-08,-1.03685737667141e-09, 3.28660818434328e-10, & -2.57091410632780e-11,-2.32357655300677e-12, 9.57523279048255e-13, & -1.20340828049719e-13,-2.90907716770715e-15, 4.55656454580149e-15, & -9.99003874810259e-16/ data b(1), b(2), b(3), b(4), b(5), b(6), b(7), & b(8), b(9), b(10), b(11), b(12), b(13), b(14), & b(15) / 2.78593552803079e-01,-3.52915691882584e-03, & -2.31149677384994e-05, 4.71317842263560e-06,-1.12415907931333e-07, & -2.00100301184339e-08, 2.60948075302193e-09,-3.55098136101216e-11, & -3.50849978423875e-11, 5.83007187954202e-12,-2.04644828753326e-13, & -1.10529179476742e-13, 2.87724778038775e-14,-2.88205111009939e-15, & -3.32656311696166e-16/ data n1d,n2d,n3d,n4d/14,24,19,15/ data m1d,m2d,m3d,m4d/12,22,17,13/ data dak1(1), dak1(2), dak1(3), dak1(4), dak1(5), dak1(6), & dak1(7), dak1(8), dak1(9), dak1(10),dak1(11),dak1(12), & dak1(13),dak1(14)/ 2.04567842307887e-01,-6.61322739905664e-02, & -8.49845800989287e-03, 3.12183491556289e-03,-2.70016489829432e-04, & -6.35636298679387e-06, 3.02397712409509e-06,-2.18311195330088e-07, & -5.36194289332826e-10, 1.13098035622310e-09,-7.43023834629073e-11, & 4.28804170826891e-13, 2.23810925754539e-13,-1.39140135641182e-14/ data dak2(1), dak2(2), dak2(3), dak2(4), dak2(5), dak2(6), & dak2(7), dak2(8), dak2(9), dak2(10),dak2(11),dak2(12), & dak2(13),dak2(14),dak2(15),dak2(16),dak2(17),dak2(18), & dak2(19),dak2(20),dak2(21),dak2(22),dak2(23), & dak2(24) / 2.93332343883230e-01,-8.06196784743112e-03, & 2.42540172333140e-03,-6.82297548850235e-04, 1.85786427751181e-04, & -4.97457447684059e-05, 1.32090681239497e-05,-3.49528240444943e-06, & 9.24362451078835e-07,-2.44732671521867e-07, 6.49307837648910e-08, & -1.72717621501538e-08, 4.60725763604656e-09,-1.23249055291550e-09, & 3.30620409488102e-10,-8.89252099772401e-11, 2.39773319878298e-11, & -6.48013921153450e-12, 1.75510132023731e-12,-4.76303829833637e-13, & 1.29498241100810e-13,-3.52679622210430e-14, 9.62005151585923e-15, & -2.62786914342292e-15/ data dak3(1), dak3(2), dak3(3), dak3(4), dak3(5), dak3(6), & dak3(7), dak3(8), dak3(9), dak3(10),dak3(11),dak3(12), & dak3(13),dak3(14)/ 2.84675828811349e-01, 2.53073072619080e-03, & -4.83481130337976e-05, 1.84907283946343e-06,-1.01418491178576e-07, & 7.05925634457153e-09,-5.85325291400382e-10, 5.56357688831339e-11, & -5.90889094779500e-12, 6.88574353784436e-13,-8.68588256452194e-14, & 1.17374762617213e-14,-1.68523146510923e-15, 2.55374773097056e-16/ data dajp(1), dajp(2), dajp(3), dajp(4), dajp(5), dajp(6), & dajp(7), dajp(8), dajp(9), dajp(10),dajp(11),dajp(12), & dajp(13),dajp(14),dajp(15),dajp(16),dajp(17),dajp(18), & dajp(19) / 6.53219131311457e-02,-1.20262933688823e-01, & 9.78010236263823e-03, 1.67948429230505e-02,-1.97146140182132e-03, & -8.45560295098867e-04, 9.42889620701976e-05, 2.25827860945475e-05, & -2.29067870915987e-06,-3.76343991136919e-07, 3.45663933559565e-08, & 4.29611332003007e-09,-3.58673691214989e-10,-3.57245881361895e-11, & 2.72696091066336e-12, 2.26120653095771e-13,-1.58763205238303e-14, & -1.12604374485125e-15, 7.31327529515367e-17/ data dajn(1), dajn(2), dajn(3), dajn(4), dajn(5), dajn(6), & dajn(7), dajn(8), dajn(9), dajn(10),dajn(11),dajn(12), & dajn(13),dajn(14),dajn(15),dajn(16),dajn(17),dajn(18), & dajn(19) / 1.08594539632967e-02, 8.53313194857091e-02, & -3.15277068113058e-01,-8.78420725294257e-02, 5.53251906976048e-02, & 9.41674060503241e-03,-3.32187026018996e-03,-4.11157343156826e-04, & 1.01297326891346e-04, 9.87633682208396e-06,-1.87312969812393e-06, & -1.50798500131468e-07, 2.32687669525394e-08, 1.59599917419225e-09, & -2.07665922668385e-10,-1.24103350500302e-11, 1.39631765331043e-12, & 7.39400971155740e-14,-7.32887475627500e-15/ data da(1), da(2), da(3), da(4), da(5), da(6), da(7), & da(8), da(9), da(10), da(11), da(12), da(13), da(14), & da(15) / 4.91627321104601e-01, 3.11164930427489e-03, & 8.23140762854081e-05,-4.61769776172142e-06,-6.13158880534626e-08, & 2.87295804656520e-08,-1.81959715372117e-09,-1.44752826642035e-10, & 4.53724043420422e-11,-3.99655065847223e-12,-3.24089119830323e-13, & 1.62098952568741e-13,-2.40765247974057e-14, 1.69384811284491e-16, & 8.17900786477396e-16/ data db(1), db(2), db(3), db(4), db(5), db(6), db(7), & db(8), db(9), db(10), db(11), db(12), db(13), db(14), & db(15) /-2.77571356944231e-01, 4.44212833419920e-03, & -8.42328522190089e-05,-2.58040318418710e-06, 3.42389720217621e-07, & -6.24286894709776e-09,-2.36377836844577e-09, 3.16991042656673e-10, & -4.40995691658191e-12,-5.18674221093575e-12, 9.64874015137022e-13, & -4.90190576608710e-14,-1.77253430678112e-14, 5.55950610442662e-15, & -7.11793337579530e-16/ ! if ( x < 0.0E+00 ) then go to 90 end if if ( c > 5.0E+00 ) then go to 60 end if if ( x > 1.20E+00 ) then go to 30 end if t = ( x + x - 1.2E+00 ) * con4 tt = t + t j = n1 f1 = ak1(j) f2 = 0.0E+00 do i = 1, m1 j = j - 1 temp1 = f1 f1 = tt * f1 - f2 + ak1(j) f2 = temp1 end do ai = t * f1 - f2 + ak1(1) j = n1d f1 = dak1(j) f2 = 0.0E+00 do i = 1, m1d j = j - 1 temp1 = f1 f1 = tt * f1 - f2 + dak1(j) f2 = temp1 end do dai = -( t * f1 - f2 + dak1(1) ) return 30 continue t = ( x + x - con2 ) * con3 tt = t + t j = n2 f1 = ak2(j) f2 = 0.0E+00 do i = 1, m2 j = j - 1 temp1 = f1 f1 = tt * f1 - f2 + ak2(j) f2 = temp1 end do rtrx = sqrt ( rx ) ec = exp ( -c ) ai = ec * ( t * f1 - f2 + ak2(1) ) / rtrx j = n2d f1 = dak2(j) f2 = 0.0E+00 do i = 1, m2d j = j - 1 temp1 = f1 f1 = tt * f1 - f2 + dak2(j) f2 = temp1 end do dai = -ec * ( t * f1 - f2 + dak2(1) ) * rtrx return 60 continue t = 10.0E+00 / c - 1.0E+00 tt = t + t j = n1 f1 = ak3(j) f2 = 0.0E+00 do i = 1, m1 j = j - 1 temp1 = f1 f1 = tt * f1 - f2 + ak3(j) f2 = temp1 end do rtrx = sqrt ( rx ) ec = exp ( -c ) ai = ec * ( t * f1 - f2 + ak3(1) ) / rtrx j = n1d f1 = dak3(j) f2 = 0.0E+00 do i = 1, m1d j = j - 1 temp1 = f1 f1 = tt * f1 - f2 + dak3(j) f2 = temp1 end do dai = -rtrx * ec * ( t * f1 - f2 + dak3(1) ) return 90 continue if ( c > 5.0E+00 ) then go to 120 end if t = 0.4E+00 * c - 1.0E+00 tt = t + t j = n3 f1 = ajp(j) e1 = ajn(j) f2 = 0.0E+00 e2 = 0.0E+00 do i = 1, m3 j = j - 1 temp1 = f1 temp2 = e1 f1 = tt * f1 - f2 + ajp(j) e1 = tt * e1 - e2 + ajn(j) f2 = temp1 e2 = temp2 end do ai = ( t * e1 - e2 + ajn(1) ) - x * ( t * f1 - f2 + ajp(1) ) j = n3d f1 = dajp(j) e1 = dajn(j) f2 = 0.0E+00 e2 = 0.0E+00 do i = 1, m3d j = j - 1 temp1 = f1 temp2 = e1 f1 = tt * f1 - f2 + dajp(j) e1 = tt * e1 - e2 + dajn(j) f2 = temp1 e2 = temp2 end do dai = x * x * ( t * f1 - f2 + dajp(1) ) + ( t * e1 - e2 + dajn(1) ) return 120 continue t = 10.0E+00 / c - 1.0E+00 tt = t + t j = n4 f1 = a(j) e1 = b(j) f2 = 0.0E+00 e2 = 0.0E+00 do i = 1, m4 j = j - 1 temp1 = f1 temp2 = e1 f1 = tt * f1 - f2 + a(j) e1 = tt * e1 - e2 + b(j) f2 = temp1 e2 = temp2 end do temp1 = t * f1 - f2 + a(1) temp2 = t * e1 - e2 + b(1) rtrx = sqrt ( rx ) cv = c - fpi12 ccv = cos(cv) scv = sin(cv) ai = ( temp1 * ccv - temp2 * scv ) / rtrx j = n4d f1 = da(j) e1 = db(j) f2 = 0.0E+00 e2 = 0.0E+00 do i = 1, m4d j = j - 1 temp1 = f1 temp2 = e1 f1 = tt * f1 - f2 + da(j) e1 = tt * e1 - e2 + db(j) f2 = temp1 e2 = temp2 end do temp1 = t * f1 - f2 + da(1) temp2 = t * e1 - e2 + db(1) e1 = ccv * con5 + 0.5E+00 * scv e2 = scv * con5 - 0.5E+00 * ccv dai = ( temp1 * e1 - temp2 * e2 ) * rtrx return end subroutine lltslv ( nr, n, a, x, b ) ! !******************************************************************************* ! !! LLTSLV solves A*x=b where A = L * L'. ! ! ! Discussion: ! ! L is a lower triangular matrix. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real A(NR,N), contains the lower triangular matrix L. ! ! Output, real X(N), the solution vector. ! ! Input, real B(N), the right hand side vector. If B is not required by ! the calling program, then B and X may share the same storage. ! implicit none ! integer n integer nr ! real a(nr,n) real b(n) real x(n) ! ! Forward solve, result in X. ! call forslv ( nr, n, a, x, b ) ! ! Back solve, result in X. ! call bakslv ( nr, n, a, x, x ) return end subroutine lnsrch ( n, x, f, g, p, xpls, fpls, fcn, mxtake, iretcd, stepmx, & steptl, sx, ipr ) ! !******************************************************************************* ! !! LNSRCH finds a next Newton iterate by line search. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), the old iterate, sometimes called X[K-1]. ! ! Input, real F, the function value at the old iterate. ! ! Input, real G(N), the gradient at the old iterate, or an ! approximation to that value. ! ! Input, real P(N), the (non-zero) Newton step. ! ! Output, real XPLS(N), the new iterate. ! ! Output, real FPLS, the function value at the new iterate. ! ! Input, external FCN, the name of the subroutine to evaluate the function, ! of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real x(n) ! real f ! ! Output, integer IRETCD, the return code. ! ! Output, logical MXTAKE, is TRUE if a step of maximum size was used. ! ! Input, real STEPMX, the maximum allowable step size. ! ! Input, real STEPTL, the relative step size at which successive ! iterates are considered close enough to terminate algorithm. ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input, integer IPR, the device to which to send output. ! ! Local variables: ! ! sln, the Newton length. ! ! rln, the relative length of Newton step ! implicit none ! integer n ! real a real almbda real b real disc real f external fcn real fpls real g(n) integer i integer ipr integer iretcd logical mxtake real p(n) real pfpls real plmbda real rln real rmnlmb real scl real sln real slp real stepmx real steptl real sx(n) real t1 real t2 real t3 real tlmbda real tmp real x(n) real xpls(n) ! mxtake = .false. iretcd = 2 sln = sqrt ( sum ( ( sx(1:n) * p(1:n) )**2 ) ) ! ! Newton step longer than maximum allowed. ! if ( sln > stepmx ) then scl = stepmx / sln p(1:n) = p(1:n) * stepmx / sln sln = stepmx end if slp = dot_product ( g, p ) rln = 0.0E+00 do i = 1, n rln = max ( rln, abs ( p(i) ) / max ( abs ( x(i) ), 1.0E+00 / sx(i) ) ) end do rmnlmb = steptl / rln almbda = 1.0E+00 ! ! Check if new iterate satisfactory. Generate new lambda if necessary. ! 100 continue if ( iretcd < 2 ) then return end if xpls(1:n) = x(1:n) + almbda * p(1:n) call fcn ( n, xpls, fpls ) if ( fpls > f + slp * 0.0001E+00 * almbda ) then go to 130 end if ! ! Solution found. ! iretcd = 0 if ( almbda == 1.0E+00 .and. sln > 0.99E+00 * stepmx ) then mxtake = .true. end if go to 100 ! ! Solution not (yet) found. ! 130 continue ! ! No satisfactory XPLS found sufficiently distinct from X. ! if ( almbda < rmnlmb ) then iretcd = 1 go to 100 end if ! ! Calculate new lambda. ! ! ! First backtrack: quadratic fit. ! if ( almbda == 1.0E+00 ) then tlmbda = -slp / ( 2.0E+00 * ( fpls - f - slp ) ) go to 170 end if ! ! All subsequent backtracks: cubic fit. ! 150 continue t1 = fpls - f - almbda * slp t2 = pfpls - f - plmbda * slp t3 = 1.0E+00 / ( almbda - plmbda ) a = t3 * ( t1 / ( almbda * almbda ) - t2 / ( plmbda * plmbda ) ) b = t3 * ( t2 * almbda / ( plmbda * plmbda ) & - t1 * plmbda / ( almbda * almbda ) ) disc = b * b - 3.0E+00 * a * slp if ( disc <= b * b ) then go to 160 end if ! ! Only one positive critical point, must be minimum ! tlmbda = ( - b + sign ( 1.0E+00, a ) * sqrt ( disc ) ) & / ( 3.0E+00 * a ) go to 165 ! ! Both critical points positive, first is minimum ! 160 continue tlmbda = ( -b - sign ( 1.0E+00, a ) * sqrt ( disc ) ) & / ( 3.0E+00 * a ) 165 if ( tlmbda > 0.5E+00 * almbda ) then tlmbda = 0.5E+00 * almbda end if 170 continue plmbda = almbda pfpls = fpls if ( tlmbda >= almbda * 0.1E+00 ) then go to 180 end if almbda = almbda * 0.1E+00 go to 190 180 almbda = tlmbda 190 continue go to 100 end subroutine mvmltl ( nr, n, a, x, y ) ! !******************************************************************************* ! !! MVMLTL computes y = L*x where L is a lower triangular matrix stored in A. ! ! ! Discussion: ! ! Note that X and Y cannot share storage. ! ! Modified: ! ! 29 May 2001 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real A(NR,N), the N by N lower triangular matrix. ! ! Input, real X(N), the vector to be multiplied. ! ! Output, real Y(N), the result. ! implicit none ! integer n integer nr ! real a(nr,n) integer i real x(n) real y(n) ! do i = 1, n y(i) = dot_product ( a(i,1:i), x(1:i) ) end do return end subroutine mvmlts ( nr, n, a, x, y ) ! !******************************************************************************* ! !! MVMLTS computes y = A*x where A is a symmetric matrix. ! ! ! Discussion: ! ! A is a symmetric N by N matrix stored in its lower triangular part ! and X and Y are N vectors. ! ! X and Y cannot share storage. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Modified: ! ! 25 August 2001 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real A(NR,N), the symmetric N by N matrix. The entries ! of A are stored in the lower half of the array. ! ! Input, real X(N), the vector to be multiplied by A. ! ! Output, real Y(N), the result. ! implicit none ! integer n integer nr ! real a(nr,n) integer i real x(n) real y(n) ! do i = 1, n y(i) = dot_product ( a(i,1:i), x(1:i) ) & + dot_product ( a(i+1:n,i), x(i+1:n) ) end do return end subroutine mvmltu ( nr, n, a, x, y ) ! !******************************************************************************* ! !! MVMLTU computes y=L'*x where L is a lower triangular matrix. ! ! ! Discussion: ! ! Note that X and Y cannot share storage. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real A(NR,N), the N by N lower triangular matrix, ! ! Input, real X(N), the matrix to be multiplied. ! ! Output, real Y(N), the result vector. ! implicit none ! integer n integer nr ! real a(nr,n) integer i real x(n) real y(n) ! do i = 1, n y(i) = dot_product ( x(i:n), a(i:n,i) ) end do return end function numxer ( nerr ) ! !******************************************************************************* ! !! NUMXER returns the most recent error number. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! R E Jones, D K Kahaner, ! XERROR, The SLATEC Error Handling Package, ! SAND82-0800, Sandia Laboratories, 1982. ! ! Author: ! ! Ron Jones ! ! Parameters: ! ! Output, integer NERR, the most recent error number. ! ! Output, integer NUMXER, the most recent error number. ! implicit none ! integer j4save integer nerr integer numxer ! nerr = j4save ( 1, 0, .false. ) numxer = nerr return end subroutine optchk ( n, x, typsiz, sx, fscale, gradtl, itnlim, ndigit, epsm, & dlt, method, iexp, iagflg, iahflg, stepmx, msg, ipr ) ! !******************************************************************************* ! !! OPTCHK checks the input to the optimization routine. ! ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), an approximate solution of the problem. ! ! Input/output, real TYPSIZ(N), a typical size for each component of X. ! If TYPSIZ(I) is zero, it is reset to 1. ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input/output, real FSCALE, an estimate of the scale of the objective ! function FCN. ! ! Input, real GRADTL, the tolerance at which the gradient is considered ! close enough to zero to terminate the algorithm. ! ! Input/output, integer ITNLIM, the maximum number of allowable ! iterations. ! ! Input/output, integer NDIGIT, the number of good digits in ! optimization function FCN. ! ! Input, real EPSM, the machine epsilon. ! ! Input/output, real DLT, the trust region radius. ! ! Input/output, integer METHOD, the algorithm indicator. ! ! Input/output, integer IEXP, the expense flag. ! ! Input/output, integer IAGFLG, = 1 if analytic gradient supplied. ! ! Input/output, integer IAHFLG, = 1 if analytic hessian supplied. ! ! Input/output, real STEPMX, the maximum step size. ! ! Input/output, integer MSG, the message and error code. ! ! Input, integer IPR, the device to which to send output. ! implicit none ! integer n ! real dlt real epsm real fscale real gradtl integer i integer iagflg integer iahflg integer iexp integer ipr integer itnlim integer method integer msg integer ndigit real stepmx real stpsiz real sx(n) real typsiz(n) real x(n) ! ! Check that parameters only take on acceptable values. ! if not, set them to default values. ! if ( method < 1 .or. method > 3 ) then method = 1 end if if ( iagflg /= 1 ) then iagflg = 0 end if if ( iahflg /= 1 ) then iahflg = 0 end if if ( iexp /= 0 ) then iexp = 1 end if if ( mod ( msg/2, 2 ) == 1 .and. iagflg == 0 ) then write ( ipr, 906 ) msg, iagflg msg = -6 return end if if ( mod ( msg/4, 2 ) == 1 .and. iahflg == 0 ) then write ( ipr, 907 ) msg, iahflg msg = -7 return end if ! ! Check N. ! if ( n <= 0 ) then write ( ipr, * ) '' write ( ipr, * ) 'OPTCHK - Fatal error!' write ( ipr, * ) ' Illegal nonpositive value of N = ', n msg = -1 return end if if ( n == 1 .and. mod ( msg, 2 ) == 0 ) then write(ipr,902) msg = -2 return end if ! ! Compute the scale matrix. ! do i = 1, n if ( typsiz(i) == 0.0E+00 ) then typsiz(i) = 1.0E+00 end if end do typsiz(1:n) = abs ( typsiz(1:n) ) sx(1:n) = 1.0E+00 / typsiz(1:n) ! ! Check maximum step size. ! if ( stepmx <= 0.0E+00 ) then stpsiz = sqrt ( sum ( x(1:n)**2 * sx(1:n)**2 ) ) stepmx = max ( 1.0E+03 * stpsiz, 1.0E+03 ) end if ! ! Check the function scale. ! if ( fscale == 0.0E+00 ) then fscale = 1.0E+00 end if if ( fscale < 0.0E+00 ) then fscale = -fscale end if ! ! Check gradient tolerance ! if ( gradtl < 0.0E+00 ) then write(ipr,903) gradtl msg = -3 return end if ! ! Check iteration limit ! if ( itnlim <= 0 ) then write(ipr,904) itnlim msg = -4 return end if ! ! Check number of digits of accuracy in function FCN. ! if ( ndigit == 0 ) then write(ipr,905) ndigit msg = -5 return end if if ( ndigit < 0 ) then ndigit = -log10 ( epsm ) end if ! ! check trust region radius ! if ( dlt <= 0.0E+00 ) then dlt = -1.0E+00 end if if ( dlt > stepmx ) then dlt = stepmx end if 902 format(' optchk +++ warning +++ this package is inefficient', & 'for problems of size n=1.'/ & ' optchk check installation libraries for more appropriate routines.'/ & ' optchk if none, set msg and resubmit.') 903 format(' optchk illegal tolerance. gradtl=',e20.13) 904 format(' optchk illegal iteration limit. itnlim=',i5) 905 format(' optchk minimization function has no good digits.', & 'ndigit=',i5) 906 format(' optchk user requests that analytic gradient be', & ' accepted as properly coded (msg=',i5, '),'/ & ' optchk but analytic gradient not supplied (iagflg=',i5, ').') 907 format(' optchk user requests that analytic hessian be', & ' accepted as properly coded (msg=',i5, '),'/ & ' optchk but analytic hessian not supplied(iahflg=',i5, ').') return end subroutine optdrv ( nr, n, x, fcn, d1fcn, d2fcn, typsiz, fscale, method, & iexp, msg, ndigit, itnlim, iagflg, iahflg, ipr, dlt, gradtl, stepmx, & steptl, xpls, fpls, gpls, itrmcd, a, udiag, g, p, sx, wrk0, wrk1, wrk2, & wrk3 ) ! !******************************************************************************* ! !! OPTDRV is a driver for the nonlinear optimization package. ! ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input/output, real X(N). On input, an rough solution of the problem. ! On output, the computed solution. ! ! Input, external FCN, the name of the subroutine that evaluates ! the optimization function, of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real f ! real x(n) ! ! Input, external D1FCN, the name of the subroutine to evaluate gradient ! of FCN, of the form ! ! subroutine d1fcn ( n, x, g ) ! integer n ! real g(n) ! real x(n) ! ! Input, external D2FCN, the name of the subroutine to evaluate the ! Hessian of the function, of the form: ! ! subroutine d2fcn ( nr, n, x, h ) ! integer nr ! integer n ! real h(nr,n) ! real x(n) ! ! Input, real TYPSIZ(N), a typical size for each component of X. ! ! Input, real FSCALE, an estimate of the scale of the objective ! function. ! ! Input, integer METHOD, the algorithm to use to solve minimization problem: ! 1, line search ! 2, double dogleg ! 3, More-Hebdon ! ! Input, integer IEXP, function expense flag. ! Set IEXP to 1 if optimization function fcn is expensive to ! evaluate, and 0 otherwise. If set then hessian will ! be evaluated by secant update instead of ! analytically or by finite differences. ! ! Input/output, integer MSG. ! On input, set > 0 to inhibit certain automatic checks ! On output. < 0 indicates an error occurred. ! ! Input, integer NDIGIT, the number of good digits in optimization ! function fcn. ! ! Input, integer ITNLIM, the maximum number of allowable iterations. ! ! Input, integer IAGFLG, is 1 if analytic gradient supplied. ! ! Input, integer IAHFLG, is 1 if analytic hessian supplied. ! ! Input, integer IPR, the device to which to send output. ! ! Input, real DLT, the trust region radius. ! ! Input, real GRADTL, the tolerance at which gradient considered ! close enough to zero to terminate algorithm. ! ! Input, real STEPMX, the maximum allowable step size. ! ! Input, real STEPTL, the relative step size at which successive iterates ! considered close enough to terminate algorithm ! ! Input/output, real XPLS(N); on exit, XPLS is the local minimizer. ! ! Input/output, real FPLS; on exit, the function value at XPLS. ! ! Input/output, real GPLS(N); on exit, the gradient at XPLS. ! ! Output, integer ITRMCD, the termination code. ! ! Workspace, real A(NR,N), workspace for hessian (or estimate) ! and its Cholesky decomposition. ! ! Workspace, real UDIAG(N), workspace for diagonal of hessian. ! ! Workspace, real G(N), workspace for gradient at current iterate. ! ! Workspace, real P(N), workspace for the step. ! ! Workspace, real SX(N), workspace for diagonal scaling matrix. ! ! Workspace, real WRK0(N), WRK1(N), WRK2(N), WRK3(N). ! ! Local variables: ! ! analtl, tolerance for gradient and hessian checking. ! ! epsm, machine epsilon. ! ! f, function value: fcn(x). ! ! itncnt, current iteration, k ! ! rnf, relative noise in optimization function fcn. ! ! noise=10.**(-ndigit) ! implicit none ! integer n integer nr ! real a(nr,n) real amu real amusav real analtl external d1fcn external d2fcn real dlpsav real dlt real dltp real dltsav real epsm real f external fcn real fpls real fscale real g(n) real gpls(n) real gradtl integer i integer iagflg integer iahflg integer icscmx integer iexp integer ipr integer iretcd integer itncnt integer itnlim integer itrmcd integer method integer msg logical mxtake integer ndigit logical noupdt real p(n) real phi real phip0 real phisav real phpsav real r1mach real rnf real stepmx real steptl real sx(n) real typsiz(n) real udiag(n) real wrk real wrk0(n) real wrk1(n) real wrk2(n) real wrk3(n) real x(n) real xpls(n) ! ! Initialization. ! p(1:n) = 0.0E+00 itncnt = 0 iretcd = -1 epsm = epsilon ( epsm ) call optchk ( n, x, typsiz, sx, fscale, gradtl, itnlim, ndigit, epsm, & dlt, method, iexp, iagflg, iahflg, stepmx, msg, ipr ) if ( msg < 0 ) then return end if rnf = max ( 10.0E+00**(-ndigit), epsm ) analtl = max ( 1.0E-02, sqrt ( rnf ) ) if ( mod ( msg/8, 2 ) == 0 ) then write(ipr,901) write(ipr,900) typsiz(1:n) write(ipr,902) write(ipr,900) sx(1:n) write(ipr,903) fscale write(ipr,904) ndigit,iagflg,iahflg,iexp,method,itnlim,epsm write(ipr,905) stepmx,steptl,gradtl,dlt,rnf,analtl end if ! ! Evaluate fcn(x) ! call fcn ( n, x, f ) ! ! Evaluate analytic or finite difference gradient and check analytic ! gradient, if requested. ! if ( iagflg /= 1 ) then call fstofd (1, 1, n, x, fcn, f, g, sx, rnf, wrk, 1) else call d1fcn ( n, x, g ) if ( mod ( msg/2, 2 ) /= 1 ) then call grdchk ( n, x, fcn, f, g, typsiz, sx, fscale, rnf, analtl, wrk1, & msg, ipr ) if ( msg < 0 ) then return end if end if end if call optstp ( n,x,f,g,wrk1,itncnt,icscmx,itrmcd,gradtl,steptl,sx,fscale, & itnlim,iretcd,mxtake,ipr,msg ) if ( itrmcd /= 0 ) then go to 700 end if if ( iexp /= 1 ) then go to 80 end if ! ! If optimization function expensive to evaluate (iexp=1), then ! hessian will be obtained by secant updates. Get initial hessian. ! call hsnint ( nr, n, a, sx, method ) go to 90 80 continue ! ! Evaluate analytic or finite difference hessian and check analytic ! hessian if requested (only if user-supplied analytic hessian ! routine d2fcn fills only lower triangular part and diagonal of a). ! if ( iahflg == 1 ) then go to 82 end if if ( iagflg == 1 ) then call fstofd ( nr, n, n, x, d1fcn, g, a, sx, rnf, wrk1, 3 ) else call sndofd ( nr, n, x, fcn, f, a, sx, rnf, wrk1, wrk2 ) end if go to 88 82 if ( mod(msg/4,2) == 0 ) go to 85 call d2fcn ( nr, n, x, a ) go to 88 85 continue call heschk ( nr, n, x, fcn, d1fcn, d2fcn, f, g, a, typsiz, & sx, rnf, analtl, iagflg, udiag, wrk1, wrk2, msg, ipr ) ! ! HESCHK evaluates d2fcn and checks it against the finite ! difference hessian which it calculates by calling fstofd ! (if iagflg == 1) or sndofd (otherwise). ! if ( msg < 0 ) return 88 continue 90 continue if ( mod ( msg/8, 2 ) == 0 ) then call result ( nr,n,x,f,g,a,p,itncnt,1,ipr ) end if ! ! iteration ! 100 continue itncnt = itncnt+1 ! ! Find perturbed local model hessian and its ll+ decomposition ! (skip this step if line search or dogstep techniques being used with ! secant updates. Cholesky decomposition l already obtained from ! secfac.) ! if ( iexp == 1 .and. method /= 3 ) go to 105 103 continue call chlhsn ( nr, n, a, epsm, sx, udiag ) 105 continue ! ! Solve for Newton step: ap=-g ! wrk1(1:n) = - g(1:n) call lltslv ( nr, n, a, p, wrk1 ) ! ! Decide whether to accept Newton step xpls=x + p ! or to choose xpls by a global strategy. ! if ( iagflg == 0 .and. method /= 1 ) then dltsav = dlt if ( method /= 2 ) then amusav = amu dlpsav = dltp phisav = phi phpsav = phip0 end if end if if ( method == 1 ) then call lnsrch ( n, x, f, g, p, xpls, fpls, fcn, mxtake, iretcd, & stepmx, steptl, sx, ipr ) else if ( method == 2 ) then call dogdrv ( nr,n,x,f,g,a,p,xpls,fpls,fcn,sx,stepmx, & steptl,dlt,iretcd,mxtake,wrk0,wrk1,wrk2,wrk3,ipr ) else if ( method == 3 ) then call hookdr ( nr,n,x,f,g,a,udiag,p,xpls,fpls,fcn,sx,stepmx, & steptl,dlt,iretcd,mxtake,amu,dltp,phi,phip0,wrk0, & wrk1,wrk2,epsm,itncnt,ipr ) end if ! ! If could not find satisfactory step and forward difference ! gradient was used, retry using central difference gradient. ! if ( iretcd /= 1 .or. iagflg /= 0 ) then go to 112 end if ! ! Set iagflg for central differences ! iagflg = -1 write(ipr,906) itncnt call fstocd (n, x, fcn, sx, rnf, g) if ( method == 1 ) go to 105 dlt = dltsav if ( method == 2 ) go to 105 amu = amusav dltp = dlpsav phi = phisav phip0 = phpsav go to 103 ! ! Calculate step for output ! 112 continue p(1:n) = xpls(1:n) - x(1:n) ! ! Calculate the gradient at XPLS. ! if ( iagflg == -1 ) then call fstocd ( n, xpls, fcn, sx, rnf, gpls ) else if ( iagflg == 0 ) then call fstofd ( 1, 1, n, xpls, fcn, fpls, gpls, sx, rnf, wrk, 1 ) else call d1fcn ( n, xpls, gpls ) end if ! ! Check whether stopping criteria satisfied. ! call optstp ( n,xpls,fpls,gpls,x,itncnt,icscmx,itrmcd,gradtl,steptl,sx,& fscale,itnlim,iretcd,mxtake,ipr,msg ) if ( itrmcd /= 0 ) go to 690 ! ! Evaluate hessian at xpls ! if ( iexp == 0 ) go to 130 if ( method == 3 ) then call secunf ( nr,n,x,g,a,udiag,xpls,gpls,epsm,itncnt,rnf, & iagflg,noupdt,wrk1,wrk2,wrk3 ) else call secfac ( nr,n,x,g,a,xpls,gpls,epsm,itncnt,rnf,iagflg, & noupdt,wrk0,wrk1,wrk2,wrk3 ) end if go to 150 130 continue if ( iahflg == 1 ) go to 140 if ( iagflg == 1 ) then call fstofd ( nr, n, n, xpls, d1fcn, gpls, a, sx, rnf, wrk1, 3 ) else call sndofd ( nr, n, xpls, fcn, fpls, a, sx, rnf, wrk1, wrk2 ) end if go to 150 140 continue call d2fcn ( nr,n,xpls,a ) 150 continue if ( mod ( msg/16, 2 ) == 1 ) then call result ( nr, n, xpls, fpls, gpls, a, p, itncnt, 1, ipr ) end if ! ! x <-- xpls ! g <-- gpls ! f <-- fpls ! f = fpls x(1:n) = xpls(1:n) g(1:n) = gpls(1:n) go to 100 ! ! Termination. ! ! Reset XPLS, FPLS, GPLS, if previous iterate solution ! 690 if ( itrmcd /= 3 ) go to 710 700 continue fpls = f xpls(1:n) = x(1:n) gpls(1:n) = g(1:n) ! ! Print results ! 710 continue if ( mod ( msg/8, 2 ) == 0) then call result ( nr, n, xpls, fpls, gpls, a, p, itncnt, 0, ipr ) end if msg = 0 900 format(' optdrv ',5(e20.13,3x)) 901 format('0optdrv typical x') 902 format(' optdrv diagonal scaling matrix for x') 903 format(' optdrv typical f =',e20.13) 904 format('0optdrv number of good digits in fcn=',i5/ & ' optdrv gradient flag =',i5,' (=1 if analytic', & ' gradient supplied)'/ & ' optdrv hessian flag =',i5,' (=1 if analytic', & ' hessian supplied)'/ & ' optdrv expense flag =',i5, ' (=1 if', & ' minimization function expensive to evaluate)'/ & ' optdrv method to use =',i5,' (=1,2,3 for line', & ' search, double dogleg, more-hebdon respectively)'/ & ' optdrv iteration limit=',i5/ & ' optdrv machine epsilon=',e20.13) 905 format('0optdrv maximum step size =',e20.13/ & ' optdrv step tolerance =',e20.13/ & ' optdrv gradient tolerance=',e20.13/ & ' optdrv trust reg radius =',e20.13/ & ' optdrv rel noise in fcn =',e20.13/ & ' optdrv anal-fd tolerance =',e20.13) 906 format(' optdrv shift from forward to central differences', & ' in iteration ', i5) return end subroutine optif0 ( n, x, fcn, xpls, fpls, gpls, itrmcd ) ! !******************************************************************************* ! !! OPTIF0 provides a simple interface to the minimization package. ! ! ! Modified: ! ! 29 May 2001 ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input/output, real X(N). On input, an rough solution of the problem. ! On output, the computed solution. ! ! Input, external FCN, the name of the subroutine that evaluates ! the optimization function, of the form ! ! subroutine fcn ( n, x, f ) ! integer n ! real f ! real x(n) ! ! Output, real XPLS(N), estimated local minimizer of the function. ! ! Output, real FPLS, the function value at XPLS. ! ! Output, real GPLS(N), the gradient at XPLS. ! ! Output, integer ITRMCD, the termination code. ! 1, relative gradient close to zero. ! The current iterate is probably solution. ! 2, successive iterates within tolerance. ! The current iterate is probably solution. ! 3, the last global step failed to locate a point lower than X. ! Either x is an approximate local minimum of the function, ! the function is too non-linear for this algorithm, ! or STEPTL is too large. ! 4, iteration limit exceeded. The algorithm failed. ! 5, maximum step size exceeded 5 consecutive times. ! Either the function is unbounded below, becomes asymptotic to a ! finite value from above in some direction, or STEPMX is too small. ! implicit none ! integer n ! real a(n,n) external d1fcn external d2fcn real dlt external fcn real fscale real fpls real gpls(n) real gradtl integer iagflg integer iahflg integer iexp integer ipr integer itnlim integer itrmcd integer method integer msg integer ndigit integer nr real stepmx real steptl real wrk(n,9) real x(n) real xpls(n) ! ! equivalence wrk(n,1) = udiag(n) ! wrk(n,2) = g(n) ! wrk(n,3) = p(n) ! wrk(n,4) = typsiz(n) ! wrk(n,5) = sx(n) ! wrk(n,6) = wrk0(n) ! wrk(n,7) = wrk1(n) ! wrk(n,8) = wrk2(n) ! wrk(n,9) = wrk3(n) ! nr = n call dfault ( n, x, wrk(1,4), fscale, method, iexp, msg, ndigit, & itnlim, iagflg, iahflg, ipr, dlt, gradtl, stepmx, steptl ) call optdrv ( nr,n,x,fcn,d1fcn,d2fcn,wrk(1,4),fscale, & method,iexp,msg,ndigit,itnlim,iagflg,iahflg,ipr, & dlt,gradtl,stepmx,steptl,xpls,fpls,gpls,itrmcd, & a,wrk(1,1),wrk(1,2),wrk(1,3),wrk(1,5),wrk(1,6), & wrk(1,7),wrk(1,8),wrk(1,9) ) return end subroutine optstp ( n, xpls, fpls, gpls, x, itncnt, icscmx, & itrmcd, gradtl, steptl, sx, fscale, itnlim, iretcd, mxtake, ipr, msg ) ! !******************************************************************************* ! !! OPTSTP: unconstrained minimization stopping criteria ! ! ! Discussion: ! ! OPSTP determines whether the optimization algorithm should terminate, ! due to any of the following: ! 1) the problem has been solved to the user's tolerance; ! 2) convergence within user tolerance; ! 3) iteration limit reached; ! 4) divergence or too restrictive maximum step (stepmx) suspected; ! ! Parameters: ! ! Input, integer N, the dimension of the problem. ! ! Input, real XPLS(N), the new iterate, X[K]. ! ! Input, real FPLS, the function value at the new iterate. ! ! Input, real GPLS(N), the gradient at the new iterate, or an ! approximation of that value. ! ! Input, real X(N), the old iterate X[K-1]. ! ! Input, integer ITNCNT, the current iteration K. ! ! Input/output, integer ICSCMX, the number consecutive steps >= STEPMX. ! [retain value between successive calls]. ! ! Output, integer ITRMD, the termination code. ! ! Input, real GRADTL, the tolerance at which relative gradient ! considered close enough to zero to terminate algorithm. ! ! Input, real STEPTL, the relative step size at which successive iterates ! are considered close enough to terminate algorithm. ! ! Input, real SX(N), the diagonal scaling matrix for X. ! ! Input, real FSCALE, an estimate of the scale of objective function. ! ! Input, integer ITNLIM, the maximum number of allowable iterations. ! ! Output, integer IRETCD, the return code. ! ! Input, logical MXTAKE, TRUE if a step of maximum length was used. ! ! Output, integer IPR, the device to which to send output. ! ! Input, integer MSG, if includes a term 8, suppress output. ! implicit none ! integer n ! real d real fpls real fscale real gpls(n) real gradtl integer i integer icscmx integer ipr integer iretcd integer itncnt integer itnlim integer itrmcd integer jtrmcd integer msg logical mxtake real relgrd real relstp real rgx real rsx real steptl real sx(n) real x(n) real xpls(n) ! itrmcd = 0 ! ! Last global step failed to locate a point lower than X. ! if ( iretcd == 1 ) then jtrmcd = 3 go to 600 end if ! ! Find direction in which relative gradient maximum. ! Check whether within tolerance ! d = max ( abs ( fpls ), fscale ) rgx = 0.0E+00 do i = 1, n relgrd = abs ( gpls(i) ) * max ( abs ( xpls(i) ), 1.0E+00 / sx(i) ) / d rgx = max ( rgx, relgrd ) end do jtrmcd = 1 if ( rgx <= gradtl ) go to 600 if ( itncnt == 0 ) then return end if ! ! Find direction in which relative stepsize is maximum. ! Check whether within tolerance. ! rsx = 0.0E+00 do i = 1, n relstp = abs ( xpls(i) - x(i) ) / max ( abs ( xpls(i) ), 1.0E+00 / sx(i) ) rsx = max ( rsx, relstp ) end do jtrmcd = 2 if ( rsx <= steptl ) go to 600 ! ! Check iteration limit. ! jtrmcd = 4 if ( itncnt >= itnlim ) go to 600 ! ! Check number of consecutive steps \ stepmx ! if ( .not. mxtake ) then icscmx = 0 return else if ( mod ( msg/8, 2 ) == 0 ) then write(ipr,900) end if icscmx = icscmx+1 if ( icscmx < 5 ) then return end if jtrmcd = 5 end if ! ! Print termination code ! 600 continue itrmcd = jtrmcd if ( itrmcd == 1 ) then write(ipr,901) else if ( itrmcd == 2 ) then write(ipr,902) else if ( itrmcd == 3 ) then write(ipr,903) else if ( itrmcd == 4 ) then write(ipr,904) else if ( itrmcd == 5 ) then write(ipr,905) end if 900 format('0optstp step of maximum length (stepmx) taken') 901 format('0optstp relative gradient close to zero.'/ & ' optstp current iterate is probably solution.') 902 format('0optstp successive iterates within tolerance.'/ & ' optstp current iterate is probably solution') 903 format('0optstp last global step failed to locate a point', & ' lower than x.'/ & ' optstp either x is an approximate local minimum', & ' of the function',/ & ' optstp the function is too non-linear for this algorithm,'/ & ' optstp or steptl is too large.') 904 format('optstp iteration limit exceeded.'/'optstp algorithm failed.') 905 format('0optstp maximum step size exceeded 5 consecutive times.'/ & ' optstp either the function is unbounded below',/ & ' optstp becomes asymptotic to a finite value', & ' from above in some direction',/ & ' optstp or stepmx is too small') return end subroutine passb ( nac, ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa ) ! !******************************************************************************* ! !! PASSB is a lower level routine used by CFFTB1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer idl1 integer ido integer ip integer l1 ! real c1(ido,l1,ip) real c2(idl1,ip) real cc(ido,ip,l1) real ch(ido,l1,ip) real ch2(idl1,ip) integer i integer idij integer idj integer idl integer idlj integer idp integer ik integer inc integer ipph integer j integer jc integer k integer l integer lc integer nac integer nt real wa(*) real wai real war ! nt = ip * idl1 ipph = ( ip + 1 ) / 2 idp = ip * ido if ( ido >= l1 ) then do j = 2, ipph jc = ip + 2 - j do k = 1, l1 ch(1:ido,k,j) = cc(1:ido,j,k) + cc(1:ido,jc,k) ch(1:ido,k,jc) = cc(1:ido,j,k) - cc(1:ido,jc,k) end do end do ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1) else do j = 2, ipph jc = ip + 2 - j do i = 1, ido ch(i,1:l1,j) = cc(i,j,1:l1) + cc(i,jc,1:l1) ch(i,1:l1,jc) = cc(i,j,1:l1) - cc(i,jc,1:l1) end do end do ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1) end if idl = 2 - ido inc = 0 do l = 2, ipph lc = ip + 2 - l idl = idl + ido do ik = 1, idl1 c2(ik,l) = ch2(ik,1) + wa(idl-1) * ch2(ik,2) c2(ik,lc) = wa(idl) * ch2(ik,ip) end do idlj = idl inc = inc + ido do j = 3, ipph jc = ip + 2 - j idlj = idlj + inc if ( idlj > idp ) then idlj = idlj - idp end if war = wa(idlj-1) wai = wa(idlj) do ik = 1, idl1 c2(ik,l) = c2(ik,l) + war * ch2(ik,j) c2(ik,lc) = c2(ik,lc) + wai * 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 do ik = 2, idl1, 2 ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc) ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc) ch2(ik,j) = c2(ik,j) + c2(ik-1,jc) ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc) end do end do nac = 1 if ( ido == 2 ) then return end if nac = 0 c2(1:idl1,1) = ch2(1:idl1,1) c1(1:2,1:l1,2:ip) = ch(1:2,1:l1,2:ip) if ( ( ido / 2 ) <= l1 ) then idij = 0 do j = 2, ip idij = idij + 2 do i = 4, 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 idj = 2 - ido do j = 2, ip idj = idj + ido do k = 1, l1 idij = idj do i = 4, 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 passb2 ( ido, l1, cc, ch, wa1 ) ! !******************************************************************************* ! !! PASSB2 is a lower level routine used by CFFTB1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,2,l1) real ch(ido,l1,2) integer i integer k real ti2 real tr2 real wa1(ido) ! if ( ido <= 2 ) then ch(1,1:l1,1) = cc(1,1,1:l1) + cc(1,2,1:l1) ch(1,1:l1,2) = cc(1,1,1:l1) - cc(1,2,1:l1) ch(2,1:l1,1) = cc(2,1,1:l1) + cc(2,2,1:l1) ch(2,1:l1,2) = cc(2,1,1:l1) - cc(2,2,1:l1) else do k = 1, l1 do i = 2, ido, 2 ch(i-1,k,1) = cc(i-1,1,k) + cc(i-1,2,k) tr2 = cc(i-1,1,k) - cc(i-1,2,k) ch(i,k,1) = cc(i,1,k) + cc(i,2,k) ti2 = cc(i,1,k) - cc(i,2,k) ch(i,k,2) = wa1(i-1) * ti2 + wa1(i) * tr2 ch(i-1,k,2) = wa1(i-1) * tr2 - wa1(i) * ti2 end do end do end if return end subroutine passb3 ( ido, l1, cc, ch, wa1, wa2 ) ! !******************************************************************************* ! !! PASSB3 is a lower level routine used by CFFTB1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,3,l1) real ch(ido,l1,3) real ci2 real ci3 real cr2 real cr3 real di2 real di3 real dr2 real dr3 integer i integer k real, parameter :: taui = 0.866025403784439E+00 real, parameter :: taur = -0.5E+00 real ti2 real tr2 real wa1(ido) real wa2(ido) ! if ( ido == 2 ) then do k = 1, l1 tr2 = cc(1,2,k) + cc(1,3,k) cr2 = cc(1,1,k) + taur * tr2 ch(1,k,1) = cc(1,1,k) + tr2 ti2 = cc(2,2,k) + cc(2,3,k) ci2 = cc(2,1,k) + taur * ti2 ch(2,k,1) = cc(2,1,k) + ti2 cr3 = taui * ( cc(1,2,k) - cc(1,3,k) ) ci3 = taui * ( cc(2,2,k) - cc(2,3,k) ) ch(1,k,2) = cr2 - ci3 ch(1,k,3) = cr2 + ci3 ch(2,k,2) = ci2 + cr3 ch(2,k,3) = ci2 - cr3 end do else do k = 1, l1 do i = 2, ido, 2 tr2 = cc(i-1,2,k) + cc(i-1,3,k) cr2 = cc(i-1,1,k) + taur * tr2 ch(i-1,k,1) = cc(i-1,1,k) + tr2 ti2 = cc(i,2,k) + cc(i,3,k) ci2 = cc(i,1,k) + taur * ti2 ch(i,k,1) = cc(i,1,k) + ti2 cr3 = taui * ( cc(i-1,2,k) - cc(i-1,3,k) ) ci3 = taui * ( cc(i,2,k) - cc(i,3,k) ) dr2 = cr2 - ci3 dr3 = cr2 + ci3 di2 = ci2 + cr3 di3 = ci2 - cr3 ch(i,k,2) = wa1(i-1) * di2 + wa1(i) * dr2 ch(i-1,k,2) = wa1(i-1) * dr2 - wa1(i) * di2 ch(i,k,3) = wa2(i-1) * di3 + wa2(i) * dr3 ch(i-1,k,3) = wa2(i-1) * dr3 - wa2(i) * di3 end do end do end if return end subroutine passb4 ( ido, l1, cc, ch, wa1, wa2, wa3 ) ! !******************************************************************************* ! !! PASSB4 is a lower level routine used by CFFTB1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,4,l1) real ch(ido,l1,4) real ci1 real ci2 real ci3 real ci4 real cr1 real cr2 real cr3 real cr4 integer i integer k real ti1 real ti2 real ti3 real ti4 real tr1 real tr2 real tr3 real tr4 real wa1(ido) real wa2(ido) real wa3(ido) ! if ( ido == 2 ) then do k = 1, l1 ti1 = cc(2,1,k) - cc(2,3,k) ti2 = cc(2,1,k) + cc(2,3,k) tr4 = cc(2,4,k) - cc(2,2,k) ti3 = cc(2,2,k) + cc(2,4,k) tr1 = cc(1,1,k) - cc(1,3,k) tr2 = cc(1,1,k) + cc(1,3,k) ti4 = cc(1,2,k) - cc(1,4,k) tr3 = cc(1,2,k) + cc(1,4,k) ch(1,k,1) = tr2 + tr3 ch(1,k,3) = tr2 - tr3 ch(2,k,1) = ti2 + ti3 ch(2,k,3) = ti2 - ti3 ch(1,k,2) = tr1 + tr4 ch(1,k,4) = tr1 - tr4 ch(2,k,2) = ti1 + ti4 ch(2,k,4) = ti1 - ti4 end do else do k = 1, l1 do i = 2, ido, 2 ti1 = cc(i,1,k) - cc(i,3,k) ti2 = cc(i,1,k) + cc(i,3,k) ti3 = cc(i,2,k) + cc(i,4,k) tr4 = cc(i,4,k) - cc(i,2,k) tr1 = cc(i-1,1,k) - cc(i-1,3,k) tr2 = cc(i-1,1,k) + cc(i-1,3,k) ti4 = cc(i-1,2,k) - cc(i-1,4,k) tr3 = cc(i-1,2,k) + cc(i-1,4,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-1) * cr2 - wa1(i) * ci2 ch(i,k,2) = wa1(i-1) * ci2 + wa1(i) * cr2 ch(i-1,k,3) = wa2(i-1) * cr3 - wa2(i) * ci3 ch(i,k,3) = wa2(i-1) * ci3 + wa2(i) * cr3 ch(i-1,k,4) = wa3(i-1) * cr4 - wa3(i) * ci4 ch(i,k,4) = wa3(i-1) * ci4 + wa3(i) * cr4 end do end do end if return end subroutine passb5 ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 ) ! !******************************************************************************* ! !! PASSB5 is a lower level routine used by CFFTB1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,5,l1) real ch(ido,l1,5) real ci2 real ci3 real ci4 real ci5 real cr2 real cr3 real cr4 real cr5 real di2 real di3 real di4 real di5 real dr2 real dr3 real dr4 real dr5 integer i integer k real, parameter :: ti11 = 0.951056516295154E+00 real, parameter :: ti12 = 0.587785252292473E+00 real ti2 real ti3 real ti4 real ti5 real, parameter :: tr11 = 0.309016994374947E+00 real, parameter :: tr12 = -0.809016994374947E+00 real tr2 real tr3 real tr4 real tr5 real wa1(ido) real wa2(ido) real wa3(ido) real wa4(ido) ! if ( ido == 2 ) then do k = 1, l1 ti5 = cc(2,2,k) - cc(2,5,k) ti2 = cc(2,2,k) + cc(2,5,k) ti4 = cc(2,3,k) - cc(2,4,k) ti3 = cc(2,3,k) + cc(2,4,k) tr5 = cc(1,2,k) - cc(1,5,k) tr2 = cc(1,2,k) + cc(1,5,k) tr4 = cc(1,3,k) - cc(1,4,k) tr3 = cc(1,3,k) + cc(1,4,k) ch(1,k,1) = cc(1,1,k) + tr2 + tr3 ch(2,k,1) = cc(2,1,k) + ti2 + ti3 cr2 = cc(1,1,k) + tr11 * tr2 + tr12 * tr3 ci2 = cc(2,1,k) + tr11 * ti2 + tr12 * ti3 cr3 = cc(1,1,k) + tr12 * tr2 + tr11 * tr3 ci3 = cc(2,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 ch(1,k,2) = cr2 - ci5 ch(1,k,5) = cr2 + ci5 ch(2,k,2) = ci2 + cr5 ch(2,k,3) = ci3 + cr4 ch(1,k,3) = cr3 - ci4 ch(1,k,4) = cr3 + ci4 ch(2,k,4) = ci3 - cr4 ch(2,k,5) = ci2 - cr5 end do else do k = 1, l1 do i = 2, ido, 2 ti5 = cc(i,2,k) - cc(i,5,k) ti2 = cc(i,2,k) + cc(i,5,k) ti4 = cc(i,3,k) - cc(i,4,k) ti3 = cc(i,3,k) + cc(i,4,k) tr5 = cc(i-1,2,k) - cc(i-1,5,k) tr2 = cc(i-1,2,k) + cc(i-1,5,k) tr4 = cc(i-1,3,k) - cc(i-1,4,k) tr3 = cc(i-1,3,k) + cc(i-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-1) * dr2 - wa1(i) * di2 ch(i,k,2) = wa1(i-1) * di2 + wa1(i) * dr2 ch(i-1,k,3) = wa2(i-1) * dr3 - wa2(i) * di3 ch(i,k,3) = wa2(i-1) * di3 + wa2(i) * dr3 ch(i-1,k,4) = wa3(i-1) * dr4 - wa3(i) * di4 ch(i,k,4) = wa3(i-1) * di4 + wa3(i) * dr4 ch(i-1,k,5) = wa4(i-1) * dr5 - wa4(i) * di5 ch(i,k,5) = wa4(i-1) * di5 + wa4(i) * dr5 end do end do end if return end subroutine passf ( nac, ido, ip, l1, idl1, cc, c1, c2, ch, ch2, wa ) ! !******************************************************************************* ! !! PASSF is a lower level routine used by CFFTF1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer idl1 integer ido integer ip integer l1 ! real c1(ido,l1,ip) real c2(idl1,ip) real cc(ido,ip,l1) real ch(ido,l1,ip) real ch2(idl1,ip) integer i integer idij integer idj integer idl integer idlj integer idp integer ik integer inc integer ipph integer j integer jc integer k integer l integer lc integer nac integer nt real wa(*) real wai real war ! nt = ip * idl1 ipph = (ip+1) / 2 idp = ip * ido if ( ido >= l1 ) then do j = 2, ipph jc = ip + 2 - j ch(1:ido,1:l1,j) = cc(1:ido,j,1:l1) + cc(1:ido,jc,1:l1) ch(1:ido,1:l1,jc) = cc(1:ido,j,1:l1) - cc(1:ido,jc,1:l1) end do ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1) else do j = 2, ipph jc = ip + 2 - j ch(1:ido,1:l1,j) = cc(1:ido,j,1:l1) + cc(1:ido,jc,1:l1) ch(1:ido,1:l1,jc) = cc(1:ido,j,1:l1) - cc(1:ido,jc,1:l1) end do ch(1:ido,1:l1,1) = cc(1:ido,1,1:l1) end if idl = 2 - ido inc = 0 do l = 2, ipph lc = ip + 2 - l idl = idl + ido do ik = 1, idl1 c2(ik,l) = ch2(ik,1) + wa(idl-1) * ch2(ik,2) c2(ik,lc) = - wa(idl) * ch2(ik,ip) end do idlj = idl inc = inc + ido do j = 3, ipph jc = ip + 2 - j idlj = idlj + inc if ( idlj > idp ) then idlj = idlj - idp end if war = wa(idlj-1) wai = wa(idlj) do ik = 1, idl1 c2(ik,l) = c2(ik,l) + war * ch2(ik,j) c2(ik,lc) = c2(ik,lc) - wai * 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 do ik = 2, idl1, 2 ch2(ik-1,j) = c2(ik-1,j) - c2(ik,jc) ch2(ik-1,jc) = c2(ik-1,j) + c2(ik,jc) ch2(ik,j) = c2(ik,j) + c2(ik-1,jc) ch2(ik,jc) = c2(ik,j) - c2(ik-1,jc) end do end do if ( ido == 2 ) then nac = 1 return end if nac = 0 c2(1:idl1,1) = ch2(1:idl1,1) c1(1,1:l1,2:ip) = ch(1,1:l1,2:ip) c1(2,1:l1,2:ip) = ch(2,1:l1,2:ip) if ( ( ido / 2 ) <= l1 ) then idij = 0 do j = 2, ip idij = idij + 2 do i = 4, 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 idj = 2 - ido do j = 2, ip idj = idj + ido do k = 1, l1 idij = idj do i = 4, 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 passf2 ( ido, l1, cc, ch, wa1 ) ! !******************************************************************************* ! !! PASSF2 is a lower level routine used by CFFTF1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,2,l1) real ch(ido,l1,2) integer i integer k real ti2 real tr2 real wa1(ido) ! if ( ido <= 2 ) then ch(1,1:l1,1) = cc(1,1,1:l1) + cc(1,2,1:l1) ch(1,1:l1,2) = cc(1,1,1:l1) - cc(1,2,1:l1) ch(2,1:l1,1) = cc(2,1,1:l1) + cc(2,2,1:l1) ch(2,1:l1,2) = cc(2,1,1:l1) - cc(2,2,1:l1) else do k = 1, l1 do i = 2, ido, 2 ch(i-1,k,1) = cc(i-1,1,k) + cc(i-1,2,k) tr2 = cc(i-1,1,k) - cc(i-1,2,k) ch(i,k,1) = cc(i,1,k) + cc(i,2,k) ti2 = cc(i,1,k) - cc(i,2,k) ch(i,k,2) = wa1(i-1) * ti2 - wa1(i) * tr2 ch(i-1,k,2) = wa1(i-1) * tr2 + wa1(i) * ti2 end do end do end if return end subroutine passf3 ( ido, l1, cc, ch, wa1, wa2 ) ! !******************************************************************************* ! !! PASSF3 is a lower level routine used by CFFTF1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,3,l1) real ch(ido,l1,3) real ci2 real ci3 real cr2 real cr3 real di2 real di3 real dr2 real dr3 integer i integer k real, parameter :: taui = -0.866025403784439E+00 real, parameter :: taur = -0.5E+00 real ti2 real tr2 real wa1(ido) real wa2(ido) ! if ( ido == 2 ) then do k = 1, l1 tr2 = cc(1,2,k) + cc(1,3,k) cr2 = cc(1,1,k) + taur * tr2 ch(1,k,1) = cc(1,1,k) + tr2 ti2 = cc(2,2,k) + cc(2,3,k) ci2 = cc(2,1,k) + taur * ti2 ch(2,k,1) = cc(2,1,k) + ti2 cr3 = taui * ( cc(1,2,k) - cc(1,3,k) ) ci3 = taui * ( cc(2,2,k) - cc(2,3,k) ) ch(1,k,2) = cr2 - ci3 ch(1,k,3) = cr2 + ci3 ch(2,k,2) = ci2 + cr3 ch(2,k,3) = ci2 - cr3 end do else do k = 1, l1 do i = 2, ido, 2 tr2 = cc(i-1,2,k) + cc(i-1,3,k) cr2 = cc(i-1,1,k) + taur * tr2 ch(i-1,k,1) = cc(i-1,1,k) + tr2 ti2 = cc(i,2,k) + cc(i,3,k) ci2 = cc(i,1,k) + taur * ti2 ch(i,k,1) = cc(i,1,k) + ti2 cr3 = taui * ( cc(i-1,2,k) - cc(i-1,3,k) ) ci3 = taui * ( cc(i,2,k) - cc(i,3,k) ) dr2 = cr2 - ci3 dr3 = cr2 + ci3 di2 = ci2 + cr3 di3 = ci2 - cr3 ch(i,k,2) = wa1(i-1) * di2 - wa1(i) * dr2 ch(i-1,k,2) = wa1(i-1) * dr2 + wa1(i) * di2 ch(i,k,3) = wa2(i-1) * di3 - wa2(i) * dr3 ch(i-1,k,3) = wa2(i-1) * dr3 + wa2(i) * di3 end do end do end if return end subroutine passf4 ( ido, l1, cc, ch, wa1, wa2, wa3 ) ! !******************************************************************************* ! !! PASSF4 is a lower level routine used by CFFTF1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,4,l1) real ch(ido,l1,4) real ci1 real ci2 real ci3 real ci4 real cr1 real cr2 real cr3 real cr4 integer i integer k real ti1 real ti2 real ti3 real ti4 real tr1 real tr2 real tr3 real tr4 real wa1(ido) real wa2(ido) real wa3(ido) ! if ( ido == 2 ) then do k = 1, l1 ti1 = cc(2,1,k) - cc(2,3,k) ti2 = cc(2,1,k) + cc(2,3,k) tr4 = cc(2,2,k) - cc(2,4,k) ti3 = cc(2,2,k) + cc(2,4,k) tr1 = cc(1,1,k) - cc(1,3,k) tr2 = cc(1,1,k) + cc(1,3,k) ti4 = cc(1,4,k) - cc(1,2,k) tr3 = cc(1,2,k) + cc(1,4,k) ch(1,k,1) = tr2 + tr3 ch(1,k,3) = tr2 - tr3 ch(2,k,1) = ti2 + ti3 ch(2,k,3) = ti2 - ti3 ch(1,k,2) = tr1 + tr4 ch(1,k,4) = tr1 - tr4 ch(2,k,2) = ti1 + ti4 ch(2,k,4) = ti1 - ti4 end do else do k = 1, l1 do i = 2, ido, 2 ti1 = cc(i,1,k) - cc(i,3,k) ti2 = cc(i,1,k) + cc(i,3,k) ti3 = cc(i,2,k) + cc(i,4,k) tr4 = cc(i,2,k) - cc(i,4,k) tr1 = cc(i-1,1,k) - cc(i-1,3,k) tr2 = cc(i-1,1,k) + cc(i-1,3,k) ti4 = cc(i-1,4,k) - cc(i-1,2,k) tr3 = cc(i-1,2,k) + cc(i-1,4,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-1) * cr2 + wa1(i) * ci2 ch(i,k,2) = wa1(i-1) * ci2 - wa1(i) * cr2 ch(i-1,k,3) = wa2(i-1) * cr3 + wa2(i) * ci3 ch(i,k,3) = wa2(i-1) * ci3 - wa2(i) * cr3 ch(i-1,k,4) = wa3(i-1) * cr4 + wa3(i) * ci4 ch(i,k,4) = wa3(i-1) * ci4 - wa3(i) * cr4 end do end do end if return end subroutine passf5 ( ido, l1, cc, ch, wa1, wa2, wa3, wa4 ) ! !******************************************************************************* ! !! PASSF5 is a lower level routine used by CFFTF1. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! implicit none ! integer ido integer l1 ! real cc(ido,5,l1) real ch(ido,l1,5) real ci2 real ci3 real ci4 real ci5 real cr2 real cr3 real cr4 real cr5 real di2 real di3 real di4 real di5 real dr2 real dr3 real dr4 real dr5 integer i integer k real, parameter :: ti11 = -0.951056516295154E+00 real, parameter :: ti12 = -0.587785252292473E+00 real ti2 real ti3 real ti4 real ti5 real tr2 real tr3 real tr4 real tr5 real, parameter :: tr11 = 0.309016994374947E+00 real, parameter :: tr12 = -0.809016994374947E+00 real wa1(ido) real wa2(ido) real wa3(ido) real wa4(ido) ! if ( ido == 2 ) then do k = 1, l1 ti5 = cc(2,2,k) - cc(2,5,k) ti2 = cc(2,2,k) + cc(2,5,k) ti4 = cc(2,3,k) - cc(2,4,k) ti3 = cc(2,3,k) + cc(2,4,k) tr5 = cc(1,2,k) - cc(1,5,k) tr2 = cc(1,2,k) + cc(1,5,k) tr4 = cc(1,3,k) - cc(1,4,k) tr3 = cc(1,3,k) + cc(1,4,k) ch(1,k,1) = cc(1,1,k) + tr2 + tr3 ch(2,k,1) = cc(2,1,k) + ti2 + ti3 cr2 = cc(1,1,k) + tr11 * tr2 + tr12 * tr3 ci2 = cc(2,1,k) + tr11 * ti2 + tr12 * ti3 cr3 = cc(1,1,k) + tr12 * tr2 + tr11 * tr3 ci3 = cc(2,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 ch(1,k,2) = cr2 - ci5 ch(1,k,5) = cr2 + ci5 ch(2,k,2) = ci2 + cr5 ch(2,k,3) = ci3 + cr4 ch(1,k,3) = cr3 - ci4 ch(1,k,4) = cr3 + ci4 ch(2,k,4) = ci3 - cr4 ch(2,k,5) = ci2 - cr5 end do else do k = 1, l1 do i = 2, ido, 2 ti5 = cc(i,2,k) - cc(i,5,k) ti2 = cc(i,2,k) + cc(i,5,k) ti4 = cc(i,3,k) - cc(i,4,k) ti3 = cc(i,3,k) + cc(i,4,k) tr5 = cc(i-1,2,k) - cc(i-1,5,k) tr2 = cc(i-1,2,k) + cc(i-1,5,k) tr4 = cc(i-1,3,k) - cc(i-1,4,k) tr3 = cc(i-1,3,k) + cc(i-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-1) * dr2 + wa1(i) * di2 ch(i,k,2) = wa1(i-1) * di2 - wa1(i) * dr2 ch(i-1,k,3) = wa2(i-1) * dr3 + wa2(i) * di3 ch(i,k,3) = wa2(i-1) * di3 - wa2(i) * dr3 ch(i-1,k,4) = wa3(i-1) * dr4 + wa3(i) * di4 ch(i,k,4) = wa3(i-1) * di4 - wa3(i) * dr4 ch(i-1,k,5) = wa4(i-1) * dr5 + wa4(i) * di5 ch(i,k,5) = wa4(i-1) * di5 - wa4(i) * dr5 end do end do end if return end subroutine pchce ( ic, vc, n, x, h, slope, d, incfd, ierr ) ! !******************************************************************************* ! !! PCHCE is called by PCHIC to set end derivatives as requested by the user. ! ! ! Discussion: ! ! PCHCE must be called after interior derivative values have been set. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the D array. ! ! Programming notes: ! ! One could reduce the number of arguments and amount of local ! storage, at the expense of reduced code clarity, by passing in ! the array WK, rather than splitting it into H and SLOPE, and ! increasing its length enough to incorporate STEMP and XTEMP. ! ! The two monotonicity checks only use the sufficient conditions. ! thus, it is possible (but unlikely) for a boundary condition to ! be changed, even though the original interpolant was monotonic. ! At least the result is a continuous function of the data. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer IC(2), specifies the desired boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! See the prologue to PCHIC for details. ! ! Input, real VC(2), specifies desired boundary values, as indicated above. ! VC(1) need be set only if IC(1) = 2 or 3. ! VC(2) need be set only if IC(2) = 2 or 3. ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real H(N), interval lengths. H(I) = X(I+1)-X(I), for I = 1 ! to N-1. ! ! Input, real SLOPE(N), the data slopes. ! SLOPE(I) = ( Y(I+1) - Y(I) ) / H(I), for I = 1 to N-1. ! ! Input/output, real D(INCFD,N), the derivative values at the data points. ! The value corresponding to X(I) must be stored in D(1+(I-1)*INCFD). ! On output, the value of D at X(1) and/or X(N) is changed, if necessary, ! to produce the requested boundary conditions. ! ! Input, integer INCFD, increment between successive values in D. ! This argument is provided primarily for 2-d applications. ! ! Output, integer IERR, error flag. ! 0, no errors. ! 1, if IBEG < 0 and D(1) had to be adjusted for monotonicity. ! 2, if IEND < 0 and D(1+(N-1)*INCFD) had to be adjusted for monotonicity. ! 3, if both of the above are true. ! implicit none ! integer incfd integer n ! real d(incfd,n) real h(n) integer ibeg integer ic(2) integer iend integer ierf integer ierr integer index integer j integer k real pchdf real pchst real slope(n) real stemp(3) real vc(2) real x(n) real xtemp(4) ! ibeg = ic(1) iend = ic(2) ierr = 0 ! ! Set to default boundary conditions if N is too small. ! if ( abs ( ibeg ) > n ) then ibeg = 0 end if if ( abs ( iend ) > n ) then iend = 0 end if ! ! Treat beginning boundary condition. ! if ( ibeg == 0 ) then go to 2000 end if k = abs ( ibeg ) if ( k == 1 ) then ! ! Boundary value provided. ! d(1,1) = vc(1) else if ( k == 2 ) then ! ! Boundary second derivative provided. ! d(1,1) = 0.5E+00 *( (3.0E+00 * slope(1) - d(1,2)) - 0.5E+00 * vc(1) * h(1) ) else if ( k < 5 ) then ! ! Use K-point derivative formula. ! Pick up first K points, in reverse order. ! do j = 1, k index = k-j+1 xtemp(j) = x(index) if ( j < k ) then stemp(j) = slope(index-1) end if end do d(1,1) = pchdf ( k, xtemp, stemp, ierf ) if ( ierf /= 0 ) then ierr = -1 call xerror ('pchce -- error return from pchdf', 32, ierr, 1) return end if else ! ! Use 'not a knot' condition. ! d(1,1) = ( 3.0E+00 * ( h(1) * slope(2) + h(2) * slope(1) ) & - 2.0E+00 * ( h(1) + h(2) ) * d(1,2) - h(1) * d(1,3) ) / h(2) end if ! ! Check d(1,1) for compatibility with monotonicity. ! if ( ibeg <= 0 ) then if ( slope(1) == 0.0E+00 ) then if ( d(1,1) /= 0.0E+00 ) then d(1,1) = 0.0E+00 ierr = ierr + 1 end if else if ( pchst ( d(1,1), slope(1) ) < 0.0E+00 ) then d(1,1) = 0.0E+00 ierr = ierr + 1 else if ( abs ( d(1,1) ) > 3.0E+00 * abs ( slope(1) ) ) then d(1,1) = 3.0E+00 * slope(1) ierr = ierr + 1 end if end if 2000 continue ! ! Treat end boundary condition. ! if ( iend == 0 ) then return end if k = abs ( iend ) if ( k == 1 ) then ! ! Boundary value provided. ! d(1,n) = vc(2) else if ( k == 2 ) then ! ! Boundary second derivative provided. ! d(1,n) = 0.5E+00 * ( (3.0E+00 * slope(n-1) - d(1,n-1)) & + 0.5E+00 * vc(2) * h(n-1) ) else if ( k < 5 ) then ! ! Use K-point derivative formula. Pick up last K points. ! do j = 1, k index = n - k + j xtemp(j) = x(index) if ( j < k ) then stemp(j) = slope(index) end if end do d(1,n) = pchdf ( k, xtemp, stemp, ierf ) if ( ierf /= 0 ) then ierr = -1 call xerror ('pchce -- error return from pchdf', 32, ierr, 1) return end if else ! ! Use 'not a knot' condition. ! d(1,n) = ( 3.0E+00 * ( h(n-1) * slope(n-2) + h(n-2) * slope(n-1) ) & - 2.0E+00 * ( h(n-1) + h(n-2)) * d(1,n-1) - h(n-1) * d(1,n-2) ) / h(n-2) end if if ( iend > 0 ) then return end if ! ! Check D(1,n) for compatibility with monotonicity. ! if ( slope(n-1) == 0.0E+00 ) then if ( d(1,n) /= 0.0E+00 ) then d(1,n) = 0.0E+00 ierr = ierr + 2 end if else if ( pchst ( d(1,n), slope(n-1) ) < 0.0E+00 ) then d(1,n) = 0.0E+00 ierr = ierr + 2 else if ( abs ( d(1,n) ) > 3.0E+00 * abs ( slope(n-1) ) ) then d(1,n) = 3.0E+00 * slope(n-1) ierr = ierr + 2 end if return end subroutine pchci ( n, h, slope, d, incfd ) ! !******************************************************************************* ! !! PCHCI sets derivatives for a monotone piecewise cubic Hermite interpolant. ! ! ! Discussion: ! ! Default boundary conditions are provided which are compatible ! with monotonicity. If the data are only piecewise monotonic, the ! interpolant will have an extremum at each point where monotonicity ! switches direction. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the D array. ! ! The resulting piecewise cubic Hermite function should be identical ! (within roundoff error) to that produced by PCHIM. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real H(N), interval lengths. H(I) = X(I+1)-X(I), for I = 1 ! to N-1. ! ! Input, real SLOPE(N), the data slopes. ! SLOPE(I) = ( Y(I+1) - Y(I) ) / H(I), for I = 1 to N-1. ! ! Output, real D(INCFD,N), the derivative values at the data points. ! If the data are monotonic, these values will determine a monotone ! cubic Hermite function. The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD). ! ! Input, integer INCFD, increment between successive values in D. ! This argument is provided primarily for 2D applications. ! implicit none ! integer incfd integer n ! real d(incfd,n) real del1 real del2 real dmax real dmin real drat1 real drat2 real h(n) real hsum real hsumt3 integer i integer nless1 real pchst real slope(n) real w1 real w2 ! nless1 = n - 1 del1 = slope(1) ! ! Special case N=2 -- use linear interpolation. ! if ( nless1 <= 1 ) then d(1,1) = del1 d(1,n) = del1 return end if ! ! Normal case, N >= 3. ! del2 = slope(2) ! ! Set D(1) via non-centered three-point formula, adjusted to be ! shape-preserving. ! hsum = h(1) + h(2) w1 = ( h(1) + hsum ) / hsum w2 = -h(1) / hsum d(1,1) = w1 * del1 + w2 * del2 if ( pchst ( d(1,1), del1 ) <= 0.0E+00 ) then d(1,1) = 0.0E+00 else if ( pchst ( del1, del2 ) < 0.0E+00 ) then ! ! Need do this check only if monotonicity switches. ! dmax = 3.0E+00 * del1 if ( abs ( d(1,1) ) > abs ( dmax ) ) then d(1,1) = dmax end if end if ! ! Loop through interior points. ! do i = 2, nless1 if ( i /= 2 ) then hsum = h(i-1) + h(i) del1 = del2 del2 = slope(i) end if ! ! Set D(I)=0 unless data are strictly monotonic. ! d(1,i) = 0.0E+00 ! ! Use Brodlie modification of Butland formula. ! if ( pchst ( del1, del2 ) > 0.0E+00 ) then hsumt3 = hsum + hsum + hsum w1 = ( hsum + h(i-1)) / hsumt3 w2 = ( hsum + h(i) ) / hsumt3 dmax = max ( abs ( del1 ), abs ( del2 ) ) dmin = min ( abs ( del1 ), abs ( del2 ) ) drat1 = del1 / dmax drat2 = del2 / dmax d(1,i) = dmin / ( w1 * drat1 + w2 * drat2 ) end if end do ! ! Set D(N) via non-centered three-point formula, adjusted to ! be shape-preserving. ! w1 = -h(n-1) / hsum w2 = ( h(n-1) + hsum ) / hsum d(1,n) = w1 * del1 + w2 * del2 if ( pchst ( d(1,n), del2 ) <= 0.0E+00 ) then d(1,n) = 0.0E+00 else if ( pchst ( del1, del2 ) < 0.0E+00 ) then dmax = 3.0E+00 * del2 if ( abs ( d(1,n) ) > abs ( dmax ) ) then d(1,n) = dmax end if end if return end subroutine pchcs ( switch, n, h, slope, d, incfd, ierr ) ! !******************************************************************************* ! !! PCHCS adjusts the curve produced by PCHIM so it is more "visually pleasing". ! ! ! Discussion: ! ! PCHCS is called by PCHIC to adjust the values of D in the vicinity of a ! switch in direction of monotonicity, to produce a more "visually ! pleasing" curve than that given by PCHIM. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, real SWITCH, indicates the amount of control desired over ! local excursions from data. ! ! Input, integer N, the number of data points. N must be at least 3. ! ! Input, real H(N), interval lengths. H(I) = X(I+1)-X(I), for I = 1 ! to N-1. ! ! Input, real SLOPE(N), the data slopes. ! SLOPE(I) = ( Y(I+1) - Y(I) ) / H(I), for I = 1 to N-1. ! ! Input/output, real D(N). On input, he derivative values at the data ! points, as determined by PCHIC. On output, derivatives in the vicinity ! of switches in direction of monotonicity may be adjusted to produce a ! more "visually pleasing" curve. The value corresponding to X(I) is ! stored in D(1+(I-1)*INCFD). ! ! Input, integer INCFD, increment between successive values in D. ! This argument is provided primarily for 2D applications. ! ! Output, integer IERR, error flag. ! 0, no errors. ! negative, trouble in PCHSW. ! implicit none ! integer incfd integer n ! real d(incfd,n) real del(3) real dext real dfloc real dfmx real fact real h(n) real, parameter :: fudge = 4.0E+00 integer i integer ierr integer indx integer k integer nless1 real pchst real slmax real slope(n) real switch real wtave(2) ! ! Define inline function for weighted average of slopes. ! real pchsd, s1, s2, h1, h2 pchsd ( s1, s2, h1, h2 ) = ( h2 / ( h1 + h2 ) ) * s1 + ( h1 / ( h1 + h2 ) ) * s2 ! ! Initialize. ! ierr = 0 nless1 = n - 1 ! ! Loop over segments. ! do i = 2, nless1 if ( pchst(slope(i-1),slope(i)) ) 100, 300, 900 100 continue ! ! Slope switches monotonicity at i-th point ! ! Do not change d if 'up-down-up'. ! if ( i > 2 ) then if ( pchst ( slope(i-2), slope(i) ) > 0.0E+00 ) then cycle end if end if if ( i < nless1 ) then if ( pchst ( slope(i+1), slope(i-1) ) > 0.0E+00 ) then cycle end if end if ! ! Compute provisional value for D(1,i). ! dext = pchsd ( slope(i-1), slope(i), h(i-1), h(i) ) ! ! Determine which interval contains the extremum. ! if ( pchst ( dext, slope(i-1) ) ) 200, 900, 250 200 continue ! ! DEXT and slope(i-1) have opposite signs -- ! extremum is in (x(i-1),x(i)). ! k = i-1 ! ! Set up to compute new values for D(1,i-1) and D(1,i). ! wtave(2) = dext if ( k > 1 ) then wtave(1) = pchsd (slope(k-1), slope(k), h(k-1), h(k)) end if go to 400 250 continue ! ! DEXT and SLOPE(I) have opposite signs. ! The extremum is in (x(i),x(i+1)). ! k = i ! ! Set up to compute new values for D(1,i) and D(1,i+1). ! wtave(1) = dext if ( k < nless1 ) then wtave(2) = pchsd ( slope(k), slope(k+1), h(k), h(k+1) ) end if go to 400 300 continue ! ! At least one of SLOPE(I-1) and slope(i) is zero. ! Check for flat-topped peak ! if ( i == nless1 ) then cycle end if if ( pchst ( slope(i-1), slope(i+1) ) >= 0.0E+00 ) then cycle end if ! ! We have flat-topped peak on (x(i),x(i+1)). ! k = i ! ! Set up to compute new values for d(1,i) and d(1,i+1). ! wtave(1) = pchsd ( slope(k-1), slope(k), h(k-1), h(k) ) wtave(2) = pchsd (slope(k), slope(k+1), h(k), h(k+1) ) 400 continue ! ! At this point we have determined that there will be an extremum ! on (x(k),x(k+1)), where k=i or i-1, and have set array wtave-- ! wtave(1) is a weighted average of slope(k-1) and slope(k), if k>1 ! wtave(2) is a weighted average of slope(k) and slope(k+1), if k 1 ) then slmax = max ( slmax, abs ( slope(k-1) ) ) end if if ( k < nless1 ) then slmax = max ( slmax, abs ( slope(k+1) ) ) end if if ( k > 1 ) then del(1) = slope(k-1) / slmax end if del(2) = slope(k) / slmax if ( k < nless1 ) then del(3) = slope(k+1) / slmax end if if ( k > 1 .and. k < nless1 ) then ! ! Normal case -- extremum is not in a boundary interval. ! fact = fudge * abs ( del(3) * ( del(1) - del(2) ) * ( wtave(2) / slmax ) ) d(1,k) = d(1,k) + min ( fact, 1.0E+00 ) * ( wtave(1) - d(1,k) ) fact = fudge * abs ( del(1) * ( del(3) - del(2) ) * ( wtave(1) / slmax ) ) d(1,k+1) = d(1,k+1) + min ( fact, 1.0E+00 ) * ( wtave(2) - d(1,k+1) ) else ! ! Special case K=1 (which can occur only if I=2) or ! k=nless1 (which can occur only if i=nless1). ! fact = fudge * abs ( del(2) ) d(1,i) = min ( fact, 1.0E+00 ) * wtave(i-k+1) ! ! Note that i-k+1 = 1 if k=i (=nless1), ! i-k+1 = 2 if k=i-1(=1). ! end if ! ! Adjust if necessary to limit excursions from data. ! if ( switch <= 0.0E+00 ) then cycle end if dfloc = h(k) * abs ( slope(k) ) if ( k > 1 ) then dfloc = max ( dfloc, h(k-1) * abs ( slope(k-1) ) ) end if if ( k < nless1 ) then dfloc = max ( dfloc, h(k+1) * abs ( slope(k+1) ) ) end if dfmx = switch * dfloc indx = i-k+1 ! ! INDX = 1 if K = I, ! INDX = 2 if K = I-1. ! call pchsw ( dfmx, indx, d(1,k), d(1,k+1), h(k), slope(k), ierr ) if ( ierr /= 0 ) then return end if 900 continue end do return end function pchdf ( k, x, s, ierr ) ! !******************************************************************************* ! !! PCHDF approximates a derivative using divided differences of data. ! ! ! Discussion: ! ! The routine uses a divided difference formulation to compute a K-point ! approximation to the derivative at X(K) based on the data in X and S. ! ! It is called by PCHCE and PCHSP to compute 3 and 4 point boundary ! derivative approximations. ! ! Reference: ! ! Carl de Boor, ! A Practical Guide to Splines, ! Springer-Verlag (new york, 1978), pp. 10-16. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer K, is the order of the desired derivative approximation. ! K must be at least 3. ! ! Input, real X(K), contains the K values of the independent variable. ! X need not be ordered, but the values must be distinct. ! ! Input/output, real S(K-1). On input, the associated slope values: ! S(I) = ( F(I+1)-F(I))/(X(I+1)-X(I)) ! On output, S is overwritten. ! ! Output, integer IERR, error flag. ! 0, no error. ! -1, if K < 2. ! ! Output, real PCHDF, the desired derivative approximation if ! IERR=0 or to zero if IERR=-1. ! implicit none ! integer k ! integer i integer ierr integer j real pchdf real s(k-1) real value real x(k) ! ! Check for legal value of K. ! if ( k < 3 ) then ierr = -1 call xerror ( 'pchdf -- k less than three', 26, ierr, 1 ) pchdf = 0.0E+00 return end if ! ! Compute coefficients of interpolating polynomial. ! do j = 2, k-1 do i = 1, k-j s(i) = ( s(i+1) - s(i) ) / ( x(i+j) - x(i) ) end do end do ! ! Evaluate the derivative at X(K). ! value = s(1) do i = 2, k-1 value = s(i) + value * ( x(k) - x(i) ) end do ierr = 0 pchdf = value return end subroutine pchev ( n, x, f, d, nval, xval, fval, dval, ierr ) ! !******************************************************************************* ! !! PCHEV evaluates a piecewise cubic Hermite or spline function. ! ! ! Discussion: ! ! PCHEV evaluates the function and first derivative of a piecewise ! cubic Hermite or spline function at an array of points XVAL. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Discussion: ! ! This routine evaluates the function and first derivative of the cubic ! Hermite or spline function at the array of points XVAL. ! ! The evaluation will be most efficient if the elements of XVAL are ! increasing relative to X; that is, for all K >= J, ! XVAL(J) >= X(I) ! implies ! XVAL(K) >= X(I). ! ! If any of the XVAL are outside the interval [X(1),X(N)], ! values are extrapolated from the nearest extreme cubic, ! and a warning error is returned. ! ! References ! ! Fred Fritsch and R Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! Fred Fritsch, ! Piecewise Cubic Hermite Interpolation Package, Final Specifications, ! Lawrence Livermore National Laboratory, ! Computer Documentation UCID-30194, August 1982. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(N), the function values. F(I) is the value corresponding ! to X(I). ! ! Input, real D(N), the derivative values. D(i) is the value corresponding ! to X(I). ! ! Input, integer NVAL, the number of points at which the functions are ! to be evaluated. ! ! Input, real XVAL(NVAL), the points at which the functions are to ! be evaluated. ! ! Output, real FVAL(NVAL), the values of the cubic Hermite function at XVAL. ! ! Output, real DVAL(NVAL), the derivatives of the cubic Hermite function at ! XVAL. ! ! Output, integer IERR, error flag. ! 0, no errors. ! positive, means that extrapolation was performed at IERR points. ! -1, if N < 2. ! -3, if the X array is not strictly increasing. ! -4, if NVAL < 1. ! -5, if an error has occurred in CHFDV. ! implicit none ! integer n integer nval ! real d(n) real dval(nval) real f(n) real fval(nval) integer ierr integer, save :: incfd = 1 logical, save :: skip = .true. real x(n) real xval(nval) ! call pchfd ( n, x, f, d, incfd, skip, nval, xval, fval, dval, ierr ) return end subroutine pchez ( n, x, f, d, spline, wk, lwk, ierr ) ! !******************************************************************************* ! !! PCHEZ carries out easy to use spline or cubic Hermite interpolation. ! ! ! Discussion: ! ! This routine sets derivatives for spline (two continuous derivatives) ! or Hermite cubic (one continuous derivative) interpolation. ! Spline interpolation is smoother, but may not "look" right if the ! data contains both "steep" and "flat" sections. Hermite cubics ! can produce a "visually pleasing" and monotone interpolant to ! monotone data. ! ! This routine is an easy to use driver for the PCHIP routines. ! Various boundary conditions are set to default values by PCHEZ. ! Many other choices are available in the subroutines PCHIC, ! PCHIM and PCHSP. ! ! Use PCHEV to evaluate the resulting function and its derivative. ! ! If SPLINE is TRUE, the interpolating spline satisfies the default ! "not-a-knot" boundary condition, with a continuous third derivative ! at X(2) and X(N-1). ! ! If SPLINE is FALSE, the interpolating Hermite cubic will be monotone ! if the input data is monotone. Boundary conditions are computed from ! the derivative of a local quadratic unless this alters monotonicity. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Fred Fritsch and R Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! Fred Fritsch and J Butland, ! A Method for Constructing Local Monotone Piecewise Cubic Interpolants, ! LLNL Preprint UCRL-87559, April 1982. ! ! Carl de Boor, ! A Practical Guide to Splines, Chapter IV, ! Springer-Verlag, ! New York, 1978. ! ! Fred Fritsch, ! Piecewise Cubic Hermite Interpolation Package, Final Specifications, ! Lawrence Livermore National Laboratory, ! Computer Documentation UCID-30194, August 1982. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(N), the function values. F(I) is the value corresponding ! to X(I). ! ! Output, real D(N), the derivative values at the data points. ! ! Input, logical SPLINE, specifies if the interpolant is to be a spline ! with two continuous derivaties (SPLINE is TRUE), or a Hermite cubic ! interpolant with one continuous derivative (SPLINE is FALSE). ! ! Workspace, real WK(LWK), required only if SPLINE is TRUE. ! ! Input, integer LWK, the length of the work array WK, which must ! be at least 2*N. However, WK is not needed if SPLINE is FALSE, ! and in this case LWK is arbitrary. ! ! Output, integer IERR, error flag. ! 0, no errors. ! positive, can only occur when SPLINE is FALSE, means that there were ! IERR switches in the direction of monotonicity. When SPLINE is ! FALSE, PCHEZ guarantees that if the input data is monotone, the ! interpolant will be too. This warning is to alert you to the fact ! that the input data was not monotone. ! -1, if N < 2. ! -3, if the X array is not strictly increasing. ! -7, if LWK is less than 2*N and SPLINE is TRUE. ! implicit none ! integer lwk integer n ! real d(n) real f(n) integer, save, dimension ( 2 ) :: ic = (/ 0, 0 /) integer ierr integer, parameter :: incfd = 1 logical spline real vc(2) real wk(lwk) real x(n) ! if ( spline ) then call pchsp ( ic, vc, n, x, f, d, incfd, wk, lwk, ierr ) else call pchim ( n, x, f, d, incfd, ierr ) end if return end subroutine pchfd ( n, x, f, d, incfd, skip, ne, xe, fe, de, ierr ) ! !******************************************************************************* ! !! PCHFD evaluates a piecewise cubic Hermite function. ! ! ! Discsussion: ! ! PCHFD evaluates a piecewise cubic Hermite function and its first ! derivative at an array of points. PCHFD may be used by itself ! for Hermite interpolation, or as an evaluator for PCHIM ! or PCHIC. ! ! PCHFD evaluates the cubic Hermite function and its first derivative ! at the points XE. ! ! If only function values are required, use PCHFE instead. ! ! To provide compatibility with PCHIM and PCHIC, includes an ! increment between successive values of the F and D arrays. ! ! Programming notes: ! ! Most of the coding between the call to CHFDV and the end of ! the IR loop could be eliminated if it were permissible to ! assume that XE is ordered relative to X. ! ! CHFDV does not assume that X1 is less than X2. Thus, it would ! be possible to write a version of PCHFD that assumes a strictly ! decreasing X array by simply running the IR loop backwards ! and reversing the order of appropriate tests. ! ! The present code has a minor bug, which I have decided is not ! worth the effort that would be required to fix it. ! If XE contains points in [X(N-1),X(N)], followed by points < ! X(N-1), followed by points > X(N), the extrapolation points ! will be counted (at least) twice in the total returned in IERR. ! ! The evaluation will be most efficient if the elements of XE are ! increasing relative to X; that is, for all K >= J, ! XE(J) >= X(I) ! implies ! XE(K) >= X(I). ! ! If any of the XE are outside the interval [X(1),X(N)], ! values are extrapolated from the nearest extreme cubic, ! and a warning error is returned. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(INCFD,N), the function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, real D(INCFD,N), the derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, integer INCFD, increment between successive values in F and D. ! ! Input/output, logical SKIP, controls whether data validity checks ! should be made. Setting the input value to FALSE will skip the checks. ! On output with IERR >= 0, SKIP will be set to TRUE. ! ! Input, integer NE, the number of evaluation points. ! ! Input, real XE(NE), points at which the function is to be evaluated. ! ! Output, real FE(NE), the values of the cubic Hermite function at XE. ! ! Output, real DE(NE), the derivative of the cubic Hermite function at XE. ! ! Output, integer IERR, error flag. ! 0, no errors. ! positive, means that extrapolation was performed at IERR points. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! -4, if NE < 1. ! -5, if an error has occurred in the lower-level routine CHFDV. ! implicit none ! integer incfd integer n integer ne ! real d(incfd,n) real de(ne) real f(incfd,n) real fe(ne) integer i integer ierc integer ierr integer ir integer j integer jfirst integer next(2) integer nj logical skip real x(n) real xe(ne) ! ! Check arguments. ! if ( .not. skip ) then if ( n < 2 ) then ierr = -1 call xerror ('pchfd -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchfd -- increment less than one', 32, ierr, 1) return end if do i = 2, n if ( x(i) <= x(i-1) ) then ierr = -3 call xerror ('pchfd -- x-array not strictly increasing', 40, ierr, 1) return end if end do end if if ( ne < 1 ) then ierr = -4 call xerror ('pchfd -- number of evaluation points less than one', 50, & ierr, 1) return end if ierr = 0 skip = .true. ! ! Loop over intervals. ! ( interval index is il = ir-1 . ) ! ( interval is x(il)<=x ne ) then return end if ! ! Locate all points in interval. ! do j = jfirst, ne if ( xe(j) >= x(ir) ) go to 30 end do j = ne + 1 go to 40 ! ! Have located first point beyond interval. ! 30 continue if ( ir == n ) then j = ne + 1 end if 40 continue nj = j - jfirst ! ! Skip evaluation if no points in interval. ! if ( nj == 0 ) go to 50 ! ! Evaluate cubic at xe(i), i = jfirst (1) j-1 . ! call chfdv ( x(ir-1), x(ir), f(1,ir-1), f(1,ir), d(1,ir-1), d(1,ir), & nj, xe(jfirst), fe(jfirst), de(jfirst), next, ierc) if ( ierc < 0 ) go to 5005 if ( next(2) == 0 ) go to 42 ! ! In the current set of XE-points, there are next(2) to the right of x(ir). ! if ( ir < n ) go to 41 ! ! These are actually extrapolation points. ! ierr = ierr + next(2) go to 42 41 continue ! ! We should never have gotten here. ! go to 5005 42 continue if ( next(1) == 0 ) go to 49 ! ! In the current set of xe-points, there are next(1) to the left of x(ir-1). ! if ( ir > 2 ) go to 43 ! ! These are actually extrapolation points. ! ierr = ierr + next(1) go to 49 43 continue ! ! XE is not ordered relative to x, so must adjust evaluation interval. ! ! First, locate first point to left of X(IR-1). ! do i = jfirst, j-1 if ( xe(i) < x(ir-1) ) go to 45 end do ! ! Cannot drop through here unless there is an error in chfdv. ! go to 5005 45 continue ! ! Reset J. This will be the new JFIRST. ! j = i ! ! Now find out how far to back up in the x-array. ! do i = 1, ir-1 if ( xe(j) < x(i) ) then exit end if end do ! ! Can never drop through here, since xe(j) X(N), the extrapolation points ! will be counted (at least) twice in the total returned in IERR. ! ! The evaluation will be most efficient if the elements of XE are ! increasing relative to X; that is, for all K >= J, ! XE(J) >= X(I) ! implies ! XE(K) >= X(I). ! ! If any of the XE are outside the interval [X(1),X(N)], ! values are extrapolated from the nearest extreme cubic, ! and a warning error is returned. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(INCFD,N), the function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, real D(INCFD,N), the derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, integer INCFD, increment between successive values in F and D. ! ! Input/output, logical SKIP, controls whether data validity checks ! should be made. Setting the input value to FALSE will skip the checks. ! On output with IERR >= 0, SKIP will be set to TRUE. ! ! Input, integer NE, the number of evaluation points. ! ! Input, real XE(NE), points at which the function is to be evaluated. ! ! Output, real FE(NE), the values of the cubic Hermite function at XE. ! ! Output, integer IERR, error flag. ! 0, no errors. ! positive, means that extrapolation was performed at IERR points. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! -4, if NE < 1. ! -5, error in CHFEV. ! implicit none ! integer incfd integer n integer ne ! real d(incfd,n) real f(incfd,n) real fe(ne) integer i integer ierc integer ierr integer ir integer j integer jfirst integer next(2) integer nj logical skip real x(n) real xe(ne) ! ! Check arguments. ! if ( .not. skip ) then if ( n < 2 ) then ierr = -1 call xerror ('pchfe -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchfe -- increment less than one', 32, ierr, 1) return end if do i = 2, n if ( x(i) <= x(i-1) ) then ierr = -3 call xerror ('pchfe -- x-array not strictly increasing', 40, ierr, 1) return end if end do end if if ( ne < 1 ) then ierr = -4 call xerror ('pchfe -- number of evaluation points less than one', 50, & ierr, 1 ) return end if ierr = 0 skip = .true. ! ! Loop over intervals. ! ( interval index is il = ir-1 . ) ! ( interval is x(il)<=x ne ) then return end if ! ! Locate all points in interval. ! do j = jfirst, ne if ( xe(j) >= x(ir) ) go to 30 end do j = ne + 1 go to 40 ! ! Have located first point beyond interval. ! 30 continue if ( ir == n ) then j = ne + 1 end if 40 continue nj = j - jfirst ! ! Skip evaluation if no points in interval. ! if ( nj == 0 ) go to 50 ! ! Evaluate cubic at xe(i), i = jfirst (1) j-1 . ! call chfev (x(ir-1),x(ir), f(1,ir-1),f(1,ir), d(1,ir-1),d(1,ir), & nj, xe(jfirst), fe(jfirst), next, ierc) if ( ierc < 0 ) go to 5005 if ( next(2) == 0 ) go to 42 ! ! In the current set of XE points, there are next(2) to the right of x(ir). ! if ( ir < n ) go to 41 ! ! These are actually extrapolation points. ! ierr = ierr + next(2) go to 42 41 continue ! ! We should never have gotten here. ! go to 5005 42 continue if ( next(1) == 0 ) go to 49 ! ! In the current set of xe-points, there are next(1) to the left of x(ir-1). ! if ( ir > 2 ) go to 43 ! ! These are actually extrapolation points. ! ierr = ierr + next(1) go to 49 43 continue ! ! XE is not ordered relative to X, so must adjust evaluation interval. ! ! First, locate first point to left of x(ir-1). ! do i = jfirst, j-1 if ( xe(i) < x(ir-1) ) go to 45 end do ! ! Cannot drop through here unless there is an error in CHFEV. ! go to 5005 45 continue ! ! Reset J. (this will be the new jfirst.) ! j = i ! ! Now find out how far to back up in the X array. ! do i = 1, ir-1 if ( xe(j) < x(i) ) go to 47 end do ! ! Can never drop through here, since xe(j)= 0, SKIP will be set to TRUE. ! ! Input, real A, B, the limits of integration. The integration interval ! is normally contained within [X(1),X(N)], but this is not required. ! ! Output, integer IERR, error flag. ! 0, no errors. ! 1, if A is outside the interval [X(1),X(N)]. ! 2, if B is outside the interval [X(1),X(N)]. ! 3, if both of the above are true. This means that either [A,B] contains ! the data interval or the intervals do not intersect at all. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! implicit none ! integer incfd integer n ! real a real b real chfiv real d(incfd,n) real f(incfd,n) integer i integer ia integer ib integer ierd integer ierr integer ierv integer il integer ir real pchia real pchid logical skip real value real x(n) real xa real xb ! ! Check arguments. ! if ( .not. skip ) then if ( n < 2 ) then ierr = -1 call xerror ('pchia -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchia -- increment less than one', 32, ierr, 1) return end if do i = 2, n if ( x(i) <= x(i-1) ) then ierr = -3 call xerror ('pchia -- x-array not strictly increasing', 40, ierr, 1) return end if end do skip = .true. end if ierr = 0 if ( a < x(1) .or. a > x(n) ) then ierr = ierr + 1 end if if ( b < x(1) .or. b > x(n) ) then ierr = ierr + 2 end if ! ! Compute integral value. ! if ( a == b ) then value = 0.0E+00 else xa = min (a, b) xb = max (a, b) if ( xb <= x(2) ) then ! ! Interval is to left of X(2), so use first cubic. ! value = chfiv ( x(1), x(2), f(1,1),f(1,2), & d(1,1),d(1,2), a, b, ierv) if ( ierv < 0 ) then ierr = -4 call xerror ('pchia -- trouble in chfiv', 25, ierr, 1) return end if else if ( xa >= x(n-1) ) then ! ! Interval is to right of x(n-1), so use last cubic. ! value = chfiv ( x(n-1), x(n), f(1,n-1), f(1,n), & d(1,n-1), d(1,n), a, b, ierv ) if ( ierv < 0 ) then ierr = -4 call xerror ('pchia -- trouble in chfiv', 25, ierr, 1) return end if else ! ! Normal case -- xax(2). ! ! Locate ia and ib such that ! x(ia-1) < xa <= x(ia) <= x(ib) <= xb <= x(ib+1) ! ia = 1 do i = 1, n-1 if ( xa > x(i) ) ia = i + 1 end do ! ! IA = 1 implies xa X(N). Otherwise, ! ib is smallest index such that xb x(ib) ) then ir = min ( ib+1, n ) il = ir - 1 value = value + chfiv ( x(il), x(ir), f(1,il), f(1,ir), & d(1,il), d(1,ir), x(ib), xb, ierv ) if ( ierv < 0 ) then ierr = -4 call xerror ('pchia -- trouble in chfiv', 25, ierr, 1) return end if end if ! ! Adjust sign if necessary. ! if ( a > b ) then value = -value end if end if end if end if pchia = value return ! ! error returns. ! 5005 continue ! trouble in pchid. (should never occur.) ierr = -5 call xerror ('pchia -- trouble in pchid', 25, ierr, 1) return end subroutine pchic ( ic, vc, switch, n, x, f, d, incfd, wk, nwk, ierr ) ! !******************************************************************************* ! !! PCHIC sets derivatives for a piecewise monotone cubic Hermite interpolant. ! ! ! Description: ! ! PCHIC sets derivatives needed to determine a piecewise-monotone ! piecewise-cubic Hermite interpolant to the data given in X and F ! satisfying the boundary conditions specified by IC and VC. ! ! The treatment of points where monotonicity switches direction is ! controlled by argument switch. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by PCHFE or PCHFD. ! ! User control is available over boundary conditions and ! treatment of points where monotonicity switches direction. ! ! References: ! ! Fred Fritsch and R Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! Fred Fritsch and J Butland, ! A Method for Constructing Local Monotone Piecewise Cubic Interpolants, ! LLNL Preprint UCRL-87559, April 1982. ! ! Fred Fritsch, ! Piecewise Cubic Hermite Interpolation Package, Final Specifications, ! Lawrence Livermore National Laboratory, ! Computer Documentation UCID-30194, August 1982. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer IC(2), specifies desired boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! IC(2) = IEND, desired condition at end of data. ! ! IBEG = 0 for the default boundary condition (the same as used by PCHIM). ! If IBEG/=0, then its sign indicates whether the boundary derivative is ! to be adjusted, if necessary, to be compatible with monotonicity: ! IBEG > 0, if no adjustment is to be performed. ! IBEG < 0, if the derivative is to be adjusted for monotonicity. ! ! Allowable values for the magnitude of IBEG are: ! 1, if first derivative at x(1) is given in VC(1). ! 2, if second derivative at x(1) is given in VC(1). ! 3, to use the 3-point difference formula for D(1). ! This reverts to the default boundary condition if N < 3. ! 4, to use the 4-point difference formula for D(1). ! This reverts to the default boundary condition if N < 4. ! 5, to set D(1) so that the second derivative is continuous at X(2). ! This reverts to the default boundary condition if N < 4. ! This option is somewhat analogous to the "not a knot" ! boundary condition provided by PCHSP. ! ! An error return is taken if |IBEG| > 5 . ! Only in case IBEG <= 0 is it guaranteed that the interpolant will be ! monotonic in the first interval. If the returned value of D(1) lies ! between zero and 3 * SLOPE(1), the interpolant will be monotonic. This ! is not checked if IBEG > 0. ! If IBEG < 0 and D(1) had to be changed to achieve monotonicity, a ! warning error is returned. ! ! IEND may take on the same values as IBEG, but applied to the derivative ! at X(N). In case IEND = 1 or 2, the value is given in VC(2). ! ! An error return is taken if |IEND| > 5 . ! Only in case IEND <= 0 is it guaranteed that the interpolant will be ! monotonic in the last interval. If the returned value of ! D(1+(N-1)*INCFD) lies between zero and 3 * SLOPE(N-1), the interpolant ! will be monotonic. This is not checked if IEND > 0. ! If IEND < 0 and D(1+(N-1)*INCFD) had to be changed to achieve ! monotonicity, a warning error is returned. ! ! Input, real VC(2), specifies desired boundary values, as indicated above. ! VC(1) need be set only if IC(1) = 1 or 2. ! VC(2) need be set only if IC(2) = 1 or 2. ! ! Input, integer SWITCH, indicates the desired treatment of points where ! the direction of monotonicity switches: ! * set SWITCH to zero if the interpolant is required to be monotonic in ! each interval, regardless of monotonicity of data. This will cause D ! to be set to zero at all switch points, thus forcing extrema there. ! The result of using this option with the default boundary conditions ! will be identical to using PCHIM, but will generally cost more ! compute time. This option is provided only to facilitate comparison ! of different switch and/or boundary conditions. ! * set SWITCH nonzero to use a formula based on the 3-point difference ! formula in the vicinity of switch points. If SWITCH is positive, the ! interpolant on each interval containing an extremum is controlled to ! not deviate from the data by more than SWITCH * DFLOC, where DFLOC is the ! maximum of the change of F on this interval and its two immediate ! neighbors. If SWITCH is negative, no such control is to be imposed. ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(INCFD,N), the dependent values to be interpolated. ! F(1+(I-1)*INCFD) is the value corresponding to X(I). ! ! Output, real D(INCFD,N), the derivative values at the data points. ! These values will determine a monotone cubic Hermite function on each ! subinterval on which the data are monotonic, except possibly adjacent ! to switches in monotonicity. The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD). ! ! Input, integer INCFD, increment between successive values in F and D. ! ! Workspace, real WK(NWK). The user may wish to know that the returned ! values, for I = 1 to N-1, are: ! WK(I) = H(I) = X(I+1) - X(I) ! WK(N-1+I) = SLOPE(I) = ( F(1,I+1) - F(1,I)) / H(I) ! ! Input, integer NWK, the length of the work array, which must be at ! least 2 * ( N - 1 ). ! ! Output, integer IERR, error flag. ! 0, no errors. ! 1, if IBEG < 0 and D(1) had to be adjusted for monotonicity. ! 2, if IEND < 0 and D(1+(N-1)*INCFD) had to be adjusted for monotonicity. ! 3, if both of the above are true. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! -4, if abs ( IBEG ) > 5. ! -5, if abs ( IEND ) > 5. ! -6, if both of the above are true. ! -7, if NWK < 2 * ( N - 1 ). ! implicit none ! integer incfd integer n integer nwk ! real d(incfd,n) real f(incfd,n) integer i integer ibeg integer ic(2) integer iend integer ierr integer nless1 real switch real vc(2) real wk(nwk) real x(n) ! if ( n < 2 ) then ierr = -1 call xerror ('pchic -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchic -- increment less than one', 32, ierr, 1) return end if do i = 2, n if ( x(i) <= x(i-1) ) then ierr = -3 call xerror ('pchic -- x-array not strictly increasing', 40, ierr, 1) return end if end do ibeg = ic(1) iend = ic(2) ierr = 0 if ( abs ( ibeg ) > 5 ) then ierr = ierr - 1 end if if ( abs ( iend ) > 5 ) then ierr = ierr - 2 end if if ( ierr < 0 ) then ierr = ierr - 3 call xerror ('pchic -- ic out of range', 24, ierr, 1) return end if ! ! Function definition is ok -- go on. ! nless1 = n - 1 if ( nwk < 2 * nless1 ) then ierr = -7 call xerror ('pchic -- work array too small', 29, ierr, 1) return end if ! ! Set up H and slope arrays. ! do i = 1, nless1 wk(i) = x(i+1) - x(i) wk(nless1+i) = (f(1,i+1) - f(1,i)) / wk(i) end do ! ! Special case n=2 -- use linear interpolation. ! if ( nless1 > 1 ) go to 1000 d(1,1) = wk(2) d(1,n) = wk(2) go to 3000 ! ! Normal case (n >= 3) . ! 1000 continue ! ! Set interior derivatives and default end conditions. ! call pchci ( n, wk(1), wk(n), d, incfd ) ! ! Set derivatives at points where monotonicity switches direction. ! if ( switch /= 0.0E+00 ) then call pchcs (switch, n, wk(1), wk(n), d, incfd, ierr) if ( ierr /= 0 ) then ierr = -8 call xerror ('pchic -- error return from pchcs', 32, ierr, 1) return end if end if ! ! Set end conditions. ! 3000 continue if ( ibeg == 0 .and. iend == 0 ) then return end if call pchce ( ic, vc, n, x, wk(1), wk(n), d, incfd, ierr ) if ( ierr < 0 ) then ierr = -9 call xerror ('pchic -- error return from pchce', 32, ierr, 1) return end if return end function pchid ( n, x, f, d, incfd, skip, ia, ib, ierr ) ! !******************************************************************************* ! !! PCHID evaluates the definite integral of a piecewise cubic Hermite function. ! ! ! Description: ! ! PCHID evaluates the definite integral of a cubic Hermite function ! over the interval [X(IA), X(IB)]. The endpoints of the integration ! interval must be data points. ! ! To provide compatibility with PCHIM and pchic, includes an ! increment between successive values of the F and D arrays. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(INCFD,N), the function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, real F(INCFD,N), the derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, integer INCFD, increment between successive values in F and D. ! ! Input/output, logical SKIP, should be set to TRUE if the user wishes to ! skip checks for validity of preceding parameters, or to FALSE otherwise. ! This will save time in case these checks have already been performed ! say, in PCHIM or PCHIC. SKIP will be set to TRUE on return with ! IERR = 0 or -4. ! ! Input, integer IA, IB, the indices in the X array for the limits of ! integration. Both must be in the range [1,N]. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! -4, if IA or IB is out of range. ! ! Output, real PCHID, the value of the requested integral. ! implicit none ! integer incfd integer n ! real d(incfd,n) real f(incfd,n) real h integer i integer ia integer ib integer ierr integer iup integer low real pchid logical skip real sum2 real value real x(n) ! if ( .not. skip ) then if ( n < 2 ) then ierr = -1 call xerror ('pchid -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchid -- increment less than one', 32, ierr, 1) return end if do i = 2, n if ( x(i) <= x(i-1) ) then ierr = -3 call xerror ('pchid -- x-array not strictly increasing', 40, ierr, 1) return end if end do end if skip = .true. if ( ia < 1 .or. ia > n ) then go to 5004 end if if ( ib < 1 .or. ib > n ) then go to 5004 end if ierr = 0 ! ! Compute integral value. ! if ( ia == ib ) then value = 0.0E+00 else low = min ( ia, ib ) iup = max ( ia, ib ) - 1 sum2 = 0.0E+00 do i = low, iup h = x(i+1) - x(i) sum2 = sum2 + h * ( ( f(1,i) + f(1,i+1) ) + ( d(1,i) - d(1,i+1) ) * ( h / 6.0E+00 ) ) end do value = 0.5E+00 * sum2 if ( ia > ib ) then value = -value end if end if pchid = value return ! ! error returns. ! 5004 continue ! ia or ib out of range return. ierr = -4 call xerror ('pchid -- ia or ib out of range', 30, ierr, 1) return end subroutine pchim ( n, x, f, d, incfd, ierr ) ! !******************************************************************************* ! !! PCHIM sets derivatives for a piecewise cubic Hermite interpolant. ! ! ! Discussion: ! ! The routine set derivatives needed to determine a monotone piecewise ! cubic Hermite interpolant to given data. The interpolant will have ! an extremum at each point where monotonicity switches direction. ! See PCHIC if user control is desired over boundary or switch conditions. ! ! If the data are only piecewise monotonic, the interpolant will ! have an extremum at each point where monotonicity switches direction. ! See PCHIC if user control is desired in such cases. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by PCHFE or PCHFD. ! ! References: ! ! Fred Fritsch and R Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! Fred Fritsch and J Butland, ! A Method for Constructing Local Monotone Piecewise Cubic Interpolants, ! LLNL Preprint UCRL-87559, April 1982. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(INCFD,N), dependent variable values to be interpolated. ! F(1+(I-1)*INCFD) is the value corresponding to X(I). PCHIM is designed ! for monotonic data, but it will work for any F-array. It will force ! extrema at points where monotonicity switches direction. If some other ! treatment of switch points is desired, PCHIC should be used instead. ! ! Output, real D(INCFD,N), the derivative values at the data points. ! If the data are monotonic, these values will determine a monotone ! cubic Hermite function. The value corresponding to X(I) is stored in ! D(1+(I-1)*INCFD). ! ! Input, integer INCFD, increment between successive values in F and D. ! ! Output, integer IERR, error flag. ! 0, no errors. ! positive, means that IERR switches in the direction of monotonicity ! were detected. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! implicit none ! integer incfd integer n ! real d(incfd,n) real del1 real del2 real dmax real dmin real drat1 real drat2 real dsave real f(incfd,n) real h1 real h2 real hsum real hsumt3 integer i integer ierr integer nless1 real pchst real w1 real w2 real x(n) ! ! Check arguments. ! if ( n < 2 ) then ierr = -1 call xerror ('pchim -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchim -- increment less than one', 32, ierr, 1) return end if do i = 2, n if ( x(i) <= x(i-1) ) then ierr = -3 call xerror ('pchim -- x-array not strictly increasing', 40, ierr, 1) return end if end do ierr = 0 nless1 = n - 1 h1 = x(2) - x(1) del1 = ( f(1,2) - f(1,1) ) / h1 dsave = del1 ! ! Special case N=2 -- use linear interpolation. ! if ( n == 2 ) then d(1,1) = del1 d(1,n) = del1 return end if ! ! Normal case, N >= 3. ! h2 = x(3) - x(2) del2 = ( f(1,3) - f(1,2) ) / h2 ! ! Set D(1) via non-centered three-point formula, adjusted to be ! shape-preserving. ! hsum = h1 + h2 w1 = ( h1 + hsum ) / hsum w2 = -h1 / hsum d(1,1) = w1 * del1 + w2 * del2 if ( pchst ( d(1,1), del1 ) <= 0.0E+00 ) then d(1,1) = 0.0E+00 else if ( pchst ( del1, del2 ) < 0.0E+00 ) then ! ! Need do this check only if monotonicity switches. ! dmax = 3.0E+00 * del1 if ( abs ( d(1,1) ) > abs ( dmax ) ) then d(1,1) = dmax end if end if ! ! Loop through interior points. ! do i = 2, nless1 if ( i > 2 ) then h1 = h2 h2 = x(i+1) - x(i) hsum = h1 + h2 del1 = del2 del2 = ( f(1,i+1) - f(1,i) ) / h2 end if ! ! Set D(I)=0 unless data are strictly monotonic. ! d(1,i) = 0.0E+00 if ( pchst ( del1, del2 ) ) 42, 41, 45 ! ! Count number of changes in direction of monotonicity. ! 41 continue if ( del2 /= 0.0E+00 ) then if ( pchst ( dsave, del2 ) < 0.0E+00 ) then ierr = ierr + 1 end if dsave = del2 end if go to 50 42 continue ierr = ierr + 1 dsave = del2 go to 50 ! ! Use Brodlie modification of Butland formula. ! 45 continue hsumt3 = 3.0E+00 * hsum w1 = ( hsum + h1 ) / hsumt3 w2 = ( hsum + h2 ) / hsumt3 dmax = max ( abs ( del1 ), abs ( del2 ) ) dmin = min ( abs ( del1 ), abs ( del2 ) ) drat1 = del1 / dmax drat2 = del2 / dmax d(1,i) = dmin / ( w1 * drat1 + w2 * drat2 ) 50 continue end do ! ! Set D(N) via non-centered three-point formula, adjusted to be ! shape-preserving. ! w1 = -h2 / hsum w2 = ( h2 + hsum ) / hsum d(1,n) = w1 * del1 + w2 * del2 if ( pchst ( d(1,n), del2 ) <= 0.0E+00 ) then d(1,n) = 0.0E+00 else if ( pchst(del1,del2) < 0.0E+00 ) then ! ! Need do this check only if monotonicity switches. ! dmax = 3.0E+00 * del2 if ( abs ( d(1,n) ) > abs ( dmax ) ) then d(1,n) = dmax end if end if return end subroutine pchmc ( n, x, f, d, incfd, skip, ismon, ierr ) ! !******************************************************************************* ! !! PCHMC: piecewise cubic Hermite monotonicity checker. ! ! ! Discussion: ! ! PCHMC checks a cubic Hermite function for monotonicity. ! ! To provide compatibility with PCHIM and PCHIC, includes an ! increment between successive values of the F and D arrays. ! ! Reference: ! ! Fred Fritsch and R Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(INCFD,N), the function values. F(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, real D(INCFD,N), the derivative values. D(1+(I-1)*INCFD) is ! the value corresponding to X(I). ! ! Input, integer INCFD, increment between successive values in F and D. ! ! Input/output, logical SKIP. On input, should be set to TRUE if the ! user wishes to skip checks for validity of preceding parameters, or ! to FALSE otherwise. This will save time in case these checks have ! already been performed. SKIP will be set to TRUE on normal return. ! ! Output, integer ISMON(N), indicates the intervals on which the ! piecewise cubic Hermite function is monotonic. ! For data interval [X(I),X(I+1)], and 1 <= I <= N-1, ISMON(I) is ! -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. This means that the D values are near the ! boundary of the monotonicity region. A small increase produces ! non-monotonicity; decrease, strict monotonicity. ! ISMON(N) indicates whether the entire function is monotonic on [X(1),X(N)]. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! implicit none ! integer incfd integer n ! real chfmc real d(incfd,n) real delta real f(incfd,n) integer i integer ierr integer ismon(n) integer nseg logical skip real x(n) ! if ( .not. skip ) then if ( n < 2 ) then ierr = -1 call xerror ('pchmc -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchmc -- increment less than one', 32, ierr, 1) return end if do i = 2, n if ( x(i) <= x(i-1) ) then ierr = -3 call xerror ('pchmc -- x-array not strictly increasing', 40, ierr, 1) return end if end do skip = .true. end if nseg = n - 1 do i = 1, nseg delta = ( f(1,i+1) - f(1,i) ) / ( x(i+1) - x(i) ) ismon(i) = chfmc ( d(1,i), d(1,i+1), delta ) if ( i == 1 ) then ismon(n) = ismon(1) else ! ! Need to figure out cumulative monotonicity from 'multiplication table'-- ! ! * i s m o n (i) ! * -1 0 1 2 3 ! i *--------------------* ! s -1 i -1 -1 2 2 3 i ! m 0 i -1 0 1 2 3 i ! o 1 i 2 1 1 2 3 i ! n 2 i 2 2 2 2 2 i ! (n) 3 i 3 3 3 2 3 i ! *--------------------* ! ! If equal or already declared nonmonotonic, no change needed. ! if ( ismon(i) /= ismon(n) .and. ismon(n) /= 2 ) then if ( max ( ismon(i), ismon(n) ) > 1 ) then ! ! At least one is either 'no' or 'maybe'. ! if ( ismon(i) == 2 ) then ismon(n) = 2 else ismon(n) = 3 end if else if ( ismon(i) * ismon(n) < 0 ) then ! ! Both monotonic, but in opposite senses. ! ismon(n) = 2 else ! ! At this point, one is zero, the other is +-1. ! ismon(n) = ismon(n) + ismon(i) end if end if end if end do ierr = 0 return end function pchqa ( n, x, f, d, a, b, ierr ) ! !******************************************************************************* ! !! PCHQA: easy to use cubic Hermite or spline integration. ! ! ! Discussion: ! ! PCHQA evaluates the definite integral of a cubic Hermite or spline ! function over the interval [A, B]. This is an easy to use driver ! for the routine PCHIA. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Fred Fritsch and R Carlson, ! Monotone Piecewise Cubic Interpolation, ! SIAM Journal on Numerical Analysis, ! Volume 17, Number 2, April 1980, pages 238-246. ! ! Fred Fritsch, ! Piecewise Cubic Hermite Interpolation Package, Final Specifications, ! Lawrence Livermore National Laboratory, ! Computer Documentation UCID-30194, August 1982. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(N), the function values. F(I) is the value ! corresponding to X(I). ! ! Input, real D(N), the derivative values. D(I) is the value ! corresponding to X(I). ! ! Input, real A, B, the limits of integration. The interval [A,B] is ! normally contained in [X(1),X(N)], but this is not required. ! ! Output, integer IERR, error flag. ! 0, no errors). ! 1, if A is outside the interval [X(1),X(N)]. ! 2, if B is outside the interval [X(1),X(N)]. ! 3, if both of the above are true. This means that either [A,B] contains ! the data interval or the intervals do not intersect at all. ! -1, if N < 2 . ! -3, if the X array is not strictly increasing. ! ! Output, real PCHQA, the value of the requested integral. ! implicit none ! integer n ! real a real b real d(n) real f(n) integer ierr integer, save :: incfd = 1 real pchia real pchqa logical, save :: skip = .true. real x(n) ! pchqa = pchia ( n, x, f, d, incfd, skip, a, b, ierr ) return end subroutine pchsp ( ic, vc, n, x, f, d, incfd, wk, nwk, ierr ) ! !******************************************************************************* ! !! PCHSP sets derivatives for Hermite representation of cubic spline interpolant. ! ! ! Description: ! ! PCHSP sets derivatives needed to determine the Hermite representation ! of the cubic spline interpolant to given data, with specified boundary ! conditions. ! ! To facilitate two-dimensional applications, includes an increment ! between successive values of the F and D arrays. ! ! The resulting piecewise cubic Hermite function may be evaluated ! by PCHFE or PCHFD. ! ! This is a modified version of Carl de Boor's cubic spline routine CUBSPL. ! ! Reference: ! ! Carl de Boor, ! A Practical Guide to Splines, ! Springer-Verlag (new york, 1978). ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, integer IC(2), specifies desired boundary conditions: ! IC(1) = IBEG, desired condition at beginning of data. ! 0, to set D(1) so that the third derivative is continuous at X(2). ! This is the "not a knot" condition provided by de Boor's cubic spline ! routine CUBSPL, and is the default boundary condition here. ! 1, if first derivative at X(1) is given in VC(1). ! 2, if second derivative at X(1) is given in VC(1). ! 3, to use the 3-point difference formula for D(1). ! Reverts to the default boundary condition if N < 3. ! 4, to use the 4-point difference formula for D(1). ! Reverts to the default boundary condition if N < 4. ! For the "natural" boundary condition, use ibeg=2 and vc(1)=0. ! IC(2) = IEND, desired condition at end of data. ! IEND may take on the same values as IBEG, but applied to derivative at ! X(N). In case IEND = 1 or 2, the value is given in VC(2). ! ! Input, real VC(2), specifies desired boundary values, as indicated above. ! VC(1) need be set only if IC(1) = 1 or 2. ! VC(2) need be set only if IC(2) = 1 or 2. ! ! Input, integer N, the number of data points. N must be at least 2. ! ! Input, real X(N), the strictly increasing independent variable values. ! ! Input, real F(INCFD,N), the dependent values to be interpolated. ! F(1+(I-1)*INCFD) is the value corresponding to X(I). ! ! Output, real D(INCFD,N), the derivative values at the data points. ! These values will determine the cubic spline interpolant with the ! requested boundary conditions. The value corresponding to X(I) is ! stored in D(1+(I-1)*INCFD). ! ! Input, integer INCFD, increment between successive values in F and D. ! ! Workspace, real WK(NWK). ! ! Input, integer NWK, the size of WK, which must be at least 2 * N. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, if N < 2. ! -2, if INCFD < 1. ! -3, if the X array is not strictly increasing. ! -4, if IBEG < 0 or IBEG > 4. ! -5, if IEND < 0 or IEND > 4. ! -6, if both of the above are true. ! -7, if NWK is too small. ! -8, in case of trouble solving the linear system ! for the interior derivative values. ! implicit none ! integer incfd integer n ! real d(incfd,n) real f(incfd,n) real g integer ibeg integer ic(2) integer iend integer ierr integer index integer j integer nwk real pchdf real stemp(3) real vc(2) real wk(2,n) real x(n) real xtemp(4) ! if ( n < 2 ) then ierr = -1 call xerror ('pchsp -- number of data points less than two', 44, ierr, 1) return end if if ( incfd < 1 ) then ierr = -2 call xerror ('pchsp -- increment less than one', 32, ierr, 1) return end if do j = 2, n if ( x(j) <= x(j-1) ) then ierr = -3 call xerror ('pchsp -- x-array not strictly increasing', 40, ierr, 1) return end if end do ibeg = ic(1) iend = ic(2) ierr = 0 if ( ibeg < 0 .or. ibeg > 4 ) ierr = ierr - 1 if ( iend < 0 .or. iend > 4 ) ierr = ierr - 2 if ( ierr < 0 ) go to 5004 ! ! Function definition is ok -- go on. ! if ( nwk < 2 * n ) go to 5007 ! ! Compute first differences of X sequence and store in wk(1,.). also, ! compute first divided difference of data and store in wk(2,.). ! do j = 2, n wk(1,j) = x(j) - x(j-1) wk(2,j) = ( f(1,j) - f(1,j-1) ) / wk(1,j) end do ! ! Set to default boundary conditions if N is too small. ! if ( ibeg > n ) ibeg = 0 if ( iend > n ) iend = 0 ! ! Set up for boundary conditions. ! if ( ibeg == 1 .or. ibeg == 2 ) then d(1,1) = vc(1) else if ( ibeg > 2 ) then ! ! Pick up first IBEG points, in reverse order. ! do j = 1, ibeg index = ibeg-j+1 xtemp(j) = x(index) if ( j < ibeg ) then stemp(j) = wk(2,index) end if end do d(1,1) = pchdf ( ibeg, xtemp, stemp, ierr ) if ( ierr /= 0 ) then go to 5009 end if ibeg = 1 end if if ( iend == 1 .or. iend == 2 ) then d(1,n) = vc(2) else if ( iend > 2 ) then ! ! Pick up last IEND points. ! do j = 1, iend index = n - iend + j xtemp(j) = x(index) if ( j < iend ) then stemp(j) = wk(2,index+1) end if end do d(1,n) = pchdf ( iend, xtemp, stemp, ierr ) if ( ierr /= 0 ) then go to 5009 end if iend = 1 end if ! ! Begin coding from cubspl ! ! A tridiagonal linear system for the unknown slopes S(1:N) of ! F at X(1:N) is generated and then solved by Gauss elimination, ! with s(j) ending up in d(1,j), all j. ! wk(1,.) and wk(2,.) are used for temporary storage. ! ! Construct first equation from first boundary condition, of the form ! wk(2,1) * s(1) + wk(1,1) * s(2) = D(1,1) ! if ( ibeg == 0 ) then if ( n == 2 ) then ! ! No condition at left end and N = 2. ! wk(2,1) = 1.0E+00 wk(1,1) = 1.0E+00 d(1,1) = 2.0E+00 * wk(2,2) else ! ! Not-a-knot condition at left end and N > 2. ! wk(2,1) = wk(1,3) wk(1,1) = wk(1,2) + wk(1,3) d(1,1) =(( wk(1,2) + 2.0E+00 * wk(1,1) ) * wk(2,2) * wk(1,3) & + wk(1,2)**2 * wk(2,3)) / wk(1,1) end if else if ( ibeg == 1 ) then ! ! Slope prescribed at left end. ! wk(2,1) = 1.0E+00 wk(1,1) = 0.0E+00 else ! ! Second derivative prescribed at left end. ! wk(2,1) = 2.0E+00 wk(1,1) = 1.0E+00 d(1,1) = 3.0E+00 * wk(2,2) - 0.5E+00 * wk(1,2) * d(1,1) end if ! ! If there are interior knots, generate the corresponding equations and ! carry out the forward pass of Gauss elimination, after which the J-th ! equation reads ! ! wk(2,j) * s(j) + wk(1,j) * s(j+1) = d(1,j). ! if ( n-1 > 1 ) then do j = 2, n-1 if ( wk(2,j-1) == 0.0E+00 ) go to 5008 g = -wk(1,j+1) / wk(2,j-1) d(1,j) = g * d(1,j-1) + 3.0E+00 * ( wk(1,j) * wk(2,j+1) + wk(1,j+1) * wk(2,j) ) wk(2,j) = g * wk(1,j-1) + 2.0E+00 * ( wk(1,j) + wk(1,j+1) ) end do end if ! ! Construct last equation from second boundary condition, of the form ! ! (-g * wk(2,n-1)) * s(n-1) + wk(2,n) * s(n) = d(1,n) ! ! If slope is prescribed at right end, one can go directly to back- ! substitution, since arrays happen to be set up just right for it ! at this point. ! if ( iend == 1 ) then go to 30 end if if ( iend == 0 ) then if ( n == 2 .and. ibeg == 0 ) then ! ! Not-a-knot at right endpoint and at left endpoint and N = 2. ! d(1,2) = wk(2,2) go to 30 else if ( n == 2 .or. ( n == 3 .and. ibeg == 0 ) ) then ! ! Either ( N = 3 and not-a-knot also at left) or (N=2 and *not* ! not-a-knot at left end point). ! d(1,n) = 2.0E+00 * wk(2,n) wk(2,n) = 1.0E+00 if ( wk(2,n-1) == 0.0E+00 ) then go to 5008 end if g = -1.0E+00 / wk(2,n-1) else ! ! Not-a-knot and N >= 3, and either N > 3 or also not-a- ! knot at left end point. ! g = wk(1,n-1) + wk(1,n) ! ! Do not need to check following denominators (x-differences). ! d(1,n) = ( ( wk(1,n) + 2.0E+00 * g ) * wk(2,n) * wk(1,n-1) & + wk(1,n)**2 * ( f(1,n-1) - f(1,n-2) ) / wk(1,n-1) ) / g if ( wk(2,n-1) == 0.0E+00 ) go to 5008 g = -g / wk(2,n-1) wk(2,n) = wk(1,n-1) end if else ! ! Second derivative prescribed at right endpoint. ! d(1,n) = 3.0E+00 *wk(2,n) + 0.5E+00 * wk(1,n) * d(1,n) wk(2,n) = 2.0E+00 if ( wk(2,n-1) == 0.0E+00 ) then go to 5008 end if g = -1.0E+00 / wk(2,n-1) end if ! ! Complete forward pass of Gauss elimination. ! wk(2,n) = g * wk(1,n-1) + wk(2,n) if ( wk(2,n) == 0.0E+00 ) then go to 5008 end if d(1,n) = ( g * d(1,n-1) + d(1,n) ) / wk(2,n) ! ! Carry out back substitution. ! 30 continue do j = n-1, 1, -1 if ( wk(2,j) == 0.0E+00 ) then go to 5008 end if d(1,j) = ( d(1,j) - wk(1,j) * d(1,j+1) ) / wk(2,j) end do return ! ! error returns. ! 5004 continue ! ! ic out of range return. ! ierr = ierr - 3 call xerror ('pchsp -- ic out of range', 24, ierr, 1) return 5007 continue ! ! nwk too small return. ! ierr = -7 call xerror ('pchsp -- work array too small', 29, ierr, 1) return 5008 continue ! singular system. ! theoretically, this can only occur if successive x-values ! are equal, which should already have been caught (ierr=-3). ierr = -8 call xerror ('pchsp -- singular linear system', 31, ierr, 1) return ! 5009 continue ! error return from pchdf. ! this case should never occur. ierr = -9 call xerror ('pchsp -- error return from pchdf', 32, ierr, 1) return end function pchst ( arg1, arg2 ) ! !******************************************************************************* ! !! PCHST: PCHIP sign-testing routine. ! ! ! Discussion: ! ! The object is to do this without multiplying ARG1 * ARG2, to avoid ! possible over/underflow problems. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, real ARG1, ARG2, two values to check. ! ! Output, real PCHST, ! -1.0, if ARG1 and ARG2 are of opposite sign. ! 0.0, if either argument is zero. ! +1.0, if ARG1 and ARG2 are of the same sign. ! implicit none ! real arg1 real arg2 real pchst ! pchst = sign ( 1.0E+00, arg1 ) * sign ( 1.0E+00, arg2 ) if ( arg1 == 0.0E+00 .or. arg2 == 0.0E+00 ) then pchst = 0.0E+00 end if return end subroutine pchsw ( dfmax, iextrm, d1, d2, h, slope, ierr ) ! !******************************************************************************* ! !! PCHSW: the PCHCS switch excursion limiter. ! ! ! Discussion: ! ! This routine is called by PCHCS to adjust D1 and D2 if necessary to ! insure that the extremum on this interval is not further than DFMAX ! from the extreme data value. ! ! Author: ! ! Fred Fritsch, ! Mathematics and Statistics Division, ! Lawrence Livermore National Laboratory. ! ! Parameters: ! ! Input, real DFMAX, the maximum allowed difference between F(IEXTRM) and ! the cubic determined by the derivative values D1 and D2. DFMAX should ! be nonnegative. ! ! Input, integer IEXTRM, the index of the extreme data value, which should ! be 1 or 2. ! ! Input/output, real D1, D2, the derivative values at the ends of the ! interval. It is assumed that D1 * D2 <= 0. On output, the values may ! be modified if necessary to meet the restriction imposed by DFMAX. ! ! Input, real H, interval length. H should be positive. ! ! Input, real SLOPE, the data slope on the interval. ! ! Output, integer IERR, error flag. ! 0, no errors. ! -1, assumption on D1 and D2 is not satisfied. ! -2, quadratic equation locating extremum has negative descriminant ! (should never occur). ! ! Local variables: ! ! RHO is the ratio of the data slope to the derivative being tested. ! ! LAMBDA is the ratio of D2 to D1. ! ! THAT = T-hat(rho) is the normalized location of the extremum. ! ! PHI is the normalized value of P(X)-f1 at X = xhat = x-hat(rho), ! where that = (xhat - x1)/h . ! that is, p(xhat)-f1 = D * H * PHI, where d=d1 or d2. ! similarly, p(xhat)-f2 = d*h*(phi-rho) . ! ! SMALL should be a few orders of magnitude greater than macheps. ! implicit none ! real cp real d1 real d2 real dfmax real dmax real, parameter :: fact = 100.0E+00 real h integer ierr integer iextrm real lambda real nu real phi real radcal real rho real r1mach real sigma real slope real small real that real, parameter :: third = 0.33333E+00 ! small = fact * epsilon ( 1.0E+00 ) if ( d1 == 0.0E+00 ) then ! ! Special case -- D1 == 0.0E+00 . ! ! If D2 is also zero, this routine should not have been called. ! if ( d2 == 0.0E+00 ) then ierr = -1 call xerror ('pchsw -- d1 and/or d2 invalid', 29, ierr, 1) return end if rho = slope / d2 ! ! Extremum is outside interval when RHO >= 1/3 . ! if ( rho >= third ) then ierr = 0 return end if that = ( 2.0E+00 * ( 3.0E+00 * rho - 1.0E+00 ) ) & / ( 3.0E+00 * ( 2.0E+00 * rho - 1.0E+00 ) ) phi = that**2 * ( ( 3.0E+00 * rho - 1.0E+00 ) / 3.0E+00 ) ! ! Convert to distance from F2 if IEXTRM /= 1. ! if ( iextrm /= 1 ) then phi = phi - rho end if ! ! Test for exceeding limit, and adjust accordingly. ! dmax = dfmax / ( h * abs ( phi ) ) if ( abs ( d2 ) > dmax ) then d2 = sign ( dmax, d2 ) end if else rho = slope / d1 lambda = -d2 / d1 if ( d2 == 0.0E+00 ) then ! ! Special case -- D2 == 0.0E+00 . ! ! Extremum is outside interval when RHO >= 1/3 . ! if ( rho >= third ) then ierr = 0 return end if cp = 2.0E+00 - 3.0E+00 * rho nu = 1.0E+00 - 2.0E+00 * rho that = 1.0E+00 / ( 3.0E+00 * nu ) else if ( lambda <= 0.0E+00 ) then ierr = -1 call xerror ('pchsw -- d1 and/or d2 invalid', 29, ierr, 1) return end if ! ! Normal case, D1 and D2 both nonzero, opposite signs. ! nu = 1.0E+00 - lambda - 2.0E+00 * rho sigma = 1.0E+00 - rho cp = nu + sigma if ( abs ( nu ) > small ) then radcal = ( nu - ( 2.0E+00 * rho + 1.0E+00 ) ) * nu + sigma**2 if ( radcal < 0.0E+00 ) then ierr = -2 call xerror ( 'pchsw -- negative radical', 25, ierr, 1) return end if that = ( cp - sqrt ( radcal ) ) / ( 3.0E+00 * nu ) else that = 1.0E+00 / ( 2.0E+00 * sigma ) end if end if phi = that * ( ( nu * that - cp ) * that + 1.0E+00 ) ! ! Convert to distance from F2 if IEXTRM /= 1. ! if ( iextrm /= 1 ) then phi = phi - rho end if ! ! Test for exceeding limit, and adjust accordingly. ! dmax = dfmax / ( h * abs ( phi ) ) if ( abs ( d1 ) > dmax ) then d1 = sign ( dmax, d1 ) d2 = -lambda * d1 end if end if ierr = 0 return end function pi ( ) ! !******************************************************************************* ! !! PI returns the value of pi. ! ! ! Modified: ! ! 04 December 1998 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, real PI, the value of pi. ! implicit none ! real pi ! pi = 3.14159265358979323846264338327950288419716939937510E+00 return end subroutine q1da ( f, a, b, eps, r, e, kf, iflag ) ! !******************************************************************************* ! !! Q1DA approximates the definite integral of a function of one variable. ! ! ! Discussion: ! ! A small amount of randomization is built into this program. ! Calling Q1DA a few times in succession will give different ! but hopefully consistent results. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, external F, the name of the function which evaluates the integrand. ! F must have the form: ! ! function f ( x ) ! real f ! real x ! ! Input, real A, B, the endpoints of the integration interval. ! ! Input, real EPS, the desired accuracy. ! ! Output, real R, the estimate of the value of the integral. ! ! Output, real E, an estimate of the error, |integral-R|. ! ! Output, integer KF, the cost of the integration, measured in ! number of evaluations of your integrand. KF will always be at least 30. ! ! Output, integer IFLAG, termination flag. ! 0, normal completion, E < EPS and E < EPS * |R|. ! 1, normal completion, E < EPS, but E > EPS * |R|. ! 2, normal completion, E < EPS * |R|, but E > EPS. ! 3, normal completion, but EPS was too small to satisfy absolute ! or relative error request. ! 4, aborted calculation because of serious rounding error. Probably E ! and R are consistent. ! 5, aborted calculation because of insufficient storage. R and E ! are consistent. ! 6, aborted calculation because of serious difficulties meeting your ! error request. ! 7, aborted calculation because EPS was set <= 0.0E+00 ! implicit none ! integer, parameter :: nmax = 50 ! real a real b real e real eps real, external :: f real fmax real fmin integer iflag integer kf integer nint real r logical rst real w(nmax,6) ! nint = 1 rst = .false. call q1dax ( f, a, b, eps, r, e, nint, rst, w, nmax, fmin, fmax, kf, iflag ) return end subroutine q1dax ( f, a, b, eps, r, e, nint, rst, w, nmax, fmin, fmax, kf, & iflag ) ! !******************************************************************************* ! !! Q1DAX approximates the integral of a function of one variable. ! ! ! Discussion: ! ! For an easier to use routine see Q1DA. ! ! Capabilities of Q1DAX, beyond those of Q1DA, include: ! * the ability to restart a calculation to greater accuracy without ! penalty... ! * the ability to specify an initial partition of the integration ! interval... ! * the ability to increase the work space to handle more difficult ! problems... ! * output of largest/smallest integrand value for applications such ! as scaling graphs... ! ! A small amount of randomization is built into this program. ! Calling Q1DAX a few times in succession will give different ! but hopefully consistent results. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Parameters: ! ! Input, real external F, the name of the routine that evaluates the ! function, of the form ! ! function f ( x ) ! real f ! real x ! ! Input, real A, B, the endpoints of the integration interval. ! ! Input, real EPS, the desired accuracy. ! ! Output, real R, the estimate of the value of the integral. ! ! Output, real E, an estimate of the error, |integral-R|. ! ! Input/output, integer NINT. On input, NINT must be set to the ! number of subintervals in the initial partition of [a,b]. ! For most problems this is just 1, for the interval [a,b] itself. ! NINT must be less than NMAX. NINT is useful if you would like to ! help Q1DAX locate a difficult spot on [a,b]. In this regard NINT is ! used along with the array w (see below). if you set ! NINT=1 it is not necessary to be concerned ! with W, except that it must be dimensioned... ! as an example of more general applications, ! if [a,b]=[0,1] but the integrand jumps at 0.3, ! it would be wise to set NINT=2 and then set ! w(1,1)=0.0E+00 (left endpoint) ! w(2,1)=0.3 (singular point) ! w(3,1)=1.0E+00 (right endpoint) ! If you set NINT greater than 1, be sure to set ! W(1,1) = A ! W(NINT+1,1) = B ! ! As an output quantity, NINT gives the number of subintervals in the ! final partition of [A,B]. ! ! Input, logical RST, indicates first call or restart. ! FALSE, for the initial call to Q1DAX. ! TRUE for a subsequent call, for the same problem, for which ! more accuracy is desired (a smaller EPS). A restart only ! makes sense if the preceding call returned with a value of IFLAG ! less than 3. On a restart you may not change the values of any ! other arguments in the call sequence, except EPS. ! ! Input, real W(NMAX,6). an adequate value of ! nmax is 50. if you set nint>1 you must also ! initialize w, see nint above. ! ! Input, integer NMAX, the leading dimension of W. This is also equal to ! the maximum number of subintervals permitted in the internal partition ! of [A,B]. A value of 50 is ample for most problems. ! ! Output, real FMIN, FMAX, the smallest and largest values of the integrand ! which occurred during the calculation. The actual integrand range ! on [A,B] may, of course, be greater but probably not by more than 10%. ! ! Output, integer KF, the cost of the integration, measured in ! number of evaluations of your integrand. KF will always be at least 30. ! ! Output, integer IFLAG, error flag. ! 0, normal completion, e < eps and e eps * abs ( r ) ! 2. normal completion, e < eps * abs ( r ), but e>eps ! 3. normal completion but eps was too small to satisfy absolute ! or relative error request. ! 4, aborted calculation because of serious rounding ! error. probably e and r are consistent. ! 5, aborted calculation because of insufficient storage. ! r and e are consistent. perhaps increasing nmax ! will produce better results. ! 6, aborted calculation because of serious difficulties ! meeting your error request. ! 7, aborted calculation because either eps, nint or nmax ! has been set to an illegal value. ! 8, aborted calculation because you set nint>1 but forgot ! to set w(1,1)=a and w(nint+1,1)=b ! implicit none ! integer nmax ! real a real b integer c real e real eb real epmach real eps real, external :: f real fmax real fmaxl real fmaxr real fmin real fminl real fminr real fmn real fmx integer i integer iflag integer iroff integer isamax integer kf integer loc integer mxtry integer nint real r real r1mach real rab real rabs real rav logical rst real t real te real te1 real te2 real tr real tr1 real tr2 real uflow real uni real w(nmax,6) real xm ! epmach = epsilon ( epmach ) uflow = tiny ( uflow ) mxtry = nmax / 2 ! ! In case there is no more room, we can toss out easy intervals, ! at most MXTRY times. ! if ( a == b ) then r = 0.0E+00 e = 0.0E+00 nint = 0 iflag = 0 kf = 1 fmin = f(a) fmax = fmin go to 20 end if if ( rst ) then if ( iflag < 3 ) then eb = max ( 100.0E+00 * uflow, max ( eps, 50.0E+00 * epmach ) * abs ( r ) ) do i = 1, nint if ( abs ( w(i,3) ) > ( eb * ( w(i,2) - w(i,1) ) / ( b - a ) ) ) then w(i,3) = abs ( w(i,3) ) else w(i,3) = -abs ( w(i,3) ) end if end do go to 15 else go to 20 end if end if kf = 0 if ( eps <= 0.0E+00 .or. nint <= 0 .or. nint >= nmax ) then iflag = 7 go to 20 end if if ( nint == 1 ) then w(1,1) = a w(2,2) = b w(1,5) = a w(1,6) = b w(2,5) = a w(2,6) = b ! ! Select the first subdivision randomly. ! w(1,2) = a + ( b - a ) / 2.0E+00 * ( 2.0E+00 * uni() + 7.0E+00 ) / 8.0E+00 w(2,1) = w(1,2) nint = 2 else if ( w(1,1) /= a .or. w(nint+1,1) /= b ) then iflag = 8 go to 20 end if w(1,5) = a do i = 1, nint w(i,2) = w(i+1,1) w(i,5) = w(i,1) w(i,6) = w(i,2) end do end if iflag = 0 iroff = 0 rabs = 0.0E+00 do i = 1, nint call gl15t ( f, w(i,1), w(i,2), dble(w(i,5)), dble(w(i,6)), & w(i,4), w(i,3), rab, rav, fmn, fmx ) kf = kf+15 if ( i == 1 ) then r = w(i,4) e = w(i,3) rabs = rabs + rab fmin = fmn fmax = fmx else r = r + w(i,4) e = e + w(i,3) rabs = rabs + rab fmax = max ( fmax, fmx ) fmin = min ( fmin, fmn ) end if end do w(nint+1:nmax,3) = 0.0E+00 15 continue ! ! main subprogram loop ! if ( 100.0E+00 * epmach * rabs >= abs ( r ) .and. e < eps ) then go to 20 end if eb = max ( 100.0E+00 * uflow, max ( eps, 50.0E+00 * epmach ) * abs ( r ) ) if ( e <= eb ) then go to 20 end if if ( nint < nmax ) then nint = nint+1 c = nint else c=0 16 continue if ( c == nmax .or. mxtry <= 0 ) then iflag = 5 go to 20 end if c = c + 1 if ( w(c,3) > 0.0E+00 ) then go to 16 end if ! ! Found an interval to throw out. ! mxtry = mxtry-1 end if loc = isamax ( nint, w(1,3), 1 ) xm = w(loc,1) + ( w(loc,2) - w(loc,1) ) / 2.0E+00 if ( ( max ( abs ( w(loc,1) ), abs ( w(loc,2) ) ) ) > & ( ( 1.0E+00 + 100.0E+00 * epmach)*( abs ( xm ) + 0.1E+04 * uflow ) ) ) then call gl15t ( f, w(loc,1), xm, dble(w(loc,5)), dble(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), dble(w(loc,5)), dble(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.001E+00 * te ) then iroff = iroff + 1 if ( iroff >= 10 ) then iflag = 4 go to 20 end if end if else if ( eb > w(loc,3) ) then w(loc,3) = 0.0E+00 else iflag = 6 go to 20 end if end if go to 15 20 continue if ( iflag >= 4 ) then return end if iflag = 3 t = eps * abs ( r ) if ( e > eps .and. e > t ) return iflag = 2 if ( e > eps .and. e < t ) return iflag = 1 if ( e < eps .and. e > t ) return iflag = 0 return end subroutine qagi ( f, bound, inf, epsabs, epsrel, result, abserr, neval, & ier, limit, lenw, last, iwork, work ) ! !******************************************************************************* ! !! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! R Piessens, E de Doncker-Kapenger, C W Ueberhuber, D K 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 f ! real x ! ! Input, real BOUND, the value of the finite endpoint of the integration ! range, if any, that is, if INF is 1 or -1. ! ! Input, integer INF, indicates the type of integration range. ! 1: ( BOUND, +Infinity), ! -1: ( -Infinity, BOUND), ! 2: ( -Infinity, +Infinity). ! ! Input, real EPSABS, the absolute accuracy requested. ! ! Input, real EPSREL, the relative accuracy requested ! If EPSABS <= 0 and EPSREL < max ( 50 * epsilon, 0.5E-14), ! the routine will end with IER = 6. ! ! Output, real RESULT, the estimated value of the integral. ! ! Output, real ABSERR, the estimate of the modulus of the absolute error, ! which should equal or exceed | I - RESULT |. ! ! Output, integer NEVAL, the number of integrand evaluations. ! ! on return ! ! ier - integer ! ier = 0 normal and reliable termination of the ! routine. it is assumed that the requested ! accuracy has been achieved. ! - ier>0 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=1. in many cases limit = 100 is ok. ! if limit<1, the routine will end with ier = 6. ! ! lenw - integer ! dimensioning parameter for work ! lenw must be at least limit*4. ! if lenw errbnd ) then ier = 2 end if if ( limit == 1 ) then ier = 1 end if if ( ier /= 0 ) then go to 130 end if if ( ( abserr <= errbnd .and. abserr /= resabs ) .or. abserr == 0.0E+00 ) then go to 130 end if ! ! Initialization. ! uflow = 2.0E+00 * tiny ( uflow ) lerr = .false. call ea ( newflg, result, limexp, reseps, abseps, rlist2, ierr ) errmax = abserr maxerr = 1 area = result errsum = abserr nrmax = 1 ktmin = 0 extrap = .false. noext = .false. ierro = 0 iroff1 = 0 iroff2 = 0 iroff3 = 0 if ( dres >= ( 1.0E+00 - 0.5E+02 * epmach ) * defabs ) then ksgn = 1 else ksgn = -1 end if do last = 2, limit ! ! Bisect the subinterval with nrmax-th largest error estimate. ! a1 = alist(maxerr) b1 = 0.5E+00 * ( alist(maxerr) + blist(maxerr) ) a2 = b1 b2 = blist(maxerr) erlast = errmax call qk15i ( f, boun, inf, a1, b1, area1, error1, resabs, defab1 ) call qk15i ( f, boun, inf, a2, b2, area2, error2, resabs, defab2 ) ! ! Improve previous approximations to integral ! and error and test for accuracy. ! area12 = area1 + area2 erro12 = error1 + error2 errsum = errsum + erro12 - errmax area = area + area12 - rlist(maxerr) if ( defab1 == error1 .or. defab2 == error2 ) go to 15 if ( abs ( rlist(maxerr) - area12 ) > 0.1E-04 * abs ( area12 ) .or. & erro12 < 0.99E+00 * errmax ) then go to 10 end if if ( extrap ) then iroff2 = iroff2+1 else iroff1 = iroff1+1 end if 10 if ( last > 10 .and. erro12 > errmax ) iroff3 = iroff3+1 15 rlist(maxerr) = area1 rlist(last) = area2 errbnd = max ( epsabs, epsrel * abs ( area ) ) ! ! Test for roundoff error and eventually set error flag. ! if ( iroff1 + iroff2 >= 10 .or. iroff3 >= 20 ) then ier = 2 end if if ( iroff2 >= 5 ) then ierro = 3 end if ! ! Set error flag in the case that the number of subintervals equals limit. ! if ( last == limit ) then ier = 1 end if ! ! Set error flag in the case of bad integrand behavior ! at some points of the integration range. ! if ( max ( abs ( a1 ), abs ( b2 ) ) <= ( 1.0E+00 + 0.1E+03 * epmach )* & ( abs ( a2 ) + 0.1E+04 * uflow ) ) then ier = 4 end if ! ! Append the newly-created intervals to the list. ! if ( error2 <= error1 ) then alist(last) = a2 blist(maxerr) = b1 blist(last) = b2 elist(maxerr) = error1 elist(last) = error2 else alist(maxerr) = a2 alist(last) = a1 blist(last) = b1 rlist(maxerr) = area2 rlist(last) = area1 elist(maxerr) = error2 elist(last) = error1 end if ! ! Call QPSRT to maintain the descending ordering ! in the list of error estimates and select the ! subinterval with nrmax-th largest error estimate (to be ! bisected next). ! call qpsrt ( limit, last, maxerr, errmax, elist, iord, nrmax ) if ( errsum <= errbnd ) go to 115 if ( ier /= 0 ) go to 100 if ( last == 2 ) go to 80 if ( noext ) go to 90 erlarg = erlarg - erlast if ( abs ( b1 - a1 ) > small ) then erlarg = erlarg + erro12 end if if ( extrap ) go to 40 ! ! Test whether the interval to be bisected next is the ! smallest interval. ! if ( abs ( blist(maxerr) - alist(maxerr) ) > small ) then go to 90 end if extrap = .true. nrmax = 2 40 continue if ( ierro == 3 .or. erlarg <= ertest ) go to 60 ! ! the smallest interval has the largest error. ! before bisecting decrease the sum of the errors ! over the larger intervals (erlarg) and perform ! extrapolation. ! id = nrmax jupbnd = last if ( last > (2+limit/2) ) then jupbnd = limit+3-last end if do k = id, jupbnd maxerr = iord(nrmax) errmax = elist(maxerr) if ( abs ( blist(maxerr) - alist(maxerr) ) > small ) then go to 90 end if nrmax = nrmax+1 end do ! ! Perform extrapolation. ! 60 continue call ea ( newflg, area, limexp, reseps, abseps, rlist2, ierr ) ktmin = ktmin+1 if ( ( ktmin > 5 ) .and. ( abserr < 0.1E-02 * errsum ) .and. ( lerr ) ) then ier = 5 end if if ( abseps >= abserr .and. lerr ) go to 70 ktmin = 0 abserr = abseps lerr = .true. result = reseps correc = erlarg ertest = max ( epsabs, epsrel * abs ( reseps ) ) if ( abserr <= ertest .and. lerr ) go to 100 ! ! Prepare bisection of the smallest interval. ! 70 continue if ( rlist2(limexp+3) == 1 ) noext = .true. if ( ier == 5 ) go to 100 maxerr = iord(1) errmax = elist(maxerr) nrmax = 1 extrap = .false. small = small * 0.5E+00 erlarg = errsum go to 90 80 continue small = 0.375E+00 erlarg = errsum ertest = errbnd call ea ( newflg, area, limexp, reseps, abseps, rlist2, ierr ) 90 continue end do ! ! Set final result and error estimate. ! 100 if ( .not. lerr ) go to 115 if ( ier + ierro == 0 ) go to 110 if ( ierro == 3 ) abserr = abserr + correc if ( ier == 0 ) ier = 3 if ( result /= 0.0E+00 .and. area /= 0.0E+00 ) go to 105 if ( abserr > errsum ) go to 115 if ( area == 0.0E+00 ) go to 130 go to 110 105 continue if ( abserr / abs ( result ) > errsum / abs ( area ) ) then go to 115 end if ! ! Test on divergence ! 110 continue if ( ksgn == (-1) .and. & max ( abs ( result ), abs ( area ) ) <= defabs * 0.1E-01 ) then go to 130 end if if ( 0.1E-01 > ( result / area ) .or. & ( result / area ) > 0.1E+03 .or. errsum > abs ( area ) ) then ier = 6 end if go to 130 ! ! Compute global integral sum. ! 115 continue result = sum ( rlist(1:last) ) abserr = errsum 130 continue neval = 30 * last-15 if ( inf == 2 ) neval = 2*neval if ( ier > 2 ) then ier = ier-1 end if return end subroutine qform ( m, n, q, ldq ) ! !******************************************************************************* ! !! QFORM produces the explicit QR factorization of a matrix. ! ! ! Discussion: ! ! The QR factorization of a matrix is usually accumulated in implicit ! form, that is, as a series of orthogonal transformations of the ! original matrix. This routine carries out those transformations, ! to explicitly exhibit the factorization construced by QRFAC. ! ! Parameters: ! ! Input, integer M, is a positive integer input variable set to the number ! of rows of A and the order of Q. ! ! Input, integer N, is a positive integer input variable set to the number ! of columns of A. ! ! Input/output, real Q(LDQ,M). Q is an M by M array. ! On input the full lower trapezoid in the first min ( M, N ) columns of Q ! contains the factored form. ! On output, Q has been accumulated into a square matrix. ! ! Input, integer LDQ, is a positive integer input variable not less ! than M which specifies the leading dimension of the array Q. ! implicit none ! integer ldq integer m integer n ! integer i integer j integer jm1 integer k integer l integer minmn real q(ldq,m) real temp real wa(m) ! minmn = min ( m, n ) do j = 2, minmn q(1:j-1,j) = 0.0E+00 end do ! ! Initialize remaining columns to those of the identity matrix. ! do j = n+1, m do i = 1, m q(i,j) = 0.0E+00 end do q(j,j) = 1.0E+00 end do ! ! Accumulate Q from its factored form. ! do l = 1, minmn k = minmn - l + 1 wa(k:m) = q(k:m,k) q(k:m,k) = 0.0E+00 q(k,k) = 1.0E+00 if ( wa(k) /= 0.0E+00 ) then do j = k, m temp = dot_product ( wa(k:m), q(k:m,j) ) / wa(k) do i = k, m q(i,j) = q(i,j) - temp * wa(i) end do end do end if end do return end subroutine qk15 ( f, a, b, result, abserr, resabs, resasc ) ! !******************************************************************************* ! !! QK15 carries out a 15 point Gauss-Kronrod quadrature rule. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! R Piessens, E de Doncker-Kapenger, C W Ueberhuber, D K Kahaner, ! QUADPACK, a Subroutine Package for Automatic Integration, ! Springer Verlag, 1983 ! ! Parameters: ! ! Input, external F, the name of the user-supplied function, of the form: ! ! function f ( x ) ! real f ! real x ! ! Input, real A, B, the lower and upper limits of integration. ! ! Output, real RESULT, the estimate of the integral I. ! ! Output, real ABSERR, an estimate of the modulus of the absolute error, ! which should not exceed |I-RESULT|. ! ! Output, real RESABS, approximation to the integral of the absolute ! value of F. ! ! Output, real RESASC, approximation to the integral | F-I/(B-A) | ! over [A,B]. ! ! Local parameters: ! ! centr - mid point of the interval ! hlgth - half-length of the interval ! absc - abscissa ! fval* - function value ! resg - result of the 7-point Gauss formula ! resk - result of the 15-point Kronrod formula ! reskh - approximation to the mean value of f over (a,b), i.e. to i/(b-a) ! implicit none ! real a real absc real abserr real b real centr real dhlgth real epmach real, external :: f real fc real fsum real fval1 real fval2 real fv1(7) real fv2(7) real hlgth integer j integer jtw integer jtwm1 real resabs real resasc real resg real resk real reskh real result real r1mach real uflow real, parameter, dimension ( 4 ) :: wg = (/ & 0.1294849661688697E+00, & 0.2797053914892767E+00, & 0.3818300505051189E+00, & 0.4179591836734694E+00 /) real, parameter, dimension ( 8 ) :: wgk = (/ & 0.2293532201052922E-01, 0.6309209262997855E-01, & 0.1047900103222502E+00, 0.1406532597155259E+00, & 0.1690047266392679E+00, 0.1903505780647854E+00, & 0.2044329400752989E+00, 0.2094821410847278E+00 /) real, parameter, dimension ( 8 ) :: xgk = (/ & 0.9914553711208126E+00, 0.9491079123427585E+00, & 0.8648644233597691E+00, 0.7415311855993944E+00, & 0.5860872354676911E+00, 0.4058451513773972E+00, & 0.2077849550078985E+00, 0.0E+00 /) ! epmach = epsilon ( epmach ) uflow = tiny ( uflow ) centr = 0.5E+00 * (a+b) hlgth = 0.5E+00 * (b-a) dhlgth = abs ( hlgth ) ! ! Compute the 15-point Kronrod approximation to ! the integral, and estimate the absolute error. ! fc = f(centr) resg = fc * wg(4) resk = fc * wgk(8) resabs = abs ( resk ) do j = 1, 3 jtw = j * 2 absc = hlgth * xgk(jtw) fval1 = f(centr-absc) fval2 = f(centr+absc) fv1(jtw) = fval1 fv2(jtw) = fval2 fsum = fval1 + fval2 resg = resg + wg(j) * fsum resk = resk + wgk(jtw) * fsum resabs = resabs + wgk(jtw) * ( abs ( fval1 ) + abs ( fval2 ) ) end do do j = 1, 4 jtwm1 = j * 2 - 1 absc = hlgth * xgk(jtwm1) fval1 = f(centr-absc) fval2 = f(centr+absc) fv1(jtwm1) = fval1 fv2(jtwm1) = fval2 fsum = fval1 + fval2 resk = resk + wgk(jtwm1) * fsum resabs = resabs + wgk(jtwm1) * ( abs ( fval1 ) + abs ( fval2 ) ) end do reskh = resk * 0.5E+00 resasc = wgk(8) * abs ( fc - reskh ) do j = 1, 7 resasc = resasc + wgk(j) * & ( abs ( fv1(j) - reskh ) + abs ( fv2(j) - reskh ) ) end do result = resk * hlgth resabs = resabs * dhlgth resasc = resasc * dhlgth abserr = abs ( ( resk - resg ) * hlgth ) if ( resasc /= 0.0E+00 .and. abserr /= 0.0E+00 ) then abserr = resasc * min ( 1.0E+00, ( 0.2E+03 * abserr / resasc )**1.5E+00 ) end if if ( resabs > uflow / ( 0.5E+02 * epmach ) ) then abserr = max ( ( epmach * 0.5E+02 ) * resabs, abserr ) end if return end subroutine qk15i ( f, boun, inf, a, b, result, abserr, resabs, resasc ) ! !******************************************************************************* ! !! QK15I applies a 15 point Gauss Kronrod quadrature rule. ! ! ! Discussion: ! ! The integration interval is assumed to be infinite or semi-infinite. ! A mapping is applied to the interval to bring it into [0,1]. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! R Piessens, E de Doncker-Kapenger, C W Ueberhuber, D K Kahaner, ! QUADPACK, a Subroutine Package for Automatic Integration, ! Springer Verlag, 1983 ! ! Parameters: ! ! Input, external F, the name of the user-supplied function, of the form: ! ! function f ( x ) ! real f ! real x ! ! Input, real BOUN, the value of the finite endpoint of the integration ! range, if any, that is, if INF is 1 or -1. ! ! Input, integer INF, indicates the type of integration range. ! 1: ( BOUND, +Infinity), ! -1: ( -Infinity, BOUND), ! 2: ( -Infinity, +Infinity). ! ! Input, real A, B, ? ! ! Output, real RESULT, the estimate of the integral I. ! ! Output, real ABSERR, an estimate of the modulus of the absolute error, ! which should not exceed |I-RESULT|. ! ! Output, real RESABS, approximation to the integral J. ! ! Output, real RESASC, approximation to the integral |F-I/(B-A)| over [A,B]. ! implicit none ! real a real absc real absc1 real absc2 real abserr real b real boun real centr real dinf real r1mach real epmach real, external :: f real fc real fsum real fval1 real fval2 real fv1(7) real fv2(7) real hlgth integer inf integer j real resabs real resasc real resg real resk real reskh real result real tabsc1 real tabsc2 real uflow real wg(8) real wgk(8) real xgk(8) ! data xgk(1),xgk(2),xgk(3),xgk(4),xgk(5),xgk(6),xgk(7), xgk(8)/ & 0.9914553711208126E+00, 0.9491079123427585E+00, & 0.8648644233597691E+00, 0.7415311855993944E+00, & 0.5860872354676911E+00, 0.4058451513773972E+00, & 0.2077849550078985E+00, 0.0000000000000000E+00/ ! data wgk(1),wgk(2),wgk(3),wgk(4),wgk(5),wgk(6),wgk(7), wgk(8)/ & 0.2293532201052922E-01, 0.6309209262997855E-01, & 0.1047900103222502E+00, 0.1406532597155259E+00, & 0.1690047266392679E+00, 0.1903505780647854E+00, & 0.2044329400752989E+00, 0.2094821410847278E+00/ ! data wg(1),wg(2),wg(3),wg(4),wg(5),wg(6),wg(7),wg(8)/ & 0.0000000000000000E+00, 0.1294849661688697E+00, & 0.0000000000000000E+00, 0.2797053914892767E+00, & 0.0000000000000000E+00, 0.3818300505051189E+00, & 0.0000000000000000E+00, 0.4179591836734694E+00/ ! epmach = epsilon ( epmach ) uflow = tiny ( uflow ) dinf = min ( 1, inf ) centr = 0.5E+00 * ( a + b ) hlgth = 0.5E+00 * ( b - a ) tabsc1 = boun + dinf * ( 1.0E+00 - centr ) / centr fval1 = f(tabsc1) if ( inf == 2 ) then fval1 = fval1 + f(-tabsc1) end if fc = ( fval1 / centr ) / centr ! ! Compute the 15-point Kronrod approximation to ! the integral, and estimate the error. ! resg = wg(8) * fc resk = wgk(8) * fc resabs = abs ( resk ) do j = 1, 7 absc = hlgth * xgk(j) absc1 = centr - absc absc2 = centr + absc tabsc1 = boun + dinf * ( 1.0E+00 - absc1 ) / absc1 tabsc2 = boun + dinf * ( 1.0E+00 -absc2 ) / absc2 fval1 = f(tabsc1) fval2 = f(tabsc2) if ( inf == 2 ) fval1 = fval1 + f(-tabsc1) if ( inf == 2 ) fval2 = fval2 + f(-tabsc2) fval1 = ( fval1 / absc1 ) / absc1 fval2 = ( fval2 / absc2 ) / absc2 fv1(j) = fval1 fv2(j) = fval2 fsum = fval1 + fval2 resg = resg + wg(j) * fsum resk = resk + wgk(j) * fsum resabs = resabs + wgk(j) * ( abs ( fval1 ) + abs ( fval2 ) ) end do reskh = resk * 0.5E+00 resasc = wgk(8) * abs ( fc - reskh ) do j = 1, 7 resasc = resasc + wgk(j) * & ( abs ( fv1(j) - reskh ) + abs ( fv2(j) - reskh ) ) end do result = resk * hlgth resasc = resasc * hlgth resabs = resabs * hlgth abserr = abs ( ( resk - resg ) * hlgth ) if ( resasc /= 0.0E+00 .and. abserr /= 0.0E+00 ) then abserr = resasc * min ( 1.0E+00, ( 0.2E+03 * abserr / resasc )**1.5E+00 ) end if if ( ( 50.0E+00 * epmach ) * resabs > uflow ) then abserr = max ( abserr, ( 50.0E+00 * epmach ) * resabs ) end if return end subroutine qpsrt ( limit, last, maxerr, ermax, elist, iord, nrmax ) ! !******************************************************************************* ! !! QPSRT maintains the descending ordering in a list of integral error estimates. ! ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! R Piessens, E de Doncker-Kapenger, C W Ueberhuber, D K Kahaner, ! QUADPACK, a Subroutine Package for Automatic Integration, ! Springer Verlag, 1983 ! ! Parameters: ! ! Input, integer LIMIT, the maximum number of error estimates the list can ! contain. ! ! Input, integer LAST, the number of error estimates. ! ! Input/output, integer MAXERR, the index in the list of the NRMAX-th ! largest error. ! ! Output, real ERMAX, the NRMAX-th largest error = ELIST(MAXERR). ! ! Input, real ELIST(LIMIT), contains the error estimates. ! ! Input/output, integer IORD(LAST). The first K elements contain ! pointers to the error estimates such that ELIST(IORD(1)) through ! ELIST(IORD(K)) form a decreasing sequence, with ! K = LAST ! if ! LAST <= (LIMIT/2+2), ! and otherwise ! K = LIMIT+1-LAST. ! ! Input/output, integer NRMAX. ! implicit none ! integer last ! real elist(last) real ermax real errmax real errmin integer i integer ibeg integer ido integer iord(last) integer isucc integer j integer jbnd integer jupbn integer k integer limit integer maxerr integer nrmax ! ! Check whether the list contains more than two error estimates. ! if ( last <= 2 ) then iord(1) = 1 iord(2) = 2 go to 90 end if ! ! This part of the routine is only executed if, due to a difficult ! integrand, subdivision increased the error estimate. In the normal ! case the insert procedure should start after the nrmax-th largest ! error estimate. ! errmax = elist(maxerr) ido = nrmax-1 do i = 1, ido isucc = iord(nrmax-1) if ( errmax <= elist(isucc) ) then exit end if iord(nrmax) = isucc nrmax = nrmax-1 end do ! ! Compute the number of elements in the list to ! be maintained in descending order. this number ! depends on the number of subdivisions still allowed. ! jupbn = last if ( last > ( limit / 2 + 2 ) ) then jupbn = limit+3-last end if errmin = elist(last) ! ! Insert ERRMAX by traversing the list top-down, ! starting comparison from the element elist(iord(nrmax+1)). ! jbnd = jupbn - 1 ibeg = nrmax + 1 do i = ibeg, jbnd isucc = iord(i) if ( errmax >= elist(isucc) ) go to 60 iord(i-1) = isucc end do iord(jbnd) = maxerr iord(jupbn) = last go to 90 ! ! Insert ERRMIN by traversing the list bottom-up. ! 60 continue iord(i-1) = maxerr k = jbnd do j = i, jbnd isucc = iord(k) if ( errmin < elist(isucc) ) then go to 80 end if iord(k+1) = isucc k = k-1 end do iord(i) = last go to 90 80 continue iord(k+1) = last ! ! set maxerr and ermax. ! 90 continue maxerr = iord(nrmax) ermax = elist(maxerr) return end subroutine qraux1 ( nr, n, r, i ) ! !******************************************************************************* ! !! QRAUX1 interchanges two rows of an upper Hessenberg matrix. ! ! ! Discussion: ! ! QRAUX1 interchanges rows I and I+1 of the upper Hessenberg matrix ! R, columns I to N. ! ! Parameters: ! ! Input, integer NR, the leading dimension of the matrix. ! ! Input, integer N, the dimension of the matrix. ! ! Input/output, real R(NR,N), the N by N upper Hessenberg matrix. ! ! Input, integer I, the index of the first row to interchange. ! implicit none ! integer n integer nr ! integer i integer j real r(nr,n) ! do j = i, n call r_swap ( r(i,j), r(i+1,j) ) end do return end subroutine qraux2 ( nr, n, r, i, a, b ) ! !******************************************************************************* ! !! QRAUX2 pre-multiplies an upper Hessenberg matrix by a Jacobi rotation. ! ! ! Discussion: ! ! QRAUX2 pre-multiplies an upper Hessenberg matrix by a Jacobi rotation ! J(I,I+1,A,B) ! ! Modified: ! ! 15 December 2001 ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the order of the matrix. ! ! Input/output, real R(NR,N), the N by N upper Hessenberg matrix. ! ! Input, integer I, the index of the row. ! ! Input, real A, B, scalars that define the rotation. ! implicit none ! integer n integer nr ! real a real b real c real den integer i integer j real r(nr,n) real s real y real z ! den = sqrt ( a * a + b * b ) c = a / den s = b / den do j = i, n y = r(i,j) z = r(i+1,j) r(i,j) = c * y - s * z r(i+1,j) = s * y + c * z end do return end subroutine qrfac ( m, n, a, lda, pivot, ipvt, lipvt, rdiag, acnorm ) ! !******************************************************************************* ! !! QRFAC computes a QR factorization using Householder transformations. ! ! ! Discussion: ! ! This subroutine uses Householder transformations with column ! pivoting (optional) to compute a QR factorization of the ! M by N matrix A. That is, QRFAC determines an orthogonal ! matrix Q, a permutation matrix P, and an upper trapezoidal ! matrix R with diagonal elements of nonincreasing magnitude, ! such that A*P = Q*R. The Householder transformation for ! column K, K = 1,2,...,min ( M, N ), is of the form ! ! I - ( 1 / U(K) ) * U * U' ! ! where U has zeros in the first K-1 positions. The form of ! this transformation and the method of pivoting first ! appeared in the corresponding LINPACK subroutine. ! ! Reference: ! ! More, Garbow and Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer M, the number of rows of A. ! ! Input, integer N, the number of columns of A. ! ! Input/output, real A(LDA,N), the M by N array. ! On input, A contains the matrix for which the QR factorization is to ! be computed. On output, the strict upper trapezoidal part of A contains ! the strict upper trapezoidal part of R, and the lower trapezoidal ! part of A contains a factored form of Q (the non-trivial elements of ! the U vectors described above). ! ! Input, integer LDA, the leading dimension of A, which must ! be no less than M. ! ! Input, logical PIVOT, is TRUE if column pivoting is to be carried out. ! ! Output, integer IPVT(LIPVT), defines the permutation matrix P such ! that A*P = Q*R. Column J of P is column IPVT(J) of the identity matrix. ! If PIVOT is false, IPVT is not referenced. ! ! Input, integer LIPVT, the dimension of IPVT, which should be N if ! pivoting is used. ! ! Output, real RDIAG(N), contains the diagonal elements of R. ! ! Output, real ACNORM(N), the norms of the corresponding columns of the ! input matrix A. If this information is not needed, then ACNORM can ! coincide with RDIAG. ! implicit none ! integer lda integer lipvt integer n ! real a(lda,n) real acnorm(n) real ajnorm real enorm real epsmch integer i integer ipvt(lipvt) integer j integer k integer kmax integer m integer minmn logical pivot real rdiag(n) real temp real wa(n) ! epsmch = epsilon ( epsmch ) ! ! Compute the initial column norms and initialize several arrays. ! do j = 1, n acnorm(j) = enorm ( m, a(1,j) ) end do rdiag(1:n) = acnorm(1:n) wa(1:n) = acnorm(1:n) if ( pivot ) then do j = 1, n ipvt(j) = j end do end if ! ! Reduce A to R with Householder transformations. ! minmn = min ( m, n ) do j = 1, minmn ! ! Bring the column of largest norm into the pivot position. ! if ( pivot ) then kmax = j do k = j, n if ( rdiag(k) > rdiag(kmax) ) kmax = k end do if ( kmax /= j ) then do i = 1, m call r_swap ( a(i,j), a(i,kmax) ) end do rdiag(kmax) = rdiag(j) wa(kmax) = wa(j) call i_swap ( ipvt(j), ipvt(kmax) ) end if end if ! ! Compute the Householder transformation to reduce the ! J-th column of A to a multiple of the J-th unit vector. ! ajnorm = enorm ( m-j+1, a(j,j) ) if ( ajnorm /= 0.0E+00 ) then if ( a(j,j) < 0.0E+00 ) then ajnorm = -ajnorm end if a(j:m,j) = a(j:m,j) / ajnorm a(j,j) = a(j,j) + 1.0E+00 ! ! Apply the transformation to the remaining columns and update the norms. ! do k = j+1, n temp = dot_product ( a(j:m,j), a(j:m,k) ) / a(j,j) a(j:m,k) = a(j:m,k) - temp * a(j:m,j) if ( pivot .and. rdiag(k) /= 0.0E+00 ) then temp = a(j,k) / rdiag(k) rdiag(k) = rdiag(k) * sqrt ( max ( 0.0E+00, 1.0E+00-temp**2 ) ) if ( 0.05E+00 * ( rdiag(k) / wa(k) )**2 <= epsmch ) then rdiag(k) = enorm ( m-j, a(j+1,k) ) wa(k) = rdiag(k) end if end if end do end if rdiag(j) = -ajnorm end do return end subroutine qrupdt ( nr, n, a, u, v ) ! !******************************************************************************* ! !! QRUPDT updates a QR factorization. ! ! ! Discussion: ! ! The routine finds an orthogonal N by N matrix Q* and an upper triangular ! N by N matrix R* such that (Q*)(R*) = R + U*V' ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the order of the matrix. ! ! Input/output, real A(NR,N), on input, contains the original QR ! factorization. On output, contains the revised factorization. ! ! Input, real U(N), V(N), vectors that describe the rank one update ! applied to the original matrix A. ! implicit none ! integer n integer nr ! real a(nr,n) integer i integer k real t1 real t2 real u(n) real v(n) ! ! Determine the last non-zero in U(.) ! k = n do while ( u(k) == 0.0E+00 .and. k > 1 ) k = k - 1 end do ! ! (k-1) Jacobi rotations transform ! r + u(v+) --> (r*) + ( u(1) * e1 ) (v+) ! which is upper Hessenberg ! if ( k > 1 ) then do i = k-1, 1, -1 if ( u(i) == 0.0E+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.0E+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 ) ! !******************************************************************************* ! !! R1MACH returns single precision machine constants. ! ! ! Assume that single precision 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) ! ! To alter this function for a particular environment, the desired set of data ! statements should be activated by removing the C from column 1. ! ! On rare machines a STATIC statement may need to be added. But probably more ! systems prohibit it that require it. ! ! For IEEE-arithmetic machines (binary standard), the first set of constants ! below should be appropriate. ! ! Where possible, octal or hexadecimal constants have been used to specify the ! constants exactly which has in some cases required the use of EQUIVALENCED ! integer arrays. If your compiler uses half-word integers by default ! (sometimes called INTEGER*2), you may need to change INTEGER to INTEGER*4 or ! otherwise instruct your compiler to use full-word integers in the next 5 ! declarations. ! implicit none ! integer diver(2) integer i integer large(2) integer log10(2) real r1mach integer right(2) real rmach(5) integer small(2) ! equivalence (rmach(1),small(1)) equivalence (rmach(2),large(1)) equivalence (rmach(3),right(1)) equivalence (rmach(4),diver(1)) equivalence (rmach(5),log10(1)) ! ! IEEE arithmetic machines, such as the ATT 3B series, Motorola 68000 based ! machines such as the SUN 3 and ATT PC 7300, and 8087 based micros such as ! the IBM PC and ATT 6300. ! data small(1) / 8388608 / data large(1) / 2139095039 / data right(1) / 864026624 / data diver(1) / 872415232 / data log10(1) / 1050288283 / ! ! ALLIANT FX/8 UNIX Fortran compiler with the -r8 command line option. This ! option causes all variables declared with 'REAL' to be of type 'REAL*8' or ! DOUBLE PRECISION. This option does not override the 'REAL*4' declarations. ! These R1MACH numbers below and the coresponding I1MACH are simply the DOUBLE ! PRECISION or 'REAL*8' numbers. If you use the -r8 your whole code (and the ! user libraries you link with, the system libraries are taken care of ! automagicly) must be compiled with this option. ! ! data rmach(1) / 2.22507385850721D-308 / ! data rmach(2) / 1.79769313486231D+308 / ! data rmach(3) / 1.1101827117665D-16 / ! data rmach(4) / 2.2203654423533D-16 / ! data rmach(5) / 3.01029995663981E-1 / ! ! AMDAHL machines. ! ! data small(1) / 1048576 / ! data large(1) / 2147483647 / ! data right(1) / 990904320 / ! data diver(1) / 1007681536 / ! data log10(1) / 1091781651 / ! ! BURROUGHS 1700 system. ! ! data rmach(1) / Z400800000 / ! data rmach(2) / Z5FFFFFFFF / ! data rmach(3) / Z4E9800000 / ! data rmach(4) / Z4EA800000 / ! data rmach(5) / Z500E730E8 / ! ! BURROUGHS 5700/6700/7700 systems. ! ! data rmach(1) / O1771000000000000 / ! data rmach(2) / O0777777777777777 / ! data rmach(3) / O1311000000000000 / ! data rmach(4) / O1301000000000000 / ! data rmach(5) / O1157163034761675 / ! ! CDC CYBER 170/180 series using NOS ! ! data rmach(1) / O"00014000000000000000" / ! data rmach(2) / O"37767777777777777777" / ! data rmach(3) / O"16404000000000000000" / ! data rmach(4) / O"16414000000000000000" / ! data rmach(5) / O"17164642023241175720" / ! ! CDC CYBER 170/180 series using NOS/VE ! ! data rmach(1) / Z"3001800000000000" / ! data rmach(2) / Z"4FFEFFFFFFFFFFFE" / ! data rmach(3) / Z"3FD2800000000000" / ! data rmach(4) / Z"3FD3800000000000" / ! data rmach(5) / Z"3FFF9A209A84FBCF" / ! ! CDC CYBER 200 series ! ! data rmach(1) / X'9000400000000000' / ! data rmach(2) / X'6FFF7FFFFFFFFFFF' / ! data rmach(3) / X'FFA3400000000000' / ! data rmach(4) / X'FFA4400000000000' / ! data rmach(5) / X'FFD04D104D427DE8' / ! ! CDC 6000/7000 series using FTN4. ! ! data rmach(1) / 00564000000000000000B / ! data rmach(2) / 37767777777777777776B / ! data rmach(3) / 16414000000000000000B / ! data rmach(4) / 16424000000000000000B / ! data rmach(5) / 17164642023241175720B / ! ! CDC 6000/7000 series using FTN5. ! ! data rmach(1) / O"00564000000000000000" / ! data rmach(2) / O"37767777777777777776" / ! data rmach(3) / O"16414000000000000000" / ! data rmach(4) / O"16424000000000000000" / ! data rmach(5) / O"17164642023241175720" / ! ! CONVEX C-1. ! ! data rmach(1) / '00800000'X / ! data rmach(2) / '7FFFFFFF'X / ! data rmach(3) / '34800000'X / ! data rmach(4) / '35000000'X / ! data rmach(5) / '3F9A209B'X / ! ! CONVEX C-120 (native mode) without -R8 option ! ! data rmach(1) / 2.9387360E-39 / ! data rmach(2) / 1.7014117E+38 / ! data rmach(3) / 5.9604645E-08 / ! data rmach(4) / 1.1920929E-07 / ! data rmach(5) / 3.0102999E-01 / ! ! CONVEX C-120 (native mode) with -R8 option ! ! data rmach(1) / 5.562684646268007D-309 / ! data rmach(2) / 8.988465674311577D+307 / ! data rmach(3) / 1.110223024625157D-016 / ! data rmach(4) / 2.220446049250313D-016 / ! data rmach(5) / 3.010299956639812D-001 / ! ! CONVEX C-120 (IEEE mode) without -R8 option ! ! data rmach(1) / 1.1754945E-38 / ! data rmach(2) / 3.4028234E+38 / ! data rmach(3) / 5.9604645E-08 / ! data rmach(4) / 1.1920929E-07 / ! data rmach(5) / 3.0102999E-01 / ! ! CONVEX C-120 (IEEE mode) with -R8 option ! ! data rmach(1) / 2.225073858507202D-308 / ! data rmach(2) / 1.797693134862315D+308 / ! data rmach(3) / 1.110223024625157D-016 / ! data rmach(4) / 2.220446049250313D-016 / ! data rmach(5) / 3.010299956639812D-001 / ! ! CRAY 1, 2, XMP and YMP. ! ! data rmach(1) / 200034000000000000000B / ! data rmach(2) / 577767777777777777776B / ! data rmach(3) / 377224000000000000000B / ! data rmach(4) / 377234000000000000000B / ! data rmach(5) / 377774642023241175720B / ! ! DATA GENERAL ECLIPSE S/200. ! Note - It may be appropriate to include the line: STATIC RMACH(5) ! ! data small /20K,0/ ! data large /77777K,177777K/ ! data right /35420K,0/ ! data diver /36020K,0/ ! data log10 /40423K,42023K/ ! ! ELXSI 6400, assuming REAL*4 is the default real type. ! ! data small(1) / '00800000'X / ! data large(1) / '7F7FFFFF'X / ! data right(1) / '33800000'X / ! data diver(1) / '34000000'X / ! data log10(1) / '3E9A209B'X / ! ! HARRIS 220 ! ! data small(1),small(2) / '20000000, '00000201 / ! data large(1),large(2) / '37777777, '00000177 / ! data right(1),right(2) / '20000000, '00000352 / ! data diver(1),diver(2) / '20000000, '00000353 / ! data log10(1),log10(2) / '23210115, '00000377 / ! ! HARRIS SLASH 6 and SLASH 7. ! ! data small(1),small(2) / '20000000, '00000201 / ! data large(1),large(2) / '37777777, '00000177 / ! data right(1),right(2) / '20000000, '00000352 / ! data diver(1),diver(2) / '20000000, '00000353 / ! data log10(1),log10(2) / '23210115, '00000377 / ! ! HONEYWELL DPS 8/70 and 600/6000 series. ! ! data rmach(1) / O402400000000 / ! data rmach(2) / O376777777777 / ! data rmach(3) / O714400000000 / ! data rmach(4) / O716400000000 / ! data rmach(5) / O776464202324 / ! ! HP 2100, 3 word double precision with FTN4 ! ! data small(1), small(2) / 40000B, 1 / ! data large(1), large(2) / 77777B, 177776B / ! data right(1), right(2) / 40000B, 325B / ! data diver(1), diver(2) / 40000B, 327B / ! data log10(1), log10(2) / 46420B, 46777B / ! ! HP 2100, 4 word double precision with FTN4 ! ! data small(1), small(2) / 40000B, 1 / ! data large91), large(2) / 77777B, 177776B / ! data right(1), right(2) / 40000B, 325B / ! data diver(1), diver(2) / 40000B, 327B / ! data log10(1), log10(2) / 46420B, 46777B / ! ! HP 9000 ! ! r1mach(1) = 1.17549435E-38 ! r1mach(2) = 1.70141163E+38 ! r1mach(3) = 5.960464478E-8 ! r1mach(4) = 1.119209290E-7 ! r1mach(5) = 3.01030010E-1 ! ! data small(1) / 00040000000B / ! data large(1) / 17677777777B / ! data right(1) / 06340000000B / ! data diver(1) / 06400000000B / ! data log10(1) / 07646420233B / ! ! IBM 360/370 series, XEROX SIGMA 5/7/9, SEL systems 85/86, PERKIN ELMER 3230, ! and PERKIN ELMER (INTERDATA) 3230. ! ! data rmach(1) / Z00100000 / ! data rmach(2) / Z7FFFFFFF / ! data rmach(3) / Z3B100000 / ! data rmach(4) / Z3C100000 / ! data rmach(5) / Z41134413 / ! ! IBM PC - Microsoft FORTRAN ! ! data small(1) / #00800000 / ! data large(1) / #7F7FFFFF / ! data right(1) / #33800000 / ! data diver(1) / #34000000 / ! data log10(1) / #3E9A209A / ! ! IBM PC - Professional FORTRAN and Lahey FORTRAN ! ! data small(1)/ Z'00800000' / ! data large(1)/ Z'7F7FFFFF' / ! data right(1)/ Z'33800000' / ! data diver(1)/ Z'34000000' / ! data log10(1)/ Z'3E9A209A' / ! ! INTERDATA 8/32 with the UNIX system FORTRAN 77 compiler. ! For the INTERDATA FORTRAN VII compiler replace the Z'S specifying HEX ! constants with Y'S. ! ! data rmach(1) / Z'00100000' / ! data rmach(2) / Z'7EFFFFFF' / ! data rmach(3) / Z'3B100000' / ! data rmach(4) / Z'3C100000' / ! data rmach(5) / Z'41134413' / ! ! PDP-10 (KA or KI processor). ! ! data rmach(1) / "000400000000 / ! data rmach(2) / "377777777777 / ! data rmach(3) / "146400000000 / ! data rmach(4) / "147400000000 / ! data rmach(5) / "177464202324 / ! ! PDP-11 FORTRANS supporting 32-bit integers (integer version). ! ! data small(1) / 8388608 / ! data large(1) / 2147483647 / ! data right(1) / 880803840 / ! data diver(1) / 889192448 / ! data log10(1) / 1067065499 / ! ! PDP-11 FORTRANS supporting 32-bit integers (octal version). ! ! data rmach(1) / O00040000000 / ! data rmach(2) / O17777777777 / ! data rmach(3) / O06440000000 / ! data rmach(4) / O06500000000 / ! data rmach(5) / O07746420233 / ! ! PDP-11 FORTRANS supporting 16-bit integers (integer version). ! ! data small(1),small(2) / 128, 0 / ! data large(1),large(2) / 32767, -1 / ! data right(1),right(2) / 13440, 0 / ! data diver(1),diver(2) / 13568, 0 / ! data log10(1),log10(2) / 16282, 8347 / ! ! PDP-11 FORTRANS supporting 16-bit integers (octal version). ! ! data small(1),small(2) / O000200, O000000 / ! data large(1),large(2) / O077777, O177777 / ! data right(1),right(2) / O032200, O000000 / ! data diver(1),diver(2) / O032400, O000000 / ! data log10(1),log10(2) / O037632, O020233 / ! ! SEQUENT BALANCE 8000. ! ! data small(1) / $00800000 / ! data large(1) / $7F7FFFFF / ! data right(1) / $33800000 / ! data diver(1) / $34000000 / ! data log10(1) / $3E9A209B / ! ! SUN Microsystems UNIX F77 compiler. ! ! data rmach(1) / 1.17549435E-38 / ! data rmach(2) / 3.40282347E+38 / ! data rmach(3) / 5.96016605E-08 / ! data rmach(4) / 1.19203321E-07 / ! data rmach(5) / 3.01030010E-01 / ! ! SUN 3 (68881 or FPA) ! ! data small(1) / X'00800000' / ! data large(1) / X'7F7FFFFF' / ! data right(1) / X'33800000' / ! data diver(1) / X'34000000' / ! data log10(1) / X'3E9A209B' / ! ! UNIVAC 1100 series. ! ! data rmach(1) / O000400000000 / ! data rmach(2) / O377777777777 / ! data rmach(3) / O146400000000 / ! data rmach(4) / O147400000000 / ! data rmach(5) / O177464202324 / ! ! VAX/ULTRIX F77 compiler. ! ! data small(1) / 128 / ! data large(1) / -32769 / ! data right(1) / 13440 / ! data diver(1) / 13568 / ! data log10(1) / 547045274 / ! ! VAX-11 with FORTRAN IV-PLUS compiler. ! ! data rmach(1) / Z00000080 / ! data rmach(2) / ZFFFF7FFF / ! data rmach(3) / Z00003480 / ! data rmach(4) / Z00003500 / ! data rmach(5) / Z209B3F9A / ! ! VAX/VMS version 2.2. ! ! data rmach(1) / '80'X / ! data rmach(2) / 'FFFF7FFF'X / ! data rmach(3) / '3480'X / ! data rmach(4) / '3500'X / ! data rmach(5) / '209B3F9A'X / ! ! VAX/VMS 11/780 ! ! data small(1) / Z00000080 / ! data large(1) / ZFFFF7FFF / ! data right(1) / Z00003480 / ! data diver(1) / Z00003500 / ! data log10(1) / Z209B3F9A / ! ! Z80 microprocessor. ! ! data small(1), small(2) / 0, 256 / ! data large(1), large(2) / -1, -129 / ! data right(1), right(2) / 0, 26880 / ! data diver(1), diver(2) / 0, 27136 / ! data log10(1), log10(2) / 8347, 32538 / ! if ( i < 1 .or. i > 5 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R1MACH - Fatal error!' write ( *, '(a,i6)' ) ' I is out of bounds=', i r1mach = 0.0E+00 stop else r1mach = rmach(i) end if return end subroutine r1mpyq ( m, n, a, lda, v, w ) ! !******************************************************************************* ! !! R1MPYQ 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: ! ! More, Garbow and Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer M, the number of rows of A. ! ! Input, integer N, the number of columns of A. ! ! Input/output, real A(LDA,N), the M by N array. ! On input, the matrix A to be postmultiplied by the orthogonal matrix Q. ! On output, the value of A*Q. ! ! Input, integer LDA, the leading dimension of A, which must not ! be less than M. ! ! Input, real V(N), W(N), contain the information necessary to recover ! the Givens rotations GV and GW. ! implicit none ! integer lda integer m integer n ! real a(lda,n) real c integer i integer j real s real temp real v(n) real w(n) ! ! Apply the first set of Givens rotations to A. ! do j = n-1, 1, -1 if ( abs ( v(j) ) > 1.0E+00 ) then c = 1.0E+00 / v(j) s = sqrt ( 1.0E+00 - c**2 ) else s = v(j) c = sqrt ( 1.0E+00 - s**2 ) 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 ( abs ( w(j) ) > 1.0E+00 ) then c = 1.0E+00 / w(j) s = sqrt ( 1.0E+00 - c**2 ) else s = w(j) c = sqrt ( 1.0E+00 - s**2 ) 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 r1updt ( m, n, s, ls, u, v, w, sing ) ! !******************************************************************************* ! !! R1UPDT re-triangularizes 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: ! ! More, Garbow and Hillstrom, ! User Guide for MINPACK-1 ! Argonne National Laboratory, ! Argonne, Illinois. ! ! Parameters: ! ! Input, integer M, the number of rows of S. ! ! Input, integer N, the number of columns of S. N must not exceed M. ! ! Input/output, real S(LS). On input, the lower trapezoidal matrix S ! stored by columns. On output S contains the lower trapezoidal matrix ! produced as described above. ! ! Input, integer LS, the length of the S array. LS must be at least ! (N*(2*M-N+1))/2. ! ! Input, real U(M), the U vector. ! ! Input/output, real 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 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 ls integer m integer n ! real cos real cotan real giant integer i integer j integer jj integer l real s(ls) real sin logical sing real tan real tau real temp real u(m) real v(n) real w(m) ! ! GIANT is the largest magnitude. ! giant = huge ( 1.0E+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.0E+00 if ( v(j) /= 0.0E+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.5E+00 / sqrt ( 0.25E+00 + 0.25E+00 * cotan**2 ) cos = sin * cotan tau = 1.0E+00 if ( abs ( cos ) * giant > 1.0E+00 ) tau = 1.0E+00 / cos else tan = v(j) / v(n) cos = 0.5E+00 / sqrt ( 0.25E+00 + 0.25E+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.0E+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.5E+00 / sqrt ( 0.25E+00 + 0.25E+00 * cotan**2 ) cos = sin * cotan tau = 1.0E+00 if ( abs ( cos ) * giant > 1.0E+00 ) then tau = 1.0E+00 / cos end if else tan = w(j) / s(jj) cos = 0.5E+00 / sqrt ( 0.25E+00 + 0.25E+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.0E+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.0E+00 ) then sing = .true. end if return end function r9lgmc ( x ) ! !******************************************************************************* ! !! R9LGMC computes the log gamma correction factor. ! ! ! Discussion: ! ! The routine computes the log gamma correction factor for x >= 10.0E+00 ! so that ! ! log ( gamma ( x ) ) = ! log ( sqrt ( 2 * pi ) ) + ( x - 0.5 ) * log ( x ) - x + r9lgmc ( x ) ! ! Parameters: ! ! Input, real X, the argument of the log gamma function. ! X must be at least 10. ! ! Output, real R9LGMC, the correction. ! implicit none ! real, save, dimension ( 6 ) :: algmcs = (/ & 0.166638948045186E+00, -0.0000138494817606E+00, 0.0000000098108256E+00, & -0.0000000000180912E+00, 0.0000000000000622E+00, -0.0000000000000003E+00 /) real arg real csevl integer inits integer, save :: nalgm = 0 real r1mach real r9lgmc real x real, save :: xbig = 0.0E+00 real, save :: xmax = 0.0E+00 ! if ( nalgm == 0 ) then nalgm = inits ( algmcs, 6, epsilon ( algmcs ) ) xbig = 1.0E+00 / sqrt ( epsilon ( xbig ) ) xmax = exp ( min ( log ( huge ( xmax ) / 12.0E+00 ), & -log ( 12.0E+00 * tiny ( xmax ) ) ) ) end if if ( x < 10.0E+00 ) then call xerror ( 'r9lgmc x must be >= 10', 23, 1, 2) else if ( x < xbig ) then arg = 2.0E+00 * ( 10.0E+00 / x )**2 - 1.0E+00 r9lgmc = csevl ( arg, algmcs, nalgm ) / x else if ( x < xmax ) then r9lgmc = 1.0E+00 / ( 12.0E+00 * x ) else r9lgmc = 0.0E+00 call xerror ( 'r9lgmc x so big r9lgmc underflows', 34, 2, 1) end if return end subroutine r_random ( rlo, rhi, r ) ! !******************************************************************************* ! !! R_RANDOM returns a random real in a given range. ! ! ! Discussion: ! ! Calls to the FORTRAN 90 random number generator should go through ! this routine, to guarantee that the random number seed has been set. ! ! Modified: ! ! 05 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, real RLO, RHI, the minimum and maximum values. ! ! Output, real R, the randomly chosen value. ! implicit none ! real r real rhi real rlo integer, save :: seed = 0 logical, save :: seeded = .false. real t real uniform_01_sample ! ! Make sure the random number generator has been seeded. ! if ( .not. seeded ) then call random_initialize ( seed ) seeded = .true. end if ! ! Pick T, a random number in (0,1). ! ! call random_number ( harvest = t ) ! t = uniform_01_sample ( seed ) ! ! Set R in ( RLO, RHI ). ! r = ( 1.0E+00 - t ) * rlo + t * rhi return end subroutine r_swap ( x, y ) ! !******************************************************************************* ! !! R_SWAP swaps two real values. ! ! ! Modified: ! ! 01 May 2000 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input/output, real X, Y. On output, the values of X and ! Y have been interchanged. ! implicit none ! real x real y real z ! z = x x = y y = z return end subroutine radb2 ( ido, l1, cc, ch, wa1 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,2,l1) real ch(ido,l1,2) integer i integer ic integer k real ti2 real tr2 real 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 ( ido > 2 ) 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 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,3,l1) real ch(ido,l1,3) real ci2 real ci3 real cr2 real cr3 real di2 real di3 real dr2 real dr3 integer i integer ic integer k real, parameter :: taui = 0.866025403784439E+00 real, parameter :: taur = -0.5E+00 real ti2 real tr2 real wa1(ido) real 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 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,4,l1) real ch(ido,l1,4) real ci2 real ci3 real ci4 real cr2 real cr3 real cr4 integer i integer ic integer k real, parameter :: sqrt2 = 1.414213562373095E+00 real ti1 real ti2 real ti3 real ti4 real tr1 real tr2 real tr3 real tr4 real wa1(ido) real wa2(ido) real 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 ( ido > 2 ) 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 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,5,l1) real ch(ido,l1,5) real ci2 real ci3 real ci4 real ci5 real cr2 real cr3 real cr4 real cr5 real di2 real di3 real di4 real di5 real dr2 real dr3 real dr4 real dr5 integer i integer ic integer k real, parameter :: ti11 = 0.951056516295154E+00 real, parameter :: ti12 = 0.587785252292473E+00 real ti2 real ti3 real ti4 real ti5 real, parameter :: tr11 = 0.309016994374947E+00 real, parameter :: tr12 = -0.809016994374947E+00 real tr2 real tr3 real tr4 real tr5 real wa1(ido) real wa2(ido) real wa3(ido) real 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 ) ! !******************************************************************************* ! !! 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 idl1 integer ido integer ip integer l1 ! real ai1 real ai2 real ar1 real ar1h real ar2 real ar2h real arg real c1(ido,l1,ip) real c2(idl1,ip) real cc(ido,ip,l1) real ch(ido,l1,ip) real ch2(idl1,ip) real dc2 real dcp real ds2 real dsp integer i integer ic integer idij integer ik integer ipph integer is integer j integer j2 integer jc integer k integer l integer lc integer nbd real pi real wa(*) ! arg = 2.0E+00 * pi() / real ( ip ) 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 ( nbd >= l1 ) 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.0E+00 ai1 = 0.0E+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 ( nbd >= l1 ) 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 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,l1,2) real ch(ido,2,l1) integer i integer ic integer k real ti2 real tr2 real 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 ( ido > 2 ) 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 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,l1,3) real ch(ido,3,l1) real ci2 real cr2 real di2 real di3 real dr2 real dr3 integer i integer ic integer k real, parameter :: taui = 0.866025403784439E+00 real, parameter :: taur = -0.5E+00 real ti2 real ti3 real tr2 real tr3 real wa1(ido) real 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 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,l1,4) real ch(ido,4,l1) real ci2 real ci3 real ci4 real cr2 real cr3 real cr4 real, parameter :: hsqt2 = 0.7071067811865475E+00 integer i integer ic integer k real ti1 real ti2 real ti3 real ti4 real tr1 real tr2 real tr3 real tr4 real wa1(ido) real wa2(ido) real 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 ( ido > 2 ) 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 ) ! !******************************************************************************* ! !! 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 ido integer l1 ! real cc(ido,l1,5) real ch(ido,5,l1) real ci2 real ci3 real ci4 real ci5 real cr2 real cr3 real cr4 real cr5 real di2 real di3 real di4 real di5 real dr2 real dr3 real dr4 real dr5 integer i integer ic integer k real, parameter :: ti11 = 0.951056516295154E+00 real, parameter :: ti12 = 0.587785252292473E+00 real ti2 real ti3 real ti4 real ti5 real, parameter :: tr11 = 0.309016994374947E+00 real, parameter :: tr12 = -0.809016994374947E+00 real tr2 real tr3 real tr4 real tr5 real wa1(ido) real wa2(ido) real wa3(ido) real 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 ) ! !******************************************************************************* ! !! 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 idl1 integer ido integer ip integer l1 ! real ai1 real ai2 real ar1 real ar1h real ar2 real ar2h real arg real c1(ido,l1,ip) real c2(idl1,ip) real cc(ido,ip,l1) real ch(ido,l1,ip) real ch2(idl1,ip) real dc2 real dcp real ds2 real dsp integer i integer ic integer idij integer ik integer ipph integer is integer j integer j2 integer jc integer k integer l integer lc integer nbd real pi real wa(*) ! arg = 2.0E+00 * pi() / real ( ip ) 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 ( nbd >= l1 ) 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.0E+00 ai1 = 0.0E+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 ( nbd >= l1 ) 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 ) ! !******************************************************************************* ! !! RANDOM_INITIALIZE initializes the FORTRAN 90 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. ! ! And this is the FORTRAN 90 people's idea of convenience? ! ! And I still get poorly randomized values, somehow, having to do ! with a bad seed, or something. I am about ready to go back to ! using my own damn routine! ! ! Modified: ! ! 06 February 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Output, integer SEED, a seed value. ! implicit none ! integer date_time(8) integer i integer seed integer, allocatable :: seed_vector(:) integer seed_size real t integer value ! ! 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 ) ! !******************************************************************************* ! !! RESULT prints information about the optimization process. ! ! ! Parameters: ! ! Input, integer NR, the row dimension of the matrix. ! ! Input, integer N, the dimension of the problem. ! ! Input, real X(N), the current iterate. ! ! Input, real F, the function value at X. ! ! Input, real G(N), the gradient at X. ! ! Input, real A(NR,N), the N by N Hessian matrix at X. ! ! Input, real P(N), the step taken. ! ! Input, integer ITNCNT, the iteration number. ! ! Input, integer IFLG, the flag controlling the amount of printout. ! ! Input, integer IPR, the device to which to send output. ! implicit none ! integer n integer nr ! real a(nr,n) real f real g(n) integer i integer iflg integer ipr integer itncnt integer j real p(n) real 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 subroutine rfftb ( n, r, wsave ) ! !******************************************************************************* ! !! RFFTB computes a real periodic sequence from its Fourier coefficients. ! ! ! Discussion: ! ! This process is sometimes called Fourier synthesis. ! ! The transform is unnormalized. A call to RFFTF followed by a call to ! RFFTB 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. The ! method is more efficient when N is the product of small primes. ! ! Input/output, real R(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real WSAVE(2*N+15), a work array. The WSAVE array must be ! initialized by calling RFFTI. A different WSAVE array must be used ! for each different value of N. ! implicit none ! integer n ! real r(n) real wsave(2*n+15) ! if ( n <= 1 ) then return end if call rfftb1 ( n, r, wsave(1), wsave(n+1), wsave(2*n+1) ) return end subroutine rfftb1 ( n, c, ch, wa, ifac ) ! !******************************************************************************* ! !! RFFTB1 is a lower level routine used by RFFTB. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Input/output, real C(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real CH(N). ! ! Input, real WA(N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer n ! real c(n) real ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer l1 integer l2 integer na integer nf real 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 rfftf ( n, r, wsave ) ! !******************************************************************************* ! !! RFFTF computes the Fourier coefficients of a real periodic sequence. ! ! ! Discussion: ! ! This process is sometimes called Fourier analysis. ! ! The transform is unnormalized. A call to RFFTF followed by a call ! to RFFTB 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. The ! method is more efficient when N is the product of small primes. ! ! Input/output, real R(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real WSAVE(2*N+15), a work array. The WSAVE array must be ! initialized by calling RFFTI. A different WSAVE array must be used ! for each different value of N. ! implicit none ! integer n ! real r(n) real wsave(2*n+15) ! if ( n <= 1 ) then return end if call rfftf1 ( n, r, wsave(1), wsave(n+1), wsave(2*n+1) ) return end subroutine rfftf1 ( n, c, ch, wa, ifac ) ! !******************************************************************************* ! !! RFFTF1 is a lower level routine used by RFFTF and SINT. ! ! ! Modified: ! ! 12 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the array to be transformed. ! ! Input/output, real C(N). ! On input, the sequence to be transformed. ! On output, the transformed sequence. ! ! Input, real CH(N). ! ! Input, real WA(N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer n ! real c(n) real ch(n) integer idl1 integer ido integer ifac(15) integer ip integer iw integer ix2 integer ix3 integer ix4 integer k1 integer kh integer l1 integer l2 integer na integer nf real 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 rffti ( n, wsave ) ! !******************************************************************************* ! !! RFFTI initializes WSAVE, used in RFFTF and RFFTB. ! ! ! 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, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! P N Swarztrauber, ! Vectorizing the FFT's, ! in Parallel Computations (G. Rodrigue, editor), ! Academic Press, 1982, pages 51-83. ! ! B L Buzbee, ! The SLATEC Common Math Library, ! in Sources and Development of Mathematical Software (W. Cowell, editor), ! Prentice Hall, 1984, pages 302-318. ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! ! Output, real WSAVE(2*N+15), contains data, dependent on the value ! of N, which is necessary for the RFFTF and RFFTB routines. ! implicit none ! integer n ! real wsave(2*n+15) ! if ( n <= 1 ) then return end if call rffti1 ( n, wsave(n+1), wsave(2*n+1) ) return end subroutine rffti1 ( n, wa, ifac ) ! !******************************************************************************* ! !! RFFTI1 is a lower level routine used by RFFTI. ! ! ! Modified: ! ! 09 March 2001 ! ! Author: ! ! Paul Swarztrauber, ! National Center for Atmospheric Research ! ! Parameters: ! ! Input, integer N, the length of the sequence to be transformed. ! ! Input, real WA(N). ! ! Input, integer IFAC(15). ! IFAC(1) = N, the number that was factored. ! IFAC(2) = NF, the number of factors. ! IFAC(3:2+NF), the factors. ! implicit none ! integer n ! real arg real argh real argld real fi integer i integer ib integer ido integer ifac(15) integer ii integer ip integer is integer j integer k1 integer l1 integer l2 integer ld integer nf real pi real wa(n) ! call i_factor ( n, ifac ) nf = ifac(2) argh = 2.0E+00 * pi() / real ( n ) 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 ) * argh fi = 0.0E+00 do ii = 3, ido, 2 i = i + 2 fi = fi + 1.0E+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 function rnor ( ) ! !******************************************************************************* ! !! RNOR generates normal random numbers. ! ! ! Discussion: ! ! RNOR generates normal random numbers with zero mean and ! unit standard deviation, often denoted n(0,1). ! ! Before the first call to RNOR, you should call RSTART, passing it ! a nonzero value of ISEED. This will initialize RNOR. ! ! Reference: ! ! David Kahaner, Clever Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1988. ! ! Marsaglia and Tsang, ! A fast, easily implemented method for sampling from decreasing or ! symmetric unimodal density functions, ! SIAM Journal of Scientific and Statistical Computing, 1983. ! ! Parameters: ! ! Output, real RNOR, a normal random number. ! implicit none ! real, parameter :: aa = 12.37586E+00 real, parameter :: b = 0.4878992E+00 real, parameter :: c = 12.67706E+00 real, save :: c1 = 0.9689279E+00 real, save :: c2 = 1.301198E+00 integer ia integer ib integer ic integer id integer, save :: ii = 17 integer iii integer iseed integer j integer, save :: jj = 5 integer jjj real, save :: pc = 0.01958303E+00 real rnor real rstart real s real t real, save, dimension ( 17 ) :: u = (/ & 0.8668672834288E+00, 0.3697986366357E+00, 0.8008968294805E+00, & 0.4173889774680E+00, 0.8254561579836E+00, 0.9640965269077E+00, & 0.4508667414265E+00, 0.6451309529668E+00, 0.1645456024730E+00, & 0.2787901807898E+00, 0.06761531340295E+00, 0.9663226330820E+00, & 0.01963343943798E+00, 0.02947398211399E+00, 0.1636231515294E+00, & 0.3976343250467E+00, 0.2631008574685E+00 /) real un real v(65) real vni real x real, save :: xn = 2.776994E+00 real y ! data v/ & 0.3409450E+00, 0.4573146E+00, 0.5397793E+00, 0.6062427E+00, 0.6631691E+00, & 0.7136975E+00, 0.7596125E+00, 0.8020356E+00, 0.8417227E+00, 0.8792102E+00, & 0.9148948E+00, 0.9490791E+00, 0.9820005E+00, 1.0138492E+00, 1.0447810E+00, & 1.0749254E+00, 1.1043917E+00, 1.1332738E+00, 1.1616530E+00, 1.1896010E+00, & 1.2171815E+00, 1.2444516E+00, 1.2714635E+00, 1.2982650E+00, 1.3249008E+00, & 1.3514125E+00, 1.3778399E+00, 1.4042211E+00, 1.4305929E+00, 1.4569915E+00, & 1.4834526E+00, 1.5100121E+00, 1.5367061E+00, 1.5635712E+00, 1.5906454E+00, & 1.6179680E+00, 1.6455802E+00, 1.6735255E+00, 1.7018503E+00, 1.7306045E+00, & 1.7598422E+00, 1.7896223E+00, 1.8200099E+00, 1.8510770E+00, 1.8829044E+00, & 1.9155830E+00, 1.9492166E+00, 1.9839239E+00, 2.0198430E+00, 2.0571356E+00, & 2.0959930E+00, 2.1366450E+00, 2.1793713E+00, 2.2245175E+00, 2.2725185E+00, & 2.3239338E+00, 2.3795007E+00, 2.4402218E+00, 2.5075117E+00, 2.5834658E+00, & 2.6713916E+00, 2.7769943E+00, 2.7769943E+00, 2.7769943E+00, 2.7769943E+00 / ! ! fast part... ! ! Basic generator is fibonacci. ! un = u(ii) - u(jj) if ( un < 0.0E+00 ) then un = un + 1.0E+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.0E+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. ! rnor = vni * v(j+1) if ( abs ( rnor ) <= v(j) ) then return end if ! ! slow part; aa is a * f(0) ! x = ( abs ( rnor ) - v(j) ) / ( v(j+1) - v(j) ) ! ! Y is uniform on [0,1) ! y = u(ii) - u(jj) if ( y < 0.0E+00 ) then y = y + 1.0E+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 ( s > c2 ) go to 11 if ( s <= c1 ) then return end if if ( y > c - aa * exp ( -0.5E+00 * ( b - b * x )**2 ) )go to 11 if ( exp ( -0.5E+00 * v(j+1)**2 ) + y * pc / v(j+1) <= & exp ( -0.5E+00 * rnor**2 ) ) then return end if ! ! tail part; 0.3601016 is 1.0/xn ! y is uniform on [0,1) ! 22 continue y = u(ii) - u(jj) if ( y <= 0.0E+00 ) then y = y + 1.0E+00 end if u(ii) = y ii = ii-1 if ( ii == 0 ) ii = 17 jj = jj-1 if ( jj == 0 ) jj = 17 x = 0.3601016E+00 * log ( y ) ! ! y is uniform on [0,1) ! y = u(ii) - u(jj) if ( y <= 0.0E+00 ) y = y + 1.0E+00 u(ii) = y ii = ii-1 if ( ii == 0 ) ii = 17 jj = jj-1 if ( jj == 0 ) jj = 17 if ( -2.0E+00 * log ( y ) <= x**2 ) go to 22 rnor = sign ( xn - x, rnor ) return 11 rnor = sign ( b - b * x, rnor ) return ! ! fill ! entry rstart ( iseed ) ! !******************************************************************************* ! !! RSTART is an entry point used to initialize RNOR. ! 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.0E+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.5E+00 * t end do u(iii) = s end do end if ! ! return floating echo of iseed. ! rstart = iseed return end subroutine rsftb ( n, r, azero, a, b ) ! !******************************************************************************* ! !! RSFTB computes a "slow" backward Fourier transform of real data. ! ! ! Modified: ! ! 13 March 2001 ! ! Author: ! ! John Burkardt ! ! Parameters: ! ! Input, integer N, the number of data values. ! ! Output, real R(N), the reconstructed data sequence. ! ! Input, real AZERO, the constant Fourier coefficient. ! ! Input, real A(N/2), B(N/2), the Fourier coefficients. ! implicit none ! integer n ! real a(n/2) real azero real b(n/2) integer i integer k real, parameter :: pi = 3.14159265358979323846264338327950288419716939937510E+00 real r(n) real theta ! r(1:n) = azero do i = 1, n do k = 1, n/2 theta = real ( k * ( i - 1 ) * 2 ) * pi / real ( n ) r(i) = r(i) + a(k) * cos ( theta ) + b(k) * sin ( theta ) end do end do return end subroutine rsftf ( n, r, azero, a, b ) ! !******************************************************************************* ! !! RSFTF computes a "slow" forward Fourier transform of real data. ! ! ! Modified: ! ! 13 March 2001 ! ! Parameters: ! ! Input, integer N, the number of data values. ! ! Input, real R(N), the data to be transformed. ! ! Output, real AZERO, = sum ( 1 <= I <= N ) R(I) / N. ! ! Output, real A(N/2), B(N/2), the Fourier coefficients. ! implicit none ! integer n ! real a(1:n/2) real azero real b(1:n/2) integer i integer j real, parameter :: pi = 3.14159265358979323846264338327950288419716939937510E+00 real r(n) real theta ! azero = sum ( r(1:n) ) / real ( n ) do i = 1, n / 2 a(i) = 0.0E+00 b(i) = 0.0E+00 do j = 1, n theta = real ( 2 * i * ( j - 1 ) ) * pi / real ( n ) a(i) = a(i) + r(j) * cos ( theta ) b(i) = b(i) + r(j) * sin ( theta ) end do a(i) = a(i) / real ( n ) b(i) = b(i) / real ( n ) if ( i /= ( n / 2 ) ) then a(i) = 2.0E+00 * a(i) b(i) = 2.0E+00 * b(i) end if end do return end