subroutine abscom ( n, v, w, abstol, nfail ) !*****************************************************************************80 ! !! abscom() counts the entries of | V(1:N) - W(1:N) | greater than ABSTOL. ! ! Discussion: ! ! This routine computes the number of times the absolute difference ! between V(I) and W(I), I = 1, 2, ..., N, is greater than ABSTOL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer N, the number of observations. ! ! Input, real V(N), W(N), the values being compared. ! ! Input, real ABSTOL, the absolute tolerance used in the comparison. ! ! Output, integer NFAIL, the total number of failures. ! implicit none real abstol integer i integer n integer nfail real v(*) real w(*) nfail = 0 do i = 1, n if ( abstol < abs ( v(i) - w(i) ) ) then nfail = nfail + 1 end if end do return end subroutine accdig ( ax, x, ad, n ) !*****************************************************************************80 ! !! ACCDIG returns the number of accurate digits in an approximation to X. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, real AX(N), the approximation to the solution. ! ! Input, real X(N), the solution. ! ! Output, real AD(N), the number of accurate digits. ! ! Input, integer N, the number of elements being compared. ! ! Local Parameters: ! ! Local, real ADMAX, the number of digits carried in a floating ! point computation. ! ! Local, real FPLRS, the floating point largest relative spacing. ! implicit none integer n real ad(n) real admax real ax(n) real diff real fplrs integer i real x(n) fplrs = epsilon ( fplrs ) admax = -log10 ( fplrs ) do i = 1, n diff = ax(i) - x(i) if ( diff == 0.0E+00 ) then ad(i) = admax else ad(i) = 0.0E+00 if ( 0.0E+00 < abs ( x(i) ) ) then ad(i) = log10 ( abs ( x(i) ) ) end if if ( 0.0E+00 < abs ( diff ) ) then ad(i) = -log10 ( abs ( diff ) ) + ad(i) end if ad(i) = min ( ad(i), admax ) ad(i) = max ( ad(i), -admax ) end if end do return end subroutine acfd ( y, n, lagmax, nfac, nd, iod, ldstak ) !*****************************************************************************80 ! !! ACFD computes autocorrelations and partial autocorrelations. ! ! Discussion: ! ! This is the user callable routine for computing the autocorrelations ! and partial autocorrelations of a time series with differencing. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer acov ! the starting location in dstak for ! the autocovariance vector. ! integer aic ! the starting location in dstak for ! the array containing the akaikes criterion for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the variable used to designate whether or not the series ! being analyzed was differenced or not. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ftest ! the starting location in dstak for ! the array containing the partial f ratio and probabilities ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! integer ifp ! the indicator variable used to designate whether the floating ! point variables are single (ifp=3) or double (ifp=4) precision. ! integer iod(nfac) ! the order of each of the difference factors. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! integer nd(nfac) ! the array containing the number of times the difference ! factors are to be applied. ! integer ndum(1) ! a dummy dimensioned variable. ! logical newpg ! the variable used to designate whether or not the output ! is to begin on a new page. ! integer nfac ! the number of difference factors. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer ntimes ! the number of times the first difference factor has been ! applied. ! integer nyd, nyf ! the number of observations after the difference filter is ! applied. ! real ospvar ! the one step prediction variance for the order selected (iar). ! integer phi ! the starting location in dstak for ! the array of autoregressive coefficients for the selected ! order. ! integer prho ! the starting location in the work area for prho. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrho ! the starting location in the work area for sdrho. ! integer work ! the starting location in the work area for work. ! real y(n) ! the vector containing the observed time series ! integer yf ! the starting location in dstak for ! the vector containing the difference filtered series. ! real ymean ! the mean of the observed time series ! real ysd ! the standard deviation of the observed time series ! implicit none integer n integer nfac integer iod(nfac) real y(n) integer lagmax,ldstak ! ! array arguments integer & nd(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & chia,chiap,ospvar,ymean,ysd integer & acov,aic,ftest,i,iar,ifp,lacov,ldsmin,lyfft,nall0, & nfft,ntimes,nyd,nyf,phi,prho,sdrho,work,yf logical & differ,isfft,newpg ! ! local arrays real & rstak(12) integer & ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acfer,acfmn,acfout,difser,ldscmp,scopy,stkclr, & stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'c', 'f', 'd', ' ', ' '/ ierr = 0 lacov = lagmax+1 differ = .true. isfft = .false. lyfft = 0 nfft = 0 call ldscmp(7, 0, 0, 0, 0, 0, 's', 7*lagmax+2+n, ldsmin) call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft) if ( ierr /= 0 ) then ierr = 1 return end if ! ! set up the work area. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 acov = stkget(lagmax+1, ifp) prho = stkget(lagmax, ifp) aic = stkget(lagmax+1, ifp) ftest = stkget(2*lagmax, ifp) phi = stkget(lagmax, ifp) work = stkget(lagmax, ifp) yf = stkget(n, ifp) sdrho = work if ( ierr /= 0 ) then ierr = 1 return end if newpg = .false. ntimes = 0 ! ! check whether there is more than one difference factor. ! if (nfac <= 1) then call scopy(n, y, 1, rstak(yf), 1) else ! ! create new data by applying difference factors beyond the first. ! call difser(y, n, nfac-1, nd(2), iod(2), rstak(yf), nyf) end if nyd = n ! ! call routine for main autocorrelation computations. ! call acfmn (rstak(yf), nyd, min(lagmax, nyd-1), & rstak(acov+1), rstak(sdrho), ymean, rstak(prho), & rstak(aic), rstak(ftest), rstak(phi), iar, ospvar, & rstak(acov), lagmax+1, lagmax+1, chia, chiap, rstak(work), & 1) ysd = sqrt(rstak(acov) * real ( n ) / real(n-1)) ! ! call routine to print out autocorrelations ! call acfout (ymean, ysd, nyf, nyf, min(lagmax, nyd-1), & rstak(acov+1), rstak(sdrho), rstak(prho), ndum, rstak(aic), & lagmax+1, rstak(ftest), iar, rstak(phi), ospvar, chia, & chiap, lagmax, .false., 0.0e0, differ, newpg, nfac, nd, & iod, ntimes) newpg = .true. ! ! compute correlation analysis for first difference factor ! applied 1 to nd(1) times ! if ((nfac >= 1) .and. (nd(1) >= 1)) then do i = 1, nd(1) call difser(rstak(yf), nyd, nfac-1, nd(2), iod(2), & rstak(yf), nyf) ! ! call routine for main autocorrelation computations. ! call acfmn (rstak(yf), nyd, min(lagmax, nyd-1), & rstak(acov+1), rstak(sdrho), ymean, rstak(prho), & rstak(aic), rstak(ftest), rstak(phi), iar, ospvar, & rstak(acov), lagmax+1, lagmax+1, chia, chiap, & rstak(work), 1) ysd = sqrt(rstak(acov) * real ( n ) / real (n-1)) ! ! call routine to print out autocorrelations ! call acfout (ymean, ysd, nyf, nyf, min(lagmax, nyd-1), & rstak(acov+1), rstak(sdrho), rstak(prho), ndum, & rstak(aic), lagmax+1, rstak(ftest), iar, rstak(phi), & ospvar, chia, chiap, lagmax, .false., 0.0e0, differ, & newpg, nfac, nd, iod, i) end do end if call stkclr(nall0) return end subroutine acfdtl ( ndf, nd, iod, ntimes ) !*****************************************************************************80 ! !! ACFDTL prints titles for ACORRD. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! character*1 icom ! the hollerith value -,- (comma) ! integer iod(ndf) ! the order of each of the difference factors. ! character*1 iper ! the hollerith value -.- (period) ! character*1 ipunct ! the hollerith value of either comma or period. ! integer istop ! one less than the number of difference factors. ! integer nd(ndf) ! the array containing the number of times the difference ! factors are to be applied. ! integer ndf ! the number of difference factors. ! integer ntimes ! the number of times the differencing factor has been applied. ! implicit none integer & ndf,ntimes ! ! array arguments integer & iod(ndf),nd(ndf) ! ! integer & i,istop character & icom*1,iper*1,ipunct*1 data icom/','/, iper/'.'/ if (ndf <= 1) then write ( *, 1002 ) else istop = ndf - 1 ipunct = iper if (ntimes >= 1) ipunct = icom write ( *, 1000) if (ndf == 2) write ( *, 1001) nd(2), iod(2), iper if (ndf >= 3) write ( *, 1001) & (nd(i), iod(i), icom, i = 1, istop), nd(ndf), iod(ndf), ipunct end if if (ntimes == 0) then return end if if (ndf >= 2) write ( *, 1003) ntimes, iod(1) if (ndf == 1) write ( *, 1004) ntimes, iod(1) return 1000 format(//' series analyzed is input series differenced by'/) 1001 format(3x, 3(i3, ' factor(s) of order ', i3, a1, 1x)/) 1002 format(//' series analyzed is original input series'/) 1003 format(4x, ' and, in addition, differenced by ', i3, & ' factors of order ', i3, '.'//) 1004 format(4x, ' differenced by ', i3, ' factors of order ', & i3, '.'//) end subroutine acfer ( nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft ) !*****************************************************************************80 ! !! acfer() does error checking for the ACF routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical differ ! the indicator variable used to designate whether the calling ! routine is acfd (differ = true) or not (differ = false) ! logical err(15) ! values indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! integer iod(nfac) ! the order of each of the difference vactors ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 llacov(8), llagmx(8), llds(8), llgmx1(8), llyfft(8), ! * ln(8), lnfft(8), lnm1(8), lone(8), lthree(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in each series ! integer nd(nfac) ! the array containing the number of times the difference factors ! are to be applied ! integer nfac ! the number of factors. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! implicit none integer & lacov,lagmax,ldsmin,ldstak,lyfft,n,nfac,nfft logical & differ,isfft ! ! array arguments integer & iod(*),nd(*) character & nmsub(6)*1 ! ! scalars in common integer ierr ! ! integer & i logical & head ! ! local arrays logical & err(15) character & llacov(8)*1,llagmx(8)*1,llds(8)*1,llgmx1(8)*1, & llyfft(8)*1,ln(8)*1,lnfft(8)*1,lnm1(8)*1,lone(8)*1, & lthree(8)*1 ! ! external subroutines external eisge,eisii,erdf ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & llacov(1), llacov(2), llacov(3), llacov(4), llacov(5), & llacov(6), llacov(7), llacov(8) /'l','a','c','o','v',' ',' ',' '/ data & llagmx(1), llagmx(2), llagmx(3), llagmx(4), llagmx(5), & llagmx(6), llagmx(7), llagmx(8) /'l','a','g','m','a','x',' ',' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & llgmx1(1), llgmx1(2), llgmx1(3), llgmx1(4), llgmx1(5), & llgmx1(6), llgmx1(7), llgmx1(8) /'l','a','g','m','a','x','+','1'/ data & llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) /'l','y','f','f','t',' ',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), & ln(6), ln(7), ln(8) /'n',' ',' ',' ',' ',' ',' ',' '/ data & lnm1(1), lnm1(2), lnm1(3), lnm1(4), lnm1(5), & lnm1(6), lnm1(7), lnm1(8) /'(','n','-','1',')',' ',' ',' '/ data & lnfft(1), lnfft(2), lnfft(3), lnfft(4), lnfft(5), & lnfft(6), lnfft(7), lnfft(8) /'n','f','f','t',' ',' ',' ',' '/ data & lone(1), lone(2), lone(3), lone(4), lone(5), & lone(6), lone(7), lone(8) /'o','n','e',' ',' ',' ',' ',' '/ data & lthree(1), lthree(2), lthree(3), lthree(4), lthree(5), & lthree(6), lthree(7), lthree(8) /'t','h','r','e','e',' ',' ',' '/ ierr = 0 head = .true. err(1:15) = .false. call eisge(nmsub, ln, n, 3, 2, head, err(1), lthree) if ( err(1) ) then ierr = 1 return end if call eisii(nmsub, llagmx, lagmax, 1, n-1, 1, head, err(2), lone, lnm1) if (differ) then call erdf(nmsub, nfac, nd, iod, n, head, err(3)) end if if ( err(2) ) then ierr = 1 return end if call eisge(nmsub, llacov, lacov, lagmax+1, 2, head, err(4), llgmx1) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(5), llds) if (isfft) then call eisge(nmsub, llyfft, lyfft, nfft, 2, head, err(6), lnfft) end if do i = 1, 15 if ( err(i) ) then ierr = 1 return end if end do return end subroutine acf ( y, n ) !*****************************************************************************80 ! !! acf() is the simple interface to the autocorrelations routines. ! ! Discussion: ! ! this is the user callable routine for computing the auto- ! correlations and partial autocorrelations of a time series ! (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(101) ! the autocovariance function estimate vector. ! real aic(101) ! the array containing akiakes criteria for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the indicator variable used to designate whether the calling ! routine is acfd (differ = true) or not (differ = false) ! real ftest(2, 100) ! the array in which the f ratio and probability are stored. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer iod(1) ! the order of each of the difference factors. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the vector aic. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in each series ! integer nd(1) ! the number of times each difference factor is to be applied ! integer ndum(1) ! a dummy array. ! integer nfac ! the number of difference factors ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nprt ! the variable controling the printed output. ! real ospvar ! the one step prediction variance for the selected order (iar). ! real phi(100) ! the array of autoregressive coefficients for the selected ! order. ! real prho(100) ! the array containing the partial acf estimates. ! real rho(100) ! the array containing the acf estimates. ! real sdrho(100) ! the array containing the standard errors of the acf estimates. ! real work(100) ! a vector used in the computations of the partial ! autocorrelation coefficients. ! real y(n) ! the vector containing the observed time series ! real ymean, ysd ! the mean and standard deviation of the observed time series ! implicit none integer & n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! real & chia,chiap,ospvar,ymean,ysd integer & iar,lacov,lagmax,laic,ldsmin,ldstak,lyfft,nfac,nfft, & nprt logical & differ,isfft ! ! local arrays real & acov(101),aic(101),ftest(2,100),phi(100),prho(100),rho(100), & sdrho(100),work(100) integer & iod(1),nd(1),ndum(1) character & nmsub(6)*1 ! ! external subroutines external acfer,acfmn,acfout,setlag ! ! common blocks common /errchk/ierr ! ! equivalences equivalence (acov(2),rho(1)) equivalence (work(1),sdrho(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'c', 'f', ' ', ' ', ' '/ ierr = 0 lagmax = 1 lacov = 101 laic = 101 ldsmin = 0 ldstak = 0 nprt = 1 differ = .false. nfac = 1 nd(1) = 0 iod(1) = 0 isfft = .false. lyfft = n nfft = n call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft) if (ierr == 0) then ! ! set number of acf to be computed ! call setlag (n, lagmax) ! ! call routine for main autocorrelation computations. ! call acfmn (y, n, lagmax, rho, sdrho, ymean, prho, aic, ftest, & phi, iar, ospvar, acov, lacov, laic, chia, chiap, work, nprt) ! ysd = sqrt(acov(1) * real ( n ) / real (n-1)) ! ! call routine to print out autocorrelations ! call acfout (ymean, ysd, n, n, lagmax, rho, sdrho, prho, ndum, & aic, laic, ftest, iar, phi, ospvar, chia, chiap, lagmax, & .false., 0.0e0, .false., .false., 0, ndum, ndum, 0) end if if ( ierr /= 0 ) then ierr = 1 end if return end subroutine acff ( yfft, n, lyfft, ldstak ) !*****************************************************************************80 ! !! ACFF computes autocorrelations of a time series using an FFT. ! ! Discussion: ! ! This is the user callable routine for computing the auto- ! correlations and partial autocorrelations of a time series ! using an fft (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(101) ! the autocovariance vector. ! real aic(101) ! the array containing akaikes criteria for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the indicator variable used to designate whether the calling ! routine is acfd (differ = true) or not (differ = false) ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real ftest(2, 100) ! the array in which the f ratio and probability are stored. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr /= 0 errors were detected. ! integer ifp ! the indicator variable used to designate whether the floating ! point variables are single (ifp=3) or double (ifp=4) precision. ! integer iod(1) ! the order of each of the difference factors. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value requested. ! integer laic ! the length of the vector aic. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! integer nd(1) ! the number of times each difference factor is to be applied ! integer ndum(1) ! a dummy array. ! integer nfac ! the number of difference factors ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! real ospvar ! the one step prediction variance for the selected order (iar). ! real phi(100) ! the array of autoregressive coefficients for the selected ! order. ! real prho(100) ! the array containing the parital acf estimates. ! real rho(100) ! the array containing the acf estimates. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrho ! the starting location in dstak for ! the array containing the standard errors of the acf estimates. ! integer work ! the starting location in the work area for work. ! real yfft(lyfft) ! the vector containing the observed time series ! real ymean ! the mean of the observed time series ! real ysd ! the standard deviation of the observed time series ! implicit none integer & ldstak,lyfft,n ! ! array arguments real & yfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & chia,chiap,ospvar,ymean,ysd integer & iar,ifp,lacov,lagmax,laic,ldsmin,nall0,nfac,nfft, & sdrho,work logical & differ,isfft ! ! local arrays real & acov(101),aic(101),ftest(2,100),phi(100),prho(100),rho(100), & rstak(12) integer & iod(1),nd(1),ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acfer,acfmnf,acfout,fftlen,ldscmp,setlag,stkclr, & stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (acov(2),rho(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'c', 'f', 'f', ' ', ' '/ ierr = 0 lacov = 101 laic = 101 differ = .false. nfac = 1 nd(1) = 0 iod(1) = 0 isfft = .true. ! ! Set number of ACF to be computed and length of extended series. ! if ( 3 <= n ) then call setlag(n, lagmax) call fftlen(n+lagmax, 4, nfft) end if call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin) ! ! Call error checking routines. ! call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft) ! ! Check whether an error has been detected. ! if (ierr==0) then ! ! Set up the work area. ! call stkset (ldstak, 4) nall0 = stkst(1) ifp = 3 work = stkget(nfft, ifp) sdrho = work if (ierr==0) then ! ! Call routine for main autocorrelation computations. ! call acfmnf (yfft, n, nfft, lagmax, rho, rstak(sdrho), ymean, & prho, aic, ftest, phi, iar, ospvar, acov, lacov, laic, & chia, chiap, lyfft, rstak(work), nfft, 1) ysd = sqrt (acov(1) * real ( n ) / real (n - 1)) ! ! Print autocorrelations. ! call acfout(ymean, ysd, n, n, lagmax, rho, rstak(sdrho), prho, & ndum, aic, laic, ftest, iar, phi, ospvar, chia, chiap, & lagmax, .false., 0.0e0, .false., .false., 0, ndum, ndum, & 0) end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine acffs ( yfft, n, lyfft, ldstak, lagmax, lacov, acov, iar, phi, & nprt ) !*****************************************************************************80 ! !! ACFFS uses an FFT with ACVF estimates for autocorrelations of a time series. ! ! Discussion: ! ! this is the user callable routine for computing the auto- ! correlations and partial autocorrelations of a time series ! using a fft with the computed acvf estimates returned to the users ! routine (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance vector. ! integer aic ! the starting location in dstak for ! the array containing the akaikes criterion for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the indicator variable used to designate whether the calling ! routine is acfd (differ = true) or not (differ = false) ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ftest ! the starting location in dstak for ! the array containing the partial f ratio and probabilities ! integer i ! an indexing variable. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! integer ifp ! the indicator variable used to designate whether the floating ! point variables are single (ifp=3) or double (ifp=4) precision. ! integer iod(1) ! the order of each of the difference factors. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! integer nd(1) ! the number of times each difference factor is to be applied ! integer ndum(1) ! a dummy dimensioned variable. ! integer nfac ! the number of difference factors ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is made. ! real ospvar ! the one step prediction variance for the order selected (iar). ! real phi(lagmax) ! the array of autoregressive coefficients for the selected ! order. ! integer prho ! the starting location in the work area for prho. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrho ! the starting location in the work area for sdrho. ! integer work ! the starting location in the work area for work. ! real yfft(lyfft) ! the vector containing the observed time series ! real ymean ! the mean of the observed time series ! real ysd ! the standard deviation of the observed time series ! implicit none integer & iar,lacov,lagmax,ldstak,lyfft,n,nprt ! ! array arguments real & acov(*),phi(*),yfft(*) integer ierr ! ! arrays in common double precision dstak(3000) ! ! real & chia,chiap,ospvar,ymean,ysd integer & aic,ftest,ifp,ldsmin,nall0,nfac,nfft,prho,sdrho, & work logical & differ,isfft ! ! local arrays real & rstak(12) integer & iod(1),nd(1),ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acfer,acfmnf,acfout,fftlen,ldscmp,stkclr,stkset ! common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'c', 'f', 'f', 's', ' '/ ierr = 0 differ = .false. nfac = 1 nd(1) = 0 iod(1) = 0 isfft = .true. ! ! set length of extended series ! nfft = 0 if ((n >= 3) .and. (lagmax >= 1)) call fftlen(n+lagmax, 4, nfft) call ldscmp(4, 0, 0, 0, 0, 0, 's', (4*lagmax+1) + nfft, ldsmin) call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft) ! ! check whether an error has been detected ! if (ierr==0) then ! ! set up the work area. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 work = stkget(nfft, ifp) prho = stkget(lagmax, ifp) aic = stkget(lagmax+1, ifp) ftest = stkget(2*lagmax, ifp) sdrho = work if (ierr==0) then ! ! call routine for main autocorrelation computations. ! call acfmnf (yfft, n, nfft, lagmax, acov(2), rstak(sdrho), & ymean, rstak(prho), rstak(aic), rstak(ftest), phi, & iar, ospvar, acov, lacov, lagmax+1, chia, chiap, & lyfft, rstak(work), nfft, nprt) ysd = sqrt (acov(1) * real ( n ) / real (n - 1)) ! ! call routine to print out autocorrelations ! if ((nprt /= 0) .or. (acov(1)==0.0e0)) & call acfout (ymean, ysd, n, n, lagmax, acov(2), & rstak(sdrho), & rstak(prho), ndum, rstak(aic), lagmax+1, rstak(ftest), iar, & phi, ospvar, chia, chiap, lagmax, .false., 0.0e0, .false., & .false., 0, ndum, ndum, 0) if (nprt /= 0) then acov(2:lagmax+1) = acov(2:lagmax+1) * acov(1) end if end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine acflst ( rho, sdrho, nlppa, lagmax, ifmiss, chia, ndfchi, chiap ) !*****************************************************************************80 ! !! ACFLST lists the autocorrelations and other information. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real chia, chiap ! the variables in chich the chi square statistic and ! probability for the autocorrelations are stored. ! real fplm ! the floating point largest magnitude. ! integer i ! an index variable. ! logical ifmiss ! the indicator variable used to determine ! whether the input series has missing data or not. ! integer imax, imin ! the index values of the first and last observation ! to be printed per line ! integer lag ! the lag value of the autocorrelation or partial ! autocorrelation being printed. ! integer lagmax ! the number of autocorrelations or partial autocorrelations ! to be printed. ! integer ndfchi ! the degrees of freedom for the chi squared statistic. ! integer nlppa(lagmax) ! the array in which the number of lagged product pairs used to ! compute each autocorrelation is stored ! integer nperl ! the number of values to be printed per line. ! real rho(lagmax) ! the array in which the autocorrelations are stored. ! real sdrho(lagmax) ! the array in which the standard errors of the autocorrelations ! are stored ! implicit none real & chia,chiap integer & lagmax,ndfchi logical & ifmiss ! ! array arguments real & rho(*),sdrho(*) integer & nlppa(*) ! ! real & fplm integer & i,imax,imin,lag,nperl fplm = huge ( fplm ) nperl = 12 do i = 1, lagmax, nperl imin = i imax = min(i + nperl - 1, lagmax) write ( *, 1000) (lag, lag = imin, imax) write ( *, 1001) (rho(lag), lag = imin, imax) write ( *, 1002) (sdrho(lag), lag = imin, imax) if (ifmiss) write ( *, 1003) (nlppa(lag), lag = imin, imax) end do if (sdrho(lagmax) == fplm) write ( *, 1004) fplm write ( *, 1005) chia, ndfchi, chiap return 1000 format(/' lag ', 12(1x, i6)) 1001 format( ' acf ', 12(2x, f5.2)) 1002 format( ' standard error ', 12(2x, f5.2)) 1003 format( ' no. of obs. used ', 12(1x, i6)) 1004 format(///5x, f5.2, ' indicates value could not be computed', & ' due to missing data.') 1005 format(///' the chi square test statistic of'/ & ' the null hypothesis of white noise =', g21.4/ & ' degrees of freedom =', i17/ & ' observed significance level =', f17.4) end subroutine acfm ( y, ymiss, n ) !*****************************************************************************80 ! !! ACFM computes autocorrelations of a time series with missing data. ! ! Discussion: ! ! this is the user callable routine for computing the auto- ! correlations and partial autocorrelations of a time series ! with missing values (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(101) ! the autocovariance vector. ! real aic(101) ! the array containing the akaikes criterion for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the indicator variable used to designate whether the calling ! routine is acfd (differ = true) or not (differ = false) ! real ftest(2, 100) ! the array containing the partial f ratio and probabilities ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer iod(1) ! the order of each of the difference factors. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer laglst ! the last lag before missing data caused the acvf of the ! series not to be computed. ! integer lagmax ! the maximum lag value requested. ! integer laic ! the length of the vector aic. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! a dummy variable. ! integer n ! the integer number of observations in each series ! integer nd(1) ! the number of times each difference factor is to be applied ! integer ndum(1) ! a dummy array. ! integer nfac ! the number of difference factors ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is made. ! integer nfft ! the number of observations in the extended series. ! integer nlppa(101) ! the array containing the number of lagged product pairs ! used to compute each acvf estimate. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! real ospvar ! the one step prediction variance for the order selected (iar). ! real phi(100) ! the array of autoregressive coefficients for the selected ! order. ! real prho(100) ! the array containing the pacf estimates. ! real rho(100) ! the array containing the acf estimates. ! real sdrho(100) ! the array containing the standard errors of the acf. ! real work(100) ! the array containing work area for the pacf computations. ! real y(n) ! the vector containing the observed time series ! real ymean ! the mean of the observed time series ! real ymiss ! the user supplied code which is used to determine whether ! or not an observation in the series is missing. ! if y(i) == ymiss, the value is assumed missing. ! if y(i) /= ymiss, the value is assumed not missing. ! real ysd ! the standard deviation of the observed time series ! implicit none real & ymiss integer & n ! ! array arguments real & y(*) integer ierr ! ! real & chia,chiap,ospvar,ymean,ysd integer & iar,lacov,laglst,lagmax,laic,ldsmin,ldstak,lyfft, & nfac,nfft,nprt logical & differ,isfft ! ! local arrays real & acov(101),aic(101),ftest(2,100),phi(100),prho(100),rho(100), & sdrho(100),work(100) integer & iod(1),nd(1),ndum(1),nlppa(101) character & nmsub(6)*1 ! ! external subroutines external acfer,acfmnm,acfout,setlag ! common /errchk/ierr ! ! equivalences equivalence (acov(2),rho(1)) equivalence (work(1),sdrho(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'c', 'f', 'm', ' ', ' '/ ierr = 0 lagmax = 1 lacov = 101 laic = 101 nprt = 1 ldsmin = 0 ldstak = 0 differ = .false. nfac = 1 nd(1) = 0 iod(1) = 0 isfft = .false. lyfft = n nfft = n ! ! call error checking routines ! call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft) ! ! check whether an error has been detected ! if (ierr==0) then ! ! set largest lag to be used. ! call setlag(n, lagmax) ! ! call routine for main autocorrelation computations. ! call acfmnm (y, ymiss, n, lagmax, rho, sdrho, nlppa, ymean, & prho, aic, ftest, phi, iar, ospvar, acov, lacov, laic, chia, & chiap, laglst, work, nprt) ysd = acov(1) if (laglst >= 0) ysd = sqrt (acov(1) * real ( n ) / real (n - 1)) ! ! call routine to print out autocorrelations ! call acfout (ymean, ysd, n, nlppa(1), lagmax, rho, sdrho, prho, & nlppa, aic, lagmax+1, ftest, iar, phi, ospvar, chia, chiap, & laglst, .true., ymiss, .false., .false., 0, ndum, ndum, 0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine acfmn ( y, n, lagmax, rho, sdrho, ymean, prho, aic, & ftest, phi, iar, ospvar, acov, lacov, laic, chia, chiap, work, nprt ) !*****************************************************************************80 ! !! ACFMN computes autocorrelations of a time series. ! ! Discussion: ! ! This is the main subroutine for computing autocorrelations and ! partial autocorrelations of a time series . ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance function estimate vector. ! real aic(laic) ! the array containing akaiaes criterion for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! real ftest(2, lagmax) ! the array in which the f ratio and probability are stored. ! integer i ! an indexing variable. ! integer iar ! the order of the autoregressive process chosen. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the vector aic. ! integer n ! the integer number of observations in the series ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is made. ! real ospvar ! the one step prediction variance for the selected order (iar). ! real phi(lagmax) ! the array of autoregressive coefficients for the selected ! order (iar). ! real prho(lagmax) ! the array in which the partial autocorrelations are stored ! real rho(lagmax) ! the array in which the autocorrelations are stored ! real sdrho(lagmax) ! the array in which the standard errors of the autocorrelations ! real work(lagmax) ! an array used in the computations of the partial ! autocorrelations coefficients. ! are stored ! real y(n) ! the vector containing the observed series ! real ymean ! the mean of the observed time series. ! implicit none real & chia,chiap,ospvar,ymean integer & iar,lacov,lagmax,laic,n,nprt ! ! array arguments real & acov(*),aic(*),ftest(2,*),phi(*),prho(*),rho(*),sdrho(*), & work(*),y(*) ! ! external subroutines external acfsd,acvf,aos,chirho ! ! compute autocovariancess and standard deviation of the series. ! call acvf(y, n, ymean, acov, lagmax, lacov) ! if (acov(1) == 0.0e0) return ! ! compute partial autocorrelations and the autoregressive model ! order selection statistics. ! call aos (n, lagmax, acov, prho, iar, ospvar, phi, work, & aic, ftest, lacov, laic) if (nprt == 0) return ! ! Compute autocorrelations. ! rho(1:lagmax) = acov(2:lagmax+1) / acov(1) ! ! Compute standard error of autocorrelations. ! call acfsd (rho, sdrho, lagmax, n) ! ! compute chi statistic based on autocorrelation values ! call chirho (rho, n, lagmax, chia, chiap) return end subroutine acfmnf ( yfft, n, nfft, lagmax, rho, sdrho, ymean, & prho, aic, ftest, phi, iar, ospvar, acov, lacov, laic, & chia, chiap, lyfft, work, lwork, nprt ) !*****************************************************************************80 ! !! ACFMNF computes autocorrelations of a time series. ! ! Discussion: ! ! This is the main subroutine for computing autocorrelations and ! partial autocorrelations of a time series . ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance function estimate vector. ! real aic(laic) ! the akaikes information criterion vector. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! real ftest(2, lagmax) ! the array in which the partial f ratios and probabilities ! are stored. ! integer i ! an index variable. ! integer iar ! the order of the autoregressive process chosen. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the vector aic. ! integer lwork ! the length of the vector work. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in the series ! integer nfft ! the number of observations in the extended series. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is made. ! real ospvar ! the one step prediction variance. ! real phi(lagmax) ! the array of autoregressive coefficients for the selected ! order (iar). ! real prho(lagmax) ! the array in which the partial autocorrelations are stored ! real rho(lagmax) ! the array in which the autocorrelations are stored ! real sdrho(lagmax) ! the array in which the standard errors of the autocorrelations ! are stored ! real work(lwork) ! a work array. ! real yfft(lyfft) ! the vector containing the observed series ! real ymean ! the mean of the observed time series ! implicit none real & chia,chiap,ospvar,ymean integer & iar,lacov,lagmax,laic,lwork,lyfft,n,nfft,nprt ! ! array arguments real & acov(*),aic(*),ftest(2,*),phi(*),prho(*),rho(*),sdrho(*), & work(*),yfft(*) ! ! external subroutines external acfsd,acvff,aos,chirho ! ! compute autocovariancess and standard deviation of the series. ! call acvff(yfft, n, nfft, ymean, acov, lagmax, lacov, lyfft, work, & lwork) if (acov(1) == 0.0e0) return ! ! compute partial autocorrelations and autoregressive order ! selection statistics. ! call aos (n, lagmax, acov, prho, iar, ospvar, phi, work, & aic, ftest, lacov, laic) if (nprt == 0) return ! ! Compute autocorrelations. ! rho(1:lagmax) = acov(2:lagmax+1) / acov(1) ! ! Compute standard error of autocorrelations. ! call acfsd (rho, sdrho, lagmax, n) ! ! compute chi statistic based on autocorrelation values ! call chirho (rho, n, lagmax, chia, chiap) return end subroutine acfmnm ( y, ymiss, n, lagmax, rho, sdrho, nlppa, ymean, & prho, aic, ftest, phi, iar, ospvar, acov, lacov, laic, chia, & chiap, laglst, work, nprt ) !*****************************************************************************80 ! !! ACFMNM computes autocorrelations of a time series with missing data. ! ! Discussion: ! ! This is the main subroutine for computing autocorrelations and ! partial autocorrelations of a time series with missing data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance function estimate vector. ! real aic(laic) ! the array containing akaiaes criterion for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! real fplm ! the floating point largest magnitude. ! real ftest(2, lagmax) ! the array in which the f ratio and probability are stored. ! integer i ! an index variable. ! integer iar ! the order of the autoregressive process chosen. ! integer lacov ! the length of the vector acov. ! integer laglst ! the last lag before missing data caused the acvf of the ! series not to be computed. ! integer lagmax ! the maximum lag value to be used. ! integer n ! the integer number of observations in the series ! integer laic ! the length of the vector aic. ! integer nlppa(lacov) ! the array containing the numbers of lagged product pairs ! used to compute the acvf at each lag. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is made. ! integer nused ! the number of active (not missing) observations in the series. ! real ospvar ! the one step prediction variance for the selected order (iar). ! real phi(lagmax) ! the array of autoregressive coefficients for the selected ! order (iar). ! real prho(lagmax) ! the array in which the partial autocorrelations are stored ! real rho(lagmax) ! the array in which the autocorrelations are stored ! real sdrho(lagmax) ! the array in which the standard errors of the autocorrelations ! are stored ! real work(lagmax) ! an array used in the computations of the partial ! autocorrelations coefficients. ! real y(n) ! the vector containing the observed series ! real ymean ! the mean of the observed time series ! real ymiss ! the user supplied code which is used to determine whether ! or not an observation in the series is missing. ! if y(i) == ymiss, the value is assumed missing. ! if y(i) /= ymiss, the value is assumed not missing. ! implicit none real & chia,chiap,ospvar,ymean,ymiss integer & iar,lacov,laglst,lagmax,laic,n,nprt ! ! array arguments real & acov(*),aic(*),ftest(2,*),phi(*),prho(*),rho(*),sdrho(*), & work(*),y(*) integer & nlppa(*) ! ! real & fplm integer & i,nused ! ! external subroutines external acfsdm,acvfm,aos,chirho fplm = huge ( fplm ) ! ! compute autocovariances of the series with missing data. ! call acvfm(y, ymiss, n, ymean, acov, lagmax, laglst, nlppa, lacov) if (nlppa(1) == 0 .or. acov(1) == 0.0e0) return if (nprt == 0) return ! ! compute partial autocorrelations and the autoregressive model ! order selection statistics if there were no missing data. ! if (nlppa(1) == n) then call aos (n, lagmax, acov, prho, iar, & ospvar, phi, work, aic, ftest, lacov, laic) end if ! ! Compute autocorrelations. ! do i = 1, lagmax if ( 1 <= nlppa(i+1) ) then rho(i) = acov(i+1) / acov(1) end if end do ! ! Preset sdrho values for printing routine. ! sdrho(laglst:lagmax) = fplm ! ! Compute standard error of autocorrelations. ! call acfsdm (rho, sdrho, laglst, n, nlppa(2)) if (laglst == 0) return ! ! Compute chi statistic based on autocorrelation values. ! nused = nlppa(1) call chirho (rho, nused, laglst, chia, chiap) return end subroutine acfms ( y, ymiss, n, lagmax, lacov, acov, amiss, nlppa, & nprt, ldstak ) !*****************************************************************************80 ! !! ACFMS: user interface for autocorrelations of time series with missing data. ! ! Discussion: ! ! This is the user callable routine for computing the auto- ! correlations of a time series with missing values (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance vector. ! integer aic ! the starting location in dstak for ! the array containing the akaikes criterion for each order. ! real amiss ! the missing value code for the returned acvf estimates ! (vector acov). ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the indicator variable used to designate whether the calling ! routine is acfd (differ = true) or not (differ = false) ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fplm ! the floating point largest magnitude. ! integer ftest ! the starting location in dstak for ! the array containing the partial f ratio and probabilities ! integer i ! an index variable. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! integer ifp ! the indicator variable used to designate whether the floating ! point variables are single (ifp=3) or double (ifp=4) precision. ! integer iod(1) ! the order of each of the difference factors. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer laglst ! the last lag before missing data caused the acvf of the ! series not to be computed. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! integer nd(1) ! the number of times each difference factor is to be applied ! integer ndum(1) ! a dummy array. ! integer nfac ! the number of difference factors ! integer nfft ! the number of observations in the extended series. ! integer nlppa(lacov) ! the array containing the number of lagged product pairs ! used to compute each acvf estimate. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is made. ! real ospvar ! the one step prediction variance for the order selected (iar). ! integer phi ! the starting location in dstak for the ! the array of autoregressive coefficients for the selected ! order. ! integer prho ! the starting location in the work area for prho. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrho ! the starting location in the work area for sdrho. ! integer work ! the starting location in the work area for work. ! real y(n) ! the vector containing the observed time series ! real ymean ! the mean of the observed time series ! real ymiss ! the user supplied code which is used to determine whether ! or not an observation in the series is missing. ! if y(i) == ymiss, the value is assumed missing. ! if y(i) /= ymiss, the value is assumed not missing. ! real ysd ! the standard deviation of the observed time series ! implicit none real & amiss,ymiss integer & lacov,lagmax,ldstak,n,nprt ! ! array arguments real & acov(*),y(*) integer & nlppa(*) ! integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & chia,chiap,fplm,ospvar,ymean,ysd integer & aic,ftest,iar,ifp,laglst,ldsmin,lyfft,nall0,nfac, & nfft,phi,prho,sdrho,work logical & differ,isfft ! ! local arrays real & rstak(12) integer & iod(1),nd(1),ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'c', 'f', 'm', 's', ' '/ ierr = 0 differ = .false. nfac = 1 nd(1) = 0 iod(1) = 0 isfft = .false. lyfft = n nfft = n if (nprt == 0) then ldsmin = 0 else call ldscmp(5, 0, 0, 0, 0, 0, 's', 6*lagmax+1, ldsmin) end if call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft) ! ! check whether an error has been detected ! if (ierr==0) then ! ! set up the work area. ! call stkset(ldstak, 4) nall0 = stkst(1) fplm = huge ( fplm ) amiss = fplm if (nprt==0) then ! ! specify starting locations in the stack for dummy variables ! prho = 1 aic = 1 ftest = 1 phi = 1 work = 1 sdrho = 1 else ifp = 3 prho = stkget(lagmax, ifp) aic = stkget(lagmax+1, ifp) ftest = stkget(2*lagmax, ifp) phi = stkget(lagmax, ifp) work = stkget(lagmax, ifp) sdrho = work end if if (ierr==0) then ! ! Main autocorrelation computations. ! call acfmnm (y, ymiss, n, lagmax, acov(2), rstak(sdrho), & nlppa, ymean, rstak(prho), rstak(aic), rstak(ftest), & rstak(phi), iar, ospvar, acov, lacov, lagmax+1, chia, & chiap, laglst, rstak(work), nprt) if (laglst >= 0) then ysd = sqrt (acov(1) * real ( n ) / real (n - 1) ) else ysd = acov(1) end if ! ! Print out autocorrelations ! if ((nprt /= 0) .or. (acov(1)==0.0e0)) & call acfout (ymean, ysd, n, nlppa(1), lagmax, acov(2), & rstak(sdrho), rstak(prho), nlppa, rstak(aic), lagmax+1, & rstak(ftest), iar, rstak(phi), ospvar, chia, chiap, & laglst, .true., ymiss, .false., .false., 0, ndum, ndum, & 0) if (nprt /= 0) then acov(2:lagmax+1) = acov(2:lagmax+1) * acov(1) end if end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine acfout ( ymean, ysd, n, nused, lagmax, rho, sdrho, & prho, nlppa, aic, laic, ftest, iar, phi, ospvar, chia, chiap, & ndfchi, ifmiss, ymiss, differ, newpg, nfac, nd, iod, ntimes ) !*****************************************************************************80 ! !! ACFOUT prints autocorrelations. ! ! Discussion: ! ! This routine prints the autocorrelations and their ! standard errors, as well and the partial autocorrelations ! and miscellaneous summary information. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real aic(laic) ! the array containing the akaikes information criterion. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the variable used to designate whether or not the series ! analyzed was differenced or not. ! real fplm ! the floating point largest magnitude. ! real ftest(2, lagmax) ! the array in which the f ratio and probability are stored. ! integer iar ! the order of the autoregressive process chosen. ! logical ifmiss ! the indicator variable used to determine ! whether the input series has missing data or not. ! integer iod(nfac) ! the order of each of the differencing factors. ! integer isym(1) ! a dummy array. ! integer lagmax ! the maximum lag value used. ! integer laic ! the length of the vector aic. ! integer n ! the integer number of observations in each series ! integer nd(nfac) ! the array contaning the number of times the differencing ! factors are to be applied. ! integer ndfchi ! the degrees of freedom for the chi squared statistic. ! logical newpg ! the variable designating whether or not the output is to ! start on a new page. ! integer nfac ! the number of difference factors. ! integer nlppa(lagmax) ! the array of numbers of lagged product pairs used to ! compute each acf estimate. ! integer nmiss ! the number of missing observations. ! integer ntimes ! the number of times the first difference factor has been ! applied. ! integer nused ! the active number of observations. ! real ospvar ! the one step prediction variance for the order selected (iar). ! real phi(lagmax) ! the array of autoregressive coefficients for the selected ! order. ! real pmiss ! the percent of missing observations. ! real prho(lagmax) ! the array in which the partial autocorrelations are stored ! real rho(lagmax) ! the array in which the autocorrelations are stored ! real sdrho(lagmax) ! the array in which the standard errors of the autocorrelations ! are stored ! real ymean ! the mean of the observed series. ! real ymiss, ymmiss(1) ! the missing value code. ! real ysd ! the standard deviation of the observed series. ! implicit none real & chia,chiap,ospvar,ymean,ymiss,ysd integer & iar,lagmax,laic,n,ndfchi,nfac,ntimes,nused logical & differ,ifmiss,newpg ! ! array arguments real & aic(laic),ftest(2,lagmax),phi(lagmax),prho(lagmax), & rho(lagmax),sdrho(lagmax) integer & iod(*),nd(*),nlppa(lagmax) ! ! real & fplm,pmiss integer nmiss ! ! local arrays real & ymmiss(1) integer & isym(1) ! ! external subroutines external acfdtl,acflst,aoslst,versp,vpmn fplm = huge ( fplm ) ymmiss(1) = fplm ! ! print summary information ! if (newpg) write( *, 1004) call versp (.true.) write( *, 1005) if (differ) call acfdtl(nfac, nd, iod, ntimes) write ( *, 1000) ymean, ysd, n if ( ifmiss) then nmiss = n - nused pmiss = 100.0e0 * real ( nmiss ) / real ( n ) write ( *, 1003) nmiss, pmiss end if write ( *, 1006) lagmax if (ifmiss) write ( *, 1007) ymiss if ( ysd <= 0.0e0 ) then write ( *, 1010) return end if ! ! print acf information ! write ( *, 1008) write ( *, 1001) call acflst (rho, sdrho, nlppa, lagmax, ifmiss, chia, ndfchi, & chiap) ! ! plot acf information ! write ( *, 1004) call versp (.true.) write ( *, 1001) if (differ) then call acfdtl(nfac, nd, iod, ntimes) end if call vpmn ( rho, ymmiss, lagmax, 1, lagmax, 1, 0, isym, 1, 0, & -1.0e0, 1.0e0, 1.0e0, 1.0e0, ifmiss, 0, 0, 1) ! ! check whether pacf have been computed ! if (nused <= n-1) return ! ! print pacf information and autoregressive model order selection ! statistics ! write ( *, 1004) call versp (.true.) write ( *, 1002) write ( *, 1009) if (differ) call acfdtl(nfac, nd, iod, ntimes) call aoslst (prho, aic, ftest, lagmax, laic, iar, phi, ospvar, & .true., n) ! ! plot pacf information ! write ( *, 1004) call versp (.true.) write ( *, 1002) if (differ) then call acfdtl(nfac, nd, iod, ntimes) end if call vpmn ( prho, ymmiss, ndfchi, 1, ndfchi, 1, 0, isym, 1, 0, & -1.0e0, 1.0e0, 1.0e0, 1.0e0, ifmiss, 0, 0, 1) return 1000 format(/ & ' average of the series = ', g14.7/ & ' standard deviation of the series = ', g14.7/ & ' number of time points = ', i10) 1001 format (' autocorrelation function estimate (acf)'/) 1002 format (' partial autocorrelation function estimate (pacf)'/) 1003 format ( & ' number of missing observations = ', i10/ & ' percentage of observations missing = ', f10.4) 1004 format ('1') 1005 format ( ' autocorrelation analysis') 1006 format( & ' largest lag value used = ', i10) 1007 format( & ' missing value code = ', g14.7) 1008 format(//) 1009 format (' and autoregressive order selection statistics'///) 1010 format (///' the autocorrelations of this series', & ' could not be computed'/ & ' because the lag zero autocovariance of the series', & ' is zero.') end subroutine acfsd ( rho, sdrho, nc, n ) !*****************************************************************************80 ! !! ACFSD computes the standard error of autocorrelations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer klast ! the last lag value to be used. ! integer lag ! the index variable used to indicate the autocorrelation ! being examined. ! integer n ! the integer number of observations in each series ! integer nc ! the number of autocorrelations computed ! real rho(nc) ! the array in which the autocorrelations are stored ! real sdrho(nc) ! the array in which the standard errors of the autocorrelations ! are stored ! implicit none integer & n,nc ! ! array arguments real & rho(*),sdrho(*) integer & k,klast,lag sdrho(1) = sqrt(real(n - 1)) / real ( n ) do lag = 2, nc sdrho(lag) = 0.0e0 klast = min(lag-1, n-lag) do k = 1, klast sdrho(lag) = sdrho(lag) + real (n-lag-k) * rho(k) * rho(k) end do sdrho(lag) = sqrt(real (n-lag) + 2.0e0 * sdrho(lag)) / real ( n ) end do return end subroutine acfsdm ( rho, sdrho, nc, n, nlppa ) !*****************************************************************************80 ! !! ACFSDM computes the standard error of autocorrelations with missing data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer k ! an index variable. ! integer klast ! the last lag value to be used. ! integer lag ! the index variable used to indicate the autocorrelation ! being examined. ! integer n ! the integer number of observations in each series ! integer nc ! the number of autocorrelations computed ! integer nlppa(nc) ! the array in which the number of observations used to ! compute each autocorrelation and partial autocorrelation ! is stored ! real rho(nc) ! the array in which the autocorrelations are stored ! real sdrho(nc) ! the array in which the standard errors of the autocorrelations ! are stored ! implicit none integer & n,nc ! ! array arguments real & rho(*),sdrho(*) integer & nlppa(*) ! ! integer & k,klast,lag sdrho(1) = sqrt(real(nlppa(1))) * real (n-1) / real (n * nlppa(1)) do lag = 2, nc sdrho(lag) = 0.0e0 klast = min(lag-1, n-lag) do k = 1, klast sdrho(lag) = sdrho(lag) + real (n-lag-k) * rho(k) * rho(k) end do sdrho(lag) = sqrt ( real (n-lag) + 2.0e0 * sdrho(lag)) * & real (n-lag) / real (n*nlppa(lag)) end do return end subroutine acfs ( y, n, lagmax, lacov, acov, iar, phi, nprt, ldstak ) !*****************************************************************************80 ! !! ACFS computes autocorrelations with computed ACVF estimates. ! ! Discussion: ! ! This is the user callable routine for computing the auto- ! correlations and partial autocorrelations of a time series ! with the computed acvf estimates returned to the users ! routine (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance vector. ! integer aic ! the starting location in dstak for ! the array containing the akaikes criterion for each order. ! real chia, chiap ! the variables in which the chi square statistic and ! chi squared statistic probability for the autocorrelations ! are stored. ! logical differ ! the indicator variable used to designate whether the calling ! routine is acfd (differ = true) or not (differ = false) ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ftest ! the starting location in dstak for ! the array containing the partial f ratio and probabilities ! integer i ! an index variable. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! integer ifp ! the indicator variable used to designate whether the floating ! point variables are single (ifp=3) or double (ifp=4) precision. ! integer iod(1) ! the order of each of the difference factors. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations. ! integer nd(1) ! the number of times each difference factor is to be applied ! integer ndum(1) ! a dummy dimensioned variable. ! integer nfac ! the number of difference factors ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is made. ! real ospvar ! the one step prediction variance for the order selected (iar). ! real phi(lagmax) ! the array of autoregressive coefficients for the selected ! order. ! integer prho ! the starting location in the work area for prho. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrho ! the starting location in the work area for sdrho. ! integer work ! the starting location in the work area for work. ! real y(n) ! the vector containing the observed time series ! real ymean ! the mean of the observed time series ! real ysd ! the standard deviation of the observed time series ! implicit none integer & iar,lacov,lagmax,ldstak,n,nprt ! ! array arguments real & acov(*),phi(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & chia,chiap,ospvar,ymean,ysd integer & aic,ftest,i,ifp,ldsmin,lyfft,nall0,nfac,nfft,prho, & sdrho,work logical & differ,isfft ! ! local arrays real & rstak(12) integer & iod(1),nd(1),ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acfer,acfmn,acfout,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'c', 'f', 's', ' ', ' '/ ierr = 0 differ = .false. nfac = 1 nd(1) = 0 iod(1) = 0 isfft = .false. lyfft = n nfft = n call ldscmp(4, 0, 0, 0, 0, 0, 's', 5*lagmax+1, ldsmin) call acfer(nmsub, n, lagmax, lacov, ldstak, ldsmin, & differ, nfac, nd, iod, isfft, lyfft, nfft) ! ! check whether an error has been detected ! if (ierr==0) then ! ! set up the work area. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 prho = stkget(lagmax, ifp) aic = stkget(lagmax+1, ifp) ftest = stkget(2*lagmax, ifp) work = stkget(lagmax, ifp) sdrho = work if (ierr==0) then ! ! call routine for main autocorrelation computations. ! call acfmn (y, n, lagmax, acov(2), rstak(sdrho), & ymean, rstak(prho), rstak(aic), rstak(ftest), phi, & iar, ospvar, acov, lacov, lagmax+1, chia, chiap, & rstak(work), nprt) ysd = sqrt (acov(1) * real ( n ) / real ( n - 1 ) ) ! ! call routine to print out autocorrelations ! if ((nprt /= 0) .or. (acov(1)==0.0e0)) call acfout & (ymean, ysd, n, n, lagmax, acov(2), rstak(sdrho), & rstak(prho), ndum, rstak(aic), lagmax+1, rstak(ftest), & iar, phi, ospvar, chia, chiap, lagmax, .false., 0.0e0, & .false., .false., 0, ndum, ndum, 0) if (nprt /= 0) then do i = 1, lagmax acov(i+1) = acov(i+1) * acov(1) end do end if end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine acvf ( y, n, ymean, acov, lagmax, lacov ) !*****************************************************************************80 ! !! ACVF computes the autocovariance function of a series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the array in which the autocovariances are stored ! real dotxy, dotyy ! the dot product between vectors (y(i) - ymean)) and ! (y(lag) - ymean)), and (y(i) - ymean)) and (y(i) - ymean)), ! respectively. ! integer lacov ! the actual dimension of acov. ! integer lag, lagmax ! the indexing variable indicating the lag value of the ! autocovariance being computed and the maximum lag to be used, ! respectively. ! integer n ! the number of observations in the series ! integer ndotxy, ndotyy ! the number of observations used to compute dotxy and ! dotyy, respectively. ! real y(n) ! the vector containing the observed series ! real ymean ! the mean of the observed time series ! implicit none real & ymean integer & lacov,lagmax,n ! ! array arguments real & acov(lacov),y(*) ! ! real & dotxy,dotyy integer & lag,ndotxy,ndotyy ! ! external subroutines external amean,dotc ! ! compute arithmetic mean ! call amean(y, n, ymean) ! ! compute the variance of the series y ! call dotc (y, ymean, n, y, ymean, n, dotyy, ndotyy) acov(1) = dotyy / real ( ndotyy ) ! ! Compute autocovariances. ! do lag = 1, lagmax call dotc (y, ymean, n, y(lag+1), ymean, n - lag, & dotxy, ndotxy) acov(lag + 1) = dotxy / real ( n ) end do return end subroutine acvff ( yfft, n, nfft, ymean, acov, lagmax, lacov, & lyfft, work, lwork ) !*****************************************************************************80 ! !! ACVFF computes the ACVF of a series using two FFT passes. ! ! Discussion: ! ! This routine computes the acvf of a series using two ! passes of a fft. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the array in which the autocovariances are stored ! real fac ! a factor used in the computations. ! integer isn ! an indicator variable used by the fft routines. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag to be used. ! integer lwork ! the length of the vector work. ! integer lyfft ! the length of the vector yfft. ! integer n ! the number of observations in the series ! integer nf ! the number of Fourier frequencies. ! integer nfft ! the number of observations in the extended series. ! integer nfft2 ! the effective number of observations for the fft transform. ! real work(lwork) ! the work area for the computations. ! real yfft(lyfft) ! the vector containing the observed series ! real ymean ! the mean of the observed time series ! implicit none real & ymean integer & lacov,lagmax,lwork,lyfft,n,nfft ! ! array arguments real & acov(lacov),work(*),yfft(lyfft) ! ! real & fac integer & i,isn,nf,nfft2 ! ! external subroutines external amean,fft,fftct,realtr ! ! compute arithmetic mean ! call amean(yfft, n, ymean) ! ! Subtract the mean from the series. ! yfft(1:n) = yfft(1:n) - ymean ! ! Append zeros ! yfft(n+1:nfft) = 0.0e0 ! ! compute autocovariances. ! isn = 2 nfft2 = (nfft - 2)/ 2 call fft(yfft(1), yfft(2), nfft2, nfft2, nfft2, isn) call realtr (yfft(1), yfft(2), nfft2, isn) nf = nfft2 + 1 do i = 1, nf work(i) = yfft(2*i-1)*yfft(2*i-1) + yfft(2*i)*yfft(2*i) end do call fftct (work, nfft2, lwork) fac = 1.0e0 / real ( 4 * ( nfft - 2 ) * n ) acov(1) = work(1) * fac do i = 1, lagmax acov(i+1) = work(i+1) * fac end do return end subroutine acvfm ( y, ymiss, n, ymean, acov, lagmax, laglst, nlppa, lacov ) !*****************************************************************************80 ! !! ACVFM computes autocovariance when missing data is involved. ! ! Discussion: ! ! This routine computes the autocovariances when missing data are ! involved. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the array in which the autocovariances are stored ! real dotxy, dotyy ! the dot product between vectors (y(i) - ymean)) and ! (y(lag) - ymean)), and (y(i) - ymean)) and (y(i) - ymean)), ! respectively. ! real fplm ! the floating point largest magnitude. ! integer lacov ! the length of the vector acov. ! integer lag, laglst, lagmax ! the indexing variable indicating the lag value of the ! autocorrelation being computed, the number of autocorrelations ! computed before a missing autocorrelation, and the number of ! autocorrelations desired, respectively. ! integer n ! the integer number of observations in the series ! integer ndotxy, ndotyy ! the number of observations used to compute dotxy and ! dotyy, respectively. ! integer nlppa(lacov) ! the array containing the numbers of lagged product pairs ! used to compute the acvf at each lag. ! integer nused ! the number of active observations in the series. ! real y(n) ! the vector containing the observed series ! real ymean ! the mean of the observed time series ! real ymiss ! the user supplied code which is used to determine whether or ! not an observation in the series is missing. if y(i) = ymiss, ! the value is assumed missing, otherwise it is not. ! implicit none integer lacov integer n real acov(lacov) real dotxy real dotyy real fplm integer lag integer laglst integer lagmax integer lstlag integer ndotxy integer ndotyy integer nlppa(lacov) integer nused real y(n) real ymean real ymiss fplm = huge ( fplm ) ! ! Compute arithmetic mean, with missing values taken into account. ! call ameanm ( y, ymiss, n, nused, ymean ) ! ! Compute the variance of the series Y. ! call dotcm (y, ymean, ymiss, n, y, ymean, ymiss, n, dotyy, ndotyy) nlppa(1) = ndotyy if ( nlppa(1) == 0 ) then laglst = 0 else acov(1) = dotyy / real ( ndotyy ) ! ! Compute autocorrelations, with missing values taken into account. ! write ( *, * ) 'LACOV = ', lacov write ( *, * ) 'LAGMAX = ', lagmax write ( *, * ) 'N = ', n do lag = 1, lagmax call dotcm (y, ymean, ymiss, n, y(lag+1), ymean, & ymiss, n - lag, dotxy, ndotxy) nlppa(lag + 1) = ndotxy acov(lag + 1) = fplm if ( 0 < nlppa(lag+1) ) then acov(lag+1) = dotxy * real ( n - lag ) / real ( nlppa(lag+1) * n ) end if end do ! ! Find the last autocorrelation to be computed before ! one could not be computed due to missing data. ! laglst = lstlag ( nlppa, lagmax, lacov ) end if return end subroutine adjlmt ( ymn, ymx ) !*****************************************************************************80 ! !! ADJLMT corrects the plot limits when all observations are equal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ymn, ymx ! the y-axis lower and upper limits actually used. ! implicit none real ymn real ymx if (ymn < ymx) return ! ! correct for all observations identically equal ! ymn = ymn - abs(ymn/2.0e0) ymx = ymx + abs(ymx/2.0e0) if (ymn < ymx) return ymn = -0.5e0 ymx = 0.5e0 return end subroutine aime ( y, n, mspec, nfac, par, npar, res, ldstak ) !*****************************************************************************80 ! !! AIME is the user interface for ARIMA estimation, control call. ! ! Discussion: ! ! this is the user callable subroutine for arima estimation ! (control call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! if ifixed(1)<0, then ifixed(i)=default,i=1,...,npar, and the ! dimension of ifixed will be assumed to be 1. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where for ! ivaprx le 0, vcv = the default option ! ivaprx eq 1, vcv = inverse(transpose(j)*j) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2, vcv = inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4, vcv = inverse(transpose(j)*j) ! using only the model subroutine ! ivaprx eq 5, vcv = inverse(h) ! using only the model subroutine ! ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using only the model subroutine ! ivaprx ge 7, vcv = the default option ! with j representing the jacobian and h the hessian. ! integer ivcv ! the first dimension of matrix vcv. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the dimension of vector ifixed. ! integer lpv ! the dimension of vector pv. ! integer lscale ! the dimension of vector scale. ! integer lsdpv ! the dimension of vector sdpv. ! integer lsdres ! the dimension of vector sdres. ! integer lstp ! the dimension of vector stp. ! integer mit ! the maximum number of iterations allowed. ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! the predicted value of the fit, unused when save = false. ! real res(n) ! the residuals from the fit. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(1) ! the typical size of the parameters. ! if scale(1) <= 0, then scale(i)=default,i=1,...,npar, and the ! dimension of scale will be assumed to be 1. ! real sdpv(1) ! the standard deviations of the predicted values, unused ! when save = false. ! real sdres(1) ! the standardized residuals, unused when save = false. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(1) ! the step size array. ! if stp(1) <= 0, then stp(i)=default,i=1,...,npar, and the ! dimension of stp will be assumed to be 1. ! real vcv(1,1) ! the variance-covariance matrix, unused when save = false. ! real y(n) ! the dependent variable. ! implicit none integer ldstak integer n integer nfac integer npar double precision dstak(3000) integer ierr integer mspec(4,nfac) real par(npar) real res(n) real y(n) real & delta,rsd,stopp,stopss integer & ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,mit, & npare,nprt logical & save ! ! local arrays real & pv(1),scale(1),sdpv(1),sdres(1),stp(1),vcv(1,1) integer & ifixed(1) character & nmsub(6)*1 external amedrv common /cstak/dstak common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'a','i','m','e',' ',' '/ save = .false. lifixd = 1 ifixed(1) = -1 lstp = 1 stp(1) = 0.0e0 mit = -1 stopss = -1.0e0 stopp = -1.0e0 lscale = 1 scale(1) = 0.0e0 delta = -1.0e0 ivaprx = -1 nprt = -1 lpv = 1 lsdpv = 1 lsdres = 1 ivcv = 1 call amedrv ( y, n, mspec, nfac, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, save, npare ) return end subroutine aimec ( y, n, mspec, nfac, par, npar, res, ldstak, & ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, nprt ) !*****************************************************************************80 ! !! AIMEC is the user interface for ARIMA estimation. ! ! Discussion: ! ! this is the user callable subroutine for arima estimation ! (control call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! if ifixed(1)<0, then ifixed(i)=default,i=1,...,npar, and the ! dimension of ifixed will be assumed to be 1. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where for ! ivaprx le 0, vcv = the default option ! ivaprx eq 1, vcv = inverse(transpose(j)*j) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2, vcv = inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4, vcv = inverse(transpose(j)*j) ! using only the model subroutine ! ivaprx eq 5, vcv = inverse(h) ! using only the model subroutine ! ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using only the model subroutine ! ivaprx ge 7, vcv = the default option ! with j representing the jacobian and h the hessian. ! integer ivcv ! the first dimension of matrix vcv. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the dimension of vector ifixed. ! integer lpv ! the dimension of vector pv. ! integer lscale ! the dimension of vector scale. ! integer lsdpv ! the dimension of vector sdpv. ! integer lsdres ! the dimension of vector sdres. ! integer lstp ! the dimension of vector stp. ! integer mit ! the maximum number of iterations allowed. ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! the predicted value of the fit, unused when save = false. ! real res(n) ! the residuals from the fit. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! the typical size of the parameters. ! if scale(1) <= 0, then scale(i)=default,i=1,...,npar, and the ! dimension of scale will be assumed to be 1. ! real sdpv(1) ! the standard deviations of the predicted values, unused ! when save = false. ! real sdres(1) ! the standardized residuals, unused when save = false. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(1) ! the step size array. ! if stp(1) <= 0, then stp(i)=default,i=1,...,npar, and the ! dimension of stp will be assumed to be 1. ! real vcv(1,1) ! the variance-covariance matrix, unused when save = false. ! real y(n) ! the dependent variable. ! implicit none real & delta,stopp,stopss integer & ivaprx,ldstak,mit,n,nfac,npar,nprt ! ! array arguments real & par(*),res(*),scale(*),stp(*),y(*) integer & ifixed(1),mspec(4,*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & rsd integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,npare logical & save ! ! local arrays real & pv(1),sdpv(1),sdres(1),vcv(1,1) character & nmsub(6)*1 ! ! external subroutines external amedrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'a','i','m','e','c',' '/ save = .false. lifixd = npar if (ifixed(1) <= -1) lifixd = 1 lpv = 1 lscale = npar if (scale(1) <= 0.0e0) lscale = 1 lstp = npar if (stp(1) <= 0.0e0) lstp = 1 lsdpv = 1 lsdres = 1 ivcv = 1 call amedrv ( y, n, mspec, nfac, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, save, npare ) return end subroutine aimes ( y, n, mspec, nfac, par, npar, res, ldstak, & ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, nprt, & npare, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! AIMES is the user interface for ARIMA estimation, long call. ! ! Discussion: ! ! this is the user callable subroutine for arima estimation ! (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! if ifixed(1)<0, then ifixed(i)=default,i=1,...,npar, and the ! dimension of ifixed will be assumed to be 1. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where for ! ivaprx le 0, vcv = the default option ! ivaprx eq 1, vcv = inverse(transpose(j)*j) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2, vcv = inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4, vcv = inverse(transpose(j)*j) ! using only the model subroutine ! ivaprx eq 5, vcv = inverse(h) ! using only the model subroutine ! ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using only the model subroutine ! ivaprx ge 7, vcv = the default option ! with j representing the jacobian and h the hessian. ! integer ivcv ! the first dimension of matrix vcv. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the dimension of vector ifixed. ! integer lpv ! the dimension of vector pv. ! integer lscale ! the dimension of vector scale. ! integer lsdpv ! the dimension of vector sdpv. ! integer lsdres ! the dimension of vector sdres. ! integer lstp ! the dimension of vector stp. ! integer mit ! the maximum number of iterations allowed. ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(n) ! the predicted value of the fit. ! real res(n) ! the residuals from the fit. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! the typical size of the parameters. ! if scale(1) <= 0, then scale(i)=default,i=1,...,npar, and the ! dimension of scale will be assumed to be 1. ! real sdpv(n) ! the standard deviations of the predicted values. ! real sdres(n) ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(npar) ! the step size array. ! if stp(1) <= 0, then stp(i)=default,i=1,...,npar, and the ! dimension of stp will be assumed to be 1. ! real vcv(ivcv,npar) ! the variance-covariance matrix. ! real y(n) ! the dependent variable. ! implicit none real & delta,rsd,stopp,stopss integer & ivaprx,ivcv,ldstak,mit,n,nfac,npar,npare,nprt ! ! array arguments real & par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), & y(*) integer & ifixed(1),mspec(4,*) ! ! scalars in common integer & ierr ! arrays in common double precision dstak(3000) ! integer & lifixd,lpv,lscale,lsdpv,lsdres,lstp logical & save ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external amedrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'a','i','m','e','s',' '/ save = .true. if (ifixed(1) <= -1) then lifixd = 1 else lifixd = npar end if if (scale(1) <= 0.0e0) then lscale = 1 else lscale = npar end if if ( stp(1) <= 0.0e0 ) then lstp = 1 else lstp = npar end if call amedrv ( y, n, mspec, nfac, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, save, npare) return end subroutine aimf ( y, n, mspec, nfac, par, npar, ldstak ) !*****************************************************************************80 ! !! AIMF is the user interface for ARIMA estimation, short call. ! ! Discussion: ! ! this is the user callable subroutine for arima estimation ! (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fcst(1,1) ! the storage array for the forecasts. ! real fcstsd(1) ! the storage array for the standard deviations of the forecasts. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifcst ! the first dimension of the array fcst. ! integer ifcsto(1) ! the indices of the origins for the forecasts. ! integer ldstak ! the length of the array dstak. ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! integer nfcst ! the number of forecasts. ! integer nfcsto ! the number of the origins. ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer npar ! the number of parameters in the model. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real y(n) ! the dependent variable. ! implicit none integer & ldstak,n,nfac,npar ! ! array arguments real & par(*),y(*) integer & mspec(4,*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & ifcst,nfcst,nfcsto,nprt logical & save ! ! local arrays real & fcst(1,1),fcstsd(1) integer & ifcsto(1) character & nmsub(6)*1 ! ! external subroutines external amfcnt ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'a','i','m','f',' ',' '/ save = .false. nfcst = n/10 + 1 nfcsto = 1 ifcsto(1) = n nprt = -1 ifcst = 1 call amfcnt(y, n, mspec, nfac, par, npar, ldstak, nfcst, nfcsto, & ifcsto, nprt, fcst, ifcst, fcstsd, nmsub, save) return end subroutine aimfs ( y, n, mspec, nfac, par, npar, ldstak, & nfcst, nfcsto, ifcsto, nprt, fcst, ifcst, fcstsd ) !*****************************************************************************80 ! !! AIMFS is the user interface for ARIMA estimation, control call. ! ! Discussion: ! ! this is the user callable subroutine for arima estimation ! (control call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fcst(ifcst,nfcsto) ! the storage array for the forecasts. ! real fcstsd(nfcst) ! the storage array for the standard deviations of the forecasts. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifcst ! the first dimension of the array fcst. ! integer ifcsto(nfcsto) ! the indices of the origins for the forecasts. ! integer ldstak ! the length of the array dstak. ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! integer nfcst ! the number of forecasts. ! integer nfcsto ! the number of the origins. ! integer nfcstu ! the number of forcastes actually used. ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer npar ! the number of parameters in the model. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real y(n) ! the dependent variable. ! implicit none integer & ifcst,ldstak,n,nfac,nfcst,nfcsto,npar,nprt ! ! array arguments real & fcst(*),fcstsd(*),par(*),y(*) integer & ifcsto(*),mspec(4,*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer nfcstu logical & save ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external amfcnt ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'a','i','m','f','s',' '/ save = .true. if ((nfcst >= 1) .and. (nfcst <= n)) then nfcstu = nfcst else nfcstu = (n/10)+1 end if call amfcnt(y, n, mspec, nfac, par, npar, ldstak, nfcstu, & max(1,nfcsto), ifcsto, nprt, fcst, ifcst, fcstsd, nmsub, save) return end subroutine aimx1 ( mxn, mxpar, mxfc, mxfco, mxfac, & mod, n, mspec, nfac, par, npar, res, & ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, nprt, & npare, rsd, pv, sdpv, sdres, vcv, ivcv, & nfcst, nfcsto, ifcsto, fcst, ifcst, fcstsd ) !*****************************************************************************80 ! !! AIMX1 sets the starting parameter values for the AIMX example. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! real fcst(mxfc,mxfco) ! the forecasts. ! real fcstsd(mxfc) ! the standard deviation of the forecasts. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifcsto(mxfco) ! the forecast origins. ! integer ifixed(mxpar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i)==0, then par(i) will be held fixed. ! ifixed(i)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivcv ! the actual first dimension of vcv. ! integer mod ! an indicator value used to designate the model for which ! the parameters are to be set. ! integer mspec(4,mxfac) ! the values of p, d, q and s for each factor. ! integer mxfac ! the maximum number of factors allowed. ! integer mxfc ! the maximum number of forecasts allowed. ! integer mxfco ! the maximum number of forecasts origins allowed. ! integer mxn ! the maximum number of observations allowed. ! integer mxpar ! the maximum number of parameters allowed. ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! integer nfcst, nfcsto ! the number of forecasts and forcast origins. ! integer npar ! the number of parameters in the model. ! to be provided. ! integer npare ! the number of parameters estimated by the routine. ! real par(mxpar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real pv(mxn) ! the predicted values. ! real res(mxn) ! the residuals. ! real rsd ! the residual standard deviation. ! real scale(mxpar) ! the scale values. ! real sdpv(mxn) ! the standard deviation of the predicted values. ! real sdres(mxn) ! the standardized residuals. ! real stp(mxpar) ! the step values. ! real vcv(mxpar,mxpar) ! the variance covariance matrix. ! implicit none integer mxpar real delta integer ierr integer npar real par(mxpar) real, external :: rmdcon real rsd external setrv real sqmeps real stopp real stopss integer & ifcst,ivaprx,ivcv,mit,mod,mxfac,mxfc,mxfco,mxn,n, & nfac,nfcst,nfcsto,npare,nprt ! ! array arguments real & fcst(mxfc,*),fcstsd(*),pv(*),res(*),scale(*),sdpv(*), & sdres(*),stp(*),vcv(mxpar,*) integer & ifcsto(*),ifixed(*),mspec(4,mxfac) common /errchk/ierr if ( mod == 1 ) then n = 144 nfac = 2 mspec(1,1) = 0 mspec(2,1) = 1 mspec(3,1) = 1 mspec(4,1) = 1 mspec(1,2) = 0 mspec(2,2) = 1 mspec(3,2) = 1 mspec(4,2) = 12 npar = 3 par(1) = 0.0e0 par(2) = 0.4e0 par(3) = 0.6e0 ifixed(1) = 1 ifixed(2) = 0 ifixed(3) = 0 else if ( mod == 2 ) then par(1) = 1.0e0 par(2) = 2.0e0 par(3) = 3.0e0 else if ( mod == 3 ) then par(1) = 6.0e0 par(2) = 5.0e0 par(3) = 4.0e0 par(4) = 3.0e0 par(5) = 2.0e0 else if ( mod == 4 ) then call setrv ( par, npar, 0.0e0 ) else if ( mod == 5 ) then call setrv ( par, npar, 0.5e0 ) else if ( mod == 6 ) then par(1) = 100.0e0 par(2) = 15.0e0 else write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'AIMX1 - Fatal error!' write ( *, '(a)' ) ' Illegal input value of MOD.' write ( *, '(a)' ) ' Legal values are 1 through 6.' stop end if sqmeps = sqrt ( epsilon ( sqmeps ) ) mit = 25 stp(1:10) = sqmeps scale(1:10) = 1.0e0 stopss = 10.0e-7 stopp = 10.0e-7 delta = 0.5e0 nprt = 11111 ivaprx = 3 ivcv = mxpar nfcst = 36 nfcsto = 2 ifcsto(1) = 103 ifcsto(2) = n ifcst = mxfc res(1:mxn) = -1.0e0 pv(1:mxn) = -1.0e0 sdpv(1:mxn) = -1.0e0 sdres(1:mxn) = -1.0e0 vcv(1:mxpar,1:mxpar) = -1.0e0 fcstsd(1:mxfc) = -1.0E+00 fcst(1:mxfc,1:mxfco) = -1.0e0 npare = -1 rsd = -1.0e0 ierr = -1 return end function albeta ( a, b ) !*****************************************************************************80 ! !! ALBETA computes the logarithm of the Beta function. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real a real albeta real alngam real alnrel real b real corr real p real q real r9lgmc real, parameter :: sq2pil = 0.91893853320467274e0 p = min (a, b) q = max (a, b) if ( p <= 0.0 ) then call xerror ( 'albeta both arguments must be gt zero', 1, 2) end if if ( 10.0 <= p ) then corr = r9lgmc(p) + r9lgmc(q) - r9lgmc(p+q) albeta = -0.5*log(q) + sq2pil + corr + (p-0.5)*log(p/(p+q)) & + q*alnrel(-p/(p+q)) else if ( 10.0 <= q ) then corr = r9lgmc(q) - r9lgmc(p+q) albeta = alngam(p) + corr + p - p*log(p+q) + & (q-0.5)*alnrel(-p/(p+q)) else albeta = log(gamma(p) * (gamma(q)/gamma(p+q)) ) end if return end subroutine algams ( x, algam, sgngam ) !*****************************************************************************80 ! !! ALGAMS evaluates the log of the absolute value of the Gamma function. ! ! Discussion: ! ! Evaluate log abs (gamma(x)) and return the sign of gamma(x) in sgngam. ! sgngam is either +1.0 or -1.0. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real algam real alngam real sgngam real x algam = alngam ( x ) sgngam = 1.0 if ( x <= 0.0 ) then if ( int ( real ( mod ( -int ( x ), 2 ) ) + 0.1 ) == 0 ) then sgngam = -1.0 end if end if return end function alngam ( x ) !*****************************************************************************80 ! !! ALNGAM computes the logarithm of the absolute value of the Gamma function. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real alngam real x ! ! real dxrel,pi,sinpiy,sq2pil,sqpi2l,xmax,y ! ! external functions real r9lgmc external r9lgmc ! data sq2pil / 0.91893853320467274e0/ ! sq2pil = log(sqrt(2.*pi)), sqpi2l = log (sqrt(pi/2.)) data sqpi2l / 0.22579135264472743e0/ data pi / 3.14159265358979324e0/ data xmax, dxrel / 0., 0. / if (xmax == 0.) then xmax = huge ( xmax ) / log ( huge ( xmax ) ) dxrel = sqrt ( epsilon ( dxrel ) ) end if y = abs(x) ! ! log (abs (gamma(x))) for abs(x) <= 10.0 ! if ( y <= 10.0 ) then alngam = log (abs (gamma(x))) return end if ! ! log (abs (gamma(x))) for abs(x) > 10.0 ! if (y > xmax) then call xerror ( 'alngam abs(x) so big alngam overflows', 2, 2) end if if (x > 0.0) then alngam = sq2pil + (x-0.5)*log(x) - x + r9lgmc(y) return end if sinpiy = abs (sin(pi*y)) if (sinpiy==0.) then call xerror ('alngam x is a negative integer', 3, 2) end if if (abs((x-aint(x-0.5))/x)= 1) then ymean = sumy / real ( nused ) else ymean = sumy end if return end subroutine amecnt ( y, wt, lwt, xm, n, m, ixm, mdl, nldrv, aprxdv, & drv, par, npar, res, ifixed, lifixd, stp, lstp, mit, stopss, & stopp, scale, lscale, delta, ivaprx, rsd, pv, lpv, sdpv, & lsdpv, sdres, lsdres, vcv, ivcv, weight, save, nnzw, npare, & nlhdr, page, wide, iptout, ndigit, hlfrpt, nrests ) !*****************************************************************************80 ! !! AMECNT is the control routine for nonlinear least squares regression. ! ! Discussion: ! ! This is the controlling subroutine for nonlinear least ! squares regression. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! integer d ! the starting location in rstak/dstak of ! the array in which the numerical derivatives with respect to ! each parameter are stored. ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd ! the starting location in istak of ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ifixed(i).eq ! then par(i) will be held fixed. ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer iiwork ! the dimension of the integer work vector iwork. ! integer iptout(5) ! the variable used to control printed output for each section. ! integer irwork ! the dimension of the real work vector rwork. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer iwork ! the starting location in istak of ! the integer work space vector used by the nl2 subroutines. ! integer ixm ! the first dimension of the independent variable array. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lvcvl ! the length of the vector containing ! the lower half of the vcv matrix, stored row wise. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. ! integer n ! the number of observations. ! integer nall0 ! number of allocations on entry. ! integer ndigit ! the number of digits in the print control value. ! external nldrv ! the name of the routine which calculates the derivatives. ! external nlhdr ! the name of the routine which produces the heading. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nrests ! the maximum number of residuals to be computed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! integer pare ! the starting location in rstak/dstak of ! the current estimates of the parameters, but only ! those to be optimized (not those whose values are fixed). ! real pv(lpv) ! the predicted value based on the current parameter estimates ! integer pvi ! the starting location in rstak/dstak of ! the predicted values. ! real res(n) ! the residuals from the fit. ! integer rests ! the starting location in rstak/dstak of ! the residuals from the arima model. ! real rsd ! the value of the residual standard deviation at the solution. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer rwork ! the starting location in rstak/dstak of ! the real work vector used by the nl2 subroutines. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(lscale) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! integer sdpvi ! the starting location in rwork of ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! integer sdresi ! the starting location in rwork of the ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(lstp) ! the step size array. ! real vcv(ivcv,npar) ! the variance-covariance matrix. ! integer vcvl ! the starting location in rwork of ! the variance-covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! implicit none integer n logical aprxdv real delta logical hlfrpt integer ierr logical page real res(n) real rsd logical save real stopp real stopss logical weight logical wide real y(n) integer & ivaprx,ivcv,ixm,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,m, & mit,ndigit,nnzw,npar,npare,nrests ! ! array arguments real & par(*),pv(lpv),scale(lscale),sdpv(lsdpv),sdres(lsdres),stp(lstp), & vcv(ivcv,*),wt(lwt),xm(ixm,*) integer & ifixed(lifixd),iptout(5) ! ! subroutine arguments external drv,mdl,nldrv,nlhdr ! ! arrays in common double precision dstak(3000) ! ! integer & d,ifixd,ifp,iiwork,irwork,iwork,lvcvl,nall0,pare,pvi, & rests,rwork,sdpvi,sdresi,vcvl ! ! local arrays real & rstak(12) integer & istak(12) ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external amemn,cpyasf,scopy,setiv,stkclr ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) nall0 = stkst(1) ifp = 3 ierr = 0 ! ! subdivide work area for least squares analysis ! iiwork = npare + 60 irwork = 94 + 2*nrests + npare*(3*npare+33)/2 ifixd = stkget(npar,2) iwork = stkget(iiwork,2) d = stkget ( nrests * npar, ifp ) pare = stkget ( npare, ifp ) rests = stkget ( nrests, ifp ) pvi = rests rwork = stkget ( irwork, ifp ) if ( ierr == 1 ) then return end if ! ! set values for ifixd ! if ( ifixed(1) >= 0 ) then call cpyvii(npar, ifixed, 1, istak(ifixd), 1) end if if ( ifixed(1) < 0 ) then call setiv ( istak(ifixd), npar, 0 ) end if call amemn ( y, weight, nnzw, wt, lwt, xm, n, m, ixm, nrests, & aprxdv, istak(ifixd), par, rstak(pare), npar, res, page, & wide, hlfrpt, stp, lstp, mit, stopss, stopp, scale, lscale, & delta, ivaprx, iptout, ndigit, rsd, rstak(rests), sdpvi, & sdresi, vcvl, lvcvl, rstak(d), istak(iwork), iiwork, & rstak(rwork), irwork, nlhdr, npare, rstak(pvi) ) if ( save ) then sdpvi = rwork + sdpvi - 1 sdresi = rwork + sdresi - 1 vcvl = rwork + vcvl - 1 call scopy ( n, rstak(pvi), 1, pv, 1 ) call scopy ( n, rstak(sdpvi), 1, sdpv, 1 ) call scopy ( n, rstak(sdresi), 1, sdres, 1 ) call cpyasf ( npare, rstak(vcvl), lvcvl, vcv, ivcv ) end if call stkclr ( nall0 ) return end subroutine amedrv ( y, n, mspec, nfac, par, npar, & res, ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, & scale, lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, & sdres, lsdres, vcv, ivcv, nmsub, save, npare ) !*****************************************************************************80 ! !! AMEDRV is the control routine for nonlinear least squares regression. ! ! Discussion: ! ! This is the controlling subroutine for nonlinear least ! squares regression using numerically approximated derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! external amehdr ! the routine used to print the heading ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real exmpt ! the proportion of observations for which the computed ! numerical derivatives wrt a given parameter are exempted ! from meeting the derivative acceptance criteria. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer iflag ! ... ! integer ifp ! an indicator for the precision of the stack allocation type, ! where ifp=3 indicates single and ifp=4 indicates double. ! integer iptout(5) ! the variable used to control printed output for each section. ! integer is ! a value used to determine the amount of work space needed ! based on whether step sizes are input or are to be calculated. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where for ! ivaprx le 0, vcv = the default option ! ivaprx eq 1, vcv = inverse(transpose(j)*j) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2, vcv = inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4, vcv = inverse(transpose(j)*j) ! using only the model subroutine ! ivaprx eq 5, vcv = inverse(h) ! using only the model subroutine ! ivaprx eq 6, vcv = inverse(h)*transpose(j)*jacobian*inverse(h) ! using only the model subroutine ! ivaprx ge 7, vcv = the default option ! with j representing the jacobian and h the hessian. ! integer ivcv ! the first dimension of matrix vcv. ! integer ixm ! the first dimension of matrix xm. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the dimension of vector ifixed. ! integer lpv ! the dimension of vector pv. ! integer lscale ! the dimension of vector scale. ! integer lsdpv ! the dimension of vector sdpv. ! integer lsdres ! the dimension of vector sdres. ! integer lstp ! the dimension of vector stp. ! integer lwt ! the dimension of vector wt. ! integer m ! the number of independent variables. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! external mdlts1 ! the starpac format subroutine for computing the arima model ! predicted values. ! external mdlts3 ! the starpac format subroutine for computing the arima model ! residuals. ! integer mit ! the maximum number of iterations allowed. ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer mspect ! the starting location in the work space for ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nall0 ! number of stack allocations outstanding. ! integer ndigit ! the number of digits in the print control value. ! integer neta ! the number of accurate digits in the model results. ! integer nfac ! the number of factors in the model ! integer nfact ! the number of factors in the model ! external nldrvn ! the name of the routine which calculates the derivatives. ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer npare ! the number of parameters to be optimized. ! integer nparma ! the length of the vector parma ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! integer nrests ! the maximum number of residuals to be computed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! integer parar ! the starting location in the work array for ! the autoregressive parameters ! integer pardf ! the starting location in the work space for ! the vector containing the difference filter parameters ! integer parma ! the starting location in the work array for ! the moving average parameters ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! real pv(lpv) ! the predicted value of the fit. ! real res(n) ! the residuals from the fit. ! real rsd ! the residual standard deviation. ! real rstak(12) ! the real version of the /cstak/ work area. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(lscale) ! the typical size of the parameters. ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(lstp) ! the step size array. ! external stpamo ! the routine used to print the output from the step size selecti ! routines. ! integer stpt ! the starting location in /cstak/ of vector stpt containing ! the step size array. ! integer t ! the starting location in the work array for ! a temporary work vector. ! integer temp ! the starting location in the work array for ! a temporary work vector ! real vcv(ivcv,npar) ! the variance-covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(1) ! the user supplied weights, unused when weight = false. ! real y(n) ! the dependent variable. ! implicit none integer n integer nfac integer npar external amehdr real delta external drv double precision dstak(3000) real exmpt integer ierr integer ifixed(*) integer iflag integer ifp integer is integer isubhd integer ivaprx integer ivcv integer ixm integer ldsmin integer ldstak integer lifixd integer lpv integer lscale integer lsdpv integer lsdres integer lstp integer mbo integer mbol external mdlts1 external mdlts3 integer mit integer mspec(4,nfac) integer mspect integer nfact external nldrvn character nmsub(6) integer nparar integer npardf integer npare integer nparma integer nprt integer nrests real par(npar) integer parar integer pardf integer parma real pv(*) real res(n) real rsd logical save real scale(*) real sdpv(*) real sdres(*) real stopp real stopss real stp(*) external stpamo integer t integer temp real vcv(*) real wt(1) real y(n) integer & lwt,m,nall0,ndigit,neta,nnzw,stpt logical & aprxdv,hlfrpt,page,prtfxd,weight,wide ! ! local arrays real & rstak(12) integer & iptout(5),istak(12) ! ! external functions integer & icnti,stkget,stkst external icnti,stkget,stkst ! ! common blocks ! common /cstak/ dstak common /errchk/ ierr common /mdltsc/ mspect,nfact,pardf,npardf,parar,nparar,parma, & nparma,mbo,mbol,t,temp,nrests,iflag ! ! equivalences ! equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) weight = .false. wt(1) = 1.0e0 lwt = 1 hlfrpt = .false. aprxdv = .true. prtfxd = .true. exmpt = -1.0e0 neta = 0 wide = .true. page = .false. ndigit = 5 ! ! Compute back operators. ! call backop ( mspec, nfac, npardf, mbol, mbo, nparma, nparar ) nnzw = n - npardf ierr = 0 npare = npar if ( 0 <= ifixed(1) .and. 1 <= npar ) then npare = icnti ( ifixed, npar, 0 ) end if if ( stp(1) <= 0.0e0 ) then is = 1 else is = 0 end if call ldscmp ( 25, 0, max(is*2*(n+npar),60+npar+npare) + 4*nfac, & 0, 0, 0, 's', 5*mbo + max(is*(10*n+6*mbo+606), & 94+4*(n+mbo+101)+npare*(3*npare+35)/2), & ldsmin ) call ameer ( nmsub, n, npar, npare, ldstak, & ldsmin, stp, lstp, scale, lscale, ivcv, save, mspec, nfac ) if (ierr /= 0) then return end if call stkset ( ldstak, 4 ) ! ! set print control values ! call prtcnt ( nprt, ndigit, iptout ) ! ! Subdivide workspace for step sizes. ! nall0 = stkst(1) ifp = 3 stpt = stkget ( npar, ifp ) pardf = stkget ( mbo, ifp ) parar = stkget ( mbo, ifp ) parma = stkget ( mbo, ifp ) t = stkget ( 2 * mbo, ifp ) temp = t + mbo nfact = nfac mspect = stkget ( 4 * nfac, 2 ) ! ! Set up for model. ! aprxdv = .true. m = 1 ixm = n nrests = mbo + 101 + n call cpyvii ( nfac, mspec(1,1), 4, istak(mspect), 1 ) call cpyvii ( nfac, mspec(2,1), 4, istak(mspect+nfac), 1 ) call cpyvii ( nfac, mspec(3,1), 4, istak(mspect+2*nfac), 1 ) call cpyvii ( nfac, mspec(4,1), 4, istak(mspect+3*nfac), 1 ) call dcoef ( nfac, istak(mspect+nfac), istak(mspect+3*nfac), & npardf, rstak(pardf), mbo, rstak(t) ) ! ! Copy supplied step sizes to work space. ! call scopy ( lstp, stp, 1, rstak(stpt), 1 ) ! ! Select step sizes, if desired. ! if ( ierr == 0 ) then isubhd = 1 if ( stp(1) <= 0.0e0 ) then call amestp ( y, n, m, ixm, mdlts3, par, npar, & rstak(stpt), exmpt, neta, scale, lscale, iptout(1), amehdr, & page, wide, isubhd, hlfrpt, prtfxd, ifixed, lifixd, stpamo, & nrests-n ) end if call amecnt ( y, wt, lwt, y, n, m, ixm, mdlts1, nldrvn, aprxdv, drv, & par, npar, res, ifixed, lifixd, rstak(stpt), npar, mit, & stopss, stopp, scale, lscale, delta, ivaprx, rsd, pv, lpv, & sdpv, lsdpv, sdres, lsdres, vcv, ivcv, weight, save, nnzw, & npare, amehdr, page, wide, iptout, ndigit, hlfrpt, nrests ) end if call stkclr(nall0) return end subroutine ameer ( nmsub, n, npar, npare, ldstak, ldsmin, & stp, lstp, scale, lscale, ivcv, save, mspec, nfac ) !*****************************************************************************80 ! !! AMEER checks errors for the nonlinear least squares estimation. ! ! Discussion: ! ! this is the error checking routine for nonlinear least squares ! estimation routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error(20) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! the variable used to indicate whether a heading is to be ! printed during a given call to the iteration report (true) ! or not (false). ! integer i ! an index variable. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ivcv ! the first dimension of matrix vcv. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 livcv(8), llds(8), lmspec(8), ln(8), lnfac(8), ! * lnpar(8), lnpare(8), lone(8), lscl(8), lstep(8), lzero(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer lscale ! the dimension of vector scale. ! integer lstp ! the dimension of vector stp. ! integer mspec(4,*) ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model. ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer np ! the number of parameters specified by mspec. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! integer nv ! * ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(lscale) ! the typical size of the parameters. ! real stp(lstp) ! the step size array. ! implicit none integer & ivcv,ldsmin,ldstak,lscale,lstp,n,nfac,npar,npare logical & save ! ! array arguments real & scale(*),stp(*) integer & mspec(4,*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i,np,nv logical & head ! ! local arrays logical & error(20) character & livcv(8)*1,llds(8)*1,lmspec(8)*1,ln(8)*1,lnfac(8)*1, & lnpar(8)*1,lnpare(8)*1,lone(8)*1,lscl(8)*1,lstep(8)*1, & lzero(8)*1 ! ! external subroutines external eiage,eiseq,eisge,ervgt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data livcv(1), livcv(2), livcv(3), livcv(4), livcv(5), & livcv(6), livcv(7), livcv(8) /'i','v','c','v',' ',' ',' ',' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data lmspec(1), lmspec(2), lmspec(3), lmspec(4), lmspec(5), & lmspec(6), lmspec(7), lmspec(8) & /'m','s','p','c',' ',' ',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lnfac(1), lnfac(2), lnfac(3), lnfac(4), lnfac(5), & lnfac(6), lnfac(7), lnfac(8) /'n','f','a','c',' ',' ',' ',' '/ data lnpar(1), lnpar(2), lnpar(3), lnpar(4), lnpar(5), & lnpar(6), lnpar(7), lnpar(8) /'n','p','a','r',' ',' ',' ', & ' '/ data lnpare(1), lnpare(2), lnpare(3), lnpare(4), lnpare(5), & lnpare(6), lnpare(7), lnpare(8) /'n','p','a','r','e',' ',' ', & ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), & lone(6), lone(7), lone(8) /'1',' ',' ',' ',' ',' ',' ',' '/ data lscl(1), lscl(2), lscl(3), lscl(4), lscl(5), & lscl(6), lscl(7), lscl(8) /'s','c','a','l','e',' ',' ', & ' '/ data lstep(1), lstep(2), lstep(3), lstep(4), lstep(5), & lstep(6), lstep(7), lstep(8) /'s','t','p',' ',' ',' ',' ',' '/ data lzero(1), lzero(2), lzero(3), lzero(4), lzero(5), & lzero(6), lzero(7), lzero(8) /'z','e','r','o',' ',' ',' ',' '/ ! ! Error checking ! error(1:20) = .false. ierr = 0 head = .true. call eisge(nmsub, ln, n, 1, 2, head, error(1), lone) call eisge(nmsub, lnfac, nfac, 1, 2, head, error(2), lone) if (.not. error(2)) & call eiage(nmsub, lmspec, mspec, 4, nfac, 4, 0, 0, head, 1, nv, & error(3), lmspec) if ((.not. error(2)) .and. (.not. error(3))) then np = 1 do i = 1, nfac np = np + mspec(1,i) + mspec(3,i) end do call eiseq(nmsub, lnpar, npar, np, 1, head, error(4), lnpar) if (.not.error(4)) then call eisge(nmsub, lnpare, npare, 1, 2, head, error(5), lone) call ervgt(nmsub, lstep, stp, lstp, 0.0e0, 0, head, 6, nv, & error(8), lzero) call ervgt(nmsub, lscl, scale, lscale, 0.0e0, 0, head, 6, nv, & error(12), lzero) if (save .and. (.not.error(5))) & call eisge(nmsub, livcv, ivcv, npare, 3, head, error(15), & lnpare) end if end if if ((.not.error(1)) .and. (.not.error(2)) .and. (.not.error(3)) & .and. (.not.error(4)) .and. (.not.error(5))) & call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(6), & llds) do i=1,20 if (error(i)) then ierr = 1 return end if end do return end subroutine amefin ( y, weight, nnzw, wt, lwt, xm, n, m, ixm, ifixd, & par, npar, npare, res, page, wide, iptout, ndigit, rsshlf, rsd, & pvt, sdpvt, sdrest, rd, vcvl, lvcvl, d, amehdr, ivcvpt, iskull, & nrests ) !*****************************************************************************80 ! !! AMEFIN analyzes nonlinear least squares estimates after they are computed. ! ! Discussion: ! ! this routine completes the analysis for the nonlinear ! least squares estimation routines once the estimates ! have been found. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real cond ! the condition number of d. ! real d(n,npar) ! the first derivative of the model (jacobian). ! logical exact ! an indicator value used to designate whether the fit ! was exact to machine precision (true) or not (false). ! external amehdr ! the routine used to print the heading ! integer idf ! the degrees of freedom in the fit. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer iskull(10) ! an error message indicator variable. ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! integer ixm ! the first dimension of matrix xm. ! integer lvcvl ! the dimension of vector vcvl. ! integer lwt ! the dimension of vector wt. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! integer nrests ! the maximum number of residuals to be computed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! logical prtfsm ! the variable used to indicate whether any of the summary ! information is to be printed (true) or not (false). ! real pvt(n) ! the predicted value based on the current parameter estimates. ! real rd(n) ! the diagonal elements of the r matrix of the q - r ! factorization of d. ! real res(n) ! the residuals from the fit. ! real rsd ! the residual standard deviation. ! real rss ! the residual sum of squares. ! real rsshlf ! half the residual sum of squares. ! real sdpvt(n) ! the standard deviations of the predicted values. ! real sdrest(n) ! the standardized residuals. ! real vcvl(lvcvl) ! the lower half of the variance-covariance matrix, stored ! row wise. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real xm(ixm,m) ! the independent variable. ! real y(n) ! the dependent variable. ! real yss ! the sum of the squares about the mean y value. ! implicit none real & rsd,rsshlf integer & ivcvpt,ixm,lvcvl,lwt,m,n,ndigit,nnzw,npar,npare,nrests logical & page,weight,wide ! ! array arguments real & d(n,*),par(*),pvt(*),rd(*),res(*),sdpvt(*),sdrest(*),vcvl(*), & wt(*),xm(ixm,m),y(*) integer & ifixd(*),iptout(*),iskull(10) ! ! subroutine arguments external amehdr ! ! scalars in common integer & ierr ! ! real & cond,rss,yss integer idf logical & exact,prtfsm ! ! common blocks common /errchk/ierr ! ! Modify vcv to reflect proper degrees of freedom ! vcvl(1:lvcvl) = real (nrests-npar) * vcvl(1:lvcvl) / real(n-npar) ! ! Compute returned and/or printed values. ! call nlcmp (y, weight, wt, lwt, n, npar, npare, res, & d, rd, cond, vcvl, lvcvl, nnzw, idf, rsshlf, rss, rsd, yss, & exact, pvt, sdpvt, sdrest, iskull) prtfsm = ((iptout(3) /= 0) .or. (iptout(4) /= 0) .or. & (iptout(5) /= 0) .or. (ierr /= 0)) ! ! Print summary information if desired or if an error flag ! has been set. ! if ( prtfsm ) then call ameout(y, n, & ifixd, par, npar, npare, res, iptout, ndigit, page, idf, cond, & rss, rsd, yss, exact, pvt, sdpvt, sdrest, vcvl, lvcvl, ivcvpt, & iskull, amehdr, wide) end if return end subroutine amehdr ( page, wide, isubhd ) !*****************************************************************************80 ! !! AMEHDR prints headings for nonlinear least squares estimation. ! ! Discussion: ! ! This routine prints the page headings for the nonlinear ! least squares estimation routines for arima models that use ! numerical approximations to the derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! implicit none integer & isubhd logical & page,wide ! ! external subroutines external versp if (page) write (*, 1020) call versp(wide) if (page) write (*,1000) if (.not.page) write (*,1010) page = .true. if (isubhd==0) return write ( *, 1030) return 1000 format ('+nonlinear least squares estimation', & ' for the parameters of an arima model, continued') 1010 format ('+', 77('*')/ & 1x, '* nonlinear least squares estimation', & ' for the parameters of an arima model *'/ & ' *', 16x, ' using backforecasts ', & 14x, '*'/1x, 77('*')) 1020 format ('1') 1030 format (//' summary of initial conditions'/ 1x, 30('-')) end subroutine ameism ( amehdr, page, wide, hlfrpt, npar, m, n, nnzw, & weight, ifixd, par, scale, lscale, iwork, liwork, rwork, & lrwork, res, aprxdv, stpt, lstpt, npare ) !*****************************************************************************80 ! !! AMEISM prints an initial summary for nonlinear least squares routines. ! ! Discussion: ! ! This routine prints an initial summary of the starting ! estimates and the control parameters for the nonlinear ! least squares subroutines for arima modeling. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! external amehdr ! the routine used to print the heading ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer iamhd ! the indicator value used to designate the type of list ! to be generated ! if iamhd=1, the list is for the initial summary of the ! estimation routines. ! if iamhd=2, the list is for the initial report of the ! forecasting routines. ! if iamhd=3, the list is for the final report of the ! estimation routines. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer iwork(liwork) ! work space used by the nl2 subroutines. ! integer liwork ! the dimension of vector iwork. ! integer lmax0 ! the location in rwork of the value indicating the ! maximum change allowed in the model parameters at the ! first iteration. ! integer lrwork ! the dimension of vector rwork. ! integer lscale ! the dimension of vector scale. ! integer lstpt ! the dimension of vector stpt. ! integer m ! a dummy variable. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! integer mspect ! the starting location in the work space for ! the array containing the values of p, d, q, and s for each fact ! integer mxfcal ! the location in iwork of the variable designating the ! maximum number of function calls allowed, excluding ! calls necessary to compute the derivatives and variance ! covariance matrix. ! integer mxiter ! the location in iwork of the variable designating the ! maximum number of iterations allowed. ! integer n ! the number of observations. ! integer nfact ! the number of factors in the model ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer npare ! the number of parameters to be optimized. ! integer nparma ! the length of the vector parma ! integer nrests ! the maximum number of residuals to be computed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! integer parar ! the starting location in the work array for ! the autoregressive parameters ! integer pardf ! the starting location in the work space for ! the vector containing the difference filter parameters ! integer parma ! the starting location in the work array for ! the moving average parameters ! real res(n) ! the residuals from the fit. ! integer rfctol ! the location in rwork of the relative function convergence ! tolerance. ! real rsd ! the residual standard deviation. ! real rss ! the residual sum of squares. ! real rwork(lrwork) ! work space used by the nl2 subroutines. ! real scale(lscale) ! the typical size of the parameters. ! real stpt(lstpt) ! the step size array. ! integer t ! the starting location in the work array for ! a temporary work vector. ! integer temp ! the starting location in the work array for ! a temporary work vector ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! integer xctol ! the location in rwork of the parameter convergence tolerance. ! implicit none integer & liwork,lrwork,lscale,lstpt,m,n,nnzw,npar,npare logical & aprxdv,hlfrpt,page,weight,wide ! ! array arguments real & par(*),res(*),rwork(lrwork),scale(*),stpt(*) integer & ifixd(*),iwork(liwork) ! ! subroutine arguments external amehdr ! ! scalars in common integer & iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma,nrests, & parar,pardf,parma,t,temp ! ! arrays in common double precision dstak(3000) ! ! real & rsd,rss integer & iamhd,isubhd,lmax0,mxfcal,mxiter,rfctol,xctol ! ! local arrays integer & istak(12) ! ! external functions real & snrm2 external snrm2 ! ! external subroutines external amlst,modsum ! ! common blocks common /cstak/dstak common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, & nparma,mbo,mbol,t,temp,nrests,iflag ! ! equivalences equivalence (dstak(1),istak(1)) ! ! iwork subscript values ! data mxfcal/17/, mxiter/18/ ! ! rwork subscript values ! data lmax0/35/, rfctol/32/, xctol/33/ isubhd = 1 call amehdr(page, wide, isubhd) call modsum(nfact, istak(mspect)) iamhd = 1 call amlst (iamhd, par, npar, nfact, istak(mspect), n, par, npar, & scale, lscale, stpt, lstpt, ifixd, rss, rsd, npardf, npare, 0) if (weight) write ( *, 1170) nnzw write ( *, 1070) iwork(mxiter) write ( *, 1090) iwork(mxfcal) write ( *, 1080) write ( *, 1100) rwork(rfctol) write ( *, 1110) rwork(xctol) write ( *, 1120) rwork(lmax0) rsd = snrm2(nrests, res, 1) rss = rsd * rsd if (n-npardf-npare >= 1) & rsd = rsd / sqrt(real(n-npardf-npare)) write ( *, 1200) rss write ( *, 1210) rsd write ( *, 1220) n, npardf, npare, nnzw-npare return 1070 format (/' maximum number of iterations allowed', 32x, '(mit)', & 1x, i5) 1080 format(/' convergence criterion for test based on the'/) 1090 format(/' maximum number of model subroutine calls', & ' allowed', 26x, i5) 1100 format (5x, ' forecasted relative change in residual', & ' sum of squares', 7x, '(stopss)', 1x, g11.4) 1110 format(5x, ' maximum scaled relative change in the parameters', & 13x, '(stopp)', 1x, g11.4) 1120 format(//' maximum change allowed in the parameters', & ' at the first iteration', 3x, '(delta)', 1x, g11.4) 1170 format (/' number of non zero weighted observations', 27x, & '(nnzw)', 1x, i5) 1200 format (/' residual sum of squares for input parameter', & ' values', 24x, g11.4, ' (backforecasts included)') 1210 format (/' residual standard deviation for input parameter', & ' values', 14x, '(rsd)', 1x, g11.4) 1220 format (/ ' based on degrees o', & 'f freedom', 1x, i4, ' - ', i3, ' - ', i3, ' = ', i4) end subroutine amemn ( y, weight, nnzw, wt, lwt, xm, n, m, ixm, nrests, & aprxdv, ifixd, par, pare, npar, res, page, wide, & hlfrpt, stp, lstp, mit, stopss, stopp, scale, lscale, delta, & ivaprx, iptout, ndigit, rsd, rests, sdpvi, sdresi, vcvl, lvcvl, & d, iwork, iiwork, rwork, irwork, nlhdr, npare, pvt ) !*****************************************************************************80 ! !! AMEMN is the control routine for using the NL2 software package. ! ! Discussion: ! ! This is the controling subroutine for performing nonlinear ! least squares regression using the nl2 software package ! (implementing the method of dennis, gay and welsch). ! ! This routine was adapted from subroutine nl2sol. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! Algorithm 573: ! An Adaptive Nonlinear Least-Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981, pages 367-383. ! ! Parameters: ! ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! logical cmpdrv ! the variable used to indicate whether derivatives must be ! computed (true) or not (false). ! integer cnvcod ! a value used to control the printing of iteration reports. ! integer covmat ! the location in iwork of the starting location in rwork ! of the beginning of the vcv matrix. ! real d(nrests,npar) ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter. ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! logical done ! the variable used to indicate whether this is the final ! computation of the jacobian or not. ! logical head ! the variable used to indicate whether a heading is to be ! printed during a given call to the iteration report (true) ! or not (false). ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer i ! an indexing variable. ! integer icnvcd ! the location in iwork of ! the convergence condition. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer iiwork ! the dimension of the integer work vector iwork. ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer irwork ! the dimension of the real work vector rwork. ! integer iskull(10) ! an error message indicator variable. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! integer iwork(iiwork) ! the integer work space vector used by the nl2 subroutines. ! integer ixm ! the first dimension of the independent variable array. ! integer lscale ! the actual length of the vector scale. ! integer lstp ! the actual length of the vector stp. ! integer lvcvl ! the length of the vector containing ! the lower half of the vcv matrix, stored row wise. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdlts3 ! the starpac format subroutine for computing the arima model ! residuals. ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! logical newitr ! a flag used to indicate whether a new iteration has been ! completed (true) or not (false). ! external nlhdr ! the name of the routine which produces the heading. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! integer nrests ! the maximum number of residuals to be computed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! real pare(npar) ! the current estimates of the parameters, but only ! those to be optimized (not those whose values are fixed). ! logical prtsmy ! the variable used to indicate whether the summary ! information is to be printed (true) or not (false). ! real pvt(n) ! the predicted value based on the current parameter estimates. ! integer qtr ! the location in iwork of the starting location in rwork ! the array q transpose r. ! integer rd ! the location in iwork of the starting location in rwork of ! the diagonal elements of the r matrix of the q - r ! factorization of d. ! integer rdi ! the location in rwork of the diagonal elements of the r ! matrix of the q - r factorization of d. ! real res(n) ! the residuals from the fit. ! real rests(nrests) ! the residuals from the arima model. ! integer rsave ! the location in iwork of the starting location in rwork ! the array rsave. ! real rsd ! the value of the residual standard deviation at the solution. ! integer rsshlf ! the location in rwork of ! half the residual sum of squares. ! real rwork(irwork) ! the real work vector used by the nl2 subroutines. ! integer s ! the location in iwork of the starting location in rwork ! the array of second order terms of the hessian. ! real scale(lscale) ! the typical size of the parameters. ! integer scl ! the index in rwork of the 1st value of the user supplied scale ! value. ! integer sdpvi ! the starting location in rwork of ! the standard deviations of the predicted values. ! integer sdresi ! the starting location in rwork of the ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! predicted decrease in the residual standard deviation (computed ! by starpac) to the current residual sum of squares estimate. ! real stopss ! the stopping criterion forthe test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(lstp) ! the dummy step size array. ! integer vcvl ! the starting location in rwork of the lower half of the ! vcv matrix, stored row wise. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! implicit none integer nrests real delta real rests(nrests) real rsd real stopp real stopss integer & iiwork,irwork,ivaprx,ixm,lscale,lstp,lvcvl,lwt,m,mit,n, & ndigit,nnzw,npar,npare,sdpvi,sdresi,vcvl logical & aprxdv,hlfrpt,page,weight,wide real & d(nrests,*),par(*),pare(*),pvt(*),res(*),rwork(*), & scale(*),stp(*),wt(*),xm(ixm,*),y(*) integer & ifixd(*),iptout(*),iwork(*) ! ! subroutine arguments external nlhdr ! ! scalars in common integer & ierr ! ! integer & cnvcod,covmat,icnvcd,ivcvpt,qtr,rd,rdi,rsave,rsshlf,s, & scl logical & cmpdrv,done,head,newitr,prtsmy ! ! local arrays integer & iskull(10) ! ! external subroutines external amdrv,amefin,ameism,drv,mdlts3,nl2itr,nlerr,nlinit, & nlitrp,nlsupk,repck,scopy ! ! common blocks common /errchk/ierr ! ! iwork subscript values ! data cnvcod /34/, icnvcd /1/, covmat /26/, qtr /49/, rd /51/, & rsave /52/, s/53/ data rsshlf /10/ ! ! initialize control parameters ! call nlinit (nrests, ifixd, par, npar, pare, npare, mit, stopss, & stopp, scale, lscale, delta, ivaprx, aprxdv, ivcvpt, iwork, & iiwork, rwork, irwork, scl) cmpdrv = .true. done = .false. head = .true. newitr = .false. prtsmy = (iptout(1) /= 0) ! ! compute residuals ! 10 continue call mdlts3 ( par, npar, xm, n, m, ixm, rests ) ! ! print initial summary ! if ( prtsmy) then call ameism(nlhdr, page, wide, hlfrpt, npar, m, n, nnzw, weight, & ifixd, par, scale, lscale, iwork, iiwork, rwork, irwork, rests, & aprxdv, stp, lstp, npare) prtsmy = .false. end if if (.not.cmpdrv) go to 50 cmpdrv = .false. 40 continue ! ! print iteration report if desired ! if ((iptout(2) /= 0) .and. newitr) then call nlitrp ( nlhdr, head, page, & wide, iptout(2), npar, nnzw, iwork, iiwork, rwork, irwork, & ifixd, pare, npare ) end if ! ! compute jacobian ! if ( done ) then call mdlts3 ( par, npar, xm, n, m, ixm, rests ) end if call amdrv ( mdlts3, drv, done, ifixd, par, npar, xm, n, m, ixm, & nrests, rests, d, weight, wt, lwt, stp, lstp, rwork(scl), npare ) if (done) go to 70 ! ! compute next iteration ! 50 call nl2itr(rwork(scl), iwork, d, nrests, nrests, npare, rests, & rwork, pare) ! ! unpack parameters ! call nlsupk ( pare, npare, par, ifixd, npar ) newitr = (iwork(cnvcod)==0) ! if (iwork(1)-2) 10, 40, 60 if ( iwork(1) < 2 ) then go to 10 else if ( iwork(1) == 2 ) then go to 40 else go to 60 end if 60 done = .true. go to 40 70 continue ! ! set error flags, if necessary ! call nlerr(iwork(icnvcd), iskull) ! ! finish computations and print any desired results ! call scopy(n, rests(nrests-n+1), 1, res(1), 1) pvt(1:n) = y(1:n) - res(1:n) sdpvi = iwork(rsave) sdresi = iwork(qtr) vcvl = iwork(covmat) if (vcvl >= 1) go to 80 vcvl = iwork(s) if ( ierr == 0) then iskull(1) = 1 iskull(7) = 1 ierr = 7 end if 80 continue lvcvl = npare*(npare+1)/2 rdi = iwork(rd) ! ! repck is called to avoid modification of nls code. future ! revisions of nls code should include modifications necessary ! to eliminate need to repack d for arima code. ! call repck(d, nrests, npar, n) call amefin(y, weight, nnzw, wt, lwt, xm, n, m, ixm, ifixd, par, & npar, npare, res, page, wide, iptout, ndigit, rwork(rsshlf), & rsd, pvt, rwork(sdpvi), rwork(sdresi), rwork(rdi), & rwork(vcvl), lvcvl, d, nlhdr, ivcvpt, iskull, nrests) return end subroutine ameout ( y, n, ifixd, & par, npar, npare, res, iptout, ndigit, page, idf, cond, rss, & rsd, yss, exact, pvt, sdpvt, sdrest, vcvl, lvcvl, ivcvpt, & iskull, amehdr, wide ) !*****************************************************************************80 ! !! AMEOUT prints the final summary output from ARIMA estimation. ! ! Discussion: ! ! This routine prints the final summary output from the ! arima estimation subroutines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real cond ! the condition number of d. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical exact ! an indicator value used to designate whether the fit ! was exact to machine precision (true) or not (false). ! real fplm ! the floating point largest magnitude. ! external amehdr ! the routine used to print the heading ! integer i ! an index variable. ! integer iamhd ! the indicator value used to designate the type of list ! to be generated ! if iamhd=1, the list is for the initial summary of the ! estimation routines. ! if iamhd=2, the list is for the initial report of the ! forecasting routines. ! if iamhd=3, the list is for the final report of the ! estimation routines. ! integer idf ! the degrees of freedom in the fit. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer iskull(10) ! an error message indicator variable. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! integer lvcvl ! the dimension of vector vcvl. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! integer mspect ! the starting location in the work space for ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! integer nfact ! the number of factors in the model ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer npare ! the number of parameters to be optimized. ! integer nparma ! the length of the vector parma ! integer nrests ! the maximum number of residuals to be computed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! integer parar ! the starting location in the work array for ! the autoregressive parameters ! integer pardf ! the starting location in the work space for ! the vector containing the difference filter parameters ! integer parma ! the starting location in the work array for ! the moving average parameters ! real pvt(n) ! the predicted value based on the current parameter estimates. ! real res(n) ! the residuals from the fit. ! real rsd ! the residual standard deviation. ! real rss ! the residual sum of squares. ! real sdpvt(n) ! the standard deviations of the predicted values. ! real sdrest(n) ! the standardized residuals. ! integer t ! the starting location in the work array for ! a temporary work vector. ! integer temp ! the starting location in the work array for ! a temporary work vector ! real vcvl(lvcvl) ! the lower half of the variance-covariance matrix, stored ! row wise. ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real y(n) ! the dependent variable. ! real yss ! the sum of the squares about the mean y value. ! implicit none real & cond,rsd,rss,yss integer & idf,ivcvpt,lvcvl,n,ndigit,npar,npare logical & exact,page,wide ! ! array arguments real & par(*),pvt(*),res(*),sdpvt(*),sdrest(*),vcvl(*),y(*) integer & ifixd(*),iptout(*),iskull(10) ! ! subroutine arguments external amehdr ! ! scalars in common integer & ierr,iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, & nrests,parar,pardf,parma,t,temp ! ! arrays in common double precision dstak(3000) ! ! real & fplm integer iamhd,isubhd ! ! local arrays integer & istak(12) ! ! external subroutines external amept1,amept2,amlst,modsum,nlskl,vcvotf ! ! common blocks common /cstak/dstak common /errchk/ierr common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, & nparma,mbo,mbol,t,temp,nrests,iflag ! ! equivalences equivalence (dstak(1),istak(1)) fplm = huge ( fplm ) if ((ierr >= 1) .and. (ierr /= 4)) go to 60 ! ! Test for exact fit ! if ((idf <= 0) .or. exact) go to 70 ! ! Print error heading if necessary ! if (ierr == 4 ) then call nlskl(iskull, page, wide, amehdr) end if ! ! Print primary report ! if ( (ierr/=0) .or. (iptout(3)/=0)) then isubhd = 0 call amehdr(page, wide, isubhd) call amept1(n, y, pvt, sdpvt, res, sdrest, iptout, ndigit) end if ! ! print standardized residual plots ! if ( iptout(4) /= 0 ) then isubhd = 0 call amehdr(page, wide, isubhd) call amept2 (res, sdrest, n, rss) end if ! ! print the covariance and correlation matrix ! if ((ierr==0) .and. (iptout(5)==0)) return isubhd = 0 call amehdr(page, wide, isubhd) call modsum(nfact, istak(mspect)) if ( ierr /= 0 .or. 1 < iptout(5) ) then call vcvotf(npare, vcvl, lvcvl, .true., npar, ifixd, ivcvpt) end if ! ! print analysis summary ! write ( *,1000) iamhd = 3 call amlst(iamhd, par, npar, nfact, istak(mspect), n, vcvl, lvcvl, & par, npar, par, npar, ifixd, rss, rsd, npardf, npare, idf) write ( *,1050) cond if (rss > yss) write ( *,1060) return ! ! print out error heading ! 60 continue call nlskl(iskull, page, wide, amehdr) if (ierr <= 2) return ! ! print secondary report ! 70 continue isubhd = 0 call amehdr(page, wide, isubhd) call modsum(nfact, istak(mspect)) if (ierr /= 0) write ( *,1080) write ( *,1000) iamhd = 2 call amlst(iamhd, par, npar, nfact, istak(mspect), n, vcvl, lvcvl, & par, npar, par, npar, ifixd, rss, rsd, npardf, npare, idf) if (ierr /= 3) write ( *,1050) cond if ((ierr==0) .and. (.not.exact) .and. (idf <= 0)) then write ( *, 1070) end if if ((ierr==0) .and. exact) write ( *,1090) if (ierr == 0) then sdrest(1:n) = 0.0e0 sdpvt(1:n) = 0.0e0 return end if sdrest(1:n) = fplm sdpvt(1:n) = fplm ! ! print out error exit statistics ! call amept1(n, y, pvt, sdpvt, res, sdrest, iptout, ndigit) ! ! Wipe out sdrest vector ! sdrest(1:n) = fplm ! ! wipe out vcv matrix ! vcvl(1:lvcvl) = fplm return 1000 format (///' estimates from least squares fit'/1x, 33('-')) 1050 format (/' approximate condition number', 10x, g15.7) 1060 format (//' the residual sum of squares after the least squares', & ' fit is greater than'/' the sum of squares about the mean ', & 'y observation. the model is less'/' representative o', & 'f the data than a simple average. data and model shou', & 'ld'/' be checked to be sure that they are compatible.') 1070 format (/' the degrees of freedom for this problem is zero.', & ' statistical analysis of the results is not possible.') 1080 format (//' the following summary should be used to analyze', & ' the above mentioned problems.') 1090 format (/' the least squares fit of the data to the model is', & ' exact to within machine precision.'/' statistical analysi', & 's of the results is not possible.') end subroutine amept1 ( n, y, pvt, sdpvt, res, sdrest, iptout, ndigit ) !*****************************************************************************80 ! !! AMEPT1 prints data summary for nonlinear least squares routines. ! ! Discussion: ! ! This routine prints the data summary for the nonlinear ! least squares subroutines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index variable. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! integer nmax ! the maximum number of rows to be printed. ! real pvt(n) ! the predicted value based on the current parameter estimates. ! real res(n) ! the residuals from the fit. ! real sdpvt(n) ! the standard deviations of the predicted values. ! real sdrest(n) ! the standardized residuals. ! real y(n) ! the dependent variable. ! implicit none integer & n,ndigit ! ! array arguments real & pvt(*),res(*),sdpvt(*),sdrest(*),y(*) integer & iptout(*) ! ! scalars in common integer & ierr integer & i,nmax ! ! external subroutines external obssm2 ! ! common blocks common /errchk/ierr write ( *,1100) write ( *,1000) write ( *, 1110) nmax = n if ((max(iptout(3),1)==1) .and. (n >= 45)) & nmax = min(n,40) ! ! print observation summary ! call obssm2(n, y, pvt, sdpvt, res, sdrest, 1, nmax) if ( nmax < n ) then do i = 1, 3 write ( *, 1150) end do call obssm2(n, y, pvt, sdpvt, res, sdrest, n, n) end if if ((ierr==4)) write ( *, 1080) if ((ierr > 0) .and. (ierr /= 4)) write ( *, 1090) return 1000 format (/ 5x, 16x, ' -----predicted ----std dev of', 16x, & ' ---std'/ & 2x, 'row', ' --------series ---------value', & ' ----pred value ------residual ---res') 1080 format (// ' * nc - value not computed because', & ' the standard deviation of the residual is zero.') 1090 format (// ' * nc - value not computed', & ' because convergence problems prevented the covariance', & ' matrix from being computed.') 1100 format (//' results from least squares fit'/ 1x, 31('-')) 1110 format (' ') 1150 format (4x, '.', 4(15x, '.'), 7x, '.') end subroutine amept2 ( res, sdrest, n, rss ) !*****************************************************************************80 ! !! AMEPT2 prints four standardized residual plots. ! ! Discussion: ! ! This routine, adapted from omnitab ii, prints ! the four standardized residual plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real an ! the number of observations, used in computing ! the normal probability plot. ! real dot ! the dot product used to compute the correlation coefficient. ! real fac1, fac2 ! factors used in computing the normal probability plot. ! real fplm ! the floating point largest magnitude. ! real gamma ! a value used in computing the normal probability plot. ! integer i ! an index variable. ! character*1 iblank ! the value of the character -blank-. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer imid ! the midpoint of the autocorrelation plot. ! character*1 iminus ! the character minus. ! integer iplot ! an indicator variable designating whether the first or ! second set of two plots are being printed. ! character*1 iplus ! the character plus. ! integer iprb ! the location in the plot string of the symbol for the ! probability plot. ! integer irow ! the row of the variables being plotted. ! character*1 istar ! the character star. ! integer ix ! the location in the plot string of the symbol for the plots ! versus the independent variable. ! integer i1, i2 ! index values. ! integer k ! an index variable. ! integer l ! an index variable. ! character*1 line(113) ! the symbols (blanks and characters) for a given line ! of the plot. ! integer n ! the number of observations. ! integer ncol, ncolpl, ncolp1, ncolt2 ! the number of columns in the plot, ncol+l, ncol+1, ! and ncol * 2. ! integer ndot ! the number of points making up dot. ! integer nrow ! the number of columns in the plot. ! real pi ! the value of pi. ! real ratio ! a value used to produce the normal probability plot. ! real res(n) ! the residuals from the fit. ! real rowdiv ! the value of a division along the -row- axis. ! real rowmax ! the largest row value. ! real rowmid ! the midpoint of the range of the rows plotted. ! real rowmin ! the smallest row value plotted. ! real rss ! the residual sum of squares. ! real sdrest(n) ! the standardized residuals. ! real ylabel ! the label to be printed along the y axis. ! real ymax ! the largest value along the y axis ! real ymin ! the smallest value along the y axis. ! implicit none real & rss integer & n ! ! array arguments real & res(*),sdrest(*) ! ! scalars in common integer & ierr real & an,dot,fac1,fac2,fplm,gamm,pi,ratio,rowdiv,rowmax,rowmid, & rowmin,ylabel,ymax,ymin integer & i,i1,i2,imid,iplot,iprb,irow,ix,k,l,ncol,ncolp1, & ncolpl,ncolt2,ndot,nrow character & iblank*1,iminus*1,iplus*1,istar*1 ! ! local arrays character & line(113)*1 ! ! external functions logical & mvchk external mvchk ! ! external subroutines external dotc,getpi ! ! common blocks common /errchk/ierr data iplus/'+'/, iminus/'-'/, istar/'*'/, iblank/' '/ fplm = huge ( fplm ) ! ! check for insufficient points to plot ! if (ierr /= 4) go to 20 do i = 1, n if (sdrest(i) /= fplm) go to 20 end do write ( *, 1090) return 20 continue ! ! initialize values for probability plot ! call getpi(pi) gamm = pi/8.0e0 an = real ( n ) fac1 = 1.0e0 / (an - 2.0e0*gamm + 1.0e0) fac2 = 10.0e0 ! ! initialize the plot size (in plot units) ! nrow = 26 ! ! begin computations for first set of plots ! iplot = 1 ncol = 111 ! ! set x axis limits for standardized residual vs row plot, ! rowmin = 1.0 rowmax = real ( n ) rowmid = (rowmax+rowmin) / 2.0e0 rowdiv = (rowmax-rowmin) / real ( ncol - 1 ) ! ! print titles for first plots ! write ( *,1000) go to 90 ! ! begin computations for second set of plots ! 40 iplot = 2 ncol = 51 ! ! print titles for second plots ! write ( *,1050) ! ! write first line of plots ! 90 continue ! ! print plots, one line at a time ! ncolp1 = ncol + 1 ncolt2 = 2*ncol ylabel = 3.75e0 ymax = fplm ymin = 4.05e0 do k = 1, nrow ymin = ymin - 0.3e0 if (-3.70e0 >= ymin) ymin = -fplm do l=1,ncol ncolpl = l + ncol line(l) = iblank if (iplot==2) line(ncolpl) = iblank if ( k == 1 .or. k == nrow ) then line(l) = iminus if (iplot==2) line(ncolpl) = iminus if ( (mod(l,10) == 1) .or. (l == 1+ncol/2) ) then line(l) = iplus if (iplot==2) line(ncolpl) = iplus end if end if end do do i=1,n if (.not.mvchk(sdrest(i),fplm)) then if ((sdrest(i) > ymin) .and. (sdrest(i) <= ymax)) then if (iplot==1) then irow = int(((real ( i ) -rowmin)/rowdiv)+1.5e0) line(irow) = istar else ratio = (an-gamm) * fac1 iprb = int(4.91e0*(ratio**0.14e0- & (1.0e0-ratio)**0.14e0)*fac2) + 77 if (iprb <= ncol) iprb = ncol+1 if (iprb >= 103) iprb = 102 line(iprb) = istar an = an - 1.0e0 if ((an<2.0e0) .and. (n <= 10)) then gamm = 1.0e0/3.0e0 end if end if end if end if end do ! ! set plot line for correlation plot of second set of plots ! if (iplot==2) then imid = (ncol-1)/2 if (k <= n-1) then dot = 0.0e0 call dotc(res, 0.0e0, n, res(k+1), 0.0e0, & n-k, dot, ndot) ix = int(real ( imid ) *dot/rss) + imid + 1 i1 = min(ix,imid+1) i2 = max(ix,imid+1) line(i1:i2) = istar end if end if if (mod(k,5)==1) then if (iplot==1) then write ( *,2020) ylabel, (line(l),l=1,ncol) else write ( *,1020) k, (line(l),l=1,ncol), ylabel, & (line(l),l=ncolp1,ncolt2) end if ylabel = ylabel - 1.5e0 else if (iplot==1) then write ( *,2030) (line(l),l=1,111) else write ( *,1030) (line(l),l=1,102) end if end if ymax = ymin end do ! ! print bottom line of graphs ! if (iplot==1) then ! ! print x axis labels for first set of plots ! write ( *,1040) rowmin, rowmid, rowmax go to 40 ! ! print x axis labels for second set of plots ! else write ( *,1070) end if return 1000 format (/51x, ' std res vs row number' ) 1020 format (1x, i5, '+', 51a1, '+', 2x, f5.2, '+', 51a1, '+') 1030 format (6x, '-', 51a1, '-', 7x, '-', 51a1, '-') 1040 format (1x, f8.1, 47x, f8.1, 47x, f8.1) 1050 format (/13x, 'autocorrelation function of residuals', & 23x, ' normal probability plot of std res' ) 1070 format (4x, '-1.00', 22x, '0.0', 21x, '1.00', 5x, '-2.5', 23x, & '0.0', 22x, '2.5') 1090 format (// 1x, 13('*')/ 1x, 'h* warning *'/ 1x, 13('*')// & ' the standardized residual plots have been suppressed.', & ' none of the standardized residuals could be', & ' computed,'/ & ' because for each observation either the weight or', & ' the standard deviation of the residual is zero.') 2020 format (1x, f5.2, '+', 111a1, '+') 2030 format (6x, '-', 111a1, '-') end subroutine amestp ( xm, n, m, ixm, mdl, par, npar, stp, & exmpt, neta, scale, lscale, nprt, hdr, page, wide, isubhd, & hlfrpt, prtfxd, ifixed, lifixd, stpout, pvpad ) !*****************************************************************************80 ! !! AMESTP controls the step size selection. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer cd ! the starting location in the work area of ! the central difference quotient approximation to the ! derivative of the model with respect to the jth parameter. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real eta ! the relative noise in the model. ! real exm ! the proportion of observations actually used for which the ! computed numerical derivatives wrt a given parameter are ! exempted from meeting the derivative acceptance criteria. ! real exmpt ! the proportion of observations for which the computed ! numerical derivatives wrt a given parameter are exempted ! from meeting the derivative acceptance criteria. ! integer fd ! the starting location in the work area of ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter. ! integer fdlast ! the starting location in the work area of ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter ! for the last step size tried. ! integer fdsave ! the starting location in the work area of ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter ! for the best step size tried so far. ! real fplrs ! the floating point largest relative spacing. ! external hdr ! the name of the routine which produces the heading ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifailj ! the starting location in istak for ! the array of indicator variables designating whether ! the setp size selected was satisfacotry for a given ! observation and the jth parameter. ! integer ifixd ! the starting location in /cstak/ of vector ifixd containing ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer ifp ! an indicator for the precision of the stack allocation type, ! where ifp=3 indicates single and ifp=4 indicates double. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer itemp ! the starting location in istak for ! a temporary storage vector. ! integer ixm ! the first dimension of matrix xm. ! integer j ! an index variable. ! integer lifixd ! the dimension of vector ifixed. ! integer lscale ! the dimension of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer mxfail ! the maximum number of failures for any parameter. ! integer n ! the number of observations. ! integer nall0 ! number of stack allocations outstanding. ! integer ndd ! the number of decimal digits carried for a single ! precision real number. ! integer ndgt1 ! the number of reliable digits in the model used, either ! set to the user supplied value of neta, or computed ! by etamdl. ! integer neta ! the number of accurate digits in the model results. ! integer nexmpt ! the number of observations for which a given step size ! does not have to be satisfactory and the selected step ! size still be considered ok. ! integer nfail ! the number of observations for which the selected step size ! for the parameter does not meet the criteria. ! integer nfailj ! the number of observations for which the selected step size ! for the jth parameter does not meet the criteria. ! integer npar ! the number of parameters in the model. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! integer partmp ! the starting location in the work area of ! the modified model parameters ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! integer pv ! the starting location in the work area of ! the predicted value based on the current parameter estimates ! integer pvmcd ! the starting location in the work area of ! the predicted value based on the current parameter estimates ! integer pvnew ! the starting location in the work area of ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stpnew. ! integer pvpad ! additional workspace needed in pv for the evaluation of the ! model. ! integer pvpcd ! the starting location in the work area of ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stpcd. ! integer pvstp ! the starting location in the work area of ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stp(j). ! integer pvtemp ! the starting location in the work area of ! a tempory storage location for predicted values begins. ! real q ! a dummy variable which is used, along with common notopt (no ! optimization), to compute the step size. ! real rstak(12) ! the real version of the /cstak/ work area. ! real scale(lscale) ! the typical size of the parameters. ! real scl ! the actual typical size used. ! real stp(npar) ! the selected step sizes. ! external stpout ! the routine for printing the output. ! real tau ! the agreement tolerance. ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real xm(ixm,m) ! the independent variable. ! implicit none integer ixm integer lifixd real exmpt external hdr logical head integer isubhd integer lscale integer m integer n integer neta integer npar integer nprt integer pvpad logical & hlfrpt,page,prtfxd,wide ! ! array arguments real & par(*),scale(*),stp(*),xm(ixm,*) integer & ifixed(lifixd) ! ! subroutine arguments external mdl,stpout ! ! scalars in common real & q integer & ierr ! ! arrays in common double precision dstak(3000) real & eta,exm,fplrs,scl,tau integer & cd,fd,fdlast,fdsave,ifailj,ifixd,ifp,itemp,j,mxfail,nall0, & ndd,ndgt1,nexmpt,nfail,nfailj,partmp,pv,pvmcd,pvnew,pvpcd, & pvstp,pvtemp ! ! local arrays real & rstak(12) integer & istak(12) ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external etamdl,setiv,stkclr,stpmn ! ! common blocks common /cstak/dstak common /errchk/ierr common /notopt/ q ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) nall0 = stkst(1) fplrs = epsilon ( fplrs ) ifp = 3 ! ! set print controls ! head = .true. ! ! subdivide work area ! ifixd = stkget(npar, 2) itemp = stkget(n, 2) ifailj = stkget(n, 2) nfail = stkget(npar, 2) cd = stkget(n, ifp) fd = stkget(n, ifp) fdlast = stkget(n, ifp) fdsave = stkget(n, ifp) pv = stkget(n+pvpad, ifp) pvmcd = stkget(n+pvpad, ifp) pvnew = stkget(n+pvpad, ifp) pvpcd = stkget(n+pvpad, ifp) pvstp = stkget(n+pvpad, ifp) pvtemp = stkget(n+pvpad, ifp) if ( ierr == 1 ) then return end if partmp = cd ! ! set up ifixd ! if ( ifixed(1)<0 ) then call setiv(istak(ifixd), npar, 0) else call cpyvii(npar, ifixed, 1, istak(ifixd), 1) end if ! ! Set parameters necessary for the computations ! ndd = int(-log10(fplrs)) if ((neta >= 2) .and. (neta <= ndd)) then eta = 10.0e0 ** (-neta) ndgt1 = neta else call etamdl(mdl, par, npar, xm, n, m, ixm, eta, ndgt1, & rstak(partmp), rstak(pvtemp), 0) end if tau = min ( eta**0.25e0, 0.01e0 ) exm = exmpt if ((exm<0.0e0) .or. (exm > 1.0e0)) then exm = 0.10e0 end if nexmpt = int ( exm * real ( n ) ) if (exm /= 0.0e0) then nexmpt = max(nexmpt, 1) end if ! ! Compute predicted values of the model using the input parameter ! estimates ! call mdl ( par, npar, xm, n, m, ixm, rstak(pv) ) mxfail = 0 nfailj = nfail do j = 1, npar if ( scale(1) <= 0.0e0 ) then if ( par(j) == 0.0e0 ) then scl = 1.0e0 else scl = abs ( par(j) ) end if else scl = scale(j) end if ! ! Select step size. ! call stpmn ( j, xm, n, m, ixm, mdl, par, npar, nexmpt, & eta, tau, scl, stp(j), istak(nfailj), istak(ifailj), & rstak(cd), istak(itemp), rstak(fd), rstak(fdlast), & rstak(fdsave), rstak(pv), rstak(pvmcd), rstak(pvnew), & rstak(pvpcd), rstak(pvstp), rstak(pvtemp) ) ! ! Compute the maximum number of failures for any parameter. ! mxfail = max ( istak(nfailj), mxfail ) ! ! Print results if they are desired. ! if ( nprt /= 0 .or. mxfail > nexmpt ) then call stpout ( head, n, exm, nexmpt, ndgt1, j, par, npar, & stp, istak(nfail), istak(ifailj), scale, lscale, hdr, & page, wide, isubhd, nprt, prtfxd, istak(ifixd) ) end if nfailj = nfailj + 1 end do hlfrpt = .false. if ( nprt /= 0 .or. mxfail > nexmpt ) then hlfrpt = .true. end if if ( mxfail > nexmpt ) then ierr = 2 end if call stkclr ( nall0 ) return end subroutine amfcnt ( y, n, mspec, nfac, par, npar, ldstak, & nfcst, nfcsto, ifcsto, nprt, fcst, ifcst, fcstsd, nmsub, save ) !*****************************************************************************80 ! !! AMFCNT is the control routine for ARIMA forecasting. ! ! Discussion: ! ! This is the controlling subroutine for forecasting using arima models. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer f ! the starting location in the work vector for ! the forecasts. ! real fcst(ifcst,nfcsto) ! the storage array for the forecasts. ! real fcstsd(nfcst) ! the storage array for the standard deviations of the forecasts. ! integer fsd ! the starting location in the work vector for ! the standard deviations of the forecasts. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifcst ! the first dimension of the array fcst. ! integer ifcsto(nfcsto) ! the indices of the origins for the forecasts. ! integer ifp ! an indicator for the precision of the stack allocation type, ! where ifp=3 indicates single and ifp=4 indicates double. ! integer is ! a value used to determine the amount of work space needed ! based on whether step sizes are input or are to be calculated. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer mspect ! the starting location in the work space for ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nall0 ! number of stack allocations outstanding. ! integer nfac ! the number of factors in the model ! integer nfact ! the number of factors in the model ! integer nfcst ! the number of forecasts. ! integer nfcsto ! the number of the origins. ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer nparma ! the length of the vector parma ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! integer parar ! the starting location in the work array for ! the autoregressive parameters ! integer pardf ! the starting location in the work space for ! the vector containing the difference filter parameters ! integer parma ! the starting location in the work array for ! the moving average parameters ! integer pv ! the starting location in the work array for ! the predicted values ! integer nrests ! the maximum number of residuals to be computed. ! real rstak(12) ! the real version of the /cstak/ work area. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! integer t ! the starting location in the work array for ! a temporary work vector. ! integer temp ! the starting location in the work array for ! a temporary work vector ! real y(n) ! the dependent variable. ! implicit none integer & ifcst,ldstak,n,nfac,nfcst,nfcsto,npar,nprt logical & save ! ! array arguments real & fcst(*),fcstsd(*),par(*),y(*) integer & ifcsto(*),mspec(4,*) character & nmsub(6)*1 ! ! scalars in common integer & ierr,iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, & nrests,parar,pardf,parma,t,temp ! ! arrays in common double precision dstak(3000) integer & f,fsd,ifp,ldsmin,nall0,pv ! ! local arrays real & rstak(12) integer & istak(12) ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external amfer,amfmn,backop,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, & nparma,mbo,mbol,t,temp,nrests,iflag ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) ! ! compute back operators ! call backop(mspec, nfac, npardf, mbol, mbo, nparma, nparar) ierr = 0 call ldscmp(8, 0, 4*nfac, & 0, 0, 0, 's', 5*mbo + 2*nfcst + n + mbo + 101, ldsmin) call amfer(nmsub, n, npar, ldstak, ldsmin, save, mspec, nfac, & ifcst, nfcst) if (ierr==0) then call stkset(ldstak, 4) ! ! subdivide workspace for step sizes ! nall0 = stkst(1) ifp = 3 pardf = stkget(mbo, ifp) parar = stkget(mbo, ifp) parma = stkget(mbo, ifp) t = stkget(2*mbo, ifp) temp = t + mbo nfact = nfac mspect = stkget(4*nfac, 2) f = stkget(nfcst, ifp) fsd = stkget(nfcst, ifp) ! ! set up for model ! nrests = mbo + 101 + n pv = stkget(nrests, ifp) call cpyvii(nfac, mspec(1,1), 4, istak(mspect), 1) call cpyvii(nfac, mspec(2,1), 4, istak(mspect+nfac), 1) call cpyvii(nfac, mspec(3,1), 4, istak(mspect+2*nfac), 1) call cpyvii(nfac, mspec(4,1), 4, istak(mspect+3*nfac), 1) ! ! call main routine for computing and printing forecasts ! call amfmn ( par, rstak(pv), y, npar, n, nfac, istak(mspect), & rstak(pardf), npardf, rstak(t), rstak(temp), rstak(parar), & rstak(parma), mbo, mbol, n-nrests+1, n, nprt, save, & nfcst, nfcsto, ifcsto, fcst, ifcst, fcstsd, rstak(f), & rstak(fsd), nparar, nparma ) end if call stkclr(nall0) return end subroutine amfer ( nmsub, n, npar, ldstak, ldsmin, & save, mspec, nfac, ifcst, nfcst ) !*****************************************************************************80 ! !! AMFER checks errors for nonlinear least squares estimation. ! ! Discussion: ! ! This is the error checking routine for nonlinear least squares ! estimation routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error(20) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! the variable used to indicate whether a heading is to be ! printed during a given call to the iteration report (true) ! or not (false). ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 lifcst(8), llds(8), lmspec(8), ln(8), lnfac(8), ! * lnpar(8), lnfcst(8), lone(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! integer nfcst ! the number of forecasts. ! character*1 nmsub(6) ! the name of the routine calling the error checking routine ! integer npar ! the number of parameters in the model. ! integer nv ! * ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! implicit none integer & ifcst,ldsmin,ldstak,n,nfac,nfcst,npar logical & save ! ! array arguments integer & mspec(4,*) character & nmsub(6)*1 ! ! scalars in common integer & ierr integer & i,np,nv logical & head ! ! local arrays logical & error(20) character & lifcst(8)*1,llds(8)*1,lmspec(8)*1,ln(8)*1,lnfac(8)*1, & lnfcst(8)*1,lnpar(8)*1,lone(8)*1 ! ! external subroutines external eiage,eiseq,eisge ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data lifcst(1), lifcst(2), lifcst(3), lifcst(4), lifcst(5), & lifcst(6), lifcst(7), lifcst(8) & /'i','f','c','s','t',' ',' ',' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data lmspec(1), lmspec(2), lmspec(3), lmspec(4), lmspec(5), & lmspec(6), lmspec(7), lmspec(8) & /'m','s','p','c',' ',' ',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lnfac(1), lnfac(2), lnfac(3), lnfac(4), lnfac(5), & lnfac(6), lnfac(7), lnfac(8) /'n','f','a','c',' ',' ',' ',' '/ data lnfcst(1), lnfcst(2), lnfcst(3), lnfcst(4), lnfcst(5), & lnfcst(6), lnfcst(7), lnfcst(8) & /'n','f','c','s','t',' ',' ',' '/ data lnpar(1), lnpar(2), lnpar(3), lnpar(4), lnpar(5), & lnpar(6), lnpar(7), lnpar(8) /'n','p','a','r',' ',' ',' ', & ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), & lone(6), lone(7), lone(8) /'1',' ',' ',' ',' ',' ',' ',' '/ ! error(1:20) = .false. ierr = 0 head = .true. call eisge(nmsub, ln, n, 1, 2, head, error(1), lone) call eisge(nmsub, lnfac, nfac, 1, 2, head, error(2), lone) if (.not. error(2)) & call eiage(nmsub, lmspec, mspec, 4, nfac, 4, 0, 0, head, 1, nv, & error(3), lmspec) if ((.not. error(2)) .and. (.not. error(3))) then np = 1 do i = 1, nfac np = np + mspec(1,i) + mspec(3,i) end do call eiseq(nmsub, lnpar, npar, np, 1, head, error(4), lnpar) end if if ((.not.error(1)) .and. (.not.error(2)) .and. (.not.error(3)) & .and. (.not.error(4)) .and. (.not.error(5))) & call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(6), & llds) if (save) & call eisge(nmsub, lifcst, ifcst, nfcst, 3, head, error(15), & lnfcst) do i=1,20 if (error(i)) then ierr = 1 return end if end do return end subroutine amfhdr ( page, wide, isubhd ) !*****************************************************************************80 ! !! AMFHDR prints headers for nonlinear least squares estimation. ! ! Discussion: ! ! This routine prints the page headings for the nonlinear ! least squares estimation routines for arima models that use ! numerical approximations to the derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! implicit none integer & isubhd logical & page,wide if (page) write ( *, 1020) call versp(wide) if (page) write ( *,1000) if (.not.page) write ( *,1010) page = .true. if (isubhd==0) return write ( *, 1030) return 1000 format ('+arima forecasting, continued') 1010 format ('+', 23('*')/ ' * arima forecasting *', /1x, 23('*')) 1020 format ('1') 1030 format (//' model summary'/' -------------') end subroutine amfmn ( par, pv, y, npar, n, nfac, mspect, & pardf, npardf, t, temp, parar, parma, mbo, mbol, n1, n2, nprt, & save, nfcst, nfcsto, ifcsto, fcst, ifcst, fcstsd, f, & fsd, nparar, nparma ) !*****************************************************************************80 ! !! AMFMN computes and prints ARIMA forecasts. ! ! Discussion: ! ! This is the main routine for computing and printing the arima forecasts ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real const ! the constant term in the model, modeling either the series ! mean or a deterministic trend. ! real f(nfcst) ! the forecasts. ! real fcst(ifcst,nfcsto) ! the storage array for the forecasts. ! real fcstsd(nfcst) ! the storage array for the standard deviations of the forecasts. ! real fsd(nfcst) ! the standard deviations of the forecasts. ! integer i ! an index variable. ! integer if ! an index variable. ! integer ifcst ! the first dimension of the array fcst. ! integer ifcsto(nfcsto) ! the indices of the origins for the forecasts. ! integer iflag ! an indicator variable designating whether the back forecasts ! were essentially zero (iflag=0) or not (iflag=1). ! integer ifo ! the index of the origin being used. ! integer ifomin ! the smallest origin used. ! integer i1 ! an index value. ! integer j ! an index variable. ! integer k ! an index variable. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! integer mspect(nfac,4) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! integer nfcst ! the number of forecasts. ! integer nfcsto ! the number of the origins. ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer nparma ! the length of the vector parma ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! integer nt ! the number of parameters in t, where nt = mbol ! integer n1 ! the lower bound for pv. ! integer n2 ! the upper bound for pv. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! real parar(mbo) ! the autoregressive parameters ! real pardf(npardf) ! the vector containing the difference filter parameters. ! real parma(mbo) ! the moving average parameters ! real pmu ! the value of mu, i.e., the trend or mean. ! real pv(n1:n2) ! the predicted value of the fit. ! real rsd ! the residual standard deviation. ! real rss ! the residual sum of squares. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real t(2*mbo) ! a temporary work vector. ! real temp(mbo) ! a temporary work vector ! real t975 ! the value of the 97.5 percent point function for the ! t distribution. ! real wsum ! the sum of the weights squared, used to compute the ! standard deviation of the forecast. ! real wsumt ! a temporary storage location for wsum. ! real y(n) ! the dependent variable. ! implicit none integer npar integer ifcst integer ifixd(npar) integer mbo,mbol,n,n1,n2,nfac,nfcst,nfcsto,nparar, & npardf,nparma,nprt logical & save ! ! array arguments real & f(*),fcst(ifcst,*),fcstsd(*),fsd(*),par(*),parar(*),pardf(*), & parma(*),pv(n1:n2),t(*),temp(*),y(*) integer & ifcsto(*),mspect(nfac,4) real & const,pmu,rsd,rss,t975,wsum,wsumt integer & i,i1,idf,if,ifc,iflag,ifo,ifomin,j,k,nt logical & page ! ! external functions real & ppft,sdot external ppft,sdot ! ! external subroutines external amfhdr,amfout,amlst,dcoef,mdlts2,modsum,multbp ! ! Set IFIXD to zero. ! I simply inserted this variable here; it wasn't in the original, ! but AMLST seems to expect it. ! JVB, 24 April 2007. ! ifixd(1:npar) = 0 ! ! Compute differencing parameters ! call dcoef (nfac, mspect(1,2), mspect(1,4), npardf, pardf, mbo, t) ! ! compute residuals, given values of parameters ! call mdlts2 (par, pv, y, npar, n, nfac, mspect, pmu, & pardf, npardf, t, temp, parar, parma, mbo, n1, n2, iflag) idf = n - npardf - npar rss = sdot(n, pv(1), 1, pv(1), 1) rsd = sqrt(rss / real ( idf ) ) ! ! print initial summary ! page = .false. if ( nprt /= 0 ) then call amfhdr ( page, .true., 2 ) call modsum ( nfac, mspect ) call amlst ( 2, par, npar, nfac, mspect, n, par, npar, par, & npar, par, npar, ifixd, rss, rsd, npardf, npar, idf ) page = .true. end if ! ! combine pardf and parar into t ! nt = nparar + npardf call multbp(parar, nparar, pardf, npardf, t, nt, mbo) ! ! compute constant ! const = 0.0e0 if (pmu /= 0.0e0) then if (nparar >= 1) then do j = 1, nparar const = const - parar(j) end do end if const = (1.0e0 + const) * pmu end if ! ! find lowest origin ! ifomin = minval ( ifcsto(1:nfcsto) ) ! ! set temp to backforecast of y if necessary ! if ((mbol >= 1) .and. (ifomin= 1) then temp(k) = temp(k) + t(j)*y(i+j) else temp(k) = temp(k) + t(j)*temp(mbol-i-j) end if end if end do if (nparma >= 1) then do j =1, nparma if (i+j <= n) temp(k) = temp(k) - parma(j)*pv(i+j) end do end if end do end if ! ! compute weights for computing standard deviations of the forecast ! do j = 1, nfcst fsd(j) = 0.0e0 if (mbol >= 1) then do i = 1, mbol if (j-i >= 1) then fsd(j) = fsd(j) + t(i)*fsd(j-i) else if (j-i==0) fsd(j) = fsd(j) + t(i) end if end do end if if (j <= nparma) fsd(j) = fsd(j) - parma(j) end do ! ! compute standard deviations of forecasts. ! wsum = 1.0e0 do i = 1, nfcst wsumt =wsum wsum = wsum + fsd(i)*fsd(i) fsd(i) = sqrt(wsumt)*rsd end do ! ! set percent point value for 95 percent confidence limits. ! t975 = ppft(0.975e0, n-npar) ! ! compute forecasts for each origin. ! do ifo = 1, nfcsto ifc = ifcsto(ifo) if ((ifc<1) .or. (ifc > n)) ifc = n do if = 1, nfcst f(if) = const if (mbol >= 1) then do j = 1, mbol k = if + ifc-j if (k <= 0) then f(if) = f(if) + t(j)*temp(1-k) else if (k <= ifc) then f(if) = f(if) + t(j)*y(k) else f(if) = f(if) + t(j)*f(if-j) end if end if end do end if do j = 1, nparma k = if + ifc - j if (k <= ifc) f(if) = f(if) - parma(j)*pv(k) end do if (save) fcst(if,ifo) = f(if) end do ! ! Print results from this origin. ! if (nprt /= 0) then call amfout(f, fsd, n, nfcst, ifcsto, ifo, nfcsto, y, t975, & page) end if end do return end subroutine amfout ( f, fsd, n, nfcst, ifcsto, ifo, nfcsto, y, t975, page ) !*****************************************************************************80 ! !! AMFOUT produces ARIMA forecasting output. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real f(nfcst) ! the forecasts. ! real fl ! the lower 95 percent confidence limit for the forecast ! real fsd(nfcst) ! the standard deviations of the forecasts. ! real fu ! the upper 95 percent confidence limit for the forecast ! integer i ! an index variable. ! integer iend ! the last location in the plot string. ! integer if ! an index variable. ! integer ifcsto(nfcsto) ! the indices of the origins for the forecasts. ! integer ifo ! the index of the origin being used. ! integer ilim ! the number of locations in ylim. ! integer inter ! the number of plot intervals. ! integer ipf ! the location in the plot string of the forecast. ! integer ipfl ! the location in the plot string of the forecast lower ! confidence limit. ! integer ipfu ! the location in the plot string of the forecast upper ! confidence limit. ! integer ipy ! the location in the plot string of the observed value. ! integer iy ! an index variable. ! integer j ! an index variable. ! character*1 line(53) ! the array of symbols to be plotted. ! integer n ! the number of observations. ! integer nfcst ! the number of forecasts. ! integer nfcsto ! the number of the origins. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real scale ! the plot scale. ! real t975 ! the value of the 97.5 percent point function for the ! t distribution. ! real y(n) ! the dependent variable. ! real ylim(4) ! the values of the axis labels. ! real ymn ! the minimum value to be plotted. ! real ymx ! the maximum value to be plotted. ! implicit none logical page real t975 integer & ifo,n,nfcst,nfcsto ! ! array arguments real & f(nfcst),fsd(*),y(*) integer & ifcsto(nfcsto) ! ! real & fl,fu,scale,ymn,ymx integer & i,iend,if,ilim,inter,ipf,ipfl,ipfu,ipy,iy,j ! ! local arrays real & ylim(4) character & line(53)*1 ! ! external subroutines external amfhdr ! ! set variables for plots ! inter = 50 iend = inter + 1 ilim = 4 ! ! Compute scale for plot. ! ymn = f(nfcst)-t975*fsd(nfcst) ymx = f(nfcst)+t975*fsd(nfcst) iy = ifcsto(ifo) do i = 1, nfcst ymn = min(ymn, f(i)-t975*fsd(i)) ymx = max(ymx, f(i)+t975*fsd(i)) if ((iy >= 1) .and. (iy <= n)) then ymn = min(ymn, y(iy)) ymx = max(ymx, y(iy)) iy = iy + 1 end if end do if (ifcsto(ifo) >= 2) then do iy = max(ifcsto(ifo)-4, 1), ifcsto(ifo)-1 ymn = min(ymn, y(iy)) ymx = max(ymx, y(iy)) end do end if scale = (ymx-ymn) / real ( inter ) ! ! print plot headings ! do i = 1, ilim ylim(i) = ymn + scale * real ( i ) * 10.0e0 end do call amfhdr(page, .true., 0) write ( *, 1030) ifo write ( *, 1000) ymn, ylim(2), ylim(4), & ylim(1), ylim(4), ymx ! ! begin plotting ! do i=max(ifcsto(ifo)-4,1), ifcsto(ifo)+nfcst if (i /= ifcsto(ifo)) then line(1:iend) = ' ' else line(1:iend) = '.' end if if (i <= ifcsto(ifo)) then ipy = int(((y(i)-ymn) / scale) + 1.5e0) line(ipy) = '*' write ( *, 1020) i, (line(j),j=1,iend), i, y(i) else if = i-ifcsto(ifo) fl = f(if) - t975*fsd(if) fu = f(if) + t975*fsd(if) if (i <= n) then ipfl = int(((fl-ymn) / scale) + 1.5e0) ipfu = int(((fu-ymn) / scale) + 1.5e0) line(ipfl:ipfu) = '-' line(ipfl) = '(' line(ipfu) = ')' ipy = int(((y(i)-ymn) / scale) + 1.5e0) line(ipy) = '*' ipf = int(((f(if)-ymn) / scale) + 1.5e0) if (ipf /= ipy) then line(ipf) = 'x' else line(ipf) = '2' end if write ( *, 1010) i, (line(j),j=1,iend), i, & f(if), fl, fu, y(i) else ipfl = int(((fl-ymn) / scale) + 1.5e0) ipfu = int(((fu-ymn) / scale) + 1.5e0) line(ipfl:ipfu) = '-' line(ipfl) = '(' line(ipfu) = ')' ipf = int(((f(if)-ymn) / scale) + 1.5e0) line(ipf) = 'x' write ( *, 1010) i, (line(j),j=1,iend), i, & f(if), fl, fu end if end if end do return 1000 format (// & 82x, ' --------------------95 percent'/ & 1x, 3(g15.8, 5x), 21x, & ' --------------confidence limits', & ' ---------actual'/ & 11x, 2(g15.8, 5x), g15.8, & ' ------forecasts ----------lower', & ' ----------upper -------if known'/ & 9x, 5('i---------'), 'i', 6x, & ' ------------[x] ------------[(]', & ' ------------[)] ------------[*]') 1010 format (2x, i5, 1x, 'i', 51a1, 'i', i5, 4(1x, g15.8)) 1020 format (2x, i5, 1x, 'i', 51a1, 'i', i5, 49x, g15.8) 1030 format (//' forecasts for origin ', i2) end subroutine amlst1 ( iamhd, par, npar, mspect, nfac, vcvl, lvcvl, & scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd ) !*****************************************************************************80 ! !! AMLST1 prints parameters for the ARIMA routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! character*1 fixed(3) ! the characters used to label the parameters fixed or not. ! real fplm ! the floating point largest magnitude. ! integer iamhd ! the indicator value used to designate the type of list ! to be generated ! if iamhd=1, the list is for the initial summary of the ! estimation routines. ! if iamhd=2, the list is for the initial report of the ! forecasting routines. ! if iamhd=3, the list is for the final report of the ! estimation routines. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer iparmn ! the smallest parameter index included in this term. ! integer iparmx ! the largest parameter index included in this term. ! integer lvcvl ! the dimension of vector vcvl. ! integer j ! an index variable. ! integer l ! an index variable. ! integer lbltyp ! the type of lable to be printed, where ! 1 indicates the term is autoregressive and ! 2 indicates the term is moving average ! integer ll ! an index variable. ! integer lpar ! an index variable. ! integer lscale ! the dimension of vector scale. ! integer lstpt ! the dimension of vector stpt. ! integer mspect(nfac,4) ! the array containing the values of p, d, q, and s for each fact ! integer nfac ! the number of factors in the model ! integer npar ! the number of parameters in the model. ! integer order ! the order of b for the parameter being printed ! real par(npar) ! the current estimates of the parameters. ! real pll ! the lower confidence limit for a given parameter. ! real pul ! the upper confidence limit for a given parameter. ! real ratio ! the ratio of a given parameter value to its standard error. ! real scale(lscale) ! the typical size of the parameters. ! real sdpar ! the standard deviation of a given parameter value. ! real stpt(lstpt) ! the step size array. ! real t975 ! the value of the 97.5 percent point function for the ! t distribution. ! real vcvl(lvcvl) ! the lower half of the variance-covariance matrix, stored ! row wise. ! implicit none real & t975 integer & iamhd,iparmn,iparmx,lbltyp,lscale,lstpt,lvcvl,nfac,npar ! ! array arguments real & par(npar),scale(lscale),stpt(lstpt),vcvl(lvcvl) integer & ifixd(*),mspect(nfac,4) ! ! real & fplm,pll,pul,ratio,sdpar integer & j,k,l,ll,lpar,order ! ! local arrays character & fixed(3)*1 fplm = huge ( fplm ) ! ! print next set of terms ! lpar = 0 do j=1,iparmx if ( ifixd(j) == 0 ) then lpar = lpar + 1 end if end do do j=1,nfac if ((mspect(j,lbltyp)==0) .and. (lbltyp /= 2)) then cycle end if if (lbltyp /= 2) iparmx = iparmx + mspect(j,lbltyp) if (lbltyp==2) iparmx = iparmx + 1 order = 0 do l = iparmn, iparmx order = order + mspect(j,4) if ( iamhd == 2 ) then if (lbltyp==1) then write ( *, 1010) l, j, order, par(l) else if (lbltyp==2) then write ( *, 1014) l, par(l) else if (lbltyp==3) then write ( *, 1015) l, j, order, par(l) end if else call fixprt(ifixd(l), fixed) if (lbltyp==1) then write ( *, 1000) l, j, order, (fixed(k),k=1,3), par(l) else if (lbltyp==2) then write ( *, 1004) l, (fixed(k),k=1,3), par(l) else if (lbltyp==3) then write ( *, 1005) l, j, order, (fixed(k),k=1,3), par(l) end if if (iamhd/=3) then if (ifixd(l)/=0) then write ( *, 1007) else if (scale(1) <= 0.0e0 ) then write ( *, 1001) stpt(l) else write ( *, 1002) scale(l), stpt(l) end if end if end if if ( iamhd /= 1 ) then if ( ifixd(l) == 0 ) then lpar = lpar + 1 ratio = fplm ll = lpar*(lpar-1)/2 + lpar if (vcvl(ll) > 0.0e0) ratio = par(l)/sqrt(vcvl(ll)) sdpar = sqrt(vcvl(ll)) pll = par(l) - t975*sdpar pul = par(l) + t975*sdpar write ( *, 1003) sdpar, ratio, pll, pul else write ( *, 1006) end if end if end if end do iparmn = iparmx + 1 end do return 1000 format(1x, i5, 2x, 'ar (factor', i2, ')',4x,i5,6x,3a1,e17.8) 1001 format ('+', 65x, 'default', e17.8) 1002 format ('+', 55x, 2e17.8) 1003 format ('+', 55x, 4(2x, e15.8)) 1004 format(1x, i5, 13x, 'mu', 4x, ' ---' ,6x,3a1,e17.8) 1005 format(1x, i5, 2x, 'ma (factor', i2, ')',4x,i5,6x,3a1,e17.8) 1006 format('+', 55x, 4(14x, '---')) 1007 format('+', 69x, '---', 14x, '---') 1010 format(1x, i5, 2x, 'ar (factor', i2, ')',4x,i5,e17.8) 1014 format(1x, i5, 13x, 'mu', 4x, ' ---' ,e17.8) 1015 format(1x, i5, 2x, 'ma (factor', i2, ')',4x,i5,e17.8) end subroutine amlst ( iamhd, par, npar, nfac, mspect, n, vcvl, & lvcvl, scale, lscale, stpt, lstpt, ifixd, rss, rsd, npardf, & npare, idf ) !*****************************************************************************80 ! !! AMLST prints parameter summaries from ARIMA forecasting. ! ! Discussion: ! ! This routine prints the parameter summary output from the ! ARIMA forecasting subroutines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer iamhd ! the indicator value used to designate the type of list ! to be generated ! if iamhd=1, the list is for the initial summary of the ! estimation routines. ! if iamhd=2, the list is for the initial report of the ! forecasting routines. ! if iamhd=3, the list is for the final report of the ! estimation routines. ! integer idf ! the degrees of freedom in the fit. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i)==0, then par(i) will be optimized. ! integer iparmn ! the smallest parameter index included in this term. ! integer iparmx ! the largest parameter index included in this term. ! integer lscale ! the dimension of vector scale. ! integer lstpt ! the dimension of vector stpt. ! integer lvcvl ! the dimension of vector vcvl. ! integer mspect(nfac,4) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer npardf ! the order of the expanded difference filter. ! integer nfac ! the number of factors in the model ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! real par(npar) ! the current estimates of the parameters. ! real rsd ! the residual standard deviation. ! real rss ! the residual sum of squares. ! real scale(lscale) ! the typical size of the parameters. ! real stpt(lstpt) ! the step size array. ! real t975 ! the value of the 97.5 percent point function for the ! t distribution. ! real vcvl(lvcvl) ! the lower half of the variance-covariance matrix, stored ! row wise. ! implicit none real & rsd,rss integer & iamhd,idf,lscale,lstpt,lvcvl,n,nfac,npar,npardf,npare ! ! array arguments real & par(*),scale(*),stpt(*),vcvl(*) integer & ifixd(*),mspect(nfac,4) real t975 integer & iparmn,iparmx,lbltyp ! ! external functions real & ppft external ppft ! ! print heading for information about parameters ! write ( *, 1001) if (iamhd == 1) then write ( *, 1004) else if (iamhd == 2) then write ( *, 1005) else if (iamhd == 3) then write ( *, 1006) end if write ( *, 1001) ! ! print model summary information ! iparmn = 1 iparmx = 0 t975 = ppft(0.95e0, n-npar) ! ! print autoregressive terms ! lbltyp = 1 call amlst1 (iamhd, par, npar, mspect, nfac, vcvl, lvcvl, & scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd ) ! ! print mean or trend term ! lbltyp = 2 call amlst1 (iamhd, par, npar, mspect, 1, vcvl, lvcvl, & scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd ) ! ! print moving average terms ! lbltyp = 3 call amlst1 (iamhd, par, npar, mspect, nfac, vcvl, lvcvl, & scale, lscale, stpt, lstpt, iparmn, iparmx, lbltyp, t975, ifixd ) write ( *, 1160) n if ( 2 <= iamhd ) then write ( *, 1040) rss, rsd, n, npardf, npare, idf end if return 1001 format(1x) 1004 format (//73x, ' --step size for'/ & 39x, ' ------parameter', 17x, ' --approximating'/ & ' -----------------parameter description starting values', & ' ----------scale -----derivative'/ & ' index ---------type --order --fixed ----------(par)', & ' --------(scale) ----------(stp)') 1005 format(30x, ' ------parameter'/ & ' --------parameter description ------estimates'/ & ' index ---------type --order ----------(par)') 1006 format( & 39x, ' ------parameter -----std dev of', 17x, & ' ---------------------approximate'/ & ' -----------------parameter description ------estimates', & ' ------parameter ----------ratio', & ' ----95 percent confidence limits'/ & ' index ---------type --order --fixed ----------(par)', & ' ------estimates', & ' par/(sd of par) ----------lower ----------upper') 1040 format (//' residual sum of squares ', 8x, g15.7, & ' (backforecasts included)'//' resid', & 'ual standard deviation ', 8x, g15.7/' based on degrees o', & 'f freedom', 1x, i4, ' - ', i3, ' - ', i3, ' = ', i4) 1160 format (//' number of observations', 48x, '(n)', 1x, i5) end subroutine aos ( n, lagmax, acov, prho, iar, ospvar, phi, work, & aic, ftest, lacov, laic ) !*****************************************************************************80 ! !! AOS computes autoregressive model order selection statistics. ! ! Discussion: ! ! This routine computes autoregressive model order selection ! statistics. It performs stepwise fitting of autoregressive ! coefficients by Durbin's method using Akaike's AIC criterion ! for selecting order. The routine is modeled after ! subroutine UFPE written by Dick Jones. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov), acov0 ! the autocovariances for lags zero to lagmax, and the ! autocovariance at lag zero. ! real aic(laic), aicmin ! the array contaning akiakes criteria for each order, where ! aic(i+1) is the criteria for order i-1, and the minimum ! criteria computed. ! real fplm ! the floating point largest magnitude. ! real ftest(2, lagmax) ! the array in which the f percentage point and probability are ! stored. ! integer i ! an index variable. ! integer iar ! the order of the autoregressive process chosen. ! integer j ! an index variable. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the vector aic. ! integer n ! the integer number of observations in each series ! real ospvar ! the one step prediction variance for the order selected (iar). ! real phi(lagmax) ! the array of autoregressive coefficients for the ! selected order. ! real prho(lagmax) ! the array containing the partial autocorrelation ! coefficients. ! real rss, rssmin ! the one step prediction residual sum of squares and the ! minimum one step prediction residual sum of squares. ! real sqpacf ! the squared value of the partial autocorrelation function at ! lag i. ! real work(lagmax) ! a real work area. ! implicit none integer lacov integer lagmax integer laic real acov(lacov) real acov0 real aic(laic) real aicmin external arcoef real, external :: cdff real fplm real ftest(2,lagmax) integer i integer iar integer n real ospvar real phi(lagmax) real prho(lagmax) real rss real rssmin real sqpacf real work(lagmax) fplm = huge ( fplm ) rss = acov(1) * real ( n ) rssmin = rss aic(1) = real ( n ) * log ( rss * real ( n + 1 ) / real ( n - 1 ) ) aicmin = aic(1) iar = 0 ! ! Start stepwise procedure. ! work(1) = acov(2) / acov(1) prho(1) = work(1) rss = rss * (1.0e0 - work(1)*work(1)) aic(2) = real ( n ) * log(rss * real (n+2) / real (n-2)) sqpacf = work(1) * work(1) ftest(1, 1) = fplm ftest(2, 1) = 0.0e0 if ( sqpacf < 1.0e0 ) then ftest(1,1) = real (n-2) * sqpacf / (1.0e0 - sqpacf) ftest(2,1) = 1.0e0 - cdff(ftest(1,1), 1.0e0, real(n-2)) end if if ( aic(2) < aicmin ) then aicmin = aic(2) rssmin = rss iar = 1 phi(1) = work(1) end if acov0 = acov(1) do i = 2, lagmax call arcoef (acov(2), work, rss, i, lagmax, acov0) prho(i) = work(i) aic(i+1) = fplm ftest(1,i) = fplm ftest(2,i) = fplm if ( i /= n-1 ) then aic(i+1) = real ( n ) * log(rss * real (n+i+1) / real (n-i-1)) sqpacf = work(i) * work(i) if ( sqpacf < 1.0e0 ) then ftest(1,i) = real (n-i-1) * sqpacf / (1.0e0 - sqpacf) ftest(2,i) = 1.0e0 - cdff(ftest(1,i), 1.0e0, real(n-i-1)) end if end if ! ! if this aic is a minimum and its lag does not exceed n/2, ! save the coefficients. ! if ((aic(i+1) >= aicmin) .or. (i > n/2)) then cycle end if aicmin = aic(i+1) rssmin = rss iar = i phi(1:i) = work(1:i) end do ! ! normalize aic ! aic(1) = aic(1) - aicmin aic(2:lagmax+1) = aic(2:lagmax+1) - aicmin ospvar = rssmin / real (n-iar-1) return end subroutine aoslst ( prho, aic, ftest, lagmax, laic, iar, phi, & ospvar, ifprho, n ) !*****************************************************************************80 ! !! AOSLST lists the autoregressive model order selection statistics. ! ! Discussion: ! ! This routine lists the autoregressive model order selection ! statistics. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real aic(laic) ! the array containing the akaikes information criterion. ! character*160 fmt ! the format used. ! real ftest(2, lagmax) ! the array contianing the partial f ratio and its probability ! of being exceeded. ! integer i ! an index variable. ! integer iar ! the order of the autoregressive model selected. ! logical ifprho ! the logical variable used to indicate if the partial ! autocorrelations are being printed. if -ifprho- is ! .false. the autocorrelationa and their standard errors ! are printed, if .true., the partials. ! integer imax, imin ! the index values of the first and last observation ! to be printed per line ! integer lag ! the lag value of the autoregressive order selection statistic ! being printed. ! integer lagmax ! the maximum lag at which the autoregressive order selection ! statistics were computed. ! integer laic ! the length of the vector aic. ! integer m ! an index variable. ! integer n ! the number of observations in the series. ! integer nperl ! the number of values to be printed per line. ! real ospvar ! the one step prediction variance for the order selected. ! real phi(lagmax) ! the autoregressive coefficients for the selected order. ! real prho(lagmax) ! the array containing the partial autocorrelation ! coefficients. ! implicit none integer iar logical ifprho integer lagmax integer laic integer n real ospvar ! ! array arguments real & aic(laic),ftest(2,*),phi(*),prho(*) integer & i,imax,imin,lag,m,nperl nperl = 12 do i = 1, lagmax, nperl imin = i imax = min ( i + nperl - 1, lagmax ) write ( *, '(a)' ) ' ' write ( *, '(a, 12(i7))' ) ' lag ', (lag, lag = imin, imax) if (ifprho) then write ( *, 1001) (prho(lag), lag = imin, imax) end if if ( imax == lagmax .and. lagmax == n-1 ) then write ( *, '(a19,12(f7.2))' ) ' aic ', aic(imin+1:imax) write ( *, '(a19,12(f7.2))' ) ' f ratio ', ftest(1,imin:imax-1) write ( *, '(a19,12(f7.2))' ) ' f probability ', ftest(2,imin:imax-1) else write ( *, '(a19,12(f7.2))') ' aic ', aic(imin+1:imax+1) write ( *, '(a19,12(f7.2))') ' f ratio ', ftest(1,imin:imax) write ( *, '(a19,12(f7.2))') ' f probability ', ftest(2,imin:imax) end if end do if ( lagmax == n-1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'This value cannot be computed because LAG = N-1.' end if ! ! Print information on order selected ! write ( *, '(a,i8)' ) & ' order autoregressive process selected = ', iar write ( *, '(a,g14.6)' ) & ' one step prediction variance of process selected =', ospvar if ( iar == 0 ) then return end if write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Yule-Walker estimates of the coefficients of' write ( *, '(a)' ) ' the autoregressive process selected' do i = 1, iar, nperl imin = i imax = min ( i + nperl - 1, iar ) write ( *, '(a)' ) ' ' write ( *, '(a,12(i7))' ) ' coefficient number', (m, m = imin, imax) write ( *, '(a,12(f7.4))' ) ' coefficient value ', phi(imin:imax) end do return 1001 format( ' pacf ', 12(2x, f5.2)) !1002 format('(a19,',i2,'(f7.2) )') !1003 format('(a19 )') !1004 format('(a19,',i2,'(f7.2))') end subroutine aov1er ( y, tag, n, igstat, nztags, ng, ldstak, nmsub, & index, isaov1, nall0 ) !*****************************************************************************80 ! !! AOV1ER does preliminary checks on input to the one-way family. ! ! Discussion: ! ! This routine does preliminary checking for errors in the input ! parameters of the oneway family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical error ! set true if the error checking routine found any errors ! logical head ! indicates whether heading needs to be printed ! true - yes, needs to be printed ! false - no, has been printed ! integer i ! * ! integer ierr ! if ierr /= 0, then errors where found in the parameters ! integer igstat ! * ! integer index ! the starting location in the stach area of the index for ! the sorted tags. ! integer isaov1 ! an indicator variable used for the computation of work ! space. if isaov1 = 0, the calling routine is aov1s. if ! isaov1 = 1, the calling routine is aov1. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldsmin ! the minimum size allowed for the stack ! integer ldstak ! size of stack allocated in the users main program ! character*1 ligsta(8), llds(8), ln(8), lng(8), ltag(8), ! * ltwo(8), lzero(8) ! the array(s) containing the name(s) of the variable(s) checked ! errors ! integer n ! the number of observations ! integer nall0 ! output parameter. number of stack allocations after ! stack is initialized. ! character*1 nmsub(6) ! name of the calling subroutine ! integer nv ! the number of values less than or equal to zero. ! integer nztags ! the number of positive non-zero tags, to be determined by ! this routine ! real tag(n) ! the vector of tags. ! real y(n) ! the vector of observations. ! implicit none integer & igstat,index,isaov1,ldstak,n,nall0,ng,nztags ! ! array arguments real & tag(*),y(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer & i,j,ldsmin,nv logical & error,head ! ! local arrays integer & istak(12) character & ligsta(8)*1,llds(8)*1,ln(8)*1,lng(8)*1,ltag(8)*1, & ltwo(8)*1,lzero(8)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) data ligsta(1),ligsta(2),ligsta(3),ligsta(4),ligsta(5),ligsta(6), & ligsta(7),ligsta(8) & / 'i', 'g', 's', 't', 'a', 't', ' ', ' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) & / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), & ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data lng(1), lng(2), lng(3), lng(4), lng(5), lng(6), & lng(7), lng(8) & / 'n', 'g', ' ', ' ', ' ', ' ', ' ', ' '/ data ltag(1), ltag(2), ltag(3), ltag(4), ltag(5), ltag(6), & ltag(7), ltag(8) & / 't', 'a', 'g', ' ', ' ', ' ', ' ', ' '/ data ltwo(1), ltwo(2), ltwo(3), ltwo(4), ltwo(5), ltwo(6), & ltwo(7), ltwo(8) & / 't', 'w', 'o', ' ', ' ', ' ', ' ', ' '/ data lzero(1), lzero(2), lzero(3), lzero(4), lzero(5), lzero(6), & lzero(7), lzero(8) & / 'z', 'e', 'r', 'o', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. ! ! Is number of observations less than 2? ! call eisge(nmsub, ln, n, 2, 2, head, error, ltwo) if ( error ) then ierr = 1 return end if ! ! Is number of non-zero tags less than 2? ! call ervgt(nmsub, ltag, tag, n, 0.0e0, (n-2), head, 7, nv, error, & lzero) if (error) then ierr = 1 return end if nztags = n - nv ! ! Stack must be large enough for a vector of length n to continue ! call ldscmp(1, 0, n, 0, 0, 0, 's', 0, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error, llds) if (error) then ierr = 1 return end if ! ! Initialize stack and nall0 ! call stkset(ldstak, 4) nall0 = stkst(1) index = stkget(n,2) ! ! sort tag vector carrying along index to original order and the ! vector of observations ! call geni(istak(index), n, 1, 1) call srtirr(istak(index), y, n, tag) ! ! Count the number of different tag values. ! j = n - nztags + 2 ng = 1 do i=j,n if (tag(i) > tag(i-1)) ng = ng + 1 end do ! ! less than 2 different tag groups ! call eisii(nmsub, lng, ng, 2, nztags-1, 3, head, error, & ltwo, ln) if (error) then call srtrri(tag, y, n, istak(index)) call stkclr (nall0) ierr = 1 return end if ! ! Check that dimension of statistics matrix is sufficient ! call eisge(nmsub, ligsta, igstat, ng, 3, head, error, lng) if (error) then call srtrri(tag, y, n, istak(index)) call stkclr (nall0) ierr = 1 return end if ! ! compute and check for sufficient stack ! call ldscmp(11, 0, n+nztags, 0, 0, 0, & 's', isaov1*4*ng+4*ng+nztags, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error, llds) if (error) then call srtrri(tag, y, n, istak(index)) call stkclr (nall0) ierr = 1 return end if return !1000 format(/' note. the value of ldstak mentioned above is the', & ! ' minimum necessary'/ & ! ' to continue checking for errors and', & ! ' to calculate the correct value'/ & ! ' of ldstak. the correct', & ! ' value will be larger. consult the documentation'/ & ! ' for the formulas used to calculate ldstak.') end subroutine aov1 ( y, tag, n, ldstak ) !*****************************************************************************80 ! !! AOV1 is a user interface to AOV1MN, one-way analysis of variance. ! ! Discussion: ! ! This routine - ! 1. calls other routines to check the input parameters ! 2. sets up the needed storage locations, and ! 3. calls aov1mn to compute a comprehensive set of results for a ! oneway analysis of variance with automatic printout. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer b10 ! starting location in the stack area for b10 ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer dtmean ! the starting location in the stack area for the means ! of each group ! integer dtsd ! the starting location in the stack area of the ! standard deviations ! integer dtsize ! the starting location in the stack area of the size of the ! different groups ! integer gpmax ! the starting location in the stack area of maximum ! observation ! integer gpmin ! the starting location in the stack area of the minumum ! observation ! integer ierr ! a common variable used as a flag indicating whether there ! are any errors, if = 0 then no errors ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer index ! the starting location in the stack array of the index for ! the sorted tags ! integer int ! framework code value for integer numbers ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer itemp ! starting location in the stack for the ! temporary storage array ! integer ldstak ! size of the stack area allocated in the users main program ! integer n ! the number of observations to be analyzed ! integer nall0 ! the number of allocations outstanding at the time that this ! routine was called. ! integer ng ! the number of groups with different positive tag values ! character*1 nmsub(6) ! subroutine name ! integer nprt ! the variable controlling automatic printout ! if =0, printout is supressed ! otherwise printout is provided ! integer nztags ! the number of observations with positive non-zero wieghts ! integer ranks ! the starting location in work area for the ranks of y ! real rstak(12) ! the real version of the /cstak/ work area. ! integer srank ! the starting location in stack for the sum of ranks ! real tag(n) ! the vector of tag values ! integer tval ! the starting location in the stack for the vector of ! the different positive tag values, for aov1 ! real y(n) ! the vector of observations ! implicit none integer & ldstak,n ! ! array arguments real & tag(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer & b10,dtmean,dtsd,dtsize,gpmax,gpmin,ifp,index,int, & itemp,nall0,ng,nprt,nztags,ranks,srank,tval ! ! local arrays real & rstak(12) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget external stkget ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'o', 'v', '1', ' ', ' '/ ! ! Set up framework variables for number types ! int = 2 ifp = 3 ! ! Check for errors in parameters, initialize stack, and set nall0. ! call aov1er(y, tag, n, n, nztags, ng, ldstak, nmsub, index, 1, & nall0) ! ! Print correct form of call statement and return to caller ! if (ierr /= 0 ) then ierr = 1 return end if ! ! print heading ! call aov1hd ( ) ! ! Set up additional work vectors for aov1mn as called from aov1 ! tval = stkget(ng,ifp) dtsize = stkget(ng,ifp) dtmean = stkget(ng,ifp) dtsd = stkget(ng,ifp) srank = stkget(ng,ifp) gpmin = stkget(ng,ifp) gpmax = stkget(ng,ifp) b10 = stkget(ng,ifp) ranks = stkget(nztags,ifp) itemp = stkget(nztags,int) nprt = 1 call aov1mn(y, tag, n, rstak(tval), rstak(dtsize), rstak(dtmean), & rstak(dtsd), nprt, istak(index), rstak(srank), rstak(gpmin), & rstak(gpmax), rstak(b10), rstak(ranks), & istak(itemp), ng, nztags) ! ! Release the stack area ! call stkclr(nall0) return end subroutine aov1hd ( ) !*****************************************************************************80 ! !! AOV1HD prints headers for the one-way ANOVA family. ! ! Discussion: ! ! A subroutine to print out the heading for the one-way ANOVA ! family, and is the only source for headings in that family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! None ! implicit none call versp ( .true. ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' write ( *, '(a)' ) & ' Analysis of Variance' write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' ' return end subroutine aov1mn ( y, tag, n, tvalue, tsize, tmean, tsd, nprt, & index, srank, gpmin, gpmax, b10, ranks, itemp, ng, nzw ) !*****************************************************************************80 ! !! AOV1MN computes results for analysis of a one-way classification. ! ! Discussion: ! ! This routine computes a comprehensive set of results for ! analysis of a one-way classification with optional printed output. ! tag values can be any value where all measurements with tag ! values less than or equal to zero are excluded from analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real af ! a for f ! real bf ! bartlett f ! real bfrat ! between groups f ratio ! real bfsig ! between groups significance level ! character*1 blank ! hollerith blank ! real bms ! between ms ! real bss ! between ss ! real c ! intermediate result storage ! real cc ! cochrans c ! real cfkw ! correction factor for kruskal-wallis ! real df ! d.f. ! real dfrat ! deviations about line f ratio ! real dfsig ! deviations about line f significance level ! real dms ! deviations about line ms ! real dss ! deviations about line ss ! real f ! between means f-test ! real fmlc ! fixed model lower confidence limit for mean ! real fmuc ! fixed model upper confidence limit for mean ! real fnzw ! * ! real fplm ! largest single precision magnitude of machine ! real fstat ! f statistic associated with kruskal-wallis h statistic ! real f1kw ! f1 d.f. for kruskal-wallis f ! real f2kw ! f2 d.f. for kruskal-wallis f ! real gm ! grand mean, mean of all observations with positive ! non-zero tags ! real gpmax(ng) ! the vector of maximum observations for each group ! real gpmin(ng) ! the vector of minimum observations for each group ! real gr ! nzw-ng ! real g1 ! ng-1 ! character*1 high ! hollerith + (plus) ! real hstat ! kruskal-wallis h statistic, see brownlee(1965), page 256 ! integer i ! index variable ! real ibar ! i bar, ((sum of i)/nzw), where i=1,nzw ! integer index(n) ! permutation vector for y and later for tmean ! character*1 isd ! can contain following characters for printing ! +, -, (blank) ! integer isz ! integer size of group ! integer itemp(nzw) ! temporary index vector used in computing ranks ! integer j ! an index variable ! integer k ! index variable ! integer kk ! pointer to the largest of the group means ! integer kkk ! pointer to the smallest of the group means ! real k0 ! = nzw - (snc/nzw)/ g1 ! integer l ! index variable ! character*1 low ! hollerith - (minus) ! integer m ! index variable ! character*1 mean ! can contain following characters for printing ! +, -, (blank) ! real mf ! m for f ! real mkw ! m for kruskal-wallis mean ! integer m28 ! used in creating backward loop ! integer m3 ! ng - 2 ! integer m5 ! nzw - 1 ! integer n ! the number of observations ! integer ng ! the number of groups of different positive tag values ! integer nn ! aid in printing values ! integer nne1 ! number of groups with size not equal to one ! integer nprt ! the varaible controlling automatic printout ! if nprt = 0, printout suppressed ! otherwise printout provided ! integer nzpntr ! a pointer to the first non-zero tag in the sorted tag vector ! integer nzw ! the number of observations with positive, non-zero, tag values ! real q ! significance level from f-distribution ! real ranks(nzw) ! the ranks of the observations with positive tag values ! real ressq ! residuals squared ! real rmlc ! random model lower confidence limit for mean ! real rmuc ! random model upper confidence limit for mean ! real rx ! used in calculating mandel approximation ! real sbms ! sqrt between ms ! real sc ! sum of n(i) cubed, where n(i) is the size of group i ! real sfrat ! slope f ratio ! real sfsig ! slope f significance level ! real sigkw ! significance level for kruskal-wallis f (or h) ! real slbf ! significance level for barlett f ! real slcc ! significance level for cochrans c ! real smax ! maximum of s(i), where s(i) is the std. dev. of group i ! real smin ! minimum of s(i) ! real sms ! slope ms ! real snc ! sum of n(i) squared ! real sos ! sum of s(i) squared ! real sqb ! sqrt between ms / nzw ! real sqms ! sqrt within ms / nzw ! real sqom ! omega hat squared ! real sqt ! sqrt total ms / nzw ! real srank(ng) ! the sum of the ranks for the observations in each group ! real ssf ! s * sqrt(ng-1) * f ! real sss ! slope ss ! real stats(15) ! vector of statistics ! real stms ! sqrt total ms ! real sum ! intermidiate value ! real swms ! sqrt within ms ! real tag(n) ! vector of classification values - values less than or equal ! to zero are ignored for analysis. on entering tag is ! sorted smallest to largest ! real tmean(ng) ! the mean of each of the groups ! real tms ! total ms ! real tsd(ng) ! the standard deviations of each of the groups (not the ! standard deviations of the means) ! real tsize(ng) ! the size of each of the different groups ! real tss ! total ss ! real tvalue(ng) ! the different positive (non-zero) tag values analyzed, ordered ! from smallest to largest ! real t1 ! t(.05,ng-1) ! real t2 ! t(.05,ng-1) ! real t3 ! t(.05,nzw-1) ! real umlc ! ungrouped model lower confidence limit for mean ! real umuc ! ungrouped model upper confidence limit for mean ! real u1, u2 ! used in calculating mandel approximation ! real vkw ! u for kruskal-wallis f ! real vls ! largest variance / smallest variance ! real v1, v2 ! used in calculating mandel approximation ! real wms ! within ms ! real wss ! within ss ! real y(n) ! observations to be analyzed, sorted by tags ! y(nzpntr) is the first element with a non-zero tag ! real ybmax ! maximum ybar(i), where ybar(i) is the mean of group i ! real ybmin ! minimun ybar(i) ! real ymax ! maximum observation ! real ymin ! minimum observation ! implicit none integer & n,ng,nprt,nzw ! ! array arguments real & b10(*),gpmax(*),gpmin(*),ranks(*),srank(*),tag(*),tmean(*), & tsd(*),tsize(*),tvalue(*),y(*) integer & index(*),itemp(*) ! ! real & af,bf,bfrat,bfsig,bms,bss,c,cc,cfkw,df,dfrat,dfsig,dms,dss,f, & f1kw,f2kw,fmlc,fmuc,fnzw,fplm,fstat,g1,gm,gr,hstat,ibar,k0, & mf,mkw,q,ressq,rmlc,rmuc,rx,sbms,sc,sfrat,sfsig,sigkw,slbf, & slcc,smax,smin,sms,snc,sos,sqb,sqms,sqom,sqt,ssf,sss,stms, & sum,swms,t1,t2,t3,ties,tms,tss,u1,u2,umlc,umuc,v1,v2,vkw,vls, & wms,wss,ybmax,ybmin,ymax,ymin integer & i,isz,j,k,kk,kkk,l,m,m28,m3,m5,nn,nne1,nzpntr character & blank*1,high*1,isd*1,low*1,mean*1 ! ! local arrays real & stats(15) ! ! external functions real & cdff,ppff,ppft external cdff,ppff,ppft ! ! machine dependent variable - fplm ! data blank /' '/ data low /'-'/ data high /'+'/ fplm = huge ( fplm ) nzpntr = n - nzw + 1 fnzw = real ( nzw ) ! ! Zero work vectors. ! tvalue(1:ng) = 0.0e0 tsize(1:ng) = 0.0e0 tmean(1:ng) = 0.0e0 tsd(1:ng) = 0.0e0 srank(1:ng) = 0.0e0 gpmin(1:ng) = 0.0e0 gpmax(1:ng) = 0.0e0 b10(1:ng) = 0.0e0 stats(1:15) = 0.0e0 cc = 0.0e0 f = 0.0e0 dms = 0.0e0 bss = 0.0e0 wss = 0.0e0 hstat = 0.0e0 mf = 0.0e0 sc = 0.0e0 smax = 0.0e0 nne1 = 0 snc = 0.0e0 sos = 0.0e0 sss = 0.0e0 sum = 0.0e0 ties = 0.0e0 tss = 0.0e0 smin = 0.0e0 sfrat = 0.0e0 ! ! Compute ranks ! call ranko(nzw, y(nzpntr), itemp, ranks, ties) ! ! Initialize first element before entering loop ! tvalue(1) = tag(nzpntr) srank(1) = ranks(1) gpmin(1) = y(nzpntr) gpmax(1) = y(nzpntr) ymin = gpmin(1) ymax = gpmax(1) gm = y(nzpntr) ibar = 1.0e0 tmean(1) = y(nzpntr) tsize(1) = 1.0e0 ! ! Determine means and maxs, do summation prior to determining means. ! J is the group number. ! j = 1 l = nzpntr + 1 do i=l,n ! ! New tag group ! if ( tag(i) /= tag(i-1) ) then j = j + 1 tvalue(j) = tag(i) gpmin(j) = y(i) gpmax(j) = y(i) end if tsize(j) = tsize(j) + 1.0e0 tmean(j) = tmean(j) + y(i) gm = gm + y(i) ! ! Unnecessary computations if printed output is supressed ! if ( nprt /= 0 ) then k = i + 1 - nzpntr srank(j) = srank(j) + ranks(k) gpmin(j) = min(gpmin(j),y(i)) gpmax(j) = max(gpmax(j),y(i)) ymin = min(ymin,gpmin(j)) ymax = max(ymax,gpmax(j)) ibar = ibar + real ( j ) end if end do ! ! Calculate means ! gm = gm / fnzw ibar = ibar / fnzw k = nzpntr-1 i = nzpntr do j=1,ng if (tsize(j) >= 2.0e0) then tmean(j) = tmean(j)/tsize(j) else tmean(j) = tmean(j) end if k = k + int(tsize(j)) ! ! L gives index to y value within group j ! do l=i,k ressq = (y(l)-tmean(j))*(y(l)-tmean(j)) tsd(j) = tsd(j) + ressq if ( nprt /= 0 ) then bss = bss + (tmean(j)-gm)*(tmean(j)-gm) wss = wss + ressq tss = tss + (y(l)-gm)*(y(l)-gm) end if end do i = k + 1 end do ! ! Now done with tag vector, return vector to input order ! index is freed for use in other places ! call srtrri(tag, y, n, index) ! ! check for printed output ! ! Compute standard deviations within each group ! if ( nprt == 0 ) then do j=1,ng tsd(j) = sqrt(tsd(j)) if ( 1.0 < tsize(j) ) then tsd(j) = tsd(j)/sqrt(tsize(j)-1.0e0) end if end do return end if ! ! computations complete for stored output - return if printed ! output is supressed ! ybmin = tmean(1) ybmax = tmean(1) smin = fplm ! ! here i is the group number ! do i = 1, ng if (tsd(i) > 0.0e0) then b10(i) = tsize(i)*(tsize(i)-1.0e0)/tsd(i) stats(1) = stats(1) + b10(i)*tmean(i) stats(2) = stats(2) + b10(i) if (tsize(i) > 1.0e0) then tsd(i) = sqrt(tsd(i)/(tsize(i)-1.0e0)) end if mf = mf + (tsize(i)-1.0e0)*log(tsd(i)*tsd(i)) end if if (nint(tsize(i)) >= 2) then nne1 = nne1 + 1 smax = max(smax,tsd(i)) smin = min(smin,tsd(i)) stats(3) = stats(3) + 1.0e0/(tsize(i)-1.0e0) end if sss = sss + tsize(i)* ( real ( i ) - ibar ) * (tmean(i)-gm) stats(4) = stats(4) + tsize(i) & * ( real ( i ) - ibar ) * ( real ( i ) - ibar ) ! ! look for smallest and largest means (ybar) ! ybmin = min(ybmin,tmean(i)) ybmax = max(ybmax,tmean(i)) hstat = hstat + srank(i)*srank(i)/tsize(i) sum = sum + 1.0e0/tsize(i) stats(5) = stats(5) + (tmean(i)-gm)*(tmean(i)-gm) sos = sos + tsd(i)*tsd(i) snc = snc + tsize(i)*tsize(i) sc = sc + tsize(i)*tsize(i)*tsize(i) end do if (stats(2) /= 0.0e0) stats(1) = stats(1)/stats(2) if (stats(4) /= 0.0e0) sss = sss*sss/stats(4) dss = bss - sss ! ! degrees of freedom for anova ! g1 = real ( ng-1 ) m3 = ng - 2 gr = real ( nzw-ng ) m5 = nzw - 1 ! ! mean squares ! bms = bss/g1 sms = sss if (ng >= 3) dms = dss / real ( m3 ) wms = wss/gr tms = tss / real ( m5 ) if (wms==bms) then bfrat = 1.0e0 bfsig = 1.0e0 else if (wms==0.0e0) then bfrat = fplm bfsig = 0.0e0 else bfrat = bms/wms bfsig = 1.0e0 - cdff(bfrat,g1,gr) end if if (wms==dms) then dfrat = 1.0e0 dfsig = 1.0e0 else if (wms==0.0e0) then dfrat = fplm dfsig = 0.0e0 else dfrat = dms/wms dfsig = 1.0e0 - cdff(dfrat,real(m3),real(nzw-2)) end if if (sms==dss+wss) then sfrat = 1.0e0 sfsig = 1.0e0 else if (dss+wss==0.0e0) then sfrat = fplm sfsig = 0.0e0 else sfrat = sms/((dss+wss)/(fnzw-2.0e0)) sfsig = 1.0e0 - cdff(sfrat,1.0e0,gr) end if ! ! compute for kruskal-wallis test ! for formulae with clearer form and names see ! kraft and van eeden a non parametric introduction to statistics, ! pp. 238 - 240 ! stats(6) = real ( nzw*(nzw+1) ) hstat = (12.0e0*hstat/stats(6)) - (3.0e0*real (nzw+1)) if (ties== real ( nzw*nzw*nzw-nzw ) ) then cfkw = 0.0e0 hstat = 0.0e0 mkw = 0.0e0 else cfkw = 1.0e0 - ties/real (nzw*nzw*nzw-nzw) hstat = hstat/cfkw mkw = ((real ( nzw*nzw*nzw ) -sc)/stats(6))/cfkw end if vkw = 2.0e0*g1 - & (0.4e0* real ( 3*ng*m3+nzw*(2*ng*(ng-3)+1)) ) /stats(6) & - 6.0e0*sum/5.0e0 if (mkw-hstat > 0.0e0 .and. & mkw /= 0.0e0 .and. vkw /= 0.0e0) then f1kw = (g1*(g1*(mkw-g1)-vkw))/(0.5e0*vkw*mkw) f2kw = (mkw-g1)*f1kw/g1 fstat = (hstat*(mkw-g1))/(g1*(mkw-hstat)) sigkw = 1.0e0 - cdff(fstat,anint(f1kw),anint(f2kw)) else sigkw = 0.0e0 end if ! ! compute total statistics ! swms = sqrt(wms) sbms = sqrt(stats(5)/g1) stms = sqrt(tms) sqms = swms/(sqrt(fnzw)) sqb = sbms/(sqrt(real(ng))) sqt = stms/(sqrt(fnzw)) t1 = ppft(0.975e0,int(gr)) t2 = ppft(0.975e0,int(g1)) t3 = ppft(0.975e0,m5) fmlc = gm - sqms*t1 rmlc = gm - sqb*t2 umlc = gm - sqt*t3 fmuc = gm + sqms*t1 rmuc = gm + sqb*t2 umuc = gm + sqt*t3 ssf = swms*sqrt(g1*ppff(0.95e0,int(g1),int(gr))) ! ! tests for homogeneity of variances ! if (smax*smax==sos) then cc = 1.0e0 else if (sos /= 0.0e0) then cc = smax*smax/sos end if stats(7) = anint(fnzw/real ( ng ) ) if ((nne1 >= 2) .and. (cc /= 1.0e0)) then slcc = 1.0e0 - & cdff ( real (nne1-1)*cc/(1.0e0-cc), stats(7), & stats(7)*real (nne1-1) ) else slcc = 1.0e0 end if slcc = real (nne1-1) * slcc if (slcc > 1.0e0) slcc = 1.0e0 if (smin==smax) then vls = 1.0e0 else if (smin==0.0e0) then vls = fplm else vls = (smax/smin)*(smax/smin) end if end if if (wms > 0.0e0) mf = gr*log(wms) - mf af = (stats(3)-(1.0e0/gr))/(3.0e0*g1) slbf = 1.0e0 if ((af /= 1.0e0) .and. (nne1 >= 2)) then df = real (nne1+1) / (af*af) bf = (df*mf)/( real ( nne1 - 1 ) * (df/(1.0e0-af+(2.0e0/df))-mf)) if (bf<0.0e0) bf = 0.0e0 slbf = 1.0e0 - cdff(bf,real(nne1-1),anint(df)) else bf = fplm end if k0 = (fnzw-(snc/fnzw))/g1 sqom = (bms-wms)/k0 ! ! computations are now complete. ! ! print ANOVA ! nn = n - nzw write ( *,1000) nn nn = ng - 1 write ( *,1010) nn, bss, bms, bfrat, bfsig if (ng<3) go to 180 if (bfsig >= .10) go to 180 nn = 1 write ( *,1020) nn, sss, sms, sfrat, sfsig write ( *,1030) m3, dss, dms, dfrat, dfsig 180 nn = nzw - ng write ( *,1040) nn, wss, wms write ( *,1050) m5, tss ! ! print kruskal-wallis test ! write ( *,1060) hstat, sigkw ! ! print estimates ! write ( *,1070) do i=1,ng mean = blank if (tmean(i) <= ybmin) mean = low if (tmean(i) >= ybmax) mean = high isd = blank if (tsd(i) <= smin) isd = low if (tsd(i) >= smax) isd = high isz = int(tsize(i)) if (isz <= 1) then write ( *,1090) tvalue(i), isz, tmean(i), mean, gpmin(i), & gpmax(i), srank(i) else stats(9) = tsd(i)/sqrt(tsize(i)) stats(10) = ppft(0.975e0,isz-1) stats(8) = tmean(i) - stats(9)*stats(10) stats(11) = tmean(i) + stats(9)*stats(10) write ( *,1080) tvalue(i), isz, tmean(i), mean, tsd(i), & isd, stats(9), gpmin(i), gpmax(i), & srank(i), stats(8), stats(11) end if end do write ( *,1100) nzw, gm, ymin, ymax, swms, sqms, fmlc, fmuc, & sbms, sqb, rmlc, rmuc, stms, sqt, umlc, umuc if (bfsig<0.10) then ! ! sort ybar for multiple comparisions of means ! call geni(index, ng, 1, 1) call srtir(index, ng, tmean) ! ! compute and print for multiple comparisions ! if (nzw-ng<4) go to 270 write ( *,1110) ! ! newman-keuls-hartley ! write ( *,1120) rx = -.283917e0 + 2.63532e0*(gr-1.00123e0)**(-.95862e0) u1 = -.314115e0 + 2.38301e0*(gr-1.03428e0)**(-.864005e0) u2 = 3.65961e0*u1**2 - 1.00891e0*u1 - 0.166346e0 j = 1 m28 = 0 210 i = ng 220 if (i <= m28) go to 260 if (i==j) go to 230 stats(14) = abs(tmean(i)-tmean(j)) ! ! mandel approxmation to percent point of studentized range ! stats(12) = real ( i-j+1 ) c = 2.3849867e0 - & 2.9051857e0*(stats(12)-0.57583164e0)**(-.069648109e0) v1 = 1.30153e0 - & 1.95073e0*(stats(12)+.394915e0)**(-.139783e0) v2 = 4.72863e0*v1**2 + 0.404271e0*v1 - 0.135104e0 stats(13) = 6.15075e0 + 4.441409e0*rx + & 6.7514569e0*c + 7.4671282e0*u1*v1 - & 0.157537e0*u2*v2 kk = index(i) kkk = index(j) stats(13) = stats(13)* & sqrt(0.5e0*((1.0e0/tsize(kk))+(1.0e0/tsize(kkk))))* & swms if (stats(14) <= stats(13)) go to 230 i = i - 1 go to 220 230 if (j==1) go to 250 if (j > m28) go to 240 write ( *,1150) go to 250 240 write ( *,1160) 250 write ( *,1140) (tmean(m),m=j,i) if (i >= ng) go to 270 m28 = i 260 j = j + 1 go to 210 ! ! scheffe method ! 270 write ( *,1130) j = 1 m28 = 0 280 i = ng 290 if (i <= m28) go to 330 if (i==j) go to 300 kk = index(i) kkk = index(j) stats(14) = abs(tmean(i)-tmean(j)) stats(13) = ssf*sqrt((1.0e0/tsize(kk))+(1./tsize(kkk))) if (stats(14)-stats(13) <= 0.0e0) go to 300 i = i - 1 go to 290 300 if (j==1) go to 320 if (j > m28) go to 310 write ( *,1150) go to 320 310 write ( *,1160) 320 write ( *,1140) (tmean(m),m=j,i) if (i >= ng) go to 340 m28 = i 330 j = j + 1 go to 280 ! ! return tag means to original order ! 340 call srtri(tmean, ng, index) end if if (nne1 <= 1) return write ( *,1170) cc, slcc, bf, slbf, vls if (slcc > 0.1e0 .and. slbf > 0.1e0) then write ( *, 1190 ) sqom return end if do i=1,ng f = f + b10(i)*(tmean(i)-stats(1))*(tmean(i)-stats(1)) if (stats(2)==0.0e0 .or. tsize(i) <= 1.0e0) then exit end if stats(15) = stats(15) + & (1.0e0-b10(i)*b10(i)/stats(2)/stats(2))/ & (tsize(i)-1.0e0) end do if ( stats(15) == 0.0e0 ) then f = 0.0 else stats(15) = real ( ng*ng-1 ) / (3.0e0*stats(15)) if ( ng <= 1 ) then f = 0.0 else f = (f/g1)/(1.0e0+(2.0e0* real ( m3 ) /(3.0e0*stats(15)))) end if end if q = 1.0e0 - cdff(f,g1,anint(stats(15))) write ( *,1180) f, q write ( *,1190) sqom return ! ! automatic printout is finished ! 1000 format('group numbers have been assigned according to tag ', & /, 'values given, where the smallest tag greater than zero has ', & /, 'been assigned ', & /, 'group number 1, the next smallest, group number 2, etc. ', & /, 'tags <= zero have not been included in analysis.', & /, 'number of values excluded from analysis is ', i4, & //,17x, 'source', 14x, 'd.f.', & 4x, 'sum of squares', 5x, 'mean squares', 9x, 'f ratio', 4x, & 'f prob.'/) 1010 format(17x, 'between groups', 5x, i4, 1p2e18.6, 4x, 0pe11.3, & f10.3) 1020 format(20x, 'slope', 14x, i4, 1p2e18.6, 3x, 0pe11.3, f10.3) 1030 format(20x, 'devs. about line', 3x, i4, 1p2e18.6, 3x, 0pe11.3, & f10.3) 1040 format(17x, 'within groups', 6x, i4, 1p2e18.6) 1050 format(17x, 'total', 14x, i4, 1pe18.6//) 1060 format(11x, 'kruskal-wallis rank test for difference between g', & 'roup means * h =', e11.3, ', f prob =', f6.3, ' (approx.)' & /) 1070 format(55x, 'estimates'/96x, 'sum of'/5x, ' tag ', 10x, 'no.', & 6x, 'mean', 7x, 'within s.d.', 2x, 's.d. of mean', 5x, & 'minimum', 7x, 'maximum', 6x, 'ranks', 3x, '95pct conf int f', & 'or mean'/) 1080 format(1x, 1pe14.6, i8, e14.5, a1, e13.5, a1, e13.5, 2e14.5, & 0pf9.1, 1pe13.5, ' to', e12.5) 1090 format(1x, 1pe14.6, i8, e14.5, a1, 3x, ' estimate not available', & ' ', 2e14.5, 0pf9.1, 3x, '********** to **********' ) 1100 format(/11x, 'total', i7, 1pe14.5, 28x, 2e14.5// & 17x, 'fixed effects model ', 2e14.5, 37x, e13.5, ' to', e12.5/ & 17x, 'random ', & 'effects model', 2e14.5, 37x, e13.5, ' to', e12.5/17x, & 'ungrouped data', 6x, 2e14.5, 37x, e13.5, ' to', e12.5/) 1110 format(1x, 'pairwise multiple comparison of means. the means ', & 'hare put in increasing order in groups separated by *****. ', & 'a mean is '/' adjudged non-significantly different from a', & 'ny mean in the same group and significantly different at th', & 'e .05 level from '/' any mean in another group. ***** ***', & '** indicates adjacent groups have no common mean. ', & ' ') 1120 format(/3x, 'newman-keuls technique, hartley modification. (ap', & 'proximate if group numbers are unequal.)') 1130 format(/3x, 'scheffe technique.') 1140 format(3x, 9(1pe12.5, ',')) 1150 format(6x, '*****') 1160 format(3x, '***** *****') 1170 format(/' tests for homogeneity of variances.'/7x, 'cochrans ', & 'c = max. variance/sum(variances) = ', f7.4, ', p = ', f6.3, & ' (approx.)'/7x, 'bartlett-box f = ', f9.3, ', p = ', & f6.3/7x, 'maximum variance / minimum variance = ', f14.4) 1180 format(7x, 'approx between means f-test in presence of heterog', & 'eneous variance. f =', f8.3, ', p =', f6.3) 1190 format(/' model ii - components of variance.'/7x, 'estimate o', & 'f between component ', 1pe14.6) end subroutine aov1s ( y, tag, n, ldstak, nprt, gstat, igstat, ng ) !*****************************************************************************80 ! !! AOV1S is a user interface for AOV1MN, one-way analysis of variance. ! ! Discussion: ! ! This routine - ! 1. calls other routines to check the input parameters ! 2. sets up needed storage locations and ! 3. calls aov1mn to compute a comprehensive set of results for a ! oneway analysis of variance with optional output. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer b10 ! starting location in the stack area for b10 ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer gpmax ! the starting location in the stack area of maximum ! observation ! integer gpmin ! the starting location in the stack area of the minumum ! observation ! real gstat(igstat,4) ! the group statistics. columns correspond to the tag ! value, sample size, group mean, and group standard deviation. ! integer ierr ! a common variable used as a flag indicating whether there ! are any errors, if = 0 then no errors ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer igstat ! the first dimension of gstat. ! integer index ! the starting location in the stack array of the index for ! the sorted tags ! integer int ! framework code value for integer numbers ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer itemp ! starting location in the stack for the ! temporary storage array ! integer ldstak ! size of the stack area allocated in the users main program ! integer n ! the number of observations to be analyzed ! integer nall0 ! the number of allocations outstanding at the time that this ! routine was called. ! integer ng ! the computed number of groups with ! different positive tag values ! character*1 nmsub(6) ! subroutine name ! integer nprt ! the variable controlling automatic printout ! if =0, printout is supressed ! otherwise printout is provided ! integer nztags ! the number of observations with positive non-zero wieghts ! integer ranks ! the starting location in stack area for the ranks of y ! real rstak(12) ! the real version of the /cstak/ work area. ! integer srank ! the starting location in stack for the sum of ranks ! real tag(n) ! the vector of tag values ! real y(n) ! the vector of observations ! implicit none integer & igstat,ldstak,n,ng,nprt ! ! array arguments real & gstat(*),tag(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer & b10,gpmax,gpmin,ifp,index,int,itemp,nall0,nztags, & ranks,srank ! ! local arrays real & rstak(12) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget external stkget ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'o', 'v', '1', 's', ' '/ ! ! set up framework variables for number types ! int = 2 ifp = 3 ! ! check for errors in parameters, initialize stack, and set ! nall0. ! call aov1er(y, tag, n, igstat, nztags, ng, ldstak, nmsub, index, & 0, nall0) ! ! print correct form of call statement and return to caller ! if ( ierr /= 0 ) then ierr = 1 return end if ! ! print heading if desired ! if ( nprt /= 0 ) then call aov1hd ( ) end if ! ! set up additional work vectors for aov1mn as called from aov1s ! srank = stkget(ng,ifp) gpmin = stkget(ng,ifp) gpmax = stkget(ng,ifp) b10 = stkget(ng,ifp) ranks = stkget(nztags,ifp) itemp = stkget(nztags,int) call aov1mn(y, tag, n, & gstat(1), gstat(igstat+1), & gstat(2*igstat+1), gstat(3*igstat+1), & nprt, istak(index), rstak(srank), rstak(gpmin), & rstak(gpmax), rstak(b10), rstak(ranks), & istak(itemp), ng, nztags) ! ! release the stack area ! call stkclr(nall0) return end subroutine aov1xp ( gstat, igstat, ng ) !*****************************************************************************80 ! !! AOV1XP prints storage for one-way family exerciser. ! ! Discussion: ! ! Print storage for oneway family exerciser and clear storage vectors ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real gstat(igstat,4) ! the group statistics. columns correspond to the tag ! value, sample size, group mean, and group standard deviation. ! integer i ! an index value ! integer igstat ! the first dimension of gstat. ! implicit none integer & igstat,ng ! ! array arguments real & gstat(igstat,4) ! ! integer & i,j ! ! external subroutines external setra write ( *,1000) write ( *,1010) ((gstat(i,j),j=1,4),i=1,ng) call setra(gstat, igstat, 4, ng, 0.0e0) return 1000 format(//' storage from aov1 '//6x, 'tagvalue', & 11x, ' groupsize', 11x, ' groupmean', 13x, ' groupsd'/) 1010 format(4(1x, g20.14)) end subroutine arcoef ( acov, phi, rss, lag, lagmax, acov0 ) !*****************************************************************************80 ! !! ARCOEF uses Durbin's method for autoregression coefficients with order lag. ! ! Discussion: ! ! This routine uses Durbin's recursive method to compute ! the autoregressive coefficients of an order LAG process, ! given on input the coefficients of an order (LAG-1) process. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lagmax) ! the array of acvf estimates for lags one to lagmax. ! real acov0 ! the acvf for lag zero. ! integer j, lag ! index variables. ! integer lagmax ! the maximum lag value used. ! integer lj, l2 ! index variables. ! real phi(lagmax) ! the array of autoregressive coefficients for an ar ! process of order lag. ! real rss ! the one step prediction residual sum of squares. ! real sum1, sum2 ! variables used in the computations of the autoregressive ! coefficients. ! real t ! a temporary storage location. ! implicit none real & acov0,rss integer & lag,lagmax ! ! array arguments real & acov(lagmax),phi(*) ! ! real & sum1,sum2,t integer & j,l1,l2,lj l1 = lag - 1 sum1 = 0.0e0 sum2 = 0.0e0 do j = 1, l1 lj = lag - j sum1 = sum1 + phi(j) * acov(lj) sum2 = sum2 + phi(j) * acov(j) end do phi(lag) = (acov(lag) - sum1) / (acov0 - sum2) l2 = lag / 2 do j = 1, l2 lj = lag - j t = phi(j) - phi(lag) * phi(lj) phi(lj) = phi(lj) - phi(lag) * phi(j) phi(j) = t end do rss = rss * (1.0e0 - phi(lag)*phi(lag)) return end subroutine arflt ( y, n, iar, phi, yf, nyf ) !*****************************************************************************80 ! !! ARFLT performs autoregressive filtering. ! ! Discussion: ! ! This routine performs the autoregressive filtering ! operation defined by PHI, returning the filtered series in YF. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical err01 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer iar ! the number of filter coefficients. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! character*1 ln(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nyf ! the number of observations in the filtered series yf. ! real phi(iar) ! the vector containing the filter coefficients. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! real ymean ! the mean of the input series y. ! implicit none integer & iar,n,nyf ! ! array arguments real & phi(*),y(*),yf(*) ! ! scalars in common integer & ierr ! ! real & ymean logical & err01,head ! ! local arrays character & ln(8)*1,nmsub(6)*1 ! ! external subroutines external amean,eisge,fltar ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'a', 'r', 'f', 'l', 't', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. ! ! call error checking routines ! call eisge(nmsub, ln, n, 3, 1, head, err01, ln) if ( err01 ) then ierr = 1 return end if ! ! compute arithmetic mean ! call amean ( y, n, ymean ) yf(1:n) = y(1:n) - ymean call fltar (yf, n, iar, phi, yf, nyf) return end subroutine assess ( d, iv, p, step, stlstg, v, x, x0 ) !*********************************************************************** ! !! ASSESS assesses a candidate step. ! ! Discussion: ! ! This routine is called by an unconstrained minimization ! routine to assess the next candidate step. It may recommend one ! of several courses of action, such as accepting the step, ! recomputing it using the same or a new quadratic model, or ! halting due to convergence or false convergence. See the return ! code listing below. ! ! This routine is called as part of the NL2SOL (nonlinear ! least-squares) package. It may be used in any unconstrained ! minimization solver that uses dogleg, Goldfeld-Quandt-Trotter, ! or Levenberg-Marquardt steps. ! ! See Dennis, Gay and Welsch for further discussion of the assessing ! and model switching strategies. While NL2SOL considers only two ! models, ASSESS is designed to handle any number of models. ! ! On the first call of an iteration, only the I/O variables ! step, X, IV(IRC), IV(MODEL), V(F), V(DSTNRM), V(GTSTEP), and ! V(PREDUC) need have been initialized. Between calls, no I/O ! values execpt STEP, X, IV(MODEL), V(G) and the stopping tolerances ! should be changed. ! ! After a return for convergence or false convergence, one can ! change the stopping tolerances and call ASSESS again, in which ! case the stopping tests will be repeated. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! ! Michael Powell, ! A FORTRAN Subroutine for Solving Systems of Nonlinear Algebraic Equations, ! in Numerical Methods for Nonlinear Algebraic Equations, ! edited by Philip Rabinowitz, ! Gordon and Breach, London, 1970. ! ! Parameters: ! ! iv (i/o) integer parameter and scratch vector -- see description ! below of iv values referenced. ! ! Input, real D(P), a scale vector used in computing V(RELDX). ! ! Input, integer P, the number of parameters being optimized. ! ! step (i/o) on input, step is the step to be assessed. it is un- ! changed on output unless a previous step achieved a ! better objective function reduction, in which case stlstg ! will have been copied to step. ! ! stlstg (i/o) when assess recommends recomputing step even though the ! current (or a previous) step yields an objective func- ! tion decrease, it saves in stlstg the step that gave the ! best function reduction seen so far (in the current itera- ! tion). if the recomputed step yields a larger function ! value, then step is restored from stlstg and ! x = x0 + step is recomputed. ! ! v (i/o) real parameter and scratch vector -- see description ! below of v values referenced. ! ! x (i/o) on input, x = x0 + step is the point at which the objec- ! tive function has just been evaluated. if an earlier ! step yielded a bigger function decrease, then x is ! restored to the corresponding earlier value. otherwise, ! if the current step does not give any function decrease, ! then x is restored to x0. ! ! x0 (in) initial objective function parameter vector (at the ! start of the current iteration). ! ! iv values referenced ! ! iv(irc) (i/o) on input for the first step tried in a new iteration, ! iv(irc) should be set to 3 or 4 (the value to which it is ! set when step is definitely to be accepted). on input ! after step has been recomputed, iv(irc) should be ! unchanged since the previous return of assess. ! on output, iv(irc) is a return code having one of the ! following values... ! 1 = switch models or try smaller step. ! 2 = switch models or accept step. ! 3 = accept step and determine v(radfac) by gradient ! tests. ! 4 = accept step, v(radfac) has been determined. ! 5 = recompute step (using the same model). ! 6 = recompute step with radius = v(lmax0) but do not ! evaulate the objective function. ! 7 = x-convergence (see v(xctol)). ! 8 = relative function convergence (see v(rfctol)). ! 9 = both x- and relative function convergence. ! 10 = absolute function convergence (see v(afctol)). ! 11 = singular convergence (see v(lmax0)). ! 12 = false convergence (see v(xftol)). ! 13 = iv(irc) was out of range on input. ! return code i has precdence over i+1 for i = 9, 10, 11. ! iv(mlstgd) (i/o) saved value of iv(model). ! iv(model) (i/o) on input, iv(model) should be an integer identifying ! the current quadratic model of the objective function. ! if a previous step yielded a better function reduction, ! then iv(model) will be set to iv(mlstgd) on output. ! iv(nfcall) (in) invocation count for the objective function. ! iv(nfgcal) (i/o) value of iv(nfcall) at step that gave the biggest ! function reduction this iteration. iv(nfgcal) remains ! unchanged until a function reduction is obtained. ! iv(radinc) (i/o) the number of radius increases (or minus the number ! of decreases) so far this iteration. ! iv(restor) (out) set to 0 unless x and v(f) have been restored, in ! which case assess sets iv(restor) = 1. ! iv(stage) (i/o) count of the number of models tried so far in the ! current iteration. ! iv(stglim) (in) maximum number of models to consider. ! iv(switch) (out) set to 0 unless a new model is being tried and it ! gives a smaller function value than the previous model, ! in which case assess sets iv(switch) = 1. ! iv(toobig) (in) is nonzero if step was too big (e.g. if it caused ! overflow). ! iv(xirc) (i/o) value that iv(irc) would have in the absence of ! convergence, false convergence, and oversized steps. ! ! v values referenced ! ! v(afctol) (in) absolute function convergence tolerance. if the ! absolute value of the current function value v(f) is less ! than v(afctol), then assess returns with iv(irc) = 10. ! v(decfac) (in) factor by which to decrease radius when iv(toobig) is ! nonzero. ! v(dstnrm) (in) the 2-norm of d * step. ! v(dstsav) (i/o) value of v(dstnrm) on saved step. ! v(dst0) (in) the 2-norm of d times the Newton step (when defined, ! i.e., for 0 <= v(nreduc) ). ! v(f) (i/o) on both input and output, v(f) is the objective func- ! tion value at x. if x is restored to a previous value, ! then v(f) is restored to the corresponding value. ! v(fdif) (out) the function reduction v(f0) - v(f) (for the output ! value of v(f) if an earlier step gave a bigger function ! decrease, and for the input value of v(f) otherwise). ! v(flstgd) (i/o) saved value of v(f). ! v(f0) (in) objective function value at start of iteration. ! v(gtslst) (i/o) value of v(gtstep) on saved step. ! v(gtstep) (in) inner product between step and gradient. ! v(incfac) (in) minimum factor by which to increase radius. ! v(lmax0) (in) maximum reasonable step size (and initial step bound). ! if the actual function decrease is no more than twice ! what was predicted, if a return with iv(irc) = 7, 8, 9, ! or 10 does not occur, if v(lmax0) < v(dstnrm), and if ! v(preduc) <= v(rfctol) * abs(v(f0)), then assess re- ! turns with iv(irc) = 11. if so doing appears worthwhile, ! then assess repeats this test with v(preduc) computed for ! a step of length v(lmax0) (by a return with iv(irc) = 6). ! v(nreduc) (i/o) function reduction predicted by quadratic model for ! Newton step. if assess is called with iv(irc) = 6, i.e., ! if v(preduc) has been computed with radius = v(lmax0) for ! use in the singular convervence test, then v(nreduc) is ! set to -v(preduc) before the latter is restored. ! v(plstgd) (i/o) value of v(preduc) on saved step. ! v(preduc) (i/o) function reduction predicted by quadratic model for ! current step. ! v(radfac) (out) factor to be used in determining the new radius, ! which should be v(radfac)*dst, where dst is either the ! output value of v(dstnrm) or the 2-norm of ! diag(newd) * step for the output value of step and the ! updated version, newd, of the scale vector d. for ! iv(irc) = 3, v(radfac) = 1.0 is returned. ! v(rdfcmn) (in) minimum value for v(radfac) in terms of the input ! value of v(dstnrm) -- suggested value = 0.1. ! v(rdfcmx) (in) maximum value for v(radfac) -- suggested value = 4.0. ! v(reldx) (out) scaled relative change in x caused by step, computed ! by function reldst as ! max (d(i)*abs(x(i)-x0(i)), 1 <= i <= p) / ! max (d(i)*(abs(x(i))+abs(x0(i))), 1 <= i <= p). ! if an acceptable step is returned, then v(reldx) is com- ! puted using the output (possibly restored) values of x ! and step. otherwise it is computed using the input ! values. ! v(rfctol) (in) relative function convergence tolerance. if the ! actual function reduction is at most twice what was pre- ! dicted and v(nreduc) <= v(rfctol)*abs(v(f0)), then ! assess returns with iv(irc) = 8 or 9. see also v(lmax0). ! v(STPPAR) (in) Marquardt parameter -- 0 means full Newton step. ! v(tuner1) (in) tuning constant used to decide if the function ! reduction was much less than expected. suggested ! value = 0.1. ! v(tuner2) (in) tuning constant used to decide if the function ! reduction was large enough to accept step. suggested ! value = 10**-4. ! v(tuner3) (in) tuning constant used to decide if the radius ! should be increased. suggested value = 0.75. ! v(xctol) (in) x-convergence criterion. if step is a Newton step ! (v(STPPAR) = 0) having v(reldx) <= v(xctol) and giving ! at most twice the predicted function decrease, then ! assess returns iv(irc) = 7 or 9. ! v(xftol) (in) false convergence tolerance. if step gave no or only ! a small function decrease and v(reldx) <= v(xftol), ! then assess returns with iv(irc) = 12. ! implicit none integer p integer, parameter :: afctol = 31 real d(p) integer, parameter :: decfac = 22 real emax logical goodx real gts integer i integer, parameter :: irc = 3 integer iv(13) integer, parameter :: lmax0 = 35 integer nfc integer, parameter :: nreduc = 6 integer, parameter :: plstgd = 15 integer, parameter :: preduc = 7 integer, parameter :: radfac = 16 integer, parameter :: rdfcmn = 24 integer, parameter :: rdfcmx = 25 real reldst integer, parameter :: reldx = 17 real reldx1 real rfac1 integer, parameter :: rfctol = 32 real step(p) real stlstg(p) integer, parameter :: stppar = 5 integer, parameter :: tuner1 = 26 integer, parameter :: tuner2 = 27 integer, parameter :: tuner3 = 28 real v(35) real x(p) real x0(p) integer, parameter :: xctol = 33 integer, parameter :: xftol = 34 integer, parameter :: xirc = 13 real xmax ! ! subscripts for iv and v ! integer dstnrm, dstsav, dst0, f, fdif, flstgd, f0 integer gtslst, gtstep, incfac, mlstgd, model, nfcall, & nfgcal, radinc, & restor, stage, stglim, & switch, toobig parameter ( mlstgd=4, model=5, nfcall=6 ) parameter ( nfgcal=7, radinc=8, restor=9, stage=10 ) parameter ( stglim=11, switch=12, toobig=2 ) parameter ( dstnrm=2, dst0=3 ) parameter ( dstsav=18, f=10, fdif=11, flstgd=12, f0=13 ) parameter ( gtslst=14, gtstep=4, incfac=23 ) nfc = iv(nfcall) iv(switch) = 0 iv(restor) = 0 rfac1 = 1.0E+00 goodx = .true. i = iv(irc) if ( i < 1 .or. 12 < i ) then iv(irc) = 13 return end if go to (20,30,10,10,40,360,290,290,290,290,290,140), i ! ! Initialize for new iteration. ! 10 continue iv(stage) = 1 iv(radinc) = 0 v(flstgd) = v(f0) if ( iv(toobig) /= 0 ) then iv(stage) = -1 iv(xirc) = i v(radfac) = v(decfac) iv(radinc) = iv(radinc) - 1 iv(irc) = 5 return end if go to 90 ! ! Step was recomputed with new model or smaller radius. ! First decide which. ! 20 continue ! ! Old model retained, smaller radius tried. ! Do not consider any more new models this iteration. ! if ( iv(model) == iv(mlstgd) ) then iv(stage) = iv(stglim) iv(radinc) = -1 go to 90 end if ! ! A new model is being tried. Decide whether to keep it. ! 30 iv(stage) = iv(stage) + 1 ! ! Now we add the possibiltiy that step was recomputed with ! the same model, perhaps because of an oversized step. ! 40 if ( 0 < iv(stage) ) then go to 50 end if ! ! Step was recomputed because it was too big. ! if (iv(toobig) /= 0) then v(radfac) = v(decfac) iv(radinc) = iv(radinc) - 1 iv(irc) = 5 return end if ! ! Restore IV(STAGE) and pick up where we left off. ! iv(stage) = -iv(stage) i = iv(xirc) go to (20, 30, 90, 90, 70), i 50 if (iv(toobig) == 0) then go to 70 end if ! ! Handle oversize step. ! if ( iv(radinc) <= 0 ) then iv(stage) = -iv(stage) iv(xirc) = iv(irc) v(radfac) = v(decfac) iv(radinc) = iv(radinc) - 1 iv(irc) = 5 return end if go to 80 70 if (v(f) < v(flstgd)) then go to 90 end if ! ! The new step is a loser. Restore old model. ! if ( iv(model) /= iv(mlstgd) ) then iv(model) = iv(mlstgd) iv(switch) = 1 end if ! ! Restore step, etc. only if a previous step decreased V(F). ! 80 continue if ( v(flstgd) < v(f0) ) then iv(restor) = 1 v(f) = v(flstgd) v(preduc) = v(plstgd) v(gtstep) = v(gtslst) if (iv(switch) == 0) rfac1 = v(dstnrm) / v(dstsav) v(dstnrm) = v(dstsav) nfc = iv(nfgcal) goodx = .false. end if ! ! Compute relative change in X by current step. ! 90 continue reldx1 = reldst ( p, d, x, x0 ) ! ! Restore X and STEP if necessary. ! if ( .not. goodx ) then step(1:p) = stlstg(1:p) x(1:p) = x0(1:p) + stlstg(1:p) end if v(fdif) = v(f0) - v(f) ! ! No (or only a trivial) function decrease, ! so try new model or smaller radius. ! if ( v(fdif) <= v(tuner2) * v(preduc) ) then v(reldx) = reldx1 if ( v(f0) <= v(f) ) then iv(mlstgd) = iv(model) v(flstgd) = v(f) v(f) = v(f0) x(1:p) = x0(1:p) iv(restor) = 1 else iv(nfgcal) = nfc end if iv(irc) = 1 if ( iv(stglim) <= iv(stage) ) then iv(irc) = 5 iv(radinc) = iv(radinc) - 1 end if else ! ! Nontrivial function decrease achieved. ! iv(nfgcal) = nfc rfac1 = 1.0E+00 if ( goodx ) then v(reldx) = reldx1 end if v(dstsav) = v(dstnrm) if ( v(preduc) * v(tuner1) < v(fdif) ) then go to 200 end if ! ! Decrease was much less than predicted: either change models ! or accept step with decreased radius. ! if ( iv(stage) < iv(stglim) ) then iv(irc) = 2 else iv(irc) = 4 end if end if ! ! Set V(RADFAC) to Fletcher's decrease factor. ! iv(xirc) = iv(irc) emax = v(gtstep) + v(fdif) v(radfac) = 0.5E+00 * rfac1 if (emax < v(gtstep) ) then v(radfac) = rfac1 * max ( v(rdfcmn), 0.5E+00 * v(gtstep) / emax ) end if ! ! Do a false convergence test. ! 140 continue if ( v(reldx) <= v(xftol)) then go to 160 end if iv(irc) = iv(xirc) if (v(f) < v(f0)) then go to 230 end if go to 300 160 iv(irc) = 12 go to 310 ! ! Handle good function decrease, ! 200 if (v(fdif) < (-v(tuner3) * v(gtstep))) then go to 260 end if ! ! Increasing radius looks worthwhile. See if we just ! recomputed step with a decreased radius or restored step ! after recomputing it with a larger radius. ! if (iv(radinc) < 0) then go to 260 end if if (iv(restor) == 1) then go to 260 end if ! ! We did not. Try a longer step unless this was a Newton step. ! v(radfac) = v(rdfcmx) gts = v(gtstep) if ( v(fdif) < ( 0.5E+00 / v(radfac) - 1.0E+00) * gts ) then v(radfac) = max ( v(incfac), 0.5E+00 * gts / ( gts + v(fdif) ) ) end if iv(irc) = 4 if ( v(stppar) == 0.0E+00 ) then go to 300 end if ! ! Step was not a Newton step. Recompute it with a larger radius. ! iv(irc) = 5 iv(radinc) = iv(radinc) + 1 ! ! Save values corresponding to good step. ! 230 v(flstgd) = v(f) iv(mlstgd) = iv(model) stlstg(1:p) = step(1:p) v(dstsav) = v(dstnrm) iv(nfgcal) = nfc v(plstgd) = v(preduc) v(gtslst) = v(gtstep) go to 300 ! ! Accept step with radius unchanged. ! 260 v(radfac) = 1.0E+00 iv(irc) = 3 go to 300 ! ! Come here for a restart after convergence. ! 290 iv(irc) = iv(xirc) if ( v(dstsav) < 0.0E+00 ) then iv(irc) = 12 end if go to 310 ! ! Perform convergence tests. ! 300 iv(xirc) = iv(irc) 310 continue if ( abs ( v(f) ) < v(afctol) ) then iv(irc) = 10 end if if ( v(preduc) < 0.5E+00 * v(fdif) ) then return end if emax = v(rfctol) * abs(v(f0)) if ( v(lmax0) < v(dstnrm) .and. v(preduc) <= emax ) then iv(irc) = 11 end if if ( 0.0E+00 <= v(dst0) ) then if (( 0.0E+00 < v(nreduc) .and. v(nreduc) <= emax) .or. & (v(nreduc) == 0.0E+00 .and. v(preduc) == 0.0)) then i = 2 else i = 0 end if if ( v(stppar) == 0.0E+00 .and. & v(reldx) <= v(xctol) .and. & goodx ) then i = i + 1 end if if ( 0 < i ) then iv(irc) = i + 6 end if end if ! ! Consider recomputing step of length V(LMAX0) for singular ! convergence test. ! if ( 2 < abs ( iv(irc) -3 ) .and. iv(irc) /= 12 ) then return end if if ( v(lmax0) < v(dstnrm) ) then if ( 0.5E+00 * v(dstnrm) <= v(lmax0) ) then return end if xmax = v(lmax0) / v(dstnrm) if ( emax <= xmax * ( 2.0E+00 - xmax) * v(preduc) ) then return end if else if ( emax <= v(preduc) ) then return end if if ( 0.0E+00 < v(dst0) ) then if ( 0.5E+00 * v(dst0) <= v(lmax0) ) then return end if end if end if if ( v(nreduc) < 0.0E+00 ) then if ( -v(nreduc) <= v(rfctol) * abs ( v(f0) ) ) then iv(irc) = 11 end if return end if ! ! Recompute V(PREDUC) for use in singular convergence test. ! v(gtslst) = v(gtstep) v(dstsav) = v(dstnrm) if ( iv(irc) == 12 ) then v(dstsav) = -v(dstsav) end if v(plstgd) = v(preduc) iv(irc) = 6 stlstg(1:p) = step(1:p) return ! ! Perform singular convergence test with recomputed V(PREDUC). ! 360 continue v(gtstep) = v(gtslst) v(dstnrm) = abs(v(dstsav)) step(1:p) = stlstg(1:p) if ( v(dstsav) <= 0.0E+00 ) then iv(irc) = 12 else iv(irc) = iv(xirc) end if v(nreduc) = -v(preduc) v(preduc) = v(plstgd) if ( -v(nreduc) <= v(rfctol) * abs(v(f0)) ) then iv(irc) = 11 end if return end subroutine axpby ( n, sa, sx, incx, sb, sy, incy, sz, incz ) !*****************************************************************************80 ! !! AXPBY: SZ(1:N) = SA * SX(1:N) + SB * SY(1:N). ! ! Discussion: ! ! This routine is adapted from BLAS subroutine saxpy. ! ! Overwrite real sz with real sa*sx + sb*sy. ! ! For i = 0 to n-1, replace sz(lz+i*incz) with sa*sx(lx+i*incx) + ! sy(ly+i*incy), where lx = 1 if incx >= 0, else lx = (-incx)*n, ! and ly and lz are defined in a similar way using incy and incz, ! respectively. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & sa,sb integer & incx,incy,incz,n ! ! array arguments real & sx(*),sy(*),sz(*) integer & i,ix,iy,iz,m,ns if(n <= 0) return if ((incx == 1) .and. (incy == 1) .and. (incz == 1)) & go to 20 if ((incx >= 2) .and. (incx == incy) .and. (incx == incz)) & go to 60 ! ! code for nonequal or nonpositive increments. ! ix = 1 iy = 1 iz = 1 if(incx<0)ix = (-n+1)*incx + 1 if(incy<0)iy = (-n+1)*incy + 1 if(incz<0)iz = (-n+1)*incz + 1 do i = 1,n sz(iz) = sa*sx(ix) + sb*sy(iy) ix = ix + incx iy = iy + incy iz = iz + incz end do return ! ! code for both increments equal to 1 ! ! clean-up loop so remaining vector length is a multiple of 4. ! 20 m = mod(n,4) sz(1:m) = sa * sx(1:m) + sb * sy(1:m) if( n < 4 ) then return end if do i = m + 1, n, 4 sz(i) = sa*sx(i) + sb*sy(i) sz(i+1) = sa*sx(i+1) + sb*sy(i+1) sz(i+2) = sa*sx(i+2) + sb*sy(i+2) sz(i+3) = sa*sx(i+3) + sb*sy(i+3) end do return ! ! code for equal, positive, nonunit increments. ! 60 continue ns = n*incx do i=1,ns,incx sz(i) = sa*sx(i) + sb*sy(i) end do return end subroutine backop ( mspec, nfac, npardf, mbol, mbo, nparma, nparar ) !*****************************************************************************80 ! !! BACKOP computes the number of back order terms for an ARIMA model. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer j ! an index variable. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! integer mspec(4,nfac) ! the array containing the values of p, d, q, and s for each fact ! integer nfac ! the number of factors in the model ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer nparma ! the length of the vector parma ! implicit none integer & mbo,mbol,nfac,nparar,npardf,nparma ! ! array arguments integer & mspec(4,*) ! ! compute degree of back operator resulting from the ndf ! differencing factors (= nd dot iod). ! nparar = dot_product ( mspec(1,1:nfac), mspec(4,1:nfac) ) npardf = dot_product ( mspec(2,1:nfac), mspec(4,1:nfac) ) nparma = dot_product ( mspec(3,1:nfac), mspec(4,1:nfac) ) mbol = npardf + nparar mbo = max ( mbol, nparma ) return end function betai ( x, pin, qin ) !*****************************************************************************80 ! !! BETAI computes the incomplete Beta ratio. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Nancy Bosten, Thomas Aird, ! Remark on Algorithm 179, ! Communications of the ACM, ! Volume 17, page 153, 1974. ! ! Parameters: ! ! x value to which function is to be integrated. x must be in (0,1). ! ! p input (1st) parameter (must be greater than 0) ! ! q input (2nd) parameter (must be greater than 0) ! ! betai incomplete beta function ratio, the probability that a random ! variable from a beta distribution having parameters p and q ! will be less than or equal to x. ! ! implicit none real betai real pin real qin real x real alneps,alnsml,c,eps,fac1,fac2,finsum,p,p1,ps,q,sml,term,xb,y integer i,ib,n ! ! external functions real albeta external albeta data eps, alneps, sml, alnsml / 4*0.0 / if ( eps == 0.0 ) then eps = 0.5 * epsilon ( eps ) alneps = log(eps) sml = tiny ( sml ) alnsml = log(sml) end if if (x<0. .or. x > 1.0) then call xerror ( 'betai x is not in the range (0,1)', 1, 2) end if if (pin <= 0. .or. qin <= 0.) then call xerror ( 'betai p and/or q is le zero', 2, 2) end if y = x p = pin q = qin if ( p < q .or. 0.8 <= x ) then if ( 0.2 <= x ) then y = 1.0 - y p = qin q = pin end if end if !20 continue if ((p+q)*y/(p+1.)= alnsml) then betai = exp(xb) fac2 = 1.0 if (ps /= 1.0e0) then fac1 = 1.0 n = int ( max(alneps/log(y), 4.0e0) ) do i=1,n if (( real ( i ) -ps==0.0e0) .or. (fac1==0.0e0)) then fac1 = 0.0e0 else if (log(abs(fac1)) + log(abs(real ( i ) -ps)) + log(y) - & log(real(i)) < alnsml) then fac1 = 0.0e0 else fac1 = fac1 * ( real ( i ) -ps)*y/ real ( i ) end if end if fac2 = fac2 + fac1*p/(p+real ( i ) ) end do end if betai = betai*fac2 end if ! ! now evaluate the finite sum, maybe. ! if (q <= 1.0) go to 70 xb = p*log(y) + q*log(1.0-y) - albeta(p,q) - log(q) ib = int ( max (xb/alnsml, 0.0) ) term = exp (xb - real ( ib ) * alnsml) c = 1.0/(1.0-y) p1 = q*c/(p+q-1.0) finsum = 0.0 n = int ( q ) if (q== real ( n ) ) n = n - 1 do i=1,n if (p1 <= 1.0 .and. term/eps <= finsum) go to 60 if (q-real ( i ) +1.0e0 == 0.0e0) then term = 0.0e0 else if (log(abs(q-real ( i )+1.0e0)) + log(abs(c)) + log(abs(term)) - & log(abs(p+q-real ( i ))) < alnsml) then term = 0.0e0 else term = (q-real ( i ) +1.0e0)*c*term/(p+q-real ( i ) ) end if end if if (term > 1.0) then ib = ib - 1 term = term*sml end if if ( ib==0 ) then finsum = finsum + term end if end do 60 betai = betai + finsum 70 continue if (y /= x .or. p /= pin) betai = 1.0 - betai betai = max (min (betai, 1.0), 0.0) return 80 continue betai = 0.0 xb = p*log(max(y,sml)) - log(p) - albeta(p,q) if (xb > alnsml .and. y /= 0.) betai = exp (xb) if (y /= x .or. p /= pin) betai = 1.0 - betai return end subroutine bfsdrv ( y1, y2, ymiss1, ymiss2, ccov, nlppc, spcf1, & spcf2, nf, fmin, fmax, freq, n, nw, lagmax, lags, lagmx1, & work, lwork, delta, isym, xaxis, yaxis, lpcv, alpha, nprt, & window, iccov, jccov, m, index1, index2, cspc2, phas, icspc2, & iphas, codd, ceven, w, lw, nmsub, ldsmin, ldstak, option, & nfft, inlppc, jnlppc, ly ) !*****************************************************************************80 ! !! BFSDRV is the driver for time series Fourier spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real bw ! the bandwidth. ! real ccov(iccov,jccov,m) ! the covariances. ! real ceven(lagmx1) ! the sums of the covariances for each lag. ! real codd(lagmx1) ! the differences of the covariances for each lag. ! real cspc2(icspc2,nw) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! real df ! the effective degrees of freedom. ! real fmax, fmin ! the maximum and minimum frequences at which the ! spectrum is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index variable ! integer index1, index2 ! the indices of the covariances of the two series. ! integer inlppc ! the first dimension of the array nlppc. ! integer iphas ! the first dimension of the array phas. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ilog ! a code used to specify the type of plot, where if ! ilog = 0 the plot is linear/linear, if ! ilog = 1 the plot is log/linear, if ! integer ispcer ! an error flag used for the spectrum plots. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer i3c ! statement function for finding locations within ccov. ! integer i3n ! statement function for finding locations within nlppc. ! integer jccov ! the second dimension of ccov ! integer jnlppc ! the second dimension of nlppc ! integer lag ! the lag windwo truncation point used for a specific window. ! integer laglst ! the last lag before missing data caused an acvf ! to be unable to be computed. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! the value lagmax+1. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were computed ! integer n ! the integer number of observations in each series ! logical newpg ! the logical variable used to determine if output ! will begin on a new page (true) or not (false). ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! integer nfused ! the number of frequencies actually used. ! integer nlppc(inlppc,jnlppc,m) ! the array containing the number of lag product pairs. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer npts ! the number of x, y coordinates to be plotted. ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! integer nwused ! the number of different bandwidths actually used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! real phas(iphas,nw) ! the phase component of the bivariate spectrum. ! real spcf1(nf), spcf2(nf) ! the arrays in which the spectrum is stored. ! logical univar ! the logical variable used to determine if the output ! is for univariate (true) or bivariate (false) spectra. ! real w(lw) ! the vector of windows. ! external window ! the subroutine used to compute the window. ! real work(lwork) ! the vector of work space. ! real xaxis(lpcv) ! the x axis values for the spectrum plot. ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real yaxis(lpcv) ! the y axis values for the spectrum plots. ! real ymean1, ymean2 ! the mean of the observed time series ! real ymiss1, ymiss2 ! the user supplied code which is used to determine whether or ! not an observation in the series is missing. if y(i) = ymiss, ! the value is assumed missing, otherwise it is not. ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! real y1(n), y2(n) ! the array containing the observed time series. ! implicit none real & alpha,delta,fmax,fmin,ymiss1,ymiss2 integer & iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, & lagmax,lagmx1,ldsmin,ldstak,lpcv,lw,lwork,ly,m,n,nf,nfft, & nprt,nw ! ! array arguments real & ccov(*),ceven(*),codd(*),cspc2(*),freq(*),phas(*),spcf1(*), & spcf2(*),w(*),work(*),xaxis(*),y1(*),y2(*),yaxis(*) integer & isym(*),lags(*),nlppc(*) logical & option(4) character & nmsub(6)*1 ! ! subroutine arguments external window ! ! scalars in common integer & ierr ! ! real & bw,df,fmn,fmx,xpltmn,xpltmx,ymean1,ymean2,ypltmn,ypltmx integer & i,ilog,ispcer,j,k,lag,laglst,nfused,npts,nwused logical & newpg,univar ! ! external functions integer & lstlag external lstlag ! ! external subroutines external acvf,acvff,acvfm,bfser,bfslag,bfsmn,ccvf,ccvff,ccvfm, & dfbw,dfbwm,setfrq,ufsest,ufsout ! ! common blocks common /errchk/ierr ! ! statement functions integer & i3c,i3n ! ! statement function definitions ! i3c(i,j,k) = i + (j-1)*iccov + (k-1)*jccov*iccov i3n(i,j,k) = i + (j-1)*inlppc + (k-1)*jnlppc*inlppc nfused = nf if (option(4)) then fmn = max(fmin, 0.0e0) fmx = min(fmax, 0.5e0) if (fmn >= fmx) then fmn = 0.0e0 fmx = 0.5e0 end if else ! ! set various values for short forms of call statement ! nprt = -1 fmn = 0.0e0 fmx = 0.5e0 lagmx1 = lagmax + 1 end if ! ! check for errors ! call bfser(nmsub, n, lagmax, iccov, jccov, inlppc, jnlppc, m, & index1, index2, icspc2, iphas, nf, nw, lags, & ldstak, ldsmin, ly, nfft, option) if (ierr==1) return alpha = 0.95e0 delta = 1.0e0 ! ! compute covariances ! laglst = lagmax if (option(1)) then call acvff(y1, n, nfft, ymean1, & ccov(i3c(1,index1,index1)), & lagmax, iccov, n, work, nfft) call acvff(y2, n, nfft, ymean2, & ccov(i3c(1,index2,index2)), & lagmax, iccov, n, work, nfft) call ccvff(y1, y2, n, nfft, lagmax, & ccov(i3c(1,index1,index2)), & ccov(i3c(1,index2,index1)), iccov, n, work, lwork) else if (option(3)) then if (option(2)) laglst = lstlag(nlppc,lagmax,inlppc) else if (option(2)) then call acvfm(y1, ymiss1, n, ymean1, & ccov(i3c(1,index1,index1)), & lagmax, laglst, nlppc, iccov) call acvfm(y2, ymiss2, n, ymean2, & ccov(i3c(1,index2,index2)), & lagmax, laglst, nlppc, iccov) call ccvfm(y1, ymiss1, y2, ymiss2, n, lagmax, ymean1, & ymean2, ccov(i3c(1,index1,index2)), & ccov(i3c(1,index2,index1)), iccov, & nlppc(i3n(1,index1,index2)), & nlppc(i3n(1,index2,index1))) else call acvf(y1, n, ymean1, ccov(i3c(1,index1,index1)), lagmax, & iccov) call acvf(y2, n, ymean2, ccov(i3c(1,index2,index2)), lagmax, & iccov) call ccvf(y1, y2, n, lagmax, ymean1, ymean2, & ccov(i3c(1,index1,index2)), & ccov(i3c(1,index2,index1)), iccov) end if end if end if if (laglst <= 0) then ! ! an error has been detected ! ierr = 2 return end if ! ! compute the vector of lag window truncation points, ordered ! smallest to largest. ! nwused = nw if (.not.option(4)) call bfslag ( ccov, laglst, lags, n, nw, nwused, & iccov, jccov, index1, index2) ! ! begin computing Fourier spectrum for series ! univar = .false. ilog = 0 xpltmn = fmn xpltmx = fmx ypltmn = 0.0e0 ypltmx = 1.0e0 ! ! set frequencies for the spectrum. ! call setfrq(freq, nf, 1, fmn, fmx, delta) ! ! compute and plot spectrum values. ! newpg = .false. ! ! compute the even and odd ccvf estimates ! ceven(1) = ccov(i3c(1,index1,index2)) codd(1) = 0.0e0 do i=1,laglst ceven(i+1) = 0.5e0* & (ccov(i3c(i+1,index1,index2))+ & ccov(i3c(i+1,index2,index1))) codd(i+1) = 0.5e0* & (ccov(i3c(i+1,index1,index2))- & ccov(i3c(i+1,index2,index1))) end do do i = 1, nwused lag = lags(i) if ( laglst < lag ) then ispcer = 2 df = 0.0e0 call ufsout(xaxis, yaxis, isym, npts, bw, int(df+0.5e0), lag, & lagmax, newpg, ispcer, nfused+5, xpltmn, xpltmx, & ypltmn, ypltmx, ilog, phas(1+(i-1)*iphas), freq, & nf, univar, nmsub) newpg = .true. else ispcer = 0 ! ! compute the window, and effective degrees of freedom and ! bandwidth based on the window ! call window(lag, w, lw) if (option(2)) then call dfbwm(n, lag, w, lw, nlppc(i3n(1,index1,index2)), & nlppc(i3n(1,index2,index1)), inlppc, df, bw) else call dfbw(n, lag, w, lw, df, bw) end if ! ! compute the spectrum for each individual series ! call ufsest(ccov(i3c(1,index1,index1)), w, lag, spcf1, & nfused, iccov, lagmax, nf, freq, delta) call ufsest(ccov(i3c(1,index2,index2)), w, lag, spcf2, & nfused, iccov, lagmax, nf, freq, delta) call bfsmn(spcf1, spcf2, ceven, codd, w, lw, lag, df, nprt, & nf, cspc2(1+(i-1)*icspc2), phas(1+(i-1)*iphas), & freq, npts, xaxis, & yaxis, isym, lpcv, alpha, lagmx1, delta) if ( nprt /= 0 ) then call ufsout(xaxis, yaxis, isym, npts, bw, int(df+0.5e0), lag, & lagmax, newpg, ispcer, nfused+5, xpltmn, xpltmx, & ypltmn, ypltmx, ilog, phas(1+(i-1)*iphas), freq, & nf, univar, nmsub) newpg = .true. end if end if end do return end subroutine bfser ( nmsub, n, lagmax, iccov, jccov, inlppc, jnlppc, & m, index1, index2, icspc2, iphas, nf, nw, lags, & ldstak, ldsmin, lyfft, nfft, option ) !*****************************************************************************80 ! !! BFSER checks errors for time series Fourier univariate spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error(30) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index value. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer index1, index2 ! the indices of the covariances of the two series. ! integer inlppc ! the first dimension of the array nlppc. ! integer iphas ! the first dimension of the array phas. ! integer jccov ! the first dimension of the array ccov. ! integer jnlppc ! the first dimension of the array nlppc. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to specify the lag window truncation ! points used for each set of spectrum values. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer ldsmin ! the minimum length allowed for dstak. ! character*1 liccov(8), licspc(8), lindx1(8), ! * lindx2(8), linlpp(8), liphas(8), ljccov(8), ljnlpp(8), ! * llagmx(8), llags(8), llds(8), llgmx1(8), llyfft(8), lm(8), ! * ln(8), lnf(8), lnm1(8), lnw(8), l1(8) ! the array(s) containing the name(s) of the argument(s) ! checked for errors. ! integer lyfft ! the length of vector yfft. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in the series. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the array containing the name of the user called subroutine. ! integer nv ! the number of violations found when checking vector lags. ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! implicit none integer & iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, & lagmax,ldsmin,ldstak,lyfft,m,n,nf,nfft,nw ! ! array arguments integer & lags(*) logical & option(4) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i,nv logical & head ! ! local arrays logical & error(30) character & l1(8)*1,liccov(8)*1,licspc(8)*1,lindx1(8)*1,lindx2(8)*1, & linlpp(8)*1,liphas(8)*1,ljccov(8)*1,ljnlpp(8)*1, & llagmx(8)*1,llags(8)*1,llds(8)*1,llgmx1(8)*1, & llyfft(8)*1,lm(8)*1,ln(8)*1,lnf(8)*1,lnm1(8)*1,lnw(8)*1 ! ! external subroutines external eisge,eisii,eisle,eivii ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data liccov(1), liccov(2), liccov(3), liccov(4), liccov(5), & liccov(6), liccov(7), liccov(8) /'i','c','c','o','v',' ',' ', & ' '/ data licspc(1), licspc(2), licspc(3), licspc(4), licspc(5), & licspc(6), licspc(7), licspc(8) /'i','c','s','p','c','2',' ', & ' '/ data lindx1(1), lindx1(2), lindx1(3), lindx1(4), lindx1(5), & lindx1(6), lindx1(7), lindx1(8) /'i','n','d','e','x','1',' ', & ' '/ data lindx2(1), lindx2(2), lindx2(3), lindx2(4), lindx2(5), & lindx2(6), lindx2(7), lindx2(8) /'i','n','d','e','x','2',' ', & ' '/ data liphas(1), liphas(2), liphas(3), liphas(4), liphas(5), & liphas(6), liphas(7), liphas(8) /'i','p','h','a','s',' ',' ', & ' '/ data linlpp(1), linlpp(2), linlpp(3), linlpp(4), linlpp(5), & linlpp(6), linlpp(7), linlpp(8) /'i','n','l','p','p','c',' ', & ' '/ data ljccov(1), ljccov(2), ljccov(3), ljccov(4), ljccov(5), & ljccov(6), ljccov(7), ljccov(8) /'j','c','c','o','v',' ',' ', & ' '/ data ljnlpp(1), ljnlpp(2), ljnlpp(3), ljnlpp(4), ljnlpp(5), & ljnlpp(6), ljnlpp(7), ljnlpp(8) /'j','n','l','p','p','c',' ', & ' '/ data llagmx(1), llagmx(2), llagmx(3), llagmx(4), llagmx(5), & llagmx(6), llagmx(7), llagmx(8) /'l','a','g','m','a','x',' ', & ' '/ data llags(1), llags(2), llags(3), llags(4), llags(5), llags(6), & llags(7), llags(8) /'l','a','g','s',' ',' ',' ',' '/ data llgmx1(1), llgmx1(2), llgmx1(3), llgmx1(4), llgmx1(5), & llgmx1(6), llgmx1(7), llgmx1(8) /'l','a','g','m','a','x','+', & '1'/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lm(1), lm(2), lm(3), lm(4), lm(5), lm(6), lm(7), lm(8) /'m', & ' ',' ',' ',' ',' ',' ',' '/ data lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), lnf(6), lnf(7), & lnf(8) /'n','f',' ',' ',' ',' ',' ',' '/ data lnm1(1), lnm1(2), lnm1(3), lnm1(4), lnm1(5), lnm1(6), & lnm1(7), lnm1(8) /'n','-','1',' ',' ',' ',' ',' '/ data lnw(1), lnw(2), lnw(3), lnw(4), lnw(5), lnw(6), lnw(7), & lnw(8) /'n','w',' ',' ',' ',' ',' ',' '/ data llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) /'l','y','f','f','t',' ',' ', & ' '/ data l1(1), l1(2), l1(3), l1(4), l1(5), l1(6), l1(7), l1(8) /'1', & ' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. error(1:30) = .false. ! ! call error checking routines ! call eisge(nmsub, ln, n, 17, 1, head, error(1), ln) if ( option(3) ) then call eisii(nmsub, llagmx, lagmax, 1, n-1, 1, head, error(2), l1, & lnm1) call eisge(nmsub, lm, m, 2, 1, head, error(3), lm) call eisge(nmsub, liccov, iccov, lagmax+1, 3, head, error(4), & llgmx1) call eisge(nmsub, ljccov, jccov, m, 4, head, error(5), lm) if (option(2)) then call eisge(nmsub, linlpp, inlppc, lagmax+1, 3, head, error(6), & llgmx1) call eisge(nmsub, ljnlpp, jnlppc, m, 4, head, error(7), lm) end if call eisle(nmsub, lindx1, index1, m, 2, head, error(8), lm) call eisle(nmsub, lindx2, index2, m, 2, head, error(9), lm) end if call eisge(nmsub, llyfft, lyfft, nfft, 9, head, error(10), llyfft) if (option(1) .and. (.not.option(4))) call eisge(nmsub, llds, & ldstak, ldsmin, 9, head, error(15), llds) if ( .not. option(4)) then do i=1,15 if ( error(i) ) then ierr = 1 return end if end do return end if call eisge(nmsub, lnf, nf, 1, 1, head, error(16), lnf) call eisge(nmsub, lnw, nw, 1, 1, head, error(18), lnw) if ( .not. error(18) ) then if (option(3)) then call eivii(nmsub, llags, lags, nw, 1, lagmax, 0, & head, 4, nv, error(19), l1, llagmx) else call eivii(nmsub, llags, lags, nw, 1, n-1, 0, & head, 4, nv, error(19), l1, lnm1) end if end if call eisge(nmsub, licspc, icspc2, nf, 3, head, error(24), lnf) call eisge(nmsub, liphas, iphas, nf, 3, head, error(25), lnf) if (error(2) .or. error(16) .or. error(18) .or. error(19)) then ierr = 1 return end if call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(30), llds) do i=1,30 if (error(i)) then ierr = 1 return end if end do return end subroutine bfs ( y1, y2, n ) !*****************************************************************************80 ! !! BFS: short interface for time series Fourier bivariate spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real ccov(101,2,2) ! the covariances. ! real ceven(101) ! the sums of the autocovariances for each lag. ! real codd(101) ! the differences of the autocovariances for each lag. ! real cspc2(101,4) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer index1, index2 ! the indices of the covariances of the two series. ! integer inlppc ! the first dimension of the array nlppc. ! integer iphas ! the first dimension of the array phas. ! integer isym(404) ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer jnlppc ! the second dimension of the array nlppc. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppc(1,1,1) ! a dummy array. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(101,4) ! the phase component of the bivariate spectra. ! real spcf1(101), spcf2(101) ! the arrays in which the spectrum is stored. ! real w(101) ! the windows. ! real xaxis(404) ! the x axis values for the spectrum plots. ! real yaxis(404) ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! dummy variables. ! real y1(n) ! the first time series. ! real y2(n) ! the second time series. ! implicit none integer n integer ierr real y1(n) real y2(n) real & alpha,delta,fmax,fmin,ymiss1,ymiss2 integer & iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, & lagmax,lagmx1,ldsmin,ldstak,lpcv,lw,ly,m,nf,nprt,nw ! ! local arrays real & ccov(101,2,2),ceven(101),codd(101),cspc2(101,4),freq(101), & phas(101,4),spcf1(101),spcf2(101),w(101),xaxis(404), & yaxis(404) integer & isym(404),lags(4),nlppc(1,1,1) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external bfsdrv,parzen,setlag ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s',' ',' ',' '/ option(1) = .false. option(2) = .false. option(3) = .false. option(4) = .false. iccov = 101 jccov = 2 m = 2 index1 = 1 index2 = 2 icspc2 = 101 iphas = 101 ldstak = 0 ldsmin = 0 nf = 101 ymiss1 = 1.0e0 ymiss2 = 1.0e0 inlppc = 1 jnlppc = 1 lw = 101 ly = n lpcv = 404 ! ! set maximum lag value (lagmax) ! set number of lag window truccation points (nw) ! call setlag(n, lagmax) nw = 4 ! ! call the controling routine for the bivariate spectrum routines ! call bfsdrv(y1, y2, ymiss1, ymiss2, ccov, nlppc, spcf1, spcf2, & nf, fmin, fmax, freq, n, nw, lagmax, lags, lagmx1, w, lw, & delta, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, codd, & ceven, w, lw, nmsub, ldsmin, ldstak, option, n, inlppc, & jnlppc, ly) return end subroutine bfsf ( yfft1, yfft2, n, lyfft, ldstak ) !*****************************************************************************80 ! !! BFSF: short interface for time series Fourier bivariate spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real ccov(101,2,2) ! the covariances. ! real ceven(101) ! the sums of the autocovariances for each lag. ! real codd(101) ! the differences of the autocovariances for each lag. ! real cspc2(101,4) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision ! integer index1, index2 ! the indices of the covariances of the two series. ! integer inlppc ! the first dimension of the array nlppc. ! integer iphas ! the first dimension of the array phas. ! integer isym(404) ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer jnlppc ! the second dimension of the array nlppc. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer lwork ! the length of the vector work. ! integer lyfft ! the length of the vectors y1 and yfft1 and yfft2 ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of stack allocations on entry ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! integer nlppc(1,1,1) ! a dummy array. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(101,4) ! the phase component of the bivariate spectra. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spcf1(101), spcf2(101) ! the arrays in which the spectrum is stored. ! real w(101) ! the windows. ! integer work ! the starting location in the work area for ! the work vector ! real xaxis(404) ! the x axis values for the spectrum plots. ! real yaxis(404) ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! dummy variables. ! real yfft1(lyfft) ! the first time series. ! real yfft2(lyfft) ! the second time series. ! implicit none integer & ldstak,lyfft,n ! ! array arguments real & yfft1(*),yfft2(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,fmax,fmin,ymiss1,ymiss2 integer & iccov,icspc2,ifp,index1,index2,inlppc,iphas,jccov, & jnlppc,lagmax,lagmx1,ldsmin,lpcv,lw,lwork,m,nf,nfft, & nprt,nw,work ! ! local arrays real & ccov(101,2,2),ceven(101),codd(101),cspc2(101,4),freq(101), & phas(101,4),rstak(12),spcf1(101),spcf2(101),w(101), & xaxis(404),yaxis(404) integer & isym(404),lags(4),nlppc(1,1,1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external bfsdrv,ldscmp,parzen,setesl,setlag,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','f',' ',' '/ option(1) = .true. option(2) = .false. option(3) = .false. option(4) = .false. iccov = 101 jccov = 2 m = 2 index1 = 1 index2 = 2 icspc2 = 101 iphas = 101 ldsmin = 0 nf = 101 ymiss1 = 1.0e0 ymiss2 = 1.0e0 inlppc = 1 jnlppc = 1 lw = 101 lpcv = 404 ! ! set maximum lag value (lagmax) ! set number of lag window truccation points (nw) ! set extended series length (nfft) ! call setlag(n, lagmax) nw = 4 call setesl(n+lagmax, 4, nfft) ! ! compute minimum allowable stack length (ldsmin) ! call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin) ! ! set size of work area ! set number of outstanding allocations (nall0) ! set the stack allocation type (ifp) ! call stkset(ldstak, 4) ifp = 3 ! ! set the starting locations inthe work area for various arrays ! if ((ldsmin <= ldstak) .and. (ldsmin >= 7)) then work = stkget(nfft,ifp) lwork = nfft else work = 1 lwork = 1 end if ! ! call the controling routine for the bivariate spectrum routines ! call bfsdrv(yfft1, yfft2, ymiss1, ymiss2, ccov, nlppc, spcf1, & spcf2, nf, fmin, fmax, freq, n, nw, lagmax, lags, & lagmx1, rstak(work), lwork, delta, isym, xaxis, & yaxis, lpcv, alpha, nprt, parzen, iccov, jccov, m, & index1, index2, cspc2, phas, icspc2, iphas, codd, & ceven, w, lw, nmsub, ldsmin, ldstak, option, nfft, & inlppc, jnlppc, lyfft) return end subroutine bfsfs ( yfft1, yfft2, n, lyfft, ldstak, nw, lags, nf, & fmin, fmax, nprt, cspc2, icspc2, phas, iphas, freq ) !*****************************************************************************80 ! !! BFSFS: long interface for time series Fourier bivariate spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! integer ccov, ccov11, ccov12, ccov21, ccov22 ! the starting location in the work area for ! the covariances. ! integer ceven ! the starting location in the work area for ! the sums of the autocovariances for each lag. ! integer codd ! the starting location in the work area for ! the differences of the autocovariances for each lag. ! real cspc2(icspc2,nw) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index value. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer index1, index2 ! the indices of the covariances of the two series. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output requested. ! integer iphas ! the first dimension of the array phas. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer ldsmin ! the minimum length allowed for dstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer lwork ! the length of the vector work. ! integer lyfft ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of stack allocations on entry. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! integer nlppc(1,1,1) ! a dummy array. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(iphas,nw) ! the phase component of the bivariate spectra. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer spcf1, spcf2 ! the starting location in the work area for ! the arrays in which the spectrum is stored. ! integer w ! the starting location in the work area for ! the windows. ! integer work ! the starting location in the work area for the vector work. ! integer xaxis ! the starting location in the work area for ! the x axis values for the spectrum plots. ! integer yaxis ! the starting location in the work area for ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! dummy variables. ! real yfft1(lyfft) ! the first time series. ! real yfft2(lyfft) ! the second time series. ! implicit none real & fmax,fmin integer & icspc2,iphas,ldstak,lyfft,n,nf,nprt,nw ! ! array arguments real & cspc2(*),freq(*),phas(*),yfft1(*),yfft2(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,ymiss1,ymiss2 integer & ccov integer ceven,codd,iccov,ifp, & index1,index2,inlppc,io,isym,jccov,jnlppc,lagmax, & lagmx1,ldsmin,lpcv,lw,lwork,m,nall0,nfft,spcf1,spcf2,w, & work,xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12),nlppc(1,1,1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external bfsdrv,ldscmp,parzen,setesl,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','f','s',' '/ option(1) = .false. option(2) = .false. option(3) = .false. option(4) = .true. ! ! Set maximum lag value to be used. ! if ( 1 <= nw ) then lagmax = maxval ( lags(1:nw) ) else lagmax = n - 1 end if lagmx1 = lagmax + 1 call setesl(n+lagmax, 4, nfft) iccov = lagmax + 1 jccov = 2 inlppc = 1 jnlppc = 1 m = 2 index1 = 1 index2 = 2 ! ! compute the minimum allowable stack area ! if (nprt==0) then io = 0 else io = 1 end if call ldscmp(9, 0, io*4*nf, 0, 0, 0, 's', & 6*lagmax+6+nfft+io*8*nf, ldsmin) ymiss1 = 1.0e0 ymiss2 = 1.0e0 lpcv = 4*nf lw = nfft ! ! set size of work area. ! set the number of outstanding stack allocations (nall0) ! set the stack allocation type (ifp) ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays ! if ((ldsmin > ldstak) .or. ldsmin <= 6 ) then ccov = 1 ceven = 1 codd = 1 spcf1 = 1 spcf2 = 1 w = 1 isym = 1 xaxis = 1 yaxis = 1 else ccov = stkget(4*lagmx1,ifp) ceven = stkget(lagmx1,ifp) codd = stkget(lagmx1,ifp) spcf1 = stkget(nf,ifp) spcf2 = stkget(nf,ifp) w = stkget(lw,ifp) if (nprt==0) then isym = w xaxis = w yaxis = w else isym = stkget(lpcv,2) xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) end if end if work = w lwork = lw ! ! call the controlling routine for the bivariate spectrum routines ! call bfsdrv(yfft1, yfft2, ymiss1, ymiss2, rstak(ccov), nlppc, & rstak(spcf1), rstak(spcf2), nf, fmin, fmax, freq, n, nw, & lagmax, lags, lagmx1, rstak(work), lwork, delta, istak(isym), & rstak(xaxis), rstak(yaxis), lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, & rstak(codd), rstak(ceven), rstak(w), lw, nmsub, ldsmin, & ldstak, option, nfft, inlppc, jnlppc, lyfft) call stkclr(nall0) return end subroutine bfslag ( ccov, lagmax, lags, n, nw, nwused, iccov, & jccov, index1, index2 ) !*****************************************************************************80 ! !! BFSLAG: lag window truncation points for Fourier bivariate spectral analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov(iccov,jccov,*) ! the covariances. ! real covmx ! the maximum covariance value. ! real covmxi ! the maximum covariance value for the ith lag. ! real fac11, fac12, fac21, fac22 ! factors used to compute the correlation coefficients. ! integer iccov ! the first dimension of the array ccov. ! integer index1, index2 ! the indices of the covariances of the two series. ! integer jccov ! the second dimension of the array ccov.. ! integer lag, lagmax ! the indexing variable indicating the lag value of the ! bivariate covariance being computed and the maximum lag ! to be used, respectively. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer n ! the integer number of observations in each series ! integer nw ! the number of different bandwidths requested. ! integer nwused ! the actual number of bandwidths used. ! real p95lim ! the 95 percent confident limit for white noise. ! implicit none integer iccov integer jccov real ccov(iccov,jccov,*) real covmx real covmxi real fac11 real fac12 real fac21 real fac22 integer i integer index1 integer index2 integer j integer k integer lag integer lagmax integer lags(*) integer n integer nw integer nwused real p95lim lags(nw) = lagmax if (lags(nw) <= 32) go to 30 ! ! compute 95 percent confidence limits on bivariatecovariances, ! assuming white noise. ! p95lim = 1.96e0 / sqrt(real(n)) fac11 = ccov(1,index1,index1) fac12 = sqrt(ccov(1,index1,index1)*ccov(1,index2,index2)) fac21 = fac12 fac22 = ccov(1,index2,index2) ! ! Check for first cvf exceeding 95 percent limit on white noise ! do i=1,lagmax lag = lagmax + 1 - i covmxi = max(abs(ccov(lag,index1,index1)*fac11),abs(ccov(lag, & index1,index2)*fac12),abs(ccov(lag,index2,index1)*fac21), & abs(ccov(lag,index2,index2)*fac22)) if (covmxi >= p95lim) go to 30 lags(nw) = lags(nw) - 1 end do ! ! if no acvf exceeds white noise limits, check for largest acvf. ! lags(nw) = 1 covmx = abs(ccov(2,1,1)*fac11) do lag=1,lagmax covmxi = max(abs(ccov(lag,index1,index1)*fac11),abs(ccov(lag, & index1,index2)*fac12),abs(ccov(lag,index2,index1)*fac21), & abs(ccov(lag,index2,index2)*fac22)) if ( covmx < covmxi ) then lags(nw) = lag covmx = covmxi end if end do ! ! compute lag window truncation points ! 30 continue lags(nw) = int ( real ( lags(nw) ) *3.0e0 / 2.0e0 ) if (lags(nw)<32) lags(nw) = 32 if (lags(nw) > lagmax) lags(nw) = lagmax nwused = nw if (nw==1) return do i = 1, nw - 1 k = nw - i lags(k) = lags(k+1)/2 end do ! ! check whether all nw lag window truncation points can be used. ! nwused = nw if (lags(1) >= 4) return ! ! reconsturct -lags- vector if not all truncation points are ! to be used ! do i=2,nw nwused = nwused - 1 if (lags(i) >= 4) then exit end if end do do i=1,nwused j = nw - nwused + i lags(i) = lags(j) end do return end subroutine bfsm ( y1, ymiss1, y2, ymiss2, n ) !*****************************************************************************80 ! !! BFSM: short interface for time series bivariate Fourier spectrum analysis. ! ! Discussion: ! ! This is the user callable routine for time series bivariate ! Fourier spectrum analysis of series with missing observations ! (short call) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real ccov(101,2,2) ! the covariances. ! real ceven(101) ! the sums of the autocovariances for each lag. ! real codd(101) ! the differences of the autocovariances for each lag. ! real cspc2(101,4) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer index1, index2 ! the indices of the covariances of the two series. ! integer inlppc ! the first dimension of the array nlppc. ! integer iphas ! the first dimension of the array phas. ! integer isym(404) ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer jnlppc ! the second dimension of the array nlppc. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppc(101,2,2) ! the number of observations in each covariance estimate ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(101,4) ! the phase component of the bivariate spectra. ! real spcf1(101), spcf2(101) ! the arrays in which the spectrum is stored. ! real w(101) ! the windows. ! real xaxis(404) ! the x axis values for the spectrum plots. ! real yaxis(404) ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! the missing value codes ! real y1(n) ! the first time series. ! real y2(n) ! the second time series. ! implicit none integer n real & ymiss1,ymiss2 real & y1(n),y2(n) ! ! scalars in common integer & ierr ! ! real & alpha,delta,fmax,fmin integer & iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, & lagmax,lagmx1,ldsmin,ldstak,lpcv,lw,ly,m,nf,nprt,nw ! ! local arrays real & ccov(101,2,2),ceven(101),codd(101),cspc2(101,4),freq(101), & phas(101,4),spcf1(101),spcf2(101),w(101),xaxis(404), & yaxis(404) integer & isym(404),lags(4),nlppc(101,2,2) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external bfsdrv,ecvf,parzen,setlag ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','m',' ',' '/ option(1) = .false. option(2) = .true. option(3) = .false. option(4) = .false. iccov = 101 jccov = 2 m = 2 index1 = 1 index2 = 2 icspc2 = 101 iphas = 101 ldstak = 0 ldsmin = 0 nf = 101 inlppc = 101 jnlppc = 2 lw = 101 ly = n lpcv = 404 ! ! LAGMAX is the maximum lag value. ! call setlag ( n, lagmax ) ! ! NW is the number of lag window truncation points. ! nw = 4 ! ! Call the controlling routine for the bivariate spectrum routines. ! call bfsdrv(y1, y2, ymiss1, ymiss2, ccov, nlppc, spcf1, spcf2, & nf, fmin, fmax, freq, n, nw, lagmax, lags, lagmx1, w, lw, & delta, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, codd, & ceven, w, lw, nmsub, ldsmin, ldstak, option, n, inlppc, & jnlppc, ly) if ( ierr /= 0 ) then if ( ierr == 2 ) then call ecvf(nmsub) end if ierr = 1 end if return end subroutine bfsmn ( spcf1, spcf2, ceven, codd, w, lw, lag, df, nprt, & nf, cspc2, phas, freq, npts, xaxis, yaxis, isym, lpcv, alpha, & lagmx1, delta ) !*****************************************************************************80 ! !! BFSMN computes square coherency and phase components of a bivariate spectrum. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Gwilym Jenkins, Donald Watts, ! Spectral Analysis and its Applications, ! Holden-Day 1968. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real arg ! an argument used in the spectrum computations. ! real barl ! the smoothed cospectral estimates. ! real barq ! the smoothed quadrature spectral estimates. ! real bary ! a transformation of the squared coherency component. ! real c ! an argument used in the spectrum computations. ! real ceven(lagmx1) ! the sums of the covariances for each lag. ! real ci ! the confidence interval for the squared coherency component. ! real codd(lagmx1) ! the differences of the autocovariances for each lag. ! real cspc2(nf) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! real df ! the effective degrees of freedom. ! real fplm ! the floating point largest magnitude. ! real freq(nf) ! the frequencies at which the spectrum is computed. ! real g ! an argument used in the computation of the alpha percent ! significance level. ! integer i ! an index value. ! integer isym(lpcv) ! the vector containing the codes for the plot symbols. ! integer k ! an index value. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmx1 ! the value lagmax+1. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of vector w. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nprt ! a code used to specify the type of plot. ! if nprt = 0 the plot is suppressed. ! if nprt = 2 the plot is provided. ! integer npts ! the number of x, y coordinates to be plotted. ! real phas(nf) ! the phase component of the bivariate spectra. ! real pi, pit2 ! the value of pi and pi*2. ! real sn ! an argument used in the computation of the spectrum. ! real spcf1(nf), spcf2(nf) ! the univariate spectrum for each series. ! real v0, v1, v2 ! arguments used in the computation of the spectrum. ! real w(lw) ! the window. ! real xaxis(lpcv) ! the x axis values for the spectrum plots. ! real yaxis(lpcv) ! the y axis values for the spectrum plots. ! real z0, z1, z2 ! arguments used in the computation of the spectrum. ! implicit none real & alpha,delta,df integer & lag,lagmx1,lpcv,lw,nf,nprt,npts ! ! array arguments real & ceven(lagmx1),codd(lagmx1),cspc2(*),freq(*),phas(*),spcf1(*),spcf2(*), & w(lw),xaxis(lpcv),yaxis(lpcv) integer & isym(*) ! ! real & arg,barl,barq,bary,c,ci,fplm,g,pi,pit2,sn,v0, & v1,v2,z0,z1,z2 integer & i,k ! ! external functions real & ppfnml external ppfnml ! ! external subroutines external getpi ! call getpi(pi) pit2 = pi*2.0e0 fplm = huge ( fplm ) ! ! compute smoothed co-spectral estimate ! do i=1,nf ! ! compute smoothed co- and quadrature spectra using ! the algorithm shown on page 420 of jenkins and watts ! if (freq(i)==0.0e0) then c = 1.0e0 sn = 0.0e0 else if (freq(i)==0.25e0) then c = 0.0e0 sn = 1.0e0 else if (freq(i)==0.5e0) then c = -1.0e0 sn = 0.0 else arg = pit2*freq(i) c = cos(arg) sn = sin(arg) end if v0 = 0.0e0 v1 = 0.0e0 z0 = 0.0e0 z1 = 0.0e0 do k=lag-1,1,-1 v2 = 2.0e0*c*v1 - v0 + w(k+1)*ceven(k+1) z2 = 2.0e0*c*z1 - z0 + w(k+1)*codd(k+1) v0 = v1 v1 = v2 z0 = z1 z1 = z2 end do barl = delta*(ceven(1)+2.0e0*(v1*c-v0)) barq = 2.0e0*delta*z1*sn ! ! Compute the smoothed squared coherency spectra. ! if (spcf1(i)*spcf2(i) > 0.0e0) then cspc2(i) = (barl*barl+barq*barq) cspc2(i) = cspc2(i)/(spcf1(i)*spcf2(i)) else cspc2(i) = fplm end if ! ! compute phase (in radians) ! if ((barq /= 0.0e0) .or. (barl /= 0.0e0)) then phas(i) = atan2(-barq,barl) else if (i==1) then phas(i) = 0.0e0 else phas(i) = sign(pi,phas(i-1)) end if end if end do if (nprt==0) return ! ! compute smoothed squared coherency plot vectors ! ci = ppfnml(alpha)*sqrt(1.0e0/df) g = 2.0e0/df g = 1.0e0 - (1.0e0-alpha)**(g/(1.0e0-g)) npts = 0 do i = 1, nf npts = npts + 1 ! ! compute 95 per cent significance level ! yaxis(npts) = g xaxis(npts) = freq(i) isym(npts) = 4 if ( spcf1(i)*spcf2(i) <= 0.0e0 ) then cycle end if ! ! compute coherence spectral estimate ! if ( cspc2(i) > 1.0e0 ) then cycle end if npts = npts + 1 yaxis(npts) = cspc2(i) xaxis(npts) = freq(i) isym(npts) = 1 if (cspc2(i) 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(iphas,nw) ! the phase component of the bivariate spectra. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer spcf1, spcf2 ! the starting location in the work area for ! the arrays in which the spectrum is stored. ! integer w ! the starting location in the work area for ! the windows. ! integer work ! the starting location in the work area for the vector work. ! integer xaxis ! the starting location in the work area for ! the x axis values for the spectrum plots. ! integer yaxis ! the starting location in the work area for ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! dummy variables. ! real y1(n) ! the first time series. ! real y2(n) ! the second time series. ! implicit none real & fmax,fmin,ymiss1,ymiss2 integer & icspc2,iphas,ldstak,n,nf,nprt,nw ! ! array arguments real & cspc2(*),freq(*),phas(*),y1(*),y2(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta integer & ccov,ceven,codd,iccov,ifp,index1,index2,inlppc,io, & isym,jccov,jnlppc,lagmax,lagmx1,ldsmin,lpcv,lw,lwork,ly,m, & nall0,nlppc,spcf1,spcf2,w,work,xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external bfsdrv,ecvf,ldscmp,parzen,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','m','s',' '/ option(1) = .false. option(2) = .true. option(3) = .false. option(4) = .true. ! ! Set maximum lag value to be used (lagmax). ! if ( nw <= 0 ) then lagmax = n - 1 else lagmax = maxval ( lags(1:nw) ) end if lagmx1 = lagmax + 1 iccov = lagmax + 1 jccov = 2 inlppc = lagmax + 1 jnlppc = 2 m = 2 index1 = 1 index2 = 2 ! ! compute the minimum allowable stack area (ldsmin) ! io = 1 if (nprt==0) io = 0 call ldscmp(10, 0, 4*lagmax + 4 + io*4*nf, 0, 0, 0, 's', & 7*lagmax+7+2*nf+io*8*nf, ldsmin) ly = n lpcv = 4*nf lw = lagmx1 ! ! set size of work area. ! set the number of outstanding stack allocations (nall0). ! set the stack allocation type (ifp) ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then ccov = 1 nlppc = 1 ceven = 1 codd = 1 spcf1 = 1 spcf2 = 1 w = 1 isym = 1 xaxis = 1 yaxis = 1 else ccov = stkget(4*lagmx1,ifp) nlppc = stkget(4*lagmx1,2) ceven = stkget(lagmx1,ifp) codd = stkget(lagmx1,ifp) spcf1 = stkget(nf,ifp) spcf2 = stkget(nf,ifp) w = stkget(lw,ifp) if (nprt==0) then isym = w xaxis = w yaxis = w else isym = stkget(lpcv,2) xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) end if end if work = w lwork = lw ! ! call the controling routine for the bivariate spectrum routines ! call bfsdrv(y1, y2, ymiss1, ymiss2, rstak(ccov), istak(nlppc), & rstak(spcf1), rstak(spcf2), nf, fmin, fmax, freq, n, nw, & lagmax, lags, lagmx1, rstak(work), lwork, delta, istak(isym), & rstak(xaxis), rstak(yaxis), lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, & rstak(codd), rstak(ceven), rstak(w), lw, nmsub, ldsmin, & ldstak, option, n, inlppc, jnlppc, ly) call stkclr(nall0) ! ! check for errors ! if (ierr /= 0) then if (ierr==2) call ecvf(nmsub) ierr = 1 end if return end subroutine bfsmv ( ccov, nlppc, index1, index2, n, lagmax, iccov, & jccov, inlppc, jnlppc ) !*****************************************************************************80 ! !! BFSMV: short interface for BFS analysis, missing observations, covariances. ! ! Discussion: ! ! This is the user callable routine for time series bivariate ! Fourier spectrum analysis of series with missing observations ! and covariances input rather than original series ! (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real ccov(iccov,jccov,*) ! the covariances. ! real ceven(101) ! the sums of the autocovariances for each lag. ! real codd(101) ! the differences of the autocovariances for each lag. ! real cspc2(101,4) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer index1, index2 ! the indices of the covariances of the two series. ! integer inlppc ! the first dimension of the array nlppc. ! integer iphas ! the first dimension of the array phas. ! integer isym(404) ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer jnlppc ! the second dimension of the array nlppc. ! integer lagmax, lagmxu ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppc(inlppc,jnlppc,*) ! the number of observations in each covariance estimate ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(101,4) ! the phase component of the bivariate spectra. ! real spcf1(101), spcf2(101) ! the arrays in which the spectrum is stored. ! real w(101) ! the windows. ! real xaxis(404) ! the x axis values for the spectrum plots. ! real yaxis(404) ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! the missing value codes ! real y1(1) ! the first time series. ! real y2(1) ! the second time series. ! implicit none integer & iccov,index1,index2,inlppc,jccov,jnlppc,lagmax,n ! ! array arguments real & ccov(*) integer & nlppc(*) ! ! scalars in common integer & ierr ! ! real & alpha,delta,fmax,fmin,ymiss1,ymiss2 integer & icspc2,iphas,lagmx1,lagmxu,ldsmin,ldstak,lpcv,lw,ly, & m,nf,nprt,nw ! ! local arrays real & ceven(101),codd(101),cspc2(101,4),freq(101),phas(101,4), & spcf1(101),spcf2(101),w(101),xaxis(404),y1(1),y2(1), & yaxis(404) integer & isym(404),lags(4) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external bfsdrv,ecvf,parzen,setlag ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','m','v',' '/ option(1) = .false. option(2) = .true. option(3) = .true. option(4) = .false. m = 2 icspc2 = 101 iphas = 101 ldstak = 0 ldsmin = 0 nf = 101 lw = 101 ly = n lpcv = 404 ! ! set maximum lag value used (lagmxu) ! set number of lag window truccation points (nw) ! call setlag(n, lagmxu) lagmxu = min(lagmxu,lagmax) nw = 4 ! ! call the controling routine for the bivariate spectrum routines ! call bfsdrv(y1, y2, ymiss1, ymiss2, ccov, nlppc, spcf1, spcf2, & nf, fmin, fmax, freq, n, nw, lagmxu, lags, lagmx1, w, lw, & delta, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, codd, & ceven, w, lw, nmsub, ldsmin, ldstak, option, n, inlppc, & jnlppc, ly) if (ierr /= 0) then if (ierr==2) call ecvf(nmsub) ierr = 1 end if return end subroutine bfsmvs ( ccov, nlppc, index1, index2, n, iccov, jccov, & inlppc, jnlppc, nw, lags, nf, fmin, & fmax, nprt, cspc2, icspc2, phas, iphas, freq, ldstak ) !*****************************************************************************80 ! !! BFSMVS: long interface for BFS analysis, missing observations, covariances. ! ! Discussion: ! ! This is the user callable routine for time series bivariate ! Fourier spectrum analysis of series with missing observations ! with user input of the covariances rather than the series ! (long call) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real ccov(iccov,jccov,*) ! the covariances. ! integer ceven ! the starting location in the work area for ! the sums of the autocovariances for each lag. ! integer codd ! the starting location in the work area for ! the differences of the autocovariances for each lag. ! real cspc2(icspc2,nw) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index value. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer index1, index2 ! the indices of the covariances of the two series. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output requested. ! integer iphas ! the first dimension of the array phas. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer lwork ! the length of the vector work. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of stack allocations on entry. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppc(inlppc,jnlppc,*) ! the number of observations in each covariance estimate ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(iphas,nw) ! the phase component of the bivariate spectra. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer spcf1, spcf2 ! the starting location in the work area for ! the arrays in which the spectrum is stored. ! integer w ! the starting location in the work area for ! the windows. ! integer work ! the starting location in the work area for the vector work. ! integer xaxis ! the starting location in the work area for ! the x axis values for the spectrum plots. ! integer yaxis ! the starting location in the work area for ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! dummy variables. ! real y1(1) ! the first time series. ! real y2(1) ! the second time series. ! implicit none real fmax real fmin external parzen integer & iccov,icspc2,index1,index2,inlppc,iphas,jccov,jnlppc, & ldstak,n,nf,nprt,nw ! ! array arguments real & ccov(*),cspc2(*),freq(*),phas(*) integer & lags(*),nlppc(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,ymiss1,ymiss2 integer & ceven,codd,ifp,io,isym,lagmax,lagmx1,ldsmin,lpcv, & lw,lwork,ly,m,nall0,spcf1,spcf2,w,work,xaxis,yaxis ! ! local arrays real & rstak(12),y1(1),y2(1) integer & istak(12) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','m','v','s'/ option(1) = .false. option(2) = .true. option(3) = .true. option(4) = .true. ! ! set maximum lag value to be used (lagmax). ! if ( nw <= 0 ) then lagmax = n - 1 else lagmax = maxval ( lags(1:nw) ) end if lagmx1 = lagmax + 1 m = 2 ! ! compute the minimum allowable stack area (ldsmin) ! io = 1 if (nprt==0) io = 0 call ldscmp(8, 0, io*4*nf, 0, 0, 0, 's', & 7*lagmax+7+2*nf+io*8*nf, ldsmin) ly = n lpcv = 4*nf lw = lagmax + 1 ! ! set size of work area. ! set the number of outstanding stack allocations (nall0). ! set the stack allocation type (ifp) ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then ceven = 1 codd = 1 spcf1 = 1 spcf2 = 1 w = 1 isym = 1 xaxis = 1 yaxis = 1 else ceven = stkget(lagmx1,ifp) codd = stkget(lagmx1,ifp) spcf1 = stkget(nf,ifp) spcf2 = stkget(nf,ifp) w = stkget(lw,ifp) if (nprt==0) then isym = w xaxis = w yaxis = w else isym = stkget(lpcv,2) xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) end if end if work = w lwork = lw ! ! call the controling routine for the bivariate spectrum routines ! call bfsdrv(y1, y2, ymiss1, ymiss2, ccov, nlppc, & rstak(spcf1), rstak(spcf2), nf, fmin, fmax, freq, n, nw, & lagmax, lags, lagmx1, rstak(work), lwork, delta, istak(isym), & rstak(xaxis), rstak(yaxis), lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, & rstak(codd), rstak(ceven), rstak(w), lw, nmsub, ldsmin, & ldstak, option, n, inlppc, jnlppc, ly) call stkclr(nall0) ! ! check for errors ! if (ierr /= 0) then if (ierr==2) call ecvf(nmsub) ierr = 1 end if return end subroutine bfss ( y1, y2, n, nw, lags, nf, fmin, fmax, nprt, cspc2, & icspc2, phas, iphas, freq, ldstak ) !*****************************************************************************80 ! !! BFSS: long call for time series bivariate Fourier spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! integer ccov, ccov11, ccov12, ccov21, ccov22 ! the starting location in the work area for ! the covariances. ! integer ceven ! the starting location in the work area for ! the sums of the autocovariances for each lag. ! integer codd ! the starting location in the work area for ! the differences of the autocovariances for each lag. ! real cspc2(icspc2,nw) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index value. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer index1, index2 ! the indices of the covariances of the two series. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output requested. ! integer iphas ! the first dimension of the array phas. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer ldsmin ! the minimum length allowed for dstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer lwork ! the length of the vector work. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of stack allocations on entry. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppc(1,1,1) ! a dummy array. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt = 0 the plot is suppressed. ! if nprt = 1 the plot is provided. ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(iphas,nw) ! the phase component of the bivariate spectra. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer spcf1, spcf2 ! the starting location in the work area for ! the arrays in which the spectrum is stored. ! integer w ! the starting location in the work area for ! the windows. ! integer work ! the starting location in the work area for the vector work. ! integer xaxis ! the starting location in the work area for ! the x axis values for the spectrum plots. ! integer yaxis ! the starting location in the work area for ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! dummy variables. ! real y1(n) ! the first time series. ! real y2(n) ! the second time series. ! implicit none real fmax real fmin external parzen integer & icspc2,iphas,ldstak,n,nf,nprt,nw ! ! array arguments real & cspc2(*),freq(*),phas(*),y1(*),y2(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,ymiss1,ymiss2 integer & ccov !integer ccov11,ccov12,ccov21,ccov22 integer ceven,codd,iccov,ifp, & index1,index2,inlppc,io,isym,jccov,jnlppc,lagmax, & lagmx1,ldsmin,lpcv,lw,lwork,ly,m,nall0,spcf1,spcf2,w,work, & xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12),nlppc(1,1,1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','s',' ',' '/ option(1) = .false. option(2) = .false. option(3) = .false. option(4) = .true. ! ! set maximum lag value to be used (lagmax). ! if (nw >= 1) then lagmax = maxval ( lags(1:nw) ) else lagmax = n - 1 end if lagmx1 = lagmax + 1 iccov = lagmax + 1 jccov = 2 inlppc = 1 jnlppc = 1 m = 2 index1 = 1 index2 = 2 ! ! compute the minimum allowable stack area (ldsmin) ! io = 1 if (nprt == 0) io = 0 call ldscmp(9, 0, io*4*nf, 0, 0, 0, 's', & 7*lagmax+7+io*8*nf, ldsmin) ly = n ymiss1 = 1.0e0 ymiss2 = 1.0e0 lpcv = 4*nf lw = lagmax + 1 ! ! set size of work area. ! set the number of outstanding stack allocations (nall0). ! set the stack allocation type (ifp) ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then ccov = 1 ceven = 1 codd = 1 spcf1 = 1 spcf2 = 1 w = 1 ! ccov11 = 1 ! ccov21 = 1 ! ccov12 = 1 ! ccov22 = 1 isym = 1 xaxis = 1 yaxis = 1 else ccov = stkget(4*lagmx1,ifp) ceven = stkget(lagmx1,ifp) codd = stkget(lagmx1,ifp) spcf1 = stkget(nf,ifp) spcf2 = stkget(nf,ifp) w = stkget(lw,ifp) ! ccov11 = ccov ! ccov21 = ccov + lagmx1 ! ccov12 = ccov21 + lagmx1 ! ccov22 = ccov12 + lagmx1 if (nprt == 0) then isym = w xaxis = w yaxis = w else isym = stkget(lpcv,2) xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) end if end if work = w lwork = lw ! ! Call the controlling routine for the bivariate spectrum routines ! call bfsdrv(y1, y2, ymiss1, ymiss2, rstak(ccov), nlppc, & rstak(spcf1), rstak(spcf2), nf, fmin, fmax, freq, n, nw, & lagmax, lags, lagmx1, rstak(work), lwork, delta, istak(isym), & rstak(xaxis), rstak(yaxis), lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, & rstak(codd), rstak(ceven), rstak(w), lw, nmsub, ldsmin, & ldstak, option, n, inlppc, jnlppc, ly) call stkclr(nall0) return end subroutine bfsv ( ccov, index1, index2, n, lagmax, iccov, jccov ) !*****************************************************************************80 ! !! BFSV: short call for BFS analysis, with covariance input rather than series. ! ! Discussion: ! ! This is the user callable routine for time series bivariate ! Fourier spectrum analysis of series with ! covariances input rather than original series ! (short call) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real ccov(iccov,jccov,*) ! the covariances. ! real ceven(101) ! the sums of the autocovariances for each lag. ! real codd(101) ! the differences of the autocovariances for each lag. ! real cspc2(101,4) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer index1, index2 ! the indices of the covariances of the two series. ! integer inlppc ! the first dimension of the array nlppc. ! integer iphas ! the first dimension of the array phas. ! integer isym(404) ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer jnlppc ! the second dimension of the array nlppc. ! integer lagmax, lagmxu ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppc(1,1,1) ! a dummy array. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(101,4) ! the phase component of the bivariate spectra. ! real spcf1(101), spcf2(101) ! the arrays in which the spectrum is stored. ! real w(101) ! the windows. ! real xaxis(404) ! the x axis values for the spectrum plots. ! real yaxis(404) ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! the missing value codes ! real y1(1) ! the first time series. ! real y2(1) ! the second time series. ! implicit none integer & iccov,index1,index2,jccov,lagmax,n ! ! array arguments real & ccov(*) ! ! scalars in common integer & ierr ! ! real & alpha,delta,fmax,fmin,ymiss1,ymiss2 integer & icspc2,inlppc,iphas,jnlppc,lagmx1,lagmxu,ldsmin, & ldstak,lpcv,lw,ly,m,nf,nprt,nw ! ! local arrays real & ceven(101),codd(101),cspc2(101,4),freq(101),phas(101,4), & spcf1(101),spcf2(101),w(101),xaxis(404),y1(1),y2(1), & yaxis(404) integer & isym(404),lags(4),nlppc(1,1,1) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external bfsdrv,parzen,setlag ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','v',' ',' '/ option(1) = .false. option(2) = .false. option(3) = .true. option(4) = .false. m = 2 inlppc = 1 jnlppc = 1 icspc2 = 101 iphas = 101 ldstak = 0 ldsmin = 0 nf = 101 lw = 101 ly = n lpcv = 404 ! ! set maximum lag value used (lagmxu) ! set number of lag window truccation points (nw) ! call setlag(n, lagmxu) lagmxu = min(lagmxu,lagmax) nw = 4 ! ! call the controling routine for the bivariate spectrum routines ! call bfsdrv(y1, y2, ymiss1, ymiss2, ccov, nlppc, spcf1, spcf2, & nf, fmin, fmax, freq, n, nw, lagmxu, lags, lagmx1, w, lw, & delta, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, codd, & ceven, w, lw, nmsub, ldsmin, ldstak, option, n, inlppc, & jnlppc, ly) return end subroutine bfsvs ( ccov, index1, index2, n, iccov, jccov, & nw, lags, nf, fmin, fmax, nprt, cspc2, icspc2, phas, iphas, & freq, ldstak ) !*****************************************************************************80 ! !! BFSVS: long call for BFS analsys with covariances input rather than series. ! ! Discussion: ! ! This is the user callable routine for time series bivariate ! Fourier spectrum analysis of series with ! user input of the covariances rather than the series ! (long call) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real alpha ! the desired confidence level. ! real ccov(iccov,jccov,*) ! the covariances. ! integer ceven ! the starting location in the work area for ! the sums of the autocovariances for each lag. ! integer codd ! the starting location in the work area for ! the differences of the autocovariances for each lag. ! real cspc2(icspc2,nw) ! the squared coherency component of the bivariate spectra. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the ! spectrum is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index value. ! integer iccov ! the first dimension of the array ccov. ! integer icspc2 ! the first dimension of the array cspc2. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer index1, index2 ! the indices of the covariances of the two series. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output requested. ! integer iphas ! the first dimension of the array phas. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for ! the array containing the code for the plot symbols. ! integer jccov ! the second dimension of the array ccov. ! integer lagmax ! the maximum lag value to be used. ! integer lagmx1 ! lagmax+1. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lw ! the length of the vector w. ! integer lwork ! the length of the vector work. ! integer ly ! the length of the vectors y1 and y2. ! integer m ! the number of series for which the covariances were ! computed ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of stack allocations on entry. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppc(1,1,1) ! the number of observations in each covariance estimate ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! a code used to specify the type of plot. ! if nprt < 0 the plot is decibels/linear ! if nprt = 0 the plot is suppressed. ! if nprt > 0 the plot is log/linear ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real phas(iphas,nw) ! the phase component of the bivariate spectra. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer spcf1, spcf2 ! the starting location in the work area for ! the arrays in which the spectrum is stored. ! integer w ! the starting location in the work area for ! the windows. ! integer work ! the starting location in the work area for the vector work. ! integer xaxis ! the starting location in the work area for ! the x axis values for the spectrum plots. ! integer yaxis ! the starting location in the work area for ! the y axis values for the spectrum plots. ! real ymiss1, ymiss2 ! dummy variables. ! real y1(1) ! the first time series. ! real y2(1) ! the second time series. ! implicit none real & fmax,fmin integer & iccov,icspc2,index1,index2,iphas,jccov,ldstak,n,nf,nprt,nw ! ! array arguments real & ccov(*),cspc2(*),freq(*),phas(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,ymiss1,ymiss2 integer & ceven,codd,ifp,inlppc,io,isym,jnlppc,lagmax,lagmx1, & ldsmin,lpcv,lw,lwork,ly,m,nall0,spcf1,spcf2,w,work,xaxis, & yaxis ! ! local arrays real & rstak(12),y1(1),y2(1) integer & istak(12),nlppc(1,1,1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external bfsdrv,ldscmp,parzen,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'b','f','s','v','s',' '/ option(1) = .false. option(2) = .false. option(3) = .true. option(4) = .true. ! ! set maximum lag value to be used (lagmax). ! if ( nw <= 0 ) then lagmax = n - 1 else lagmax = maxval ( lags(1:nw) ) end if lagmx1 = lagmax + 1 m = 2 ! ! compute the minimum allowable stack area (ldsmin) ! io = 1 if (nprt == 0) io = 0 call ldscmp(8, 0, io*4*nf, 0, 0, 0, 's', & 3*lagmax+3+2*nf+io*8*nf, ldsmin) inlppc = 1 jnlppc = 1 ly = n lpcv = 4*nf lw = lagmax + 1 ! ! set size of work area. ! set the number of outstanding stack allocations (nall0). ! set the stack allocation type (ifp) ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then ceven = 1 codd = 1 spcf1 = 1 spcf2 = 1 w = 1 isym = w xaxis = w yaxis = w else ceven = stkget(lagmx1,ifp) codd = stkget(lagmx1,ifp) spcf1 = stkget(nf,ifp) spcf2 = stkget(nf,ifp) w = stkget(lw,ifp) if (nprt == 0) then isym = w xaxis = w yaxis = w else isym = stkget(lpcv,2) xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) end if end if work = w lwork = lw ! ! call the controling routine for the bivariate spectrum routines ! call bfsdrv(y1, y2, ymiss1, ymiss2, ccov, nlppc, & rstak(spcf1), rstak(spcf2), nf, fmin, fmax, freq, n, nw, & lagmax, lags, lagmx1, rstak(work), lwork, delta, istak(isym), & rstak(xaxis), rstak(yaxis), lpcv, alpha, nprt, parzen, iccov, & jccov, m, index1, index2, cspc2, phas, icspc2, iphas, & rstak(codd), rstak(ceven), rstak(w), lw, nmsub, ldsmin, & ldstak, option, n, inlppc, jnlppc, ly) call stkclr(nall0) return end subroutine ccfer ( nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, & inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong ) !*****************************************************************************80 ! !! CCFER does error checking for CCF routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical err(15) ! values indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer iccov ! the first dimension of the array ccov. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! integer inlppc ! the first dimension of the array nlppc. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! logical islong ! the indicator variable used to designate whether the calling ! routine has suffix s (islong = true) or not (islong = false) ! integer iym, iymfft ! the first dimension of the arrays ym and ymfft, respectively. ! integer jccov, jnlppc ! the second dimensions of the arrays ccov and nlppc, ! respectively. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 liccov(8), linlpp(8), liym(8), liymff(8), ljccov(8), ! * ljnlpp(8), llagmx(8), llds(8), llgmx1(8), llyfft(8), ! * lm(8), ln(8), lnfft(8), lnm1(8), lone(8), lthree(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer m ! the number of series being analyzed ! integer n ! the integer number of observations in each series ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! implicit none integer & iccov,inlppc,iym,iymfft,jccov,jnlppc,lagmax,ldsmin,ldstak, & lyfft,m,n,nfft logical & isfft,islong ! ! array arguments character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i logical & head ! ! local arrays logical & err(15) character & liccov(8)*1,linlpp(8)*1,liym(8)*1,liymff(8)*1, & ljccov(8)*1,ljnlpp(8)*1,llagmx(8)*1,llds(8)*1, & llgmx1(8)*1,llyfft(8)*1,lm(8)*1,ln(8)*1,lnfft(8)*1, & lnm1(8)*1,lone(8)*1,lthree(8)*1 ! ! external subroutines external eisge,eisii ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & liccov(1), liccov(2), liccov(3), liccov(4), liccov(5), & liccov(6), liccov(7), liccov(8) /'i','c','c','o','v',' ',' ',' '/ data & linlpp(1), linlpp(2), linlpp(3), linlpp(4), linlpp(5), & linlpp(6), linlpp(7), linlpp(8) /'i','n','l','p','p','c',' ',' '/ data & liym(1), liym(2), liym(3), liym(4), liym(5), & liym(6), liym(7), liym(8) /'i','y','m',' ',' ',' ',' ',' '/ data & liymff(1), liymff(2), liymff(3), liymff(4), liymff(5), & liymff(6), liymff(7), liymff(8) /'i','y','m','f','f','t',' ',' '/ data & ljccov(1), ljccov(2), ljccov(3), ljccov(4), ljccov(5), & ljccov(6), ljccov(7), ljccov(8) /'j','c','c','o','v',' ',' ',' '/ data & ljnlpp(1), ljnlpp(2), ljnlpp(3), ljnlpp(4), ljnlpp(5), & ljnlpp(6), ljnlpp(7), ljnlpp(8) /'j','n','l','p','p','c',' ',' '/ data & llagmx(1), llagmx(2), llagmx(3), llagmx(4), llagmx(5), & llagmx(6), llagmx(7), llagmx(8) /'l','a','g','m','a','x',' ',' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & llgmx1(1), llgmx1(2), llgmx1(3), llgmx1(4), llgmx1(5), & llgmx1(6), llgmx1(7), llgmx1(8) /'l','a','g','m','a','x','+','1'/ data & llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) /'l','y','f','f','t',' ',' ',' '/ data & lm(1), lm(2), lm(3), lm(4), lm(5), & lm(6), lm(7), lm(8) /'m',' ',' ',' ',' ',' ',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), & ln(6), ln(7), ln(8) /'n',' ',' ',' ',' ',' ',' ',' '/ data & lnm1(1), lnm1(2), lnm1(3), lnm1(4), lnm1(5), & lnm1(6), lnm1(7), lnm1(8) /'(','n','-','1',')',' ',' ',' '/ data & lnfft(1), lnfft(2), lnfft(3), lnfft(4), lnfft(5), & lnfft(6), lnfft(7), lnfft(8) /'n','f','f','t',' ',' ',' ',' '/ data & lone(1), lone(2), lone(3), lone(4), lone(5), & lone(6), lone(7), lone(8) /'o','n','e',' ',' ',' ',' ',' '/ data & lthree(1), lthree(2), lthree(3), lthree(4), lthree(5), & lthree(6), lthree(7), lthree(8) /'t','h','r','e','e',' ',' ',' '/ ierr = 0 head = .true. err(1:15) = .false. ! ! call error checking routines ! call eisge(nmsub, ln, n, 3, 2, head, err(1), lthree) call eisge(nmsub, lm, m, 1, 2, head, err(2), lone) if (.not.err(1)) then call eisii(nmsub, llagmx, lagmax, 1, n-1, 1, head, err(3), lone, & lnm1) if (isfft) then if (islong) then call eisge(nmsub, liymff, iymfft, nfft, 3, head, err(4), & lnfft) else call eisge(nmsub, llyfft, lyfft, nfft, 3, head, err(4), & lnfft) end if else call eisge(nmsub, liym, iym, n, 3, head, err(4), ln) end if if (.not.err(3)) then if (islong) then call eisge(nmsub, liccov, iccov, lagmax+1, 3, head, err(5), & llgmx1) call eisge(nmsub, ljccov, jccov, m, 3, head, err(6), & llgmx1) call eisge(nmsub, linlpp, inlppc, lagmax+1, 3, head, err(7), & llgmx1) call eisge(nmsub, ljnlpp, jnlppc, m, 3, head, err(8), & llgmx1) end if call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(9), llds) end if end if do i = 1, 15 if (err(i)) ierr = 1 end do return end subroutine ccf ( y1, y2, n ) !*****************************************************************************80 ! !! CCF computes the cross-correlation of two time series. ! ! Discussion: ! ! This is the user callable routine for computing the cross ! correlations of two time series (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov(101, 2, 2) ! the ccvf matrix. ! integer iccov ! the actual first dimension of the array ccov, as ! specified in the users program. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer inlppc ! the actual first dimension of the array nlppc as specifiec ! in the users program. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! logical islong ! the indicator variable used to designate whether the calling ! routine has suffix s (islong = true) or not (islong = false) ! integer iym ! the actual first dimension of the matrix ym as ! specified in the users program. ! integer iymfft ! the actual first dimension of the matrix ymfft as ! specified in the users program. ! integer jccov ! the actual second dimension of the array ccov, as ! specified in the users program. ! integer jnlppc ! the second dimension of the array nlppc as specified ! in the users program. ! integer lagmax ! the number of autocorrelations desired. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the length of the vector yfft. ! integer m ! the number of series being compared, ie the ! number of columns of data in ym. ! integer n ! the integer number of observations in each series ! integer ndum(1) ! a dummy dimensioned variable. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! real rhoc(201) ! the array containing the ccf. ! real sdrhoc(201) ! the array containing the sd of the ccf. ! real y1(n), y1mean, y1sd ! the first series, and its mean and standard deviation. ! real y2(n), y2mean, y2sd ! the second series, and its mean and standard deviation. ! implicit none integer & n ! ! array arguments real & y1(*),y2(*) ! ! scalars in common integer & ierr ! ! real & y1mean,y1sd,y2mean,y2sd integer & iccov,inlppc,iym,iymfft,jccov,jnlppc,lagmax,ldsmin, & ldstak,lyfft,m,nfft logical & isfft,islong ! ! local arrays real & ccov(101,2,2),rhoc(201),sdrhoc(201) integer & ndum(1) character & nmsub(6)*1 ! ! external subroutines external acvf,ccfer,ccfmn,ccfout,setlag ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'c', 'f', ' ', ' ', ' '/ ierr = 0 iccov = 101 inlppc = 1 iym = n jccov = 2 jnlppc = 1 ldsmin = 0 ldstak = 0 lagmax = 1 lyfft = n + lagmax iymfft = lyfft m = 2 nfft = n isfft = .false. islong = .false. ! ! call error checking routines ! call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, & inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong) ! ! check whether an error has been detected ! if (ierr == 0) then ! ! set the maximum lag value to be used. ! call setlag (n, lagmax) ! ! compute the series acvf and sd ! call acvf (y1, n, y1mean, ccov(1,1,1), lagmax, 101) y1sd = sqrt(ccov(1,1,1) * real ( n ) / real ( n - 1 )) call acvf (y2, n, y2mean, ccov(1,2,2), lagmax, 101) y2sd = sqrt(ccov(1,2,2) * real ( n ) / real(n-1) ) ! ! call routine for main autocorrelation computations. ! if (ccov(1,1,1)*ccov(1,2,2) /= 0.0e0) & call ccfmn (y1, y2, n, lagmax, 2*lagmax+1, ccov(1,1,1), & ccov(1,2,2), ccov(1,1,2), ccov(1,2,1), 101, y1mean, y2mean, & rhoc, sdrhoc, 1) ! ! call routine to print out autocorrelations ! call ccfout (1, y1mean, y1sd, n, n, 2, y2mean, y2sd, n, & n, lagmax, 2*lagmax+1, rhoc, sdrhoc, .false., ndum, ndum, 1, & 0.0e0, 0.0e0, .false.) end if if (ierr /= 0) then ierr = 1 end if return end subroutine ccff ( yfft1, yfft2, n, lyfft, ldstak ) !*****************************************************************************80 ! !! CCFF computes the cross-correlation of two time series by Singleton's FFT. ! ! Discussion: ! ! This is the user callable routine for computing the cross ! correlations of two time series using the singleton fft ! (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov(101, 2, 2) ! the ccvf matrix. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer iccov ! the actual first dimension of the array ccov, as ! specified in the users program. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer inlppc ! the actual first dimension of the array nlppc as specifiec ! in the users program. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! logical islong ! the indicator variable used to designate whether the calling ! routine has suffix s (islong = true) or not (islong = false) ! integer iymfft ! the actual first dimension of the matrix ymfft as ! specified in the users program. ! integer jccov ! the actual second dimension of the array ccov, as ! specified in the users program. ! integer jnlppc ! the second dimension of the array nlppc as specified ! in the users program. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the number of locations in the array yfft1 and yfft2. ! integer m ! the number of series being compared, ie the ! number of columns of data in ym. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! integer ndum(1) ! a dummy array. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! real rhoc(201) ! the array containing the ccf. ! real rstak(12) ! the real version of the /cstak/ work area. ! real sdrhoc(201) ! the array containing the sd of the ccf. ! real stak(12) ! the used version of the /cstak/ work area. ! integer work ! the starting location in dstak for ! the work array needed by the fft. ! real yfft1(n), y1mean, y1sd ! the first series, and its mean and standard deviation. ! real yfft2(n), y2mean, y2sd ! the second series, and its mean and standard deviation. ! implicit none integer & ldstak,lyfft,n ! ! array arguments real & yfft1(*),yfft2(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & y1mean,y1sd,y2mean,y2sd integer & iccov,ifp,inlppc,iym,iymfft,jccov,jnlppc,lagmax, & ldsmin,m,nall0,nfft,work logical & isfft,islong ! ! local arrays real & ccov(101,2,2),rhoc(201),rstak(12),sdrhoc(201),stak(12) integer & ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acvff,ccfer,ccfmnf,ccfout,fftlen,ldscmp,setlag, & stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),stak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'c', 'f', 'f', ' ', ' '/ ierr = 0 iccov = 101 inlppc = 1 iym = n jccov = 2 jnlppc = 1 lagmax = 1 iymfft = lyfft m = 2 nfft = n isfft = .true. islong = .false. if (n >= 3) then ! ! set largest lag value to be used ! call setlag(n, lagmax) ! ! set length of the extended series ! call fftlen(n+lagmax, 4, nfft) end if call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin) call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, & inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong) ! ! check whether an error has been detected ! if (ierr == 0) then ! ! set up the work area. ! call stkset (ldstak, 4) nall0 = stkst(1) ifp = 3 work = stkget(nfft, ifp) if (ierr == 0) then ! ! compute the series acvf and sd ! call acvff (yfft1, n, nfft, y1mean, ccov(1,1,1), lagmax, 101, & lyfft, stak(work), nfft) y1sd = sqrt(ccov(1,1,1) * real ( n ) / real (n-1) ) call acvff (yfft2, n, nfft, y2mean, ccov(1,2,2), lagmax, 101, & lyfft, stak(work), nfft) y2sd = sqrt(ccov(1,2,2) * real ( n ) / real (n-1) ) ! ! call routine for main autocorrelation computations. ! if (ccov(1,1,1)*ccov(1,2,2) /= 0.0e0) & call ccfmnf (yfft1, yfft2, n, nfft, lagmax, 2*lagmax+1, & ccov(1,1,1), ccov(1,2,2), ccov(1,1,2), ccov(1,2,1), 101, & rhoc, sdrhoc, 1, lyfft, stak(work), nfft) ! ! call routine to print out autocorrelations ! call ccfout (1, y1mean, y1sd, n, n, 2, y2mean, y2sd, n, & n, lagmax, 2*lagmax+1, rhoc, sdrhoc, .false., ndum, ndum, & 1, 0.0e0, 0.0e0, .false.) end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine ccffs ( ymfft, n, m, iymfft, lagmax, & ccov, iccov, jccov, nprt, ldstak ) !*****************************************************************************80 ! !! CCFFS computes multivariate cross-correlations and covariances by FFT. ! ! Discussion: ! ! This is the user callable routine for computing the cross ! correlations and covariances of a multivariate series using the ! Singleton FFT (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov(iccov, jccov, m) ! the cross covariance matrix. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer iccov ! the actual first dimension of the array ccov, as ! specified in the users program. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer inlppc ! the actual first dimension of the array nlppc as specifiec ! in the users program. ! integer io ! a variable used to determine the amount of storage required, ! based on whether printed output is desired. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! logical islong ! the indicator variable used to designate whether the calling ! routine has suffix s (islong = true) or not (islong = false) ! integer iym ! the actual first dimension of the matrix ym as ! specified in the users program. ! integer iymfft ! the actual first dimension of the matrix ymfft as ! specified in the users program. ! integer i2 ! statement function specifying the desired location within ymfft ! integer i3 ! statement function specifying the desired location within ccov ! integer j ! the index of -series 1- in the array ymfft. ! integer jccov ! the actual second dimension of the array ccov, as ! specified in the users program. ! integer jnlppc ! the second dimension of the array nlppc as specified ! in the users program. ! integer k ! the index of -series 2- in the array ymfft. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the number of locations in each column of ymfft allowed for ! the extended series. ! integer m ! the number of series being compared, ie the ! number of columns of data in ymfft. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! integer ndum(1) ! a dummy dmensioned array. ! logical newpg ! an indicator variable used to determine when a new page ! is appropriate for the output. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nprt ! the indicator variable used to spedify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is given. ! integer rhoc ! the starting location in stak/dstak of the array rhoc. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrhoc ! the starting location in the work area for sdrhoc. ! integer work ! the starging location in dstak of ! the work vector needed by the fft. ! integer ymean, ymeanj, ymeank ! the starting location for the array containing the ! means of each of the series, and the location in ! the array for the mean of the jth and kth series, ! respectively. ! real ymfft(iymfft, m) ! the matrix containing the observed time series ! integer ysd, ysdj, ysdk ! the starting location for the array containing the ! standard deviations of each of the series, and the ! location in the array for the standard deviation of ! the jth and kth series, respectively. ! implicit none integer & iccov,iymfft,jccov,lagmax,ldstak,m,n,nprt ! ! array arguments real & ccov(*),ymfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & i,ifp,inlppc,io,iym,j,jnlppc,k,ldsmin,lyfft,nall0, & nfft,rhoc,sdrhoc,work,ymean,ymeanj,ymeank,ysd,ysdj,ysdk logical & isfft,islong,newpg ! ! local arrays real & rstak(12) integer & ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acvff,ccfer,ccfmnf,ccfout,fftlen,ldscmp,stkclr, & stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! statement functions integer & i2,i3 ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'c', 'f', 'f', 's', ' '/ i2(i,j) = i + (j-1)*iymfft i3(i,j,k) = i + (j-1)*iccov + (k-1)*jccov*iccov ierr = 0 inlppc = iccov iym = iymfft jnlppc = jccov lyfft = iymfft m = 2 isfft = .true. islong = .true. io = 1 if (nprt == 0) io = 0 ! ! set length of extended series ! if ((n >= 3) .and. (lagmax >= 1)) then call fftlen (n+lagmax, 4, nfft) else nfft = n end if call ldscmp(3+2*io, 0, 0, 0, 0, 0, 's', & 2*m+nfft+io*(4*lagmax+2), ldsmin) call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, & inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong) ! ! check whether an error has been detected ! if (ierr == 0) then ! ! set up the work area. ! call stkset (ldstak, 4) nall0 = stkst(1) ifp = 3 ymean = stkget(m, ifp) ysd = stkget(m, ifp) if (nprt == 0) then rhoc = ysd sdrhoc = ysd else rhoc = stkget(2*lagmax+1, ifp) sdrhoc = stkget(2*lagmax+1, ifp) end if work = stkget(nfft, ifp) if (ierr == 0) then ! ! begin loop for computations ! newpg = .false. do k = 1, m ymeank = ymean + k - 1 ysdk = ysd + k - 1 call acvff (ymfft(i2(1,k)), n, nfft, rstak(ymeank), & ccov(i3(1,k,k)), lagmax, iccov, lyfft, & rstak(work), nfft) rstak(ysdk) = sqrt(ccov(i3(1,k,k)) * real ( n ) / real (n - 1)) do j = 1, (k-1) ymeanj = ymean + j - 1 ysdj = ysd + j - 1 call ccfmnf(ymfft(i2(1,j)), ymfft(i2(1,k)), & n, nfft, lagmax, 2*lagmax+1, & ccov(i3(1,j,j)), ccov(i3(1,k,k)), & ccov(i3(1,j,k)), ccov(i3(1,k,j)), & iccov, rstak(rhoc), rstak(sdrhoc), nprt, & lyfft, rstak(work), nfft) ! ! call routine to print out correlations ! if ( nprt /= 0 ) then call ccfout (j, rstak(ymeanj), rstak(ysdj), n, n, k, & rstak(ymeank), rstak(ysdk), n, n, lagmax, 2*lagmax+1, & rstak(rhoc), rstak(sdrhoc), .false., ndum, ndum, 1, & 0.0e0, 0.0e0, newpg) newpg = .true. end if end do end do end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine ccflst ( rhoc, sdrhoc, nlpp12, nlpp21, lagmax, lccov, & ncc, ifmiss ) !*****************************************************************************80 ! !! CCFLST lists cross-correlations, standard errors, and summary information. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real fplm ! the floating point largest magnitude. ! integer i ! an index variable. ! logical ifmiss ! the indicator variable used to determine ! whether the input series has missing data or not. ! integer imax, imin ! the index values of the first and last observation ! to be printed per line ! integer i1 ! an index variable. ! integer k, k0, k1 ! index variables. ! integer lag(12) ! the lag value of the correlation being printed. ! integer lagmax ! the largest lag value to be used. ! integer lagn ! the number of lag values to be printed per line. ! integer lccov ! the number of locations allowed for storing the nlppc. ! integer ncc ! the number of cross correlations computed (from -lagmax ! to +lagmax). ! integer nlplst(12) ! the array which contains the values of nlppc to be printed ! on each line, ordered properly. ! integer nlpp12(lccov), nlpp21(lccov) ! the number of lagged product pairs used to compute each ! ccvf at each lag. ! integer nperl ! the number of values to be printed per line. ! real rhoc(ncc) ! the array in which the autocorrelations or partial ! autocorrelations will be passed to this routine. ! real rlst(12) ! the array which contains the values of rho to be printed ! on each line, ordered properly. ! real sdrhoc(ncc) ! the array in which the standard errors of the autocorrelations ! are stored ! real sdrlst(12) ! the array which contains the values of sdrho to be printed ! on each line, ordered properly. ! implicit none integer & lagmax,lccov,ncc logical & ifmiss ! ! array arguments real & rhoc(ncc),sdrhoc(ncc) integer & nlpp12(lccov),nlpp21(lccov) ! ! real & fplm integer & i,i1,imax,imin,k,k0,k1,lagn,nperl ! ! local arrays real & rlst(12),sdrlst(12) integer & lag(12),nlplst(12) nperl = 12 k0 = lagmax + 1 lagn = mod(lagmax, nperl) if (lagn == 0) lagn = nperl i1 = lagn + 1 do i = i1, k0, nperl do k = 1, lagn lag(k) = i - k0 - k k1 = i - k rlst(k) = rhoc(k1) sdrlst(k) = sdrhoc(k1) if ( ifmiss ) then k1 = k0 - k1 nlplst(k) = nlpp21(k1+1) end if end do write ( *, 1000) (lag(k), k = 1, lagn) write ( *, 1001) (rlst(k), k = 1, lagn) write ( *, 1002) (sdrlst(k), k = 1, lagn) if (ifmiss) write ( *, 1003) (nlplst(k), k = 1, lagn) lagn = nperl end do lag(1) = 0 write ( *, 1000) lag(1) write ( *, 1001) rhoc(k0) write ( *, 1002) sdrhoc(k0) if (ifmiss) write ( *, 1003) nlpp12(1) do i = 1, lagmax, nperl imin = i + k0 imax = min(imin + nperl - 1, 2*lagmax+1) lagn = imax - imin + 1 do k = 1, lagn lag(k) = i - 1 + k end do write ( *, 1000) (lag(k), k = 1, lagn) write ( *, 1001) (rhoc(k), k = imin, imax) write ( *, 1002) (sdrhoc(k), k = imin, imax) if ( ifmiss) then imin = i imax = min(i + nperl - 1, lagmax) write ( *,1003) (nlpp12(k+1), k=imin,imax) end if end do fplm = huge ( fplm ) if (sdrhoc(1) == fplm .or. sdrhoc(2*lagmax+1) == fplm) & write ( *, 1004) fplm return 1000 format(/' lag ', 12(1x, i6)) 1001 format( ' ccf ', 12(2x, f5.2)) 1002 format( ' standard error ', 12(2x, f5.2)) 1003 format( ' no. of obs. used ', 12(1x, i6)) 1004 format(///5x, f5.2, ' indicates value could not be computed', & ' due to missing data.') end subroutine ccfm ( y1, y1miss, y2, y2miss, n ) !*****************************************************************************80 ! !! CCFM computes cross-correlation of two series with missing data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov(101, 2, 2) ! the array used for the ccvf estimates. ! integer iccov ! the actual first dimension of the array ccov, as ! specified in the users program. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer inlppc ! the actual first dimension of the array nlppc as specifiec ! in the users program. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! logical islong ! the indicator variable used to designate whether the calling ! routine has suffix s (islong = true) or not (islong = false) ! integer iym ! the actual first dimension of the matrix ym as ! specified in the users program. ! integer iymfft ! the actual first dimension of the matrix ymfft as ! specified in the users program. ! integer jccov ! the actual second dimension of the array ccov, as ! specified in the users program. ! integer jnlppc ! the second dimension of the array nlppc as specified ! in the users program. ! integer lagmax ! the number of autocorrelations desired. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lglst1, lglst2 ! the lag value of the last acvf which could be computed ! for series 1 and 2, respectively, before missing data ! caused a missing acvf. ! integer lyfft ! the length of the vector yfft. ! integer m ! the number of series being compared, ie the ! number of columns of data in ym. ! integer n ! the integer number of observations in each series ! integer nfft ! the number of observations in the extended series. ! integer nlppc(101, 2, 2) ! the number of lagged product pairs used to compute the ccvf. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nused1, nused2 ! the number of active (non missing) observations in series ! 1 and 2, respectively. ! real rhoc(201) ! the ccf estimates. ! real sdrhoc(201) ! the array containing the sd of the ccfm. ! real y1(n), y1mean, y1miss, y1sd ! the first series, and its mean, missing value code and ! standard deviation. ! real y2(n), y2mean, y2miss, y2sd ! the second series, and its mean, missing value code and ! standard deviation. ! implicit none real & y1miss,y2miss integer & n ! ! array arguments real & y1(*),y2(*) ! ! scalars in common integer & ierr ! ! real & y1mean,y1sd,y2mean,y2sd integer & iccov,inlppc,iym,iymfft,jccov,jnlppc,lagmax,ldsmin, & ldstak,lglst1,lglst2,lyfft,m,nfft,nused1,nused2 logical & isfft,islong ! ! local arrays real & ccov(101,2,2),rhoc(201),sdrhoc(201) integer & nlppc(101,2,2) character & nmsub(6)*1 ! ! external subroutines external acvfm,ccfer,ccfmnm,ccfout,setlag ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'c', 'f', 'm', ' ', ' '/ ierr = 0 iccov = 101 inlppc = 101 iym = n jccov = 2 jnlppc = 2 ldsmin = 0 ldstak = 0 lagmax = 1 lyfft = n + lagmax iymfft = lyfft m = 2 nfft = n isfft = .false. islong = .false. ! ! call error checking routines ! call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, & inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong) ! ! check whether an error has been detected ! if (ierr == 0) then ! ! set the maximum lag value to be used. ! call setlag (n, lagmax) ! ! compute the series acvf and sd ! call acvfm (y1, y1miss, n, y1mean, ccov(1,1,1), lagmax, lglst1, & nlppc(1,1,1), 101) nused1 = nlppc(1,1,1) y1sd = sqrt(ccov(1,1,1) * real ( n ) / real (nused1-1) ) call acvfm (y2, y2miss, n, y2mean, ccov(1,2,2), lagmax, lglst2, & nlppc(1,2,2), 101) nused2 = nlppc(1,2,2) y2sd = sqrt(ccov(1,2,2) * real ( n ) / real (nused2-1) ) ! ! call routine for main autocorrelation computations. ! if (ccov(1,1,1)*ccov(1,2,2) /= 0.0e0) & call ccfmnm (y1, y1miss, y2, y2miss, n, lagmax, 201, & ccov(1,1,1), & ccov(1,2,2), ccov(1,1,2), ccov(1,2,1), 101, nlppc(1,1,1), & nlppc(1,2,2), nlppc(1,1,2), nlppc(1,2,1), 101, y1mean, y2mean, & rhoc, sdrhoc, 1, min(lglst1, lglst2)) ! ! call routine to print out autocorrelations ! call ccfout (1, y1mean, y1sd, n, nused1, 2, y2mean, y2sd, n, & nused2, lagmax, 201, rhoc, sdrhoc, .true., nlppc(1,1,2), & nlppc(1,2,1), 101, y1miss, y2miss, .false.) end if if (ierr /= 0) then ierr = 1 end if return end subroutine ccfmn ( y1, y2, n, lagmax, ncc, ccov11, ccov22, ccov12, & ccov21, lccov, y1mean, y2mean, rhoc, sdrhoc, nprt ) !*****************************************************************************80 ! !! CCFMN is the main routine for cross-correlations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov11(lccov) ! the array in which the autocovariance function estimates ! for the first series is stored. ! real ccov12(lccov), ccov21(lccov) ! the arrays in which the cross covariance function ! estimates for the first series lagged behind the second ! and visa versa, are stored. ! real ccov22(lccov) ! the array in which the autocovariance function estimates ! for the second series is stored. ! real fac ! the inverse of the square root of the product of the ! autocovariances at lag zero. ! integer i ! the indexing variable for the lag value. ! integer im, ip, i0 ! the locations in the ccf related arrays ! of the lag -i, i, and 0, respectively. ! integer lagmax ! the maximum lag value at which the ccvf is to be computed. ! integer lccov ! the dimension of the covariance related arrays. ! integer n ! the integer number of observations in the series ! integer ncc ! the number of ccf computed. ! integer nprt ! the indicator variable used to control computations needed ! only for printed output. ! real rhoc(ncc) ! the array in which the cross correlations are stored ! real sdrhoc(ncc) ! the array containing the std. errors of the cross correlations. ! are stored ! real y1(n), y1mean ! the first series, and its mean. ! real y2(n), y2mean ! the second series, and its mean. ! implicit none real & y1mean,y2mean integer & lagmax,lccov,n,ncc,nprt ! ! array arguments real & ccov11(lccov),ccov12(lccov),ccov21(lccov),ccov22(lccov), & rhoc(ncc),sdrhoc(ncc),y1(n),y2(n) ! ! real & fac integer & i,i0,im,ip ! ! external subroutines external ccfsd,ccvf ! ! compute the cross correlations. ! call ccvf(y1, y2, n, lagmax, y1mean, y2mean, ccov12, ccov21, & lccov) if (nprt == 0 .or. ccov11(1)*ccov22(1) == 0.0e0) return fac = 1.0e0 / sqrt(ccov11(1) * ccov22(1)) i0 = lagmax + 1 rhoc(i0) = ccov12(1) * fac do i = 1, lagmax ip = i0 + i rhoc(ip) = ccov12(i+1) * fac im = i0 - i rhoc(im) = ccov21(i+1) * fac end do ! ! compute standard error of the crosscorrelations. ! call ccfsd ( ccov11, ccov22, sdrhoc, lagmax, ncc, n, lccov ) return end subroutine ccfmnf ( y1, y2, n, nfft, lagmax, ncc, ccov11, ccov22, & ccov12, ccov21, lccov, rhoc, sdrhoc, nprt, lyfft, work, lwork ) !*****************************************************************************80 ! !! CCFMNF is the main routine for cross-correlations using an FFT. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov11(lccov) ! the array in which the autocovariance function estimates ! for the first series is stored. ! real ccov12(lccov), ccov21(lccov) ! the arrays in which the cross covariance function ! estimates for the first series lagged behind the second ! and visa versa, are stored. ! real ccov22(lccov) ! the array in which the autocovariance function estimates ! for the second series is stored. ! real fac ! the inverse of the square root of the product of the ! autocovariances at lag zero. ! integer i ! the indexing variable for the lag value. ! integer im, ip, i0 ! the locations in the ccf related arrays ! of the lag -i, i, and 0, respectively. ! integer lagmax ! the maximum lag value to be used. ! integer lccov ! the dimension of the covarance arrays. ! integer lwork ! the dimension of the work array. ! integer lyfft ! the dimension of the data arrays. ! integer n ! the integer number of observations in the series ! integer ncc ! the number of cross correlations computed. ! integer nfft ! the number of observations in the extended series. ! integer nprt ! the indicator variable used to control computations needed ! only for printed output. ! real rhoc(ncc) ! the array in which the cross correlations are stored ! real sdrhoc(ncc) ! the array containing the std. errors of the cross correlations. ! are stored. ! real work(lwork) ! the work array. ! real y1(lyfft), y2(lyfft) ! the vectors containing the observed series ! implicit none integer & lagmax,lccov,lwork,lyfft,n,ncc,nfft,nprt ! ! array arguments real & ccov11(lccov),ccov12(lccov),ccov21(lccov),ccov22(lccov), & rhoc(ncc),sdrhoc(ncc),work(lwork),y1(lyfft),y2(lyfft) ! ! real & fac integer & i,i0,im,ip ! ! external subroutines external ccfsd,ccvff ! ! compute the cross correlations. ! call ccvff (y1, y2, n, nfft, lagmax, ccov12, ccov21, lccov, lyfft, & work, lwork) if (nprt == 0 .or. ccov11(1)*ccov22(1) == 0.0e0) return fac = 1.0e0 / sqrt(ccov11(1) * ccov22(1)) i0 = lagmax + 1 rhoc(i0) = ccov12(1) * fac do i = 1, lagmax ip = i0 + i rhoc(ip) = ccov12(i+1) * fac im = i0 - i rhoc(im) = ccov21(i+1) * fac end do ! ! compute standard error of the crosscorrelations. ! call ccfsd (ccov11, ccov22, sdrhoc, lagmax, ncc, n, lccov) return end subroutine ccfmnm ( y1, y1miss, y2, y2miss, n, lagmax, ncc, & ccov11, ccov22, ccov12, ccov21, iccov, nlpp11, nlpp22, & nlpp12, nlpp21, inlppc, y1mean, y2mean, rhoc, sdrhoc, nprt, & laglst ) !*****************************************************************************80 ! !! CCFMNM is the main routine for cross-correlations with missing data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov11(iccov), ccov12(iccov) ! real ccov21(iccov), ccov22(iccov) ! the array containing the autocovariance and cross covariance ! estimates for series 1 and 2. ! real fac ! the inverse of the square root of the product of the ! autocovariances at lag zero. ! real fplm ! the floating point largest magnitude. ! integer i ! the indexing variable for the lag. ! integer iccov ! the dimension of the covariance vectors. ! integer im ! the locations in the various ccf related arrays of lag -i. ! integer inlppc ! the dimension of the lagged product pair count vectors. ! integer ip ! the location if the various ccf related arrays of lag i. ! integer i0 ! the location if the various ccf related arrays of lag 0. ! integer laglst ! the last lag before missing data caused the acvf of either ! series 1 or 2 not to be computed. ! integer lagmax ! the maximum lag value to be used. ! integer n ! the integer number of observations in the series ! integer ncc ! the number of cross correlations to be computed. ! integer nlpp11(inlppc), nlpp12(inlppc), nlpp21(inlppc), ! + nlpp22(inlppc) ! the numbers of lagged product pairs used to compute ! the autocovariance and cross covariance estimates. ! integer nprt ! the variable used to control printed output. ! real rhoc(ncc) ! the array in which the auto and cross correlations are stored ! real sdrhoc(ncc) ! the array containing the std. errors of the cross correlations. ! are stored ! real y1(n), y1mean, y1miss ! the first series, and its mean, and missing value code. ! real y2(n), y2mean, y2miss ! the second series, and its mean, and missing value code. ! implicit none real & y1mean,y1miss,y2mean,y2miss integer & iccov,inlppc,laglst,lagmax,n,ncc,nprt ! ! array arguments real & ccov11(iccov),ccov12(iccov),ccov21(iccov),ccov22(iccov), & rhoc(ncc),sdrhoc(ncc),y1(n),y2(n) integer & nlpp11(inlppc),nlpp12(inlppc),nlpp21(inlppc), & nlpp22(inlppc) ! ! real & fac,fplm integer & i,i0,im,ip ! ! external subroutines external ccfsdm,ccvfm ! fplm = huge ( fplm ) ! ! Compute autocorrelations and standard deviation of the series. ! call ccvfm ( y1, y1miss, y2, y2miss, n, lagmax, y1mean, y2mean, & ccov12, ccov21, iccov, nlpp12, nlpp21 ) if (nprt == 0 .or. nlpp11(1) == 0) return if (ccov11(1) *ccov22(1) == 0.0e0) return fac = 1.0e0 / sqrt(ccov11(1) * ccov22(1)) i0 = lagmax + 1 rhoc(i0) = fplm if (nlpp12(1) >= 1) rhoc(i0) = ccov12(1) * fac do i = 1, lagmax ip = i0 + i rhoc(ip) = fplm if (nlpp12(i+1) >= 1) rhoc(ip) = ccov12(i+1) * fac im = i0 - i rhoc(im) = fplm if (nlpp21(i+1) >= 1) rhoc(im) = ccov21(i+1) * fac end do ! ! compute standard error of autocorrelations. ! call ccfsdm (ccov11, ccov22, sdrhoc, lagmax, ncc, laglst, n, & nlpp12, nlpp21, iccov, inlppc) return end subroutine ccfms ( ym, ymmiss, n, m, iym, lagmax, ccov, & cmiss, iccov, jccov, nlppc, inlppc, jnlppc, nprt, ldstak ) !*****************************************************************************80 ! !! CCFMS is a user routine for multivariate cross-correlations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov(iccov, jccov, m) ! the cross covariance matrix. ! real cmiss ! the missing value code for the ccvf estimates. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fplm ! the floating point largest magnitude. ! integer iccov ! the actual first dimension of the array ccov, as ! specified in the users program. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer inlppc ! the actual first dimension of the array nlppc as specifiec ! in the users program. ! integer io ! a variable used to determine the amount of storage required, ! based on whether printed output is desired. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! logical islong ! the indicator variable used to designate whether the calling ! routine has suffix s (islong = true) or not (islong = false) ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer iym ! the actual first dimension of the matrix ym as ! specified in the users program. ! integer iymfft ! the actual first dimension of the matrix ymfft as ! specified in the users program. ! integer i2 ! statement function specifying the desired location within ym ! integer i3c ! statement function specifying the desired location within ccov ! integer i3n ! statement function specifying the desired location within nlppc ! integer j ! the index of -series 1- in the array ym. ! integer jccov ! the actual second dimension of the array ccov, as ! specified in the users program. ! integer jnlppc ! the second dimension of the array nlppc as specified ! in the users program. ! integer k ! the index of -series 2- in the array ym. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lglst, lglstj, lglstk ! the starting location in istak for the array lglst, ! and the locations in lglst in ehich the number of the ! lag of the last acvf which could be computed for series ! j and k, respectively, before a missng acvf (due to missing ! data). ! integer lyfft ! the length of the vector yfft. ! integer m ! the number of series being compared, ie the ! number of columns of data in ym. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! logical newpg ! an indicator variable used to determine when a new page ! is appropriate for the output. ! integer nfft ! the number of observations in the extended series. ! integer nlppc(inlppc, jnlppc, m) ! the array containing the number of lagged product pairs ! used to compute each acvf estimate. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nprt ! the indicator variable used to spedify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is given. ! integer rhoc ! the starting location in dstak of the array rhoc. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrhoc ! the starting location in the work area for sdrhoc. ! real ym(iym, m) ! the matrix containing the observed time series ! integer ymean, ymeanj, ymeank ! the starting location for the array containing the ! means of each of the series, and the location in ! the array for the mean of the jth and kth series, ! respectively. ! real ymmiss(m) ! the missing value codes for each of the series in ym. ! integer ysd, ysdj, ysdk ! the starting location for the array containing the ! standard deviations of each of the series, and the ! location in the array for the standard deviation of ! the jth and kth series, respectively. ! implicit none real & cmiss integer & iccov,inlppc,iym,jccov,jnlppc,lagmax,ldstak,m,n,nprt ! ! array arguments real & ccov(*),ym(*),ymmiss(*) integer & nlppc(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & fplm integer & i,ifp,io,iymfft,j,k,ldsmin,lglst,lglstj,lglstk,lyfft, & nall0,nfft,rhoc,sdrhoc,ymean,ymeanj,ymeank,ysd,ysdj,ysdk logical & isfft,islong,newpg ! ! local arrays real & rstak(12) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acvfm,ccfer,ccfmnm,ccfout,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! statement functions integer & i2,i3c,i3n ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'c', 'f', 'm', 's', ' '/ i2(i,j) = i + (j-1)*iym i3c(i,j,k) = i + (j-1)*iccov + (k-1)*jccov*iccov i3n(i,j,k) = i + (j-1)*inlppc + (k-1)*jnlppc*inlppc ierr = 0 lyfft = n + lagmax iymfft = lyfft nfft = n isfft = .false. islong = .true. io = 1 if (nprt == 0) io = 0 call ldscmp(3+2*io, 0, m, 0, 0, 0, 's', & 2*m+io*(4*lagmax+2), ldsmin) call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, & inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong) ! ! check whether an error has been detected ! if (ierr == 0) then fplm = huge ( fplm ) ! ! set up the work area. ! call stkset (ldstak, 4) nall0 = stkst(1) ifp = 3 ymean = stkget(m, ifp) ysd = stkget(m, ifp) lglst = stkget(m, 2) if (nprt == 0) then rhoc = ysd sdrhoc = ysd else rhoc = stkget(2*lagmax+1, ifp) sdrhoc = stkget(2*lagmax+1, ifp) end if if (ierr == 0) then ! ! begin loop for computations ! newpg = .false. do k = 1, m ymeank = ymean + k - 1 ysdk = ysd + k - 1 lglstk = lglst + k - 1 call acvfm (ym(i2(1,k)), ymmiss(k), n, rstak(ymeank), & ccov(i3c(1,k,k)), lagmax, istak(lglstk), & nlppc(i3n(1,k,k)), lagmax+1) rstak(ysdk) = sqrt(ccov(i3c(1,k,k)) * real ( n ) / real (n - 1)) do j = 1, (k-1) ymeanj = ymean + j - 1 ysdj = ysd + j - 1 lglstj = lglst + j - 1 call ccfmnm (ym(i2(1,j)), ymmiss(j), & ym(i2(1,k)), ymmiss(k), & n, lagmax, 2*lagmax+1, & ccov(i3c(1,j,j)), ccov(i3c(1,k,k)), & ccov(i3c(1,j,k)), ccov(i3c(1,k,j)), iccov, & nlppc(i3n(1,j,j)), nlppc(i3n(1,k,k)), & nlppc(i3n(1,j,k)), nlppc(i3n(1,k,j)), & inlppc, & rstak(ymeanj), rstak(ymeank), rstak(rhoc), & rstak(sdrhoc), & nprt, min(istak(lglstj), istak(lglstk))) if (nprt /= 0) then ! ! Call routine to print out correlations ! call ccfout (j, rstak(ymeanj), rstak(ysdj), n, & nlppc(i3n(1,j,j)), k, rstak(ymeank), & rstak(ysdk), n, nlppc(i3n(1,k,k)), lagmax, & 2*lagmax+1, rstak(rhoc), rstak(sdrhoc), & .true., nlppc(i3n(1,j,k)), & nlppc(i3n(1,k,j)), & inlppc, ymmiss(j), ymmiss(k), newpg) newpg = .true. end if end do end do cmiss = fplm end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine ccfout ( j, ymeanj, ysdj, nj, nusedj, k, ymeank, ysdk, & nk, nusedk, lagmax, ncc, rhoc, sdrhoc, ifmiss, nlpp12, & nlpp21, lccov, ymissj, ymissk, newpg ) !*****************************************************************************80 ! !! CCFOUT prints cross-correlations and standard errors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real fplm ! the floating point largest magnitude. ! logical ifmiss ! the indicator variable used to determine ! whether the input series has missing data or not. ! integer isym(1) ! a dummy array. ! integer j, k ! the subscript values of the two series being compared. ! integer lagmax ! the largest lag value to be used. ! integer lccov ! the number of locations allowed for storing the nlppc. ! integer ncc ! the number of cross correlations computed (from -lagmax ! to +lagmax). ! logical newpg ! an indicator variable used to determine if the output should ! start on a new page. ! integer nj, nk ! the integer number of observations in each series ! integer nlpp12(lccov), nlpp21(lccov) ! the number of lagged product pairs used to compute each ! ccvf at each lag. ! integer nmissj, nmissk ! the number of missing values in each series. ! integer nusedj, nusedk ! the active number of observations in each series. ! real pmissj, pmissk ! the percent of missing observations. ! real rhoc(ncc) ! the array in which the cross correlations are stored ! real sdrhoc(ncc) ! the array in which the standard errors of the autocorrelations ! are stored ! real ymeanj, ymeank ! the mean of each of the series. ! real ymissj, ymissk ! the missing value code for each series. ! real ymmiss(1) ! the missing value code for the cross correlations. ! real ysdj, ysdk ! the standard deviaion of each series. ! implicit none real & ymeanj,ymeank,ymissj,ymissk,ysdj,ysdk integer & j,k,lagmax,lccov,ncc,nj,nk,nusedj,nusedk logical & ifmiss,newpg ! ! array arguments real & rhoc(*),sdrhoc(*) integer & nlpp12(*),nlpp21(*) real & fplm,pmissj,pmissk integer & nmissj,nmissk ! ! local arrays real & ymmiss(1) integer & isym(1) ! ! external subroutines external ccflst,versp,vpmn fplm = huge ( fplm ) ymmiss(1) = fplm ! ! Print summary information. ! if (newpg) write ( *, 1004) call versp (.true.) write ( *, 1005) write ( *, 1000) j, k, ymeanj, ymeank, ysdj, ysdk, nj, nk if ( ifmiss ) then nmissj = nj - nusedj pmissj = 100.0e0 * real ( nmissj ) / real ( nj ) nmissk = nk - nusedk pmissk = 100.0e0 * real ( nmissk ) / real ( nk ) write ( *, 1003) nmissj, nmissk, pmissj, pmissk end if write ( *, 1006) lagmax if (ifmiss) write ( *, 1007) ymissj, ymissk if ( ysdj <= 0.0e0 .or. ysdk <= 0.0e0) then write ( *, 1008) j, k return end if ! ! Print ccf information. ! write ( *, 1002) write ( *, 1001) j, k call ccflst (rhoc, sdrhoc, nlpp12, nlpp21, lagmax, lccov, ncc, & ifmiss) ! ! Plot ccf information. ! write ( *, 1004) call versp (.true.) write ( *, 1001) j, k call vpmn ( rhoc, ymmiss, 2*lagmax+1, 1, 2*lagmax+1, 1, 0, & isym, 1, 0, -1.0e0, 1.0e0, real(-lagmax), 1.0e0, ifmiss, & 0, 0, 1) return 1000 format(/ 42x, 'series ', i2, 5x, 'series ', i2// & ' average of the series = ', 2g14.7/ & ' standard deviation of the series = ', 2g14.7/ & ' number of time points = ', 2(i10, 4x)) 1001 format (' cross correlation function estimate (ccf)'// & ' ccf correlates series ', i2, ' at time t with series ', i2, & ' at time t + k.'/ & 5x, '(if peak correlation occures at positive (negative) lag'/ & 8x, 'then series 1 leads (lags) series 2)') 1002 format(//) 1003 format ( & ' number of missing observations = ', 2(i10, 4x)/ & ' percentage of observations missing = ', 2(f10.4, 4x)) 1004 format ('1') 1005 format ( ' cross correlation analysis') 1006 format(/ & ' largest lag value to be used = ', i10) 1007 format( & ' missing value code = ', 2g14.7) 1008 format (//' cross correlations between series ', i2, ' and ', & i2, ' could not be computed'/ & ' because the lag zero autocovariance of one or both of'/ & ' the series is zero.') end subroutine ccfsd ( ccov11, ccov22, sdrhoc, lagmax, ncc, n, iccov ) !*****************************************************************************80 ! !! CCFSD is the main routine for computing standard error of cross-correlations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov11(iccov), ccov22(iccov) ! the arrays in which the autocovariances are stored ! real div ! the square root of the product of the autocovariance ! function values at lag zero. ! integer iccov ! the dimension of the acvf arrays. ! integer ilast ! the last lag at which the standard error is to be computed. ! integer k ! an index varialbe. ! integer km, kp, k0 ! the locations in the arrays -rhoc- and -sdrhoc- ! of the lag -k, k and 0, respectively. ! integer lagmax ! the maximum lag value used. ! integer n ! the integer number of observations in the series ! integer ncc ! the number of ccf computed. ! real sdrhoc(ncc) ! the array in which the standard errors of the cross correlation ! are stored ! real sum ! a summing variable. ! implicit none integer & iccov,lagmax,n,ncc ! ! array arguments real & ccov11(iccov),ccov22(iccov),sdrhoc(ncc) real & div,sum integer & i,ilast,k,k0,km,kp k0 = lagmax + 1 div = ccov11(1) * ccov22(1) sum = dot_product ( ccov11(2:lagmax+1), ccov22(2:lagmax+1) ) sum = sum / div sdrhoc(k0) = sqrt( real ( n ) + 2.0e0 * sum) / real ( n ) do k = 1, lagmax sum = 0.0e0 ilast = min(lagmax, n-lagmax) do i = 1, ilast sum = sum + real(n-k-i) * ccov11(i+1)*ccov22(i+1) end do sum = sum / div km = k0 - k sdrhoc(km) = sqrt( real(n - k) + 2.0e0 * sum) / real ( n ) kp = k0 + k sdrhoc(kp) = sdrhoc(km) end do return end subroutine ccfsdm ( ccov11, ccov22, sdrhoc, lagmax, ncc, laglst, n, & nlpp12, nlpp21, iccov, inlppc ) !*****************************************************************************80 ! !! CCFSDM: standard error of cross-correlations with missing data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov11(iccov), ccov22(iccov) ! the arrays in which the autocovariances are stored. ! real div ! the square root of the product of the autocovariance ! function values at lag zero. ! real fplm ! the floating point largest magnitude. ! integer i ! indexing variables. ! integer iccov ! the dimension of the covariance vectors. ! integer ilast ! the last lag at which the standard errors are to be computed. ! integer inlppc ! the dimension of the lagged product pair count vectors. ! integer k ! indexing variables. ! integer km, kp, k0 ! the locations in the arrays -rhoc- and -sdrhoc- ! of the lag -k, k and 0, respectively. ! integer laglst ! the last autocorrelation computed before a missing ! autocorrelation was incountered in either series. ! integer lagmax ! the maximum lag value used. ! integer n ! the integer number of observations in the series ! integer ncc ! the number of cross correlations computed. ! integer nlpp12(inlppc), nlpp21(inlppc) ! the arrays in which the number of observations used to ! compute each cross correlation are stored. ! real sdrhoc(ncc) ! the array in which the standard errors of the cross correlation ! are stored ! real sum ! a summing variable. ! implicit none integer & iccov,inlppc,laglst,lagmax,n,ncc ! ! array arguments real & ccov11(iccov),ccov22(iccov),sdrhoc(ncc) integer & nlpp12(inlppc),nlpp21(inlppc) real & div,fplm,sum integer & i,ilast,k,k0,km,kp fplm = huge ( fplm ) div = ccov11(1) * ccov22(1) k0 = lagmax + 1 sum = dot_product ( ccov11(2:laglst+1), ccov22(2:laglst+1) ) sum = sum / div sdrhoc(k0) = fplm if ( 1 <= nlpp12(1) ) then sdrhoc(k0) = sqrt( real ( n ) + 2.0e0 * sum) / real ( nlpp12(1) ) end if do k = 1, lagmax sum = 0.0e0 ilast = min(laglst, n-laglst) do i = 1, ilast sum = sum + real (n-k-i) * ccov11(i+1) * ccov22(i+1) end do sum = sum / div km = k0 - k sdrhoc(km) = fplm if (nlpp21(k+1) >= 1) sdrhoc(km) = & sqrt(real (n - k) + 2.0e0 * sum) * real (n - k) & / real (n * nlpp21(k+1)) kp = k0 + k sdrhoc(kp) = fplm if (nlpp12(k+1) >= 1) sdrhoc(kp) = & sqrt( real (n - k) + 2.0e0 * sum) * real (n - k) & / real ( n * nlpp12(k+1) ) end do return end subroutine ccfs ( ym, n, m, iym, lagmax, ccov, iccov, jccov, & nprt, ldstak ) !*****************************************************************************80 ! !! CCFS is the user routine for multivariate cross-correlations. ! ! Discussion: ! ! This is the user callable routine for computing the cross ! correlations and covariances of a multivariate series (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov(iccov, jccov, m) ! the cross covariance matrix. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer iccov ! the actual first dimension of the array ccov, as ! specified in the users program. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer inlppc ! the actual first dimension of the array nlppc as specifiec ! in the users program. ! integer io ! a variable used to determine the amount of storage required, ! based on whether printed output is desired. ! logical isfft ! the indicator variable used to designate whether the calling ! routine has suffix f (isfft = true) or not (isfft = false) ! logical islong ! the indicator variable used to designate whether the calling ! routine has suffix s (islong = true) or not (islong = false) ! integer iym ! the actual first dimension of the matrix ym as ! specified in the users program. ! integer iymfft ! the actual first dimension of the matrix ymfft as ! specified in the users program. ! integer i2 ! statement function specifying the desired location within ym ! integer i3 ! statement function specifying the desired location within ccov ! integer j ! the index of -series 1- in the array ym. ! integer jccov ! the actual second dimension of the array ccov, as ! specified in the users program. ! integer jnlppc ! the second dimension of the array nlppc as specified ! in the users program. ! integer k ! the index of -series 2- in the array ym. ! integer lagmax ! the maximum lag value requested. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lyfft ! the length of the vector yfft. ! integer m ! the number of series being compared, ie the ! number of columns of data in ym. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of outstanding stack allocations ! integer ndum(1) ! a dummy dimensioned variable. ! logical newpg ! an indicator variable used to determine when a new page ! is appropriate for the output. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutine. ! integer nprt ! the indicator variable used to spedify whether or not ! printed output is to be given, where if the value of ! nprt is zero, no output is given. ! integer rhoc ! the starting location in dstak of the array rhoc. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer sdrhoc ! the starting location in the work area for sdrhoc. ! real ym(iym, m) ! the matrix containing the observed time series ! integer ymean, ymeanj, ymeank ! the starting location for the array containing the ! means of each of the series, and the location in ! the array for the mean of the jth and kth series, ! respectively. ! integer ysd, ysdj, ysdk ! the starting location for the array containing the ! standard deviations of each of the series, and the ! location in the array for the standard deviation of ! the jth and kth series, respectively. ! implicit none integer & iccov,iym,jccov,lagmax,ldstak,m,n,nprt ! ! array arguments real & ccov(*),ym(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer & i,ifp,inlppc,io,iymfft,j,jnlppc,k,ldsmin,lyfft,nall0, & nfft,rhoc,sdrhoc,ymean,ymeanj,ymeank,ysd,ysdj,ysdk logical & isfft,islong,newpg ! ! local arrays real & rstak(12) integer & ndum(1) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acvf,ccfer,ccfmn,ccfout,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! statement functions integer & i2,i3 ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'c', 'f', 's', ' ', ' '/ i2(i,j) = i + (j-1)*iym i3(i,j,k) = i + (j-1)*iccov + (k-1)*jccov*iccov ierr = 0 inlppc = iccov jnlppc = jccov lyfft = n + lagmax iymfft = iym nfft = n isfft = .false. islong = .true. io = 1 if (nprt == 0) io = 0 call ldscmp(2+2*io, 0, 0, 0, 0, 0, 's', & 2*m+io*(4*lagmax+2), ldsmin) call ccfer(nmsub, n, lagmax, ldstak, ldsmin, iccov, jccov, & inlppc, jnlppc, m, lyfft, nfft, iym, iymfft, isfft, islong) ! ! check whether an error has been detected ! if (ierr == 0) then ! ! set up the work area. ! call stkset (ldstak, 4) nall0 = stkst(1) ifp = 3 ymean = stkget(m, ifp) ysd = stkget(m, ifp) if (nprt == 0) then rhoc = ysd sdrhoc = ysd else rhoc = stkget(2*lagmax+1, ifp) sdrhoc = stkget(2*lagmax+1, ifp) end if if (ierr == 0) then ! ! begin loop for computations ! newpg = .false. do k = 1, m ymeank = ymean + k - 1 ysdk = ysd + k - 1 call acvf (ym(i2(1,k)), n, rstak(ymeank), & ccov(i3(1,k,k)), lagmax, iccov) rstak(ysdk) = sqrt(ccov(i3(1,k,k)) * real ( n ) / real ( n - 1 ) ) do j = 1, (k-1) ymeanj = ymean + j - 1 ysdj = ysd + j - 1 call ccfmn (ym(i2(1,j)), ym(i2(1,k)), & n, lagmax, 2*lagmax+1, & ccov(i3(1,j,j)), ccov(i3(1,k,k)), & ccov(i3(1,j,k)), ccov(i3(1,k,j)), & iccov, rstak(ymeanj), rstak(ymeank), & rstak(rhoc), rstak(sdrhoc), nprt) if (nprt /= 0) then ! ! call routine to print out correlations ! call ccfout (j, rstak(ymeanj), rstak(ysdj), n, n, k, & rstak(ymeank), rstak(ysdk), n, n, lagmax, 2*lagmax+1, & rstak(rhoc), rstak(sdrhoc), .false., ndum, ndum, 1, & 0.0e0, 0.0e0, newpg) newpg = .true. end if end do end do end if call stkclr(nall0) end if if (ierr /= 0) then ierr = 1 end if return end subroutine ccfxp ( store, lagmax, m, ccov, iccov, jccov, miss, & nlppc, inlppc, jnlppc, cmiss ) !*****************************************************************************80 ! !! CCFXP lists results for the time series cross-correlation routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccf(16) ! an array used for printing the ccf. ! real ccov(iccov,jccov,m) ! the cross covariance array. ! real cmiss ! the missing value code for the returned ccvf estimates ! (vector ccov). ! integer i ! an indexing variable. ! integer iccov ! the first dimension of the array ccov. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! integer inlppc ! the first dimension of the array nlppc. ! integer j ! an indexing variable. ! integer jccov, jnlppc ! the second dimensions of the arrays ccov and nlppc, ! respectively. ! integer k ! an indexing variable. ! integer l1 ! an index variable. ! integer lag ! the lag value at which the data is being printed. ! integer lagmax ! the maximum lag value requested. ! integer m ! the number of series in the multivariate time series ym. ! logical miss ! the value indicating whether the analysis included missing ! data (true) or not (false). ! integer nlppc(inlppc,jnlppc,m) ! the array containing the number of lagged product pairs ! used to compute each ccvf estimate. ! logical store ! the value indicating whether the results were returned ! to the user (true) or not (false). ! implicit none real & cmiss integer & iccov,inlppc,jccov,jnlppc,lagmax,m logical & miss,store ! ! array arguments real & ccov(iccov,jccov,*) integer & nlppc(inlppc,jnlppc,*) ! ! scalars in common integer & ierr ! ! integer & i,j,k,l,l1,lag ! ! local arrays real & ccf(16) ! ! external functions logical & mvchk external mvchk ! ! common blocks common /errchk/ierr write ( *, 1000) ierr if (ierr /= 0) then return end if ! ! Check for stored results ! if ( .not. store ) then return end if ! ! print heading for ccvf ! write ( *, 1010) write ( *, 1040) ((j,k, k=1,m), j=1,m) ! ! print cross covariances ! lag = 0 write ( *, 1060) lag, ((ccov(1,j,k), k=1,m), j=1,m) do lag = 1, lagmax write ( *, 1060) lag, ((ccov(lag+1,j,k), k=1,m), j=1,m) end do ! ! print heading for ccf ! write ( *, 1020) write ( *, 1040) ((j,k, k=1,m), j=1,m) ! ! print cross correlations ! lag = 0 i = 0 do j = 1, m do k = 1, m i = i + 1 ccf(i) = ccov(1,j,k) / sqrt(ccov(1,j,j)*ccov(1,k,k)) end do end do write ( *, 1060) lag, (ccf(l), l=1,i) do lag = 1, lagmax i = 0 do j = 1, m do k = 1, m i = i + 1 if ( miss .and. mvchk ( ccov(lag+1,j,k), cmiss ) ) then ccf(i) = cmiss else ccf(i) = ccov(lag+1,j,k) / sqrt(ccov(1,j,j)*ccov(1,k,k)) end if end do end do write ( *, 1060) lag, (ccf(l1), l1=1,i) end do ! ! Check for missing values ! if ( .not. miss ) then return end if ! ! print heading for numbers of lagged product pairs ! write ( *, 1030) write ( *, 1040) ((j,k, k=1,m), j=1,m) ! ! print numbers of lagged product pairs for each ccvf ! lag = 0 write ( *, 1070) lag, ((nlppc(1,j,k), k=1,m), j=1,m) do lag = 1, lagmax write ( *, 1070) lag, ((nlppc(lag+1,j,k), k=1,m), j=1,m) end do return 1000 format (//' ierr = ', i5) 1010 format (// 6x, ' ccvf') 1020 format (// 6x, ' ccf') 1030 format (// 6x, ' nlppc') 1040 format (1x, 'lag', 16(5x, i1, ',', i1)) 1060 format (1x, i3, 16f8.4) 1070 format (1x, i3, 16i8) end subroutine ccvf ( y1, y2, n, lagmax, y1mean, y2mean, ccov12, ccov21, iccov ) !*****************************************************************************80 ! !! CCVF computes the cross covariance function between two series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov12(iccov), ccov21(iccov) ! the arrays in which the ccvf for series 1 lagged ! behind series 2 and visa versa, respectively, are ! stored. ! real dotxy ! various cross pruducts between series y1 and y2. ! integer iccov ! the row dimension of the arrays ccov12 and ccov21. ! integer lag ! the indexing variable indicating the lag value of the ! autocorrelation being computed. ! integer lagmax ! the maximum number of lags to be used. ! integer n ! the integer number of observations in the series ! integer ndotxy ! the number of observations used to compute dotxy. ! real y1(n), y1mean ! the first series, and its mean. ! real y2(n), y2mean ! the second series, and its mean. ! implicit none real & y1mean,y2mean integer & iccov,lagmax,n ! ! array arguments real & ccov12(iccov),ccov21(iccov),y1(n),y2(n) ! ! real & dotxy integer & lag,ndotxy ! ! external subroutines external dotc ! ! Compute the cross covariances ! call dotc ( y1, y1mean, n, y2, y2mean, n, dotxy, ndotxy) ccov12(1) = dotxy / real ( n ) ccov21(1) = ccov12(1) do lag = 1, lagmax call dotc (y1, y1mean, n, y2(lag + 1), y2mean, n - lag, dotxy, ndotxy) ccov12(lag+1) = dotxy / real ( n ) call dotc (y2, y2mean, n, y1(lag + 1), y1mean, n - lag, dotxy, ndotxy) ccov21(lag+1) = dotxy / real ( n ) end do return end subroutine ccvff ( yfft1, yfft2, n, nfft, lagmax, ccov12, ccov21, & iccov, lyfft, work, lwork ) !*****************************************************************************80 ! !! CCVFF computes the cross covariance function between two series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov12(iccov), ccov21(iccov) ! the arrays in which the ccvf for series 1 lagged ! behind series 2 and visa versa, respectively, are stored. ! real fac ! the appropriate factor used to scale the ccvf. ! integer i ! an index variable. ! integer iccov ! the dimension of the arrays ccov12 and ccov21. ! integer lag, lagmax ! the indexing variable indicating the lag value of the ! cross correlation being computed, and the maximum lag ! value to be used. ! integer lwork ! the dimension of the vector work. ! integer lyfft ! the actual length of the arrays yfft1 and yfft2. ! integer n ! the integer number of observations in the series ! integer nf ! the number of Fourier frequencies. ! integer nfft ! the number of observations in the extended series. ! integer nfft2 ! the effective number of observations for the fft transform. ! integer nf2 ! twice the number of Fourier frequencies. ! real work(lwork) ! the work array needed for the computations. ! real yfft1(lyfft), yfft2(lyfft) ! the vectors containing the observed series already processed ! by one pass of a fft ! implicit none integer & iccov,lagmax,lwork,lyfft,n,nfft ! ! array arguments real & ccov12(iccov),ccov21(iccov),work(lwork),yfft1(lyfft), & yfft2(lyfft) real & fac integer & i,isn,j,lag,nf,nf2,nfft2 ! ! external subroutines external fft,realtr ! nfft2 = (nfft-2) / 2 nf = nfft2 + 1 nf2 = nf * 2 ! ! Compute the cross covariances ! do i = 2, nf2, 2 work(i-1) = yfft1(i-1)*yfft2(i-1) + yfft1(i)*yfft2(i) work(i) = yfft1(i)*yfft2(i-1) - yfft1(i-1)*yfft2(i) end do fac = 1.0e0 / real ( 4 * ( nfft - 2 ) * n ) isn = -2 call realtr (work, work(2), nfft2, isn) call fft (work, work(2), nfft2, nfft2, nfft2, isn) ccov12(1) = work(1) * fac ccov21(1) = ccov12(1) do lag = 1, lagmax ccov21(lag+1) = work(lag+1) * fac j = nfft - 1 - lag ccov12(lag+1) = work(j) * fac end do return end subroutine ccvfm ( y1, y1miss, y2, y2miss, n, nc, y1mean, y2mean, & ccov12, ccov21, iccov, nlpp12, nlpp21 ) !*****************************************************************************80 ! !! CCVFM computes the cross covariance function of two series with missing data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ccov12(iccov), ccov21(iccov) ! the arrays in which the ccvf for series 1 lagged ! behind series 2 and visa versa, respectively, are ! stored. ! real dotxy ! various cross pruducts between series y1 and y2. ! real fplm ! the floating point largest magnitude. ! integer iccov ! the row dimension of the arrays ccov12 and ccov21. ! integer lag ! the indexing variable indicating the lag value of the ! autocorrelation being computed. ! integer n ! the integer number of observations in the series ! integer nc ! the number of cross correlations desired. ! integer nlpp12(iccov), nlpp21(iccov) ! the number of lagged product pairs used to compute the ccvf ! for each pair of series at each lag. ! integer ndotxy ! the number of observations used to compute dotxy. ! real y1(n), y1mean, y1miss ! the first series, and its mean, and missing value code. ! real y2(n), y2mean, y2miss ! the second series, and its mean, and missing value code. ! implicit none real & y1mean,y1miss,y2mean,y2miss integer & iccov,n,nc ! ! array arguments real & ccov12(iccov),ccov21(iccov),y1(n),y2(n) integer & nlpp12(iccov),nlpp21(iccov) real & dotxy,fplm integer & lag,ndotxy ! ! external subroutines external dotcm ! fplm = huge ( fplm ) ! ! Compute the cross covariances ! call dotcm (y1, y1mean, y1miss, n, y2, y2mean, y2miss, n, dotxy, & ndotxy) nlpp12(1) = ndotxy ccov12(1) = fplm if (ndotxy >= 1) ccov12(1) = dotxy / real ( ndotxy ) ccov21(1) = ccov12(1) nlpp21(1) = ndotxy do lag = 1, nc call dotcm (y1, y1mean, y1miss, n, y2(lag+1), y2mean, y2miss, & n-lag, dotxy, ndotxy) nlpp12(lag+1) = ndotxy ccov12(lag+1) = fplm if (ndotxy >= 1) & ccov12(lag+1) = dotxy * real (n-lag) / real (n*ndotxy) call dotcm (y2, y2mean, y2miss, n, y1(lag+1), y1mean, y1miss, & n-lag, dotxy, ndotxy) nlpp21(lag+1) = ndotxy ccov21(lag+1) = fplm if (ndotxy >= 1) & ccov21(lag+1) = dotxy * real (n-lag) / real ( n * ndotxy ) end do return end function cdfchi ( chisqr, df ) !*****************************************************************************80 ! !! CDFCHI computes the CDF for the Chi Square distribution. ! ! Discussion: ! ! This routine computes the chi square cumulative distribution ! function from the incomplete gamma function ratio as discussed in ! chapter 17 of distributions in statistics - continuous univariate ! distributions - 1, by Johnson and Kotz. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real chisqr ! the percent point from the chi squared distribution. ! real df ! the degrees of freedom. ! real fplpm ! the real floating point largest positive magnitude. ! implicit none real cdfchi real chisqr real df real fplpm real gami logical mvchk fplpm = huge ( fplpm ) cdfchi = gami(0.5e0*df, 0.5e0*chisqr) if (mvchk(cdfchi,fplpm)) then cdfchi = 1.0e0 else cdfchi = cdfchi / gamma(0.5e0*df) if (cdfchi<0.0e0) cdfchi = 0.0e0 if (cdfchi > 1.0e0) cdfchi = 1.0e0 end if return end function cdff ( f, df1, df2 ) !*****************************************************************************80 ! !! CDFF computes the CDF for the F distribution. ! ! Discussion: ! ! This routine computes the cumulative distribution function for ! the F distribution. The approximation used depends on the ! degrees of freedom in the numerator and denominator. ! ! 1. If both degrees of freedom are small (less than 4000), ! the CDF is computed from the incomplete Beta function ! using equation 5.45 of Statistical Computing, by Kennedy and ! Gentle. ! ! 2. if one of the degrees of freedom is large (greater than or ! equal to 4000) and the other is moderately large (greater than ! or equal to 100), the cdf is approximated by a normal distrib- ! bution as shown in equation 20 on page 83 of distributions in ! statistics - continuous univariate distributions - 2, by ! johnson and kotz. ! ! 3. if one of the degrees of freedom is small (less than 100) and ! the other is large (exceeding 4000), the cdf is approximated ! by a chi squared distribution as shown in the third equation ! on page 84 of distributions in statistics - continuous ! univariate distributions - 2, by johnson and kotz. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real df1 ! the degrees of freedom in the numerator. ! real df2 ! the degrees of freedom in the denominator. ! real f ! the percentage point from the f distribution. ! real ftrans ! transforms of the f percentage point, used for the various ! approximating distributions. ! implicit none real cdff real & df1,df2,f ! ! real & ftrans ! ! external functions real & betai,cdfchi,cdfnml external betai,cdfchi,cdfnml if ( f <= 0.0e0 ) then cdff = 0.0e0 return end if ! ! both degrees of freedom are less than or equal to 4000. use ! the incomplete beta function to compute the f cdf. ! if ( df1 <= 4000.0e0 .and. df2 <= 4000.0e0 ) then ftrans = df2 / (df2 + df1 * f) cdff = 1.0e0 - betai(ftrans, 0.5e0*df2, 0.5e0*df1) return end if ! ! both degrees of freedom exceed 4000. use the normal approximation ! to compute the f cdf. ! if ( 100.0e0 < df1 .and. 100.0e0 < df2 ) then ftrans = & (((1.0e0-(2.0e0/(9.0e0*df2)))* & (f**(1.0e0/3.0e0)))-(1.0e0-(2.0e0/(9.0e0*df1)))) / & sqrt(((f**(2.0e0/3.0e0))/(4.5e0*df2))+(2.0e0/(9.0e0*df1))) cdff = cdfnml(ftrans) return end if ! ! the degrees of freedom in the denominator exceeds 4000 and the ! degrees of freedom in numerator is less than or equal to 100. ! use the chi square approximation to compute the f cdf. ! if ( df1 <= 100.0e0 ) then ftrans = & (df1 + (df1/df2)*(0.5e0*df1-1.0e0))/ & ((1.0e0/f)+(df1/df2)*0.5e0) cdff = cdfchi(ftrans, df1) return end if ! ! the degrees of freedom in the numerator exceeds 4000 and the ! degrees of freedom in denominator is less than or equal to 100. ! use the chi square approximation to compute the f cdf. ! ftrans = & (df2+(df2/df1)*(0.5e0*df2-1.0e0))/(f+(df2/df1)*0.5e0) cdff = 1.0e0 - cdfchi(ftrans, df2) return end function cdfnml ( x ) !*****************************************************************************80 ! !! CDFNML computes the CDF for the standard normal distribution. ! ! Discussion: ! ! This routine computes the normal cumulative distribution ! function from the error function as described in chapter 13 ! of distributions in statistics - continuous univariate ! distributions - 1, by Johnson and Kotz. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real x ! the percent point from the chi squared distribution. ! implicit none real cdfnml real x cdfnml = 0.5e0 * (1.0e0 + erf (x/sqrt(2.0e0))) return end function cdft ( x, idf ) !*****************************************************************************80 ! !! CDFT computes the CDF for Student's T distribution. ! ! Discussion: ! ! This routine computes the cumulative distribution function value ! for Student's T distribution with integer degrees of freedom ! parameter = idf. ! ! This distribution is defined for all X. ! The probability density function is given ! in the references below. ! ! Author: ! ! James Filliben, ! Statistical Engineering Laboratory, ! National Bureau of Standards, ! Washington, DC 20234. ! ! Reference: ! ! Formulas 26.7.3 and 26.7.4, ! Milton Abramowitz, Irene Stegun, ! Handbook of Mathematical Functions, ! National Bureau of Standards, 1964, ! LC: QA47.A34,
! ISBN: 0-486-61272-4. ! ! Enrico Federghi, ! Extended Tables of the Percentage Points of Student's T-Distribution, ! Journal of the American Statistical Association, ! Volume 54, Number 287, 1959, pages 683-688. ! ! Johnson, Kotz, ! Continuous Univariate Distributions, ! 1970, pages 94-129. ! ! Owen, ! Handbook of Statistical Tables, ! 1962, pages 27-30. ! ! Pearson, Hartley, ! Biometrika Tables for Statisticians, ! volume 1, 1954, pages 132-134. ! ! Parameters: ! ! input arguments--x = the value at ! which the cumulative distribution ! function is to be evaluated. ! x should be non-negative. ! ! --idf = the integer number of degrees ! of freedom. ! idf should be positive. ! ! output arguments--cdf = the single precision cumulative ! distribution function value. ! ! output--the single precision cumulative distribution ! function value cdf for the student"s t distribution ! with degrees of freedom parameter = idf. ! ! Local Parameters: ! ! real b11, b21, b22, b23, b24, b25 ! constants used in the computations. ! real b31, b32, b33, b34, b35, b36, b37 ! constants used in the computations. ! real df ! the degrees of freedom. ! real d1, d11, d3, d5, d7, d9 ! constants used in the computations. ! real fpspm ! the floating point smallest positive magnitude. ! integer i ! an index. ! integer idf ! the degrees of freedom. ! real x ! the t statistic. ! implicit none real cdft integer idf real x real & b11,b21,b22,b23,b24,b25,b31,b32,b33,b34,b35,b36,b37,c,csq,d1, & d11,d3,d5,d7,d9,dconst,df,fpspm,pi,sd,sum,term,term1,term2, & term3,z integer & i,idfcut,ievodd,imax,imin ! ! external functions real & cdfnml external cdfnml data idfcut /1000/ data dconst /0.3989422804e0/ data b11 /0.25e0/ data b21 /96.0e0/ ! data b21 /0.01041666666667e0/ data b22, b23, b24, b25 /3.0e0,-7.0e0,-5.0e0,-3.0e0/ data b31 /0.00260416666667e0/ data b32, b33, b34, b35, b36, b37 & /1.0e0,-11.0e0,14.0e0,6.0e0,-3.0e0,-15.0e0/ call getpi(pi) fpspm = tiny ( fpspm ) ! ! check the input arguments for errors ! if (idf <= 0) then write ( *, 1000) write ( *, 1010) idf cdft = 0.0e0 return end if df = real ( idf ) ! ! if idf is 3 through 9 and x is more than 3000 ! standard deviations below the mean, ! set cdft = 0.0e0 and return. ! if idf is 10 or larger and x is more than 150 ! standard deviations below the mean, ! set cdft = 0.0e0 and return. ! if idf is 3 through 9 and x is more than 3000 ! standard deviations above the mean, ! set cdft = 1.0e0 and return. ! if idf is 10 or larger and x is more than 150 ! standard deviations above the mean, ! set cdft = 1.0e0 and return. ! if (idf <= 2) go to 50 sd = sqrt(df/(df-2.0e0)) z = x/sd if (idf<10 .and. z<(-3000.0e0)) go to 30 if (idf >= 10 .and. z<(-150.0e0)) go to 30 if (idf<10 .and. z > 3000.0e0) go to 40 if (idf >= 10 .and. z > 150.0e0) go to 40 go to 50 30 cdft = 0.0e0 return 40 cdft = 1.0e0 return 50 continue ! ! distinguish between the small and moderate ! degrees of freedom case versus the ! large degrees of freedom case ! if (idf= log(fpspm)) then term = term*( real ( i - 1 ) / real ( i ) ) * csq sum = sum + term else term = 0.0e0 end if end if end do if (sum == 0.0e0 .or. x == 0.0e0) then sum = 0.0e0 else if (log(sum)+log(abs(x))-0.5*log(x*x+df) < log(fpspm)) then sum = 0.0e0 else sum = sum*x/sqrt(x*x+df) end if end if if ( ievodd /= 0 ) then sum = (2.0e0/pi)*(atan(x/sqrt(df))+sum) end if cdft = 0.5e0 + sum/2.0e0 return ! ! treat the large degrees of freedom case. ! method utilized--truncated asymptotic expansion ! (see johnson and kotz, volume 2, page 102, formula 10? ! see federighi, page 687). ! 120 continue d1 = x d3 = x**3 d5 = x**5 d7 = x**7 d9 = x**9 d11 = x**11 term1 = b11*(d3+d1)/df ! term2 = b21*(b22*d7+b23*d5+b24*d3+b25*d1)/(df**2) term2 = (b22*d7+b23*d5+b24*d3+b25*d1)/(df**2) / b21 term3 = b31*(b32*d11+b33*d9+b34*d7+b35*d5+b36*d3+b37*d1)/(df**3) cdft = term1 + term2 + term3 cdft = cdfnml(x) - (dconst*(exp(-x*x/2.0e0)))*cdft return 1000 format ('***** fatal error--the second input argument to t', & 'he cdft subroutine is non-positive *****') 1010 format ('***** the value of the argument is ', i8, ' *****') end subroutine center ( y, n, yc ) !*****************************************************************************80 ! !! CENTER centers an observed series. ! ! Discussion: ! ! This is the user routine for centering the observed series Y, ! returning the centered series in YC. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical err01 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! character*1 ln(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this routine. ! real y(n) ! the vector containing the observed time series. ! real yc(n) ! the vector in which the centered series is returned. ! implicit none integer & n ! ! array arguments real & y(*),yc(*) ! ! scalars in common integer & ierr logical & err01,head ! ! local arrays character & ln(8)*1,nmsub(6)*1 ! ! external subroutines external cntr,eisge ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'e', 'n', 't', 'e', 'r'/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 2, 1, head, err01, ln) if ( err01 ) then ierr = 1 return end if call cntr (y, n, yc) return end subroutine chirho ( rho, n, nc, chi, chip ) !*****************************************************************************80 ! !! CHIRHO computes the Chi Square statistic and its probability. ! ! Discussion: ! ! This routine computes the chi squared statistic and its ! probability based in a vector of autocorrelations. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real chi, chip ! the variables in which the chi square statistic and ! chi square statistic probability are stored. ! integer lag ! the indexing variable indicating the lag value of the ! autocorrelation being examined. ! integer n ! the number of observations in the series. ! integer nc ! the number of autocorrelations computed. ! real rho(nc) ! the array in which the autocorrelations are stored ! implicit none real cdfchi real chi real chip integer n integer nc real rho(*) chi = dot_product ( rho(1:nc), rho(1:nc) ) chi = chi * real ( n ) chip = 1.0e0 - cdfchi ( chi, real(nc) ) return end subroutine cmpfd ( n, stp, pvstp, pv, fd ) !*****************************************************************************80 ! !! CMPFD computes a finite difference derivative. ! ! Discussion: ! ! This routine computes a finite difference derivative, ! assuming that if the difference between pvstp(i) and pv(i) is ! small enough the derivative is zero. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index variable. ! real fd(n) ! the finite-difference derivative. ! real fplrs ! the floating point largest relative spacing. ! real pv(n) ! the predicted values at the current parameter value. ! real pvstp(n) ! the predicted values at the current parameter value plus stp. ! real stp ! the step. ! implicit none real & stp integer & n ! ! array arguments real & fd(*),pv(*),pvstp(*) real & fplrs integer & i fplrs = epsilon ( fplrs ) do i=1,n fd(i) = pvstp(i) - pv(i) if (abs(fd(i)) >= 5*fplrs*min(abs(pvstp(i)),abs(pv(i)))) then fd(i) = fd(i) / stp else fd(i) = 0.0e0 end if end do return end subroutine cntr ( y, n, yc ) !*****************************************************************************80 ! !! CNTR centers the input seriers about its mean. ! ! Discussion: ! ! This routine centers the input series Y about its mean, ! returning the centered series in YC. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index variable. ! integer n ! the number of observations in the input series. ! real y(n) ! the input array of observations to be centered. ! real yc(n) ! the output array of centered observations. ! real ymean ! the mean of the input series. ! implicit none integer & n ! ! array arguments real & y(*),yc(*) real & ymean call amean ( y, n, ymean ) yc(1:n) = y(1:n) - ymean return end subroutine correr ( nmsub, m, n, iym, ivcv, ldstak, icor, nprt ) !*****************************************************************************80 ! !! CORRER checks for errors in the input parameters. ! ! Discussion: ! ! This routine checks for errors in the input parameters. ! If any are found a flag is set and computation stops. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical err01, err02, err03, err04, err05 ! value(s) indicating whether or error was detected ! (true) or not (false). ! logical head ! a flag indicating whether the heading should be ! printed (true) or not (false). if a heading is ! printed, the value of head will be changed to false. ! integer icor ! determines which subroutine called correr ! if =1, then called by corr ! =2, then called by corrs ! integer ierr ! a flag, that when returned by this routine designates ! whether errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ip ! a temporary variable used for computing ldsmin. ! integer is ! a temporary variable used for computing ldsmin. ! integer ivcv ! the dimension of sc ! integer iym ! actual row dimension of ym ! integer ldsmin ! the minimum length allowed for dstak ! integer ldstak ! the length of the vector dstak in common cstak ! character*1 livcv(8), liym(8), llds(8), lm(8), ln(8), lthree(8), ! * ltwo(8) ! the array(s) containing the name(s) of the ! variable(s) checked for errors. ! integer m ! number of variables ! integer n ! the number ofobservations ! character*1 nmsub(6) ! the name of the calling subroutine. ! integer nprt ! the variable controlling the printed output. ! if nprt=0, output is suppressed, otherwise it is not ! implicit none integer & icor,ivcv,iym,ldstak,m,n,nprt ! ! array arguments character & nmsub(6)*1 ! ! scalars in common integer & ierr integer & ip,is,ldsmin logical & err01,err02,err03,err04,err05,head ! ! local arrays character & livcv(8)*1,liym(8)*1,llds(8)*1,lm(8)*1,ln(8)*1, & lthree(8)*1,ltwo(8)*1 ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data livcv(1), livcv(2), livcv(3), livcv(4), livcv(5), livcv(6), & livcv(7), livcv(8) / 'i', 'v', 'c', 'v', ' ', ' ', ' ', ' '/ data liym(1), liym(2), liym(3), liym(4), liym(5), liym(6), & liym(7), liym(8) / 'i', 'y', 'm', ' ', ' ', ' ', ' ', ' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data lm(1), lm(2), lm(3), lm(4), lm(5), lm(6), & lm(7), lm(8) / 'm', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), & ln(7), ln(8) / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data lthree(1),lthree(2),lthree(3),lthree(4),lthree(5),lthree(6), & lthree(7),lthree(8) / 't', 'h', 'r', 'e', 'e', ' ', ' ', ' '/ data ltwo(1), ltwo(2), ltwo(3), ltwo(4), ltwo(5), ltwo(6), & ltwo(7), ltwo(8) / 't', 'w', 'o', ' ', ' ', ' ', ' ', ' '/ head = .true. ierr = 0 ! ! number of variables less than 2. ! call eisge(nmsub, lm, m, 2, 2, head, err01, ltwo) ! ! number of observations less than 3. ! call eisge(nmsub, ln, n, 3, 2, head, err02, lthree) ! ! observation matrix dimensioned less than n. ! err03 = .false. if (.not.err02) call eisge(nmsub, liym, iym, n, 3, head, err03, & ln) ! ! sc matrix dimensioned less than m. ! err04 = .false. if ((icor == 2) .and. (.not.err01)) call eisge(nmsub, livcv, & ivcv, m, 3, head, err04, lm) if ( err01 .or. err02 ) then ierr = 1 return end if is = 0 if (icor == 1) is = 1 ip = 1 if (nprt == 0) ip = 0 ! ! check for enough common for this problem ! call ldscmp(12, 0, ip*max(n,m), 0, 0, 0, 's', & is*m*m + ip*(max(n,m)+m+n*(m+3)+6*m*m), ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err05, llds) if (err01 .or. err02 .or. err03 .or. err04 .or. err05) then ierr = 1 return end if return end subroutine corr ( ym, n, m, iym, ldstak ) !*****************************************************************************80 ! !! CORR: short call to correlation family of routines. ! ! Discussion: ! ! This is the user callable routine for the correlation family. ! it is the short call form. ! This procedure calls corer to check for errors in the parameter ! list. If no problems it then allocates space in cstak for the ! vectors needed and calls the main routine CORRMN to ! do the correlation analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer avg ! the starting location in the work area for the ! averages of ym ! integer cilo ! occupies the same space as slpc and is the lower ! confidence interval ! integer ciup ! occupies the same space as slsc and is the upper ! confidence interval ! double precision dstak(3000) ! the double precision version of ! the /cstak/ work area. ! integer icor ! determines which subroutine called CORRMN ! if =1, then called by corr ! =2, then called by corrs ! integer ierr ! a flag returned to the user indicating ! whether errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 ! indicates single precision and ifp=4 indicates ! double precision. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer iwrk ! the starting location in the work area for the ! integer work vector. ! integer iym ! the row dimension of ym specified in the users progra ! integer ldstak ! size of work area allocated in the users program ! integer liwrk ! the length of the integer work vector. ! integer lwrk ! the length of the real work vector. ! integer m ! the number of variables ! integer n ! the number of observations ! integer nall0 ! the number of allocations outstanding at the ! time that this routine was called. ! character*1 nmsub(6) ! the subroutine name ! integer nprt ! the variable controlling the automatic printout ! nprt = 0, printout is suppressed ! otherwise the printout is provided. ! integer pc ! the starting location in the work area ! of the partial correlation coefficients matrix ! integer qf ! the starting location in the work area for the ! quadratic fit ! integer quad ! the starting location in the work area for the ! real version of the quadratic fit ! integer rank ! the starting location in the work area for the ! matrix containing the ranks of ym ! real rstak(12) ! the real version of the ! /cstak/ work area. ! integer sc ! the starting location in the work area ! of the simple correlation coefficients matrix ! integer scinv ! the starting location in the work area for the ! inverse matrix of sc ! integer sd ! the starting location in the work area of the ! standard deviations of ym ! integer slpc ! the starting location in the work area of the ! significance levels of pc ! integer slsc ! the starting location in the work area of the ! significance levels of sc ! integer srcc ! the starting location in the work area of the ! spearman rank coefficients ! integer t ! starting location in the work area ! for the array t. ! integer vcv ! the starting location in the work area of the ! variance covariance matrix. ! integer wrk ! the starting location in the work area for ! work space ! real ym(iym,m) ! the matrix in which the observations are passed ! implicit none integer & iym,ldstak,m,n ! ! array arguments real & ym(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer & avg,cilo,ciup,icor,ifp,iwrk,liwrk,lwrk,nall0,nprt,pc, & qf,quad,rank,sc,scinv,sd,slpc,slsc,srcc,t,vcv,wrk ! ! local arrays real & rstak(12) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name array ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'c', 'o', 'r', 'r', ' ', ' '/ ! ! set up framework variables for number type ! ifp = 3 ! ! set caller flag, this is corr ! icor = 1 ! ! printout is automaticaly provided ! nprt = 1 ! ! check for errors in parameters ! call correr(nmsub, m, n, iym, m, ldstak, icor, nprt) ! ! if there is an error return to the callers routine ! if ( ierr /= 0 ) then return end if ! ! initialize the stack ! call stkset (ldstak, 4) nall0 = stkst(1) ! ! allocate space in cstak for matrices. ! liwrk = max(n,m) lwrk = liwrk vcv = stkget(m*m,ifp) iwrk = stkget(liwrk,2) wrk = stkget(lwrk,ifp) t = stkget(m,ifp) rank = stkget(n*m,ifp) scinv = stkget(m*m,ifp) slsc = stkget(m*m,ifp) slpc = stkget(m*m,ifp) sc = stkget(m*m,ifp) pc = stkget(m*m,ifp) quad = stkget(3*n,ifp) qf = stkget(m*m,ifp) ! ! the following variables have been indirectly equivalenced- ! ciup = slsc cilo = slpc avg = wrk sd = wrk srcc = scinv ! ! call the routine to do the computations ! call corrmn ( ym, n, m, iym, rstak(avg), rstak(sd), rstak(t), & rstak(rank), rstak(sc), rstak(pc), rstak(scinv), istak(iwrk), & rstak(wrk), rstak(slsc), rstak(slpc), rstak(srcc), & rstak(quad), rstak(ciup), rstak(cilo), rstak(qf), & nprt, rstak(vcv), m, liwrk, lwrk ) ! ! return area to the work array ! call stkclr(nall0) return end subroutine corrhd ( m, n ) !*****************************************************************************80 ! !! CORRHD prints headers for the correlation family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer m ! the number of variables ! integer n ! the number of observations for each variable ! implicit none integer m,n ! ! external subroutines external versp call versp(.true.) write ( *,1000) m, n return 1000 format (/' correlation analysis for', i3, ' variables with', & i5, ' observations'/) end subroutine corrmn ( ym, n, m, iym, avg, sd, t, rank, sc, pc, scinv, & iwrk, wrk, slsc, slpc, srcc, quad, ciup, cilo, qf, nprt, & vcv, ivcv, liwrk, lwrk ) !*****************************************************************************80 ! !! CORRMN is the main routine in the correlation family. ! ! Discussion: ! ! This is the main routine for the correlation family. ! ! It was adapted from the omnitab routine correl. it does a correlation ! analysis of a multivariate random sample. ! the following tables are produced ! simple correlation coefficients, ! partial correlation coefficients, ! and their siginificance levels, ! spearman rank coefficients, ! quadratic relationship, ! 95 and 99 percent confidence intervals. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real avg(m) ! contains the column averages of ym ! real b ! = (n-1) * n * (n+1) / 6 ! real cilo(m,m) ! lower confidence interval for sc ! real ciup(m,m) ! upper confidence interval for sc ! real d(3) ! a dummy array. ! real f ! square root of fn3 ! real fn3 ! real representation of (n-3). ! real fplm ! the floating point largest magnitude ! integer ier ! error flag for subroutines called from this routine ! integer ierr ! when returned by this routine, desginates whether any ! errors were detected during computations ! if ierr == 0, no errors ! == 1, errors were detected ! integer inert(3) ! the inertia of the simple correlation matrix. ! integer ivcv ! the row dimension of vcv specified in the users progr ! integer iwrk(liwrk) ! a work vector for the inversion routine ! integer iym ! the row dimension of ym specified in the users progra ! integer liwrk ! the length of the integer work vector. ! integer lwrk ! the length of the real work vector. ! integer m ! the number of variables (the column dimension of ym) ! integer n ! the number of observations ! integer nprt ! the variable controlling the automatic printout ! nprt =0, printout is suppressed ! otherwise printout is provided ! integer nsum ! the number of observations in the dot product ! real pc(m,m) ! partial correlation coefficients matrix ! real qf(m,m) ! quadratic fix matrix ! real quad(n,3) ! double version of qf matrix ! real rank(n,m) ! the matrix containg the ranks of ym ! real sc(m,m) ! simple correlation coefficients matrix ! real scinv(m,m) ! the inverse matrix of sc ! real sd(m) ! standard deviation of the comlumns of ym ! real slpc(m,m) ! significance levels of pc ! real slsc(m,m) ! significance levels of sc ! real sqsum ! the sum of squares of the ith column of ym ! real srcc(m,m) ! spearman rank correlation coefficients ! real sum ! used in calculating the statistics of ym ! real t(m) ! used in determining srcc ! real vcv(ivcv,m) ! the variance covariance matrix. ! real wrk(lwrk) ! work storage ! real ym(iym,m) ! the matrix whose columns each contain one of m sets ! of n observations. each column represents a different ! variable ! real z ! used in computing confidence intervals ! real zz ! used in determining correlation coefficients ! implicit none integer & ivcv,iym,liwrk,lwrk,m,n,nprt ! ! array arguments real & avg(m),cilo(m,m),ciup(m,m),pc(m,m),qf(m,m),quad(n,3), & rank(n,m),sc(m,m),scinv(m,m),sd(m),slpc(m,m),slsc(m,m), & srcc(m,m),t(m),vcv(ivcv,m),wrk(lwrk),ym(iym,m) integer & iwrk(liwrk) ! ! scalars in common integer & ierr real & b,f,fn3,fplm,hl1,hl2,sqsum,sum,z,zz integer & i,ier,j,k,k1,k2,nsum ! ! local arrays real & c(3),d(3),rr(3,3),xx(3) integer & inert(3) ! ! external functions real & cdff external cdff ! ! common blocks common /errchk/ierr ierr = 0 fplm = huge ( fplm ) do j=1,m call amean(ym(1,j), n, avg(j)) end do ! ! compute variance-covariance matrix ! do j=1,m do i=j,m call dotc(ym(1,j), avg(j), n, ym(1,i), avg(i), n, sum, nsum) vcv(j,i) = sum / real ( nsum - 1 ) vcv(i,j) = vcv(j,i) end do end do if (nprt == 0) then return end if ! ! print variance-covariance matrix and simple correlation ! coefficients ! call corrhd ( m, n ) call vcvout ( m, vcv, ivcv, .false.) ! ! compute standard deviations ! do i=1,m if ( vcv(i,i) <= 0.0e0 ) then ierr = 1 return end if sd(i) = sqrt(vcv(i,i)) end do ! ! Compute simple correlation coefficients ! do j=1,m do i=j,m sc(i,j) = 1.0e0 scinv(j,i) = 1.0e0 if (i /= j) then sc(i,j) = vcv(i,j)/sd(i)/sd(j) sc(j,i) = sc(i,j) scinv(j,i) = sc(i,j) end if end do end do if ((m <= 2) .or. (n <= m)) go to 190 ! ! Calculate partial correlation coefficients. ! call ssifa(scinv, m, m, iwrk, ier) if ( ier /= 0 ) then write ( *,1000) ierr = 1 return end if call ssidi(scinv, m, m, iwrk, d, inert, wrk, 1) do j=1,m do i=j,m pc(i,j) = 1.0e0 if (i /= j) then zz = scinv(i,i)*scinv(j,j) pc(i,j) = fplm if ( 0.0 < zz ) then pc(i,j) = -scinv(j,i)/sqrt(zz) if (abs(pc(i,j)) > 1.0e0) pc(i,j) = sign(1.0e0,pc(i,j)) end if pc(j,i) = pc(i,j) end if end do end do ! ! compute significance levels of partial correlation coefficients. ! note, lower triangular matrix stored in square matrix. ! do i=1,m do j=1,i if ( pc(i,j) == 0.0e0) then slpc(i,j) = 1.0e0 else if ( 1.0 <= abs(pc(i,j)) ) then slpc(i,j) = 0.0e0 else f = pc(i,j)*pc(i,j) if ( 1.0e0-f == 0.0e0) then slpc(i,j) = fplm else f = real ( n - m ) * f/(1.0e0-f) slpc(i,j) = 1.0e0 - cdff(f,1.0e0,real(n-m)) end if end if end do end do ! ! Compute significance levels of simple correlation coefficients ! note, only lower triangular stored in square matrix. ! 190 continue do i=1,m do j=1,i if (i == j) then slsc(i,j) = 0.0e0 else if (sc(i,j) == 0.0e0) then slsc(i,j) = 1.0e0 else if ( 1.0 <= abs(sc(i,j)) ) then slsc(i,j) = 0.0e0 else f = sc(i,j)*sc(i,j) if (f == 1.0e0) then slsc(i,j) = fplm else f = real(n-2)*f / (1.0e0-f) slsc(i,j) = 1.0e0 - cdff(f,1.0e0,real(n-2)) end if end if end do end do ! ! print significance levels of simple correlation coefficients, ! partial correlation coefficients and significance levels ! write ( *,1020) call matprt(slsc, slsc, m, 0, 1, m) if ((m > 2) .and. (n > m)) then i = m - 2 write ( *,1030) i call matprt(pc, pc, m, 0, 1, m) write ( *,1040) call matprt(slpc, slpc, m, 0, 1, m) else write ( *,1010) end if ! ! Determine the ranks of the observations. ! do i=1,m call ranko(n, ym(1,i), iwrk, rank(1,i), t(i)) t(i) = t(i) / 12.0e0 end do ! ! compute spearman rank correlation coefficients. ! note, lower triangular matrix, stored in square matrix. ! b = real ( (n-1)*n*(n+1)/6 ) do i=1,m do j=1,i srcc(i,j) = 1.0e0 if ( i /= j ) then k1 = int ( 2.0e0*t(i) + 0.4e0 ) k2 = int ( 2.0e0*t(j) + 0.4e0 ) srcc(i,j) = fplm if ((int(b)-k1 <= 0) .or. (int(b)-k2 <= 0)) then cycle end if sum = 0.0e0 do k=1,n zz = rank(k,i) - rank(k,j) sum = sum + zz*zz end do zz = (b - 2.0e0*t(i))*(b - 2.0e0*t(j)) if (zz > 0.0e0) srcc(i,j) = (b-sum-t(i)-t(j))/sqrt(zz) end if end do end do ! ! print spearman rank correlations coefficients ! write ( *,1050) call matprt(srcc, srcc, m, 0, 1, m) if ( n <= 3 ) then write ( *,1060) return end if ! ! compute the significance levels of the quadratic fit over the ! linear fit. ! ! these calculations may produce variable results in varying ! machine/compilation environments, in cases in which the ! ym matrix is near singular (essentially singular but the ! singularity is undetected by the code). the observed symptoms ! are alternation between qf values of 0.0e0 (first f = line ! produces zero) and 1.0e0 (first f = line produces approx. ! zero, and numerator in second f = line is nonzero). ! fn3 = real ( n - 3 ) do j=1,m do i=1,m if ( i == j) then qf(i,j) = 1.0e0 cycle end if sqsum = 0.0e0 do k=1,n quad(k,1) = 1.0e0 quad(k,2) = ym(k,j) quad(k,3) = ym(k,j)*ym(k,j) sqsum = sqsum + ym(k,i)*ym(k,i) wrk(k) = ym(k,i) end do call mgs(quad, wrk, n, 3, xx, c, d, rr, 3, n, ier) if ( ier /= 0) then write ( *,1090) go to 420 end if do k=1,3 c(k) = c(k)*sqrt(d(k)) end do f = (sqsum-c(1)*c(1)-c(2)*c(2)-c(3)*c(3)) qf(i,j) = 0.0e0 if ( f /= 0.0e0 ) then f = (c(3)*c(3)*fn3)/f qf(i,j) = 1.0e0 if (f > 0.0e0) qf(i,j) = 1.0e0 - cdff(f,1.0e0,fn3) end if end do end do ! ! print the quadratic fit matrix ! j = 2 k = 1 i = n - 3 write ( *,1070) i, qf(j,k), j, k call matprt(qf, qf, m, 1, 1, m) ! ! compute confidence limits for simple correlation coefficients ! 420 continue f = sqrt(fn3) hl1 = 2.5758293e0 / f hl2 = 1.9599640e0 / f do j=1,m do i=1,m if (i == j) then ciup(i,j) = 99.0e0 cilo(i,j) = 95.0e0 ! ! Compute 99 percent intervals. ! else if (i= 3: SCALE * inverse ( J' * J ). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Output, integer COVIRC, is set to 1, 2, 3, or 4 depending on ! the circumstances of the calculation. ! ! Input, real D(P), the scaling vector. ! ! Input/output, integer IV(*), the NL2SOL integer parameter vector. ! ! Input, real J(NN,P), the N by P Jacobian matrix. ! ! Input, integer N, the number of functions. ! ! Input, integer NN, the leading dimension of J. ! ! Input, integer P, the number of variables. ! ! ?, real R(N), ? ! ! Input, real V(*), the NL2SOL real parameter array. ! ! ?, real X(P), ? ! implicit none integer n integer nn integer p integer cov integer covirc integer, parameter :: covmat = 26 integer, parameter :: covreq = 15 real d(p) real del integer, parameter :: delta = 50 integer, parameter :: delta0 = 44 integer, parameter :: dltfdc = 40 integer, parameter :: f = 10 integer, parameter :: fx = 46 integer, parameter :: g = 28 integer g1 integer gp integer gsave1 integer, parameter :: h = 44 logical havej integer hc integer hmi integer hpi integer hpm integer i integer, parameter :: ierr = 32 integer, parameter :: ipiv0 = 60 integer ipivi integer ipivk integer, parameter :: ipivot = 61 integer irc integer iv(*) real j(nn,p) integer k integer, parameter :: kagqt = 35 integer, parameter :: kalm = 36 integer kind integer kl integer l integer, parameter :: lmat = 58 integer m integer mm1 integer mm1o2 integer, parameter :: mode = 38 integer, parameter :: nfgcal = 7 integer pp1o2 integer, parameter :: qtr = 49 integer qtr1 real r(n) integer, parameter :: rd = 51 integer rd1 integer, parameter :: rsave = 52 integer, parameter :: savei = 54 integer stp0 integer stpi integer stpm integer, parameter :: switch = 12 real t integer, parameter :: toobig = 2 real v(*) integer, parameter :: w = 59 integer w0 integer w1 real wk integer wl real x(p) integer, parameter :: xmsave = 49 covirc = 4 kind = iv(covreq) m = iv(mode) if ( m <= 0 ) then iv(kagqt) = -1 if ( 0 < iv(kalm) ) then iv(kalm) = 0 end if if ( 3 <= abs ( kind ) ) then rd1 = iv(rd) if ( iv(kalm) == -1 ) then qtr1 = iv(qtr) v(qtr1:qtr1+n-1) = r(1:n) w1 = iv(w) + p call qrfact ( nn, n, p, j, v(rd1), iv(ipivot), iv(ierr), 0, v(w1) ) iv(kalm) = -2 end if iv(covmat) = -1 if ( iv(ierr) /= 0 ) then return end if cov = iv(lmat) hc = abs ( iv(h) ) iv(h) = -hc ! ! Set HC = R matrix from QRFACT. ! l = hc do i = 1, p if ( 1 < i ) then call vcopy ( i-1, v(l), j(1,i) ) end if l = l + i - 1 v(l) = v(rd1) l = l + 1 rd1 = rd1 + 1 end do go to 350 end if v(fx) = v(f) k = iv(rsave) v(k:k+n-1) = r(1:n) end if if ( m <= p ) then if ( kind < 0 ) then go to 100 end if ! ! Compute finite-difference hessian using both function and ! gradient values. ! gsave1 = iv(w) + p g1 = iv(g) ! ! First call on COVCLC. Set GSAVE = G, take first step. ! if ( m <= 0 ) then v(gsave1:gsave1+p-1) = v(g1:g1+p-1) iv(switch) = iv(nfgcal) else del = v(delta) x(m) = v(xmsave) ! ! Handle oversize V(DELTA). ! if ( iv(toobig) /= 0 ) then if ( 0.0E+00 < del * x(m) ) then del = -0.5E+00 * del x(m) = x(m) + del v(delta) = del covirc = 2 return end if iv(covmat) = -2 go to 190 end if cov = iv(lmat) gp = g1 + p - 1 ! ! Set G = ( G - GSAVE ) / DEL. ! do i = g1, gp v(i) = ( v(i) - v(gsave1) ) / del gsave1 = gsave1 + 1 end do ! ! Add G as new column to finite-difference hessian matrix. ! k = cov + ( m * ( m - 1 ) ) / 2 l = k + m - 2 ! ! Set H(1:M-1,M) = 0.5 * (H(1:M-1,m) + G(1:M-1)). ! if ( m /= 1 ) then do i = k, l v(i) = 0.5E+00 * ( v(i) + v(g1) ) g1 = g1 + 1 end do end if ! ! Add H(M:P,M) = G(M:P). ! l = l + 1 do i = m, p v(l) = v(g1) l = l + i g1 = g1 + 1 end do end if m = m + 1 iv(mode) = m if ( p < m ) then go to 190 end if ! ! Choose next finite-difference step, return to get G there. ! del = v(delta0) * max ( 1.0E+00 / d(m), abs ( x(m) ) ) if ( x(m) < 0.0E+00 ) then del = -del end if v(xmsave) = x(m) x(m) = x(m) + del v(delta) = del covirc = 2 return ! ! Compute finite-difference hessian using function values only. ! 100 continue stp0 = iv(w) + p - 1 mm1 = m - 1 mm1o2 = m * mm1 / 2 ! ! First call on COVCLC. ! if ( m <= 0 ) then iv(savei) = 0 else i = iv(savei) if ( i <= 0 ) then ! ! Handle oversize step. ! if ( iv(toobig) /= 0 ) then stpm = stp0 + m del = v(stpm) ! ! We already tried shrinking the step, so quit. ! if ( del * x(xmsave) <= 0.0E+00 ) then iv(covmat) = -2 return end if ! ! Try shrinking the step. ! del = -0.5E+00 * del x(m) = x(xmsave) + del v(stpm) = del covirc = 1 return end if ! ! Save F(X + STP(M)*E(M)) in H(P,M). ! pp1o2 = ( p * ( p - 1 ) ) / 2 cov = iv(lmat) hpm = cov + pp1o2 + mm1 v(hpm) = v(f) ! ! Start computing row M of the finite-difference hessian H. ! hmi = cov + mm1o2 hpi = cov + pp1o2 do i = 1, mm1 v(hmi) = v(fx) - (v(f) + v(hpi)) hmi = hmi + 1 hpi = hpi + 1 end do v(hmi) = v(f) - 2.0E+00 * v(fx) ! ! Compute function values needed to complete row M of H. ! i = 1 iv(savei) = i stpi = stp0 + i v(delta) = x(i) x(i) = x(i) + v(stpi) if ( i == m ) then x(i) = v(xmsave) - v(stpi) end if covirc = 1 return end if x(i) = v(delta) ! ! Punt in the event of an oversize step. ! if ( iv(toobig) /= 0 ) then iv(covmat) = -2 return end if ! ! Finish computing H(M,I). ! stpi = stp0 + i hmi = cov + mm1o2 + i - 1 stpm = stp0 + m v(hmi) = ( v(hmi) + v(f) ) / ( v(stpi) * v(stpm) ) i = i + 1 if ( i <= m ) then iv(savei) = i stpi = stp0 + i v(delta) = x(i) x(i) = x(i) + v(stpi) if ( i == m ) then x(i) = v(xmsave) - v(stpi) end if covirc = 1 return end if iv(savei) = 0 x(m) = v(xmsave) end if m = m + 1 iv(mode) = m ! ! Prepare to compute row M of the finite-difference hessian H. ! Compute the M-th step size STP(M), then return to obtain ! F(X + STP(M)*E(M)), where E(M) = M-th standard unit vector. ! if ( m <= p ) then del = v(dltfdc) * max ( 1.0E+00 / d(m), abs(x(m)) ) if (x(m) < 0.0E+00 ) then del = -del end if v(xmsave) = x(m) x(m) = x(m) + del stpm = stp0 + m v(stpm) = del covirc = 1 return end if ! ! Restore R, V(F), etc. ! 190 continue k = iv(rsave) r(1:n) = v(k:k+n-1) v(f) = v(fx) if ( 0 <= kind ) then iv(nfgcal) = iv(switch) qtr1 = iv(qtr) v(qtr1:qtr1+n-1) = r(1:n) if ( 0 <= iv(covmat) ) then covirc = 3 end if return end if end if cov = iv(lmat) ! ! The complete finite-difference hessian is now stored at V(COV). ! Use it to compute the requested covariance matrix. ! ! Compute Cholesky factor C of H = C * C' and store it at V(HC). ! hc = cov if ( abs ( kind ) /= 2 ) then hc = abs ( iv(h) ) iv(h) = -hc end if call lsqrt ( 1, p, v(hc), v(cov), irc ) iv(covmat) = -1 if ( irc /= 0 ) then return end if w1 = iv(w) + p if ( 1 < abs ( kind ) ) then go to 350 end if ! ! Covariance = SCALE * inverse ( H ) * (J' * J) * inverse ( H ). ! v(cov:cov+(p*(p+1))/2) = 0.0E+00 havej = iv(kalm) == (-1) ! ! HAVEJ = .true. means J is in its original form, while ! HAVEJ = .false. means QRFACT has been applied to J. ! if ( havej ) then m = n else m = p end if w0 = w1 - 1 rd1 = iv(rd) do i = 1, m ! ! Set W = IPIVOT * (row I of R matrix from QRFACT). ! if ( .not. havej ) then v(w1:w1+p-1) = 0.0E+00 ipivi = ipiv0 + i l = w0 + iv(ipivi) v(l) = v(rd1) rd1 = rd1 + 1 do k = i+1, p ipivk = ipiv0 + k l = w0 + iv(ipivk) v(l) = j(i,k) end do ! ! Set W = (row I of J). ! else l = w0 do k = 1, p l = l + 1 v(l) = j(i,k) end do end if ! ! Set W = inverse ( H ) * W. ! call livmul ( p, v(w1), v(hc), v(w1) ) call litvmu ( p, v(w1), v(hc), v(w1) ) ! ! Add W * W' to covariance matrix. ! kl = cov do k = 1, p l = w0 + k wk = v(l) do l = 1, k wl = w0 + l v(kl) = v(kl) + wk * v(wl) kl = kl + 1 end do end do end do go to 380 ! ! The Cholesky factor C of the unscaled inverse covariance matrix ! (or permutation thereof) is stored at V(HC). ! ! Set C = inverse ( C ). ! 350 continue call linvrt ( p, v(hc), v(hc) ) ! ! Set C = C' * C. ! call ltsqar ( p, v(hc), v(hc) ) ! ! C = permuted, unscaled covariance. ! Set COV = IPIVOT * C * IPIVOT'. ! if ( hc /= cov ) then do i = 1, p m = ipiv0 + i ipivi = iv(m) kl = cov-1 + ( ipivi * (ipivi-1) ) / 2 do k = 1, i m = ipiv0 + k ipivk = iv(m) l = kl + ipivk if ( ipivi < ipivk ) then l = l + ( (ipivk-ipivi) * (ipivk+ipivi-3) ) / 2 end if v(l) = v(hc) hc = hc + 1 end do end do end if 380 continue iv(covmat) = cov ! ! Apply scale factor = (residual sum of squares) / max(1,n-p). ! t = v(f) / ( 0.5E+00 * real ( max ( 1, n-p ) ) ) k = cov - 1 + ( p * ( p + 1 ) ) / 2 v(cov:k) = t * v(cov:k) return end subroutine cpyasf ( m, x, lx, y, iy ) !*****************************************************************************80 ! !! CPYASF copies a symmetric matrix stored rowwise into rectangular storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer iy ! the first dimension of the matrix y. ! integer lx ! the length of symmetric matrix x, stored row wise. ! integer m ! the number of columns of data to be copied from matrix x. ! real x(lx) ! the matrix to be copied from. ! real y(iy,m) ! the matrix to be copied to. ! implicit none integer iy integer lx integer m integer i integer ij integer j real x(lx) real y(iy,m) do i = 1, m do j = 1, i ij = i*(i-1)/2 + j y(i,j) = x(ij) y(j,i) = y(i,j) end do end do return end subroutine cpymss ( n, m, x, ix, y, iy ) !*****************************************************************************80 ! !! CPYMSS copies an N by M matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index value. ! integer ix ! the first dimension of the matrix x. ! integer iy ! the first dimension of the matrix y. ! integer j ! an index value. ! integer m ! the number of columns of data to be copied from matrix x. ! integer n ! the number of rows of data to be copied from matrix x. ! real x(ix,m) ! the matrix to be copied from. ! real y(iy,m) ! the matrix to be copied to. ! implicit none integer ix integer iy integer m integer n real x(ix,m) real y(iy,m) y(1:n,1:m) = x(1:n,1:m) return end subroutine cpyvii ( n, x, incx, y, incy ) !*****************************************************************************80 ! !! CPYVII copies an integer vector. ! ! Discussion: ! ! Copy integer x to integer y. ! for i = 0 to n-1, copy x(lx+i*incx) to y(ly+i*incy), ! where lx = 1 if incx >= 0, else lx = (-incx)*n, and ly is ! defined in a similar way using incy. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index value. ! integer incx ! the increment for the matrix x. ! integer incy ! the increment for the matrix y. ! integer n ! the number of rows of data to be copied from matrix x. ! integer x(n) ! the matrix to be copied from. ! integer y(n) ! the matrix to be copied to. ! implicit none integer & incx,incy,n ! ! array arguments integer & x(n),y(n) ! ! integer & i,ix,iy,m,ns if(n <= 0)return if(incx == incy) then ! if(incx-1) 5,20,60 if ( incx < 1 ) then go to 5 else if ( incx == 1 ) then go to 20 else go to 60 end if end if 5 continue ! ! code for unequal or nonpositive increments. ! ix = 1 iy = 1 if(incx<0)ix = (-n+1)*incx + 1 if(incy<0)iy = (-n+1)*incy + 1 do i = 1,n y(iy) = x(ix) ix = ix + incx iy = iy + incy end do return ! ! code for both increments equal to 1 ! ! clean-up loop so remaining vector length is a multiple of 7. ! 20 m = mod(n,7) y(1:m) = x(1:m) if( n < 7 ) return do i = m+1,n,7 y(i) = x(i) y(i + 1) = x(i + 1) y(i + 2) = x(i + 2) y(i + 3) = x(i + 3) y(i + 4) = x(i + 4) y(i + 5) = x(i + 5) y(i + 6) = x(i + 6) end do return ! ! code for equal, positive, nonunit increments. ! 60 continue ns = n*incx do i=1,ns,incx y(i) = x(i) end do return end function csevl ( x, cs, n ) !*****************************************************************************80 ! !! CSEVL evaluates a Chebyshev series. ! ! Discussion: ! ! Evaluate the N term Chebyshev series CS at X. ! ! Adapted from ! r. broucke, ! algorithm 446, ! c.a.c.m., 16, 254 (1973). ! ! also see fox and parker, ! chebyshev polys in numerical analysis, ! oxford press, p.56. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! x value at which the series is to be evaluated. ! ! cs array of n terms of a chebyshev series. in eval- ! uating cs, only half the first coef is summed. ! ! n number of terms in array cs. ! ! Output, real CSEVL, the value of the Chebyshev series. ! implicit none integer n real cs(n) real csevl real x real b0,b1,b2,twox integer i,ni if (n<1) call xerror ('csevl number of terms le 0', 2,2) if (n > 1000) call xerror ('csevl number of terms gt 1000', & 3, 2) if (x<(-1.0) .or. x > 1.0) call xerror ( & 'csevl x outside (-1,+1)', 1, 1) b0 = 0.0 b1 = 0.0 b2 = 0.0 twox = 2.0*x do i=1,n b2 = b1 b1 = b0 ni = n + 1 - i b0 = twox*b1 - b2 + cs(ni) end do csevl = 0.5 * (b0-b2) return end function d1mach ( i ) !*****************************************************************************80 ! !! D1MACH returns double precision real machine constants. ! ! Discussion: ! ! Assuming that the internal representation of a double precision real ! number is in base B, with T the number of base-B digits in the mantissa, ! and EMIN the smallest possible exponent and EMAX the largest possible ! exponent, then ! ! D1MACH(1) = B**(EMIN-1), the smallest positive magnitude. ! D1MACH(2) = B**EMAX*(1-B**(-T)), the largest magnitude. ! D1MACH(3) = B**(-T), the smallest relative spacing. ! D1MACH(4) = B**(1-T), the largest relative spacing. ! D1MACH(5) = log10(B). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Phyllis Fox, Andrew Hall, Norman Schryer, ! Algorithm 528: ! Framework for a Portable Library, ! ACM Transactions on Mathematical Software, ! Volume 4, Number 2, June 1978, page 176-188. ! ! Parameters: ! ! Input, integer I, chooses the parameter to be returned. ! 1 <= I <= 5. ! ! Output, real ( kind = 8 ) D1MACH, the value of the chosen parameter. ! implicit none real ( kind = 8 ) d1mach integer i if ( i < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i d1mach = 0.0D+00 stop else if ( i == 1 ) then d1mach = 4.450147717014403D-308 else if ( i == 2 ) then d1mach = 8.988465674311579D+307 else if ( i == 3 ) then d1mach = 1.110223024625157D-016 else if ( i == 4 ) then d1mach = 2.220446049250313D-016 else if ( i == 5 ) then d1mach = 0.301029995663981D+000 else if ( 5 < i ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'D1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i d1mach = 0.0D+00 stop end if return end subroutine dckcnt ( xm, n, m, ixm, mdl, drv, par, npar, neta, ntau, & scale, lscale, nrow, nprt, hdr, page, wide, isubhd, hlfrpt, & prtfxd, ifixed, lifixd ) !*****************************************************************************80 ! !! DCKCNT controls the derivative checking process. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real d ! the scalar in which row nrowu of the derivative ! matrix with respect to the jth unknown parameter ! is stored. ! external drv ! the name of the user supplied subroutine which computes the ! analytic derivatives (jacobian matrix) of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer dtemp ! the starting location in the work area in which ! the array in which the analytic derivatives with ! respect to each unknown parameter are stored. ! real eta ! the relative noise in the model. ! real fplrs ! the floating point largest relative spacing. ! external hdr ! the name of the routine which produces the heading ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifixd ! the starting location in istak of ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer indxd, indxpv ! the index in the work area of ! the location of the value of the ! derivative with respect to the jth parameter at row nrowu ! and of the location of the predicted value from the model for r ! row nrowu . ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isubhd ! an indicator value specifying subheadings to be printed by ! routine hdr. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! an index variable. ! integer lifixd ! the length of the vector ifixed. ! integer lmsg ! the length of the vector msg. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer msg ! the starting location in the work area of ! an array used to store message parameters. ! integer n ! the number of observations of data. ! integer nall0 ! the number of stack allocations on entry. ! integer ndd ! the number of decimal digits carried for a single ! precision real number. ! integer ndgt1 ! the number of reliable digits in the model used, either ! set to the user supplied value of neta, or computed ! by etamdl. ! integer ndgt2 ! the actual number of digits of agreement used, either ! set to the user supplied value of ntau, or computed ! from ndgt1. ! integer neta ! the user supplied number of reliable digits in the model. ! integer npar ! the number of unknown parameters in the model. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! integer nrow, nrowu ! the user-supplied number of the row of the independent ! variable array at which the derivative is to be checked, ! and the number of the row actually used. ! integer ntau ! the number of digits of agreement required between the ! numerical derivatives and the user supplied derivatives. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! integer partmp ! the starting location in the work area of ! the modified model parameters ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! real pv ! the scalar in which the predicted value from the model for ! row nrow is stored. ! integer pvtemp ! the starting location in the work area of ! the predicted value based on the current parameter estimates ! real rstak(12) ! the real version of the /cstak/ work area. ! real scale(lscale) ! the typical size of the unknown parameters. ! real scl ! the actual typical size used. ! real tau ! the agreement tolerance. ! logical wide ! the variable used to indicate whether the heading should ! full width (true) or not (false). ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none integer & isubhd,ixm,lifixd,lscale,m,n,neta,npar,nprt,nrow,ntau logical & hlfrpt,page,prtfxd,wide ! ! array arguments real & par(npar),scale(lscale),xm(ixm,m) integer & ifixed(lifixd) ! ! subroutine arguments external drv,hdr,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & d,eta,fplrs,pv,scl,tau integer & dtemp,ifixd,ifp,indxd,indxpv,j,lmsg,msg,nall0,ndd,ndgt1, & ndgt2,nrowu,partmp,pvtemp ! ! local arrays real & rstak(12) integer & istak(12) ! ! external functions integer & stkget,stkst external stkget,stkst ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) nall0 = stkst(1) fplrs = epsilon ( fplrs ) ! ! select first row of independent variables which contains no zeros ! call setrow(nrow, xm, n, m, ixm, nrowu) ! ! subdivide work area ! ifp = 3 lmsg = npar + 1 ifixd = stkget(npar,2) msg = stkget(lmsg,2) dtemp = stkget(n*npar,ifp) partmp = stkget(npar,ifp) pvtemp = stkget(n,ifp) if (ierr == 1) return ! ! set up ifixd ! if (ifixed(1)<0) call setiv(istak(ifixd), npar, 0) if (ifixed(1) >= 0) call cpyvii(npar, ifixed, 1, istak(ifixd), 1) ! ! set parameters necessary for the computations ! ndd = - int ( log10(fplrs) ) if ((neta<2) .or. (neta > ndd)) then call etamdl(mdl, par, npar, xm, n, m, ixm, eta, ndgt1, & rstak(partmp), rstak(pvtemp), nrowu) else eta = 10.0e0**(-neta) ndgt1 = neta end if if ((ntau<1) .or. (ntau > (ndgt1-1)/2)) then ndgt2 = (ndgt1+3)/4 else ndgt2 = ntau end if tau = 10.0e0**(-ndgt2) indxpv = pvtemp + nrowu - 1 ! ! compute predicted value of model using current parameter ! estimates, and compute user-supplied derivative values ! call mdl(par, npar, xm, n, m, ixm, rstak(pvtemp)) pv = rstak(indxpv) call drv(par, npar, xm, n, m, ixm, rstak(dtemp)) istak(msg) = 0 do j=1,npar if (scale(1) > 0.0e0) then scl = scale(j) else scl = par(j) end if if (scl == 0.0e0) scl = 1.0e0 ! ! call routine to check user supplied numerical derivatives ! with respect to the jth parameter. ! indxd = dtemp - 1 + n*(j-1) + nrowu d = rstak(indxd) call dckmn(j, d, par, scl, npar, eta, tau, mdl, xm, n, nrowu, & m, ixm, pv, rstak(pvtemp), istak(msg), lmsg) end do if (istak(msg) >= 1) ierr = istak(msg) + 1 ! ! print results if they are desired ! hlfrpt = .false. if ((nprt /= 0) .or. (ierr /= 0)) then hlfrpt = .true. call dckout(xm,ixm,n,m,nrowu,ndgt1,ndgt2,npar,istak(msg), & lmsg,par,scale,lscale,hdr,page,wide,isubhd,prtfxd, & istak(ifixd)) end if call stkclr(nall0) return end subroutine dckcrv ( j, d, par, npar, eta, tau, mdl, xm, n, & nrow, m, ixm, pv, pvtemp, msg, lmsg, fd, parmx, pvpstp, stp ) !*****************************************************************************80 ! !! DCKCRV checks whether high curvature caused poor derivative approximation. ! ! Discussion: ! ! This routine checks whether high curvature could be the cause ! of the disagreement between the numerical and analytic derivatives ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real curve ! a measure of the curvature in the model. ! real d ! the scalar in which row nrow of the derivative ! matrix with respect to the jth unknown parameter ! is stored. ! real eta ! the relative noise in the model. ! real fd ! the forward difference quotient derivative with respect to the ! jth parameter. ! real fplrs ! the floating point largest relative spacing. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the partial derivative being examined. ! integer lmsg ! the length of the vector msg. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer msg(lmsg) ! an array used to store message parameters. ! integer n ! the number of observations. ! integer npar ! the number of unknown parameters in the model. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real parmx ! the maximum of the current parameter estimate. ! real pv ! the scalar in which the predicted value from the model for ! row nrow is stored. ! real pvmcrv ! the predicted value for row nrow of the model ! based on the current parameter estimates ! for all but the jth parameter value, which is par(j)-stpcrv. ! real pvpcrv ! the predicted value for row nrow of the model ! based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stpcrv. ! real pvpstp ! the predicted value for row nrow of the model ! based on the current parameter estimates ! for all but the jth parameter value, which is par(j) + stp. ! real pvtemp(n) ! the vector of predicted values from the model. ! real stp ! the step size currently being examined for the finite differenc ! derivative ! real stpcrv ! the step size selected to check for curvature in the model. ! real tau ! the agreement tolerance. ! real temp ! a temporary location in which the current estimate of the jth ! parameter is stored. ! real third ! the value one third. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none real & d,eta,fd,parmx,pv,pvpstp,stp,tau integer & ixm,j,lmsg,m,n,npar,nrow ! ! array arguments real & par(npar),pvtemp(n),xm(ixm,m) integer & msg(lmsg) ! ! subroutine arguments external mdl ! ! real & curve,fplrs,pvmcrv,pvpcrv,stpcrv,temp,third ! fplrs = epsilon ( fplrs ) third = 1.0e0/3.0e0 stpcrv = (eta**third*parmx*sign(1.0e0,par(j))+par(j)) - par(j) temp = par(j) par(j) = temp + stpcrv call mdl(par, npar, xm, n, m, ixm, pvtemp) pvpcrv = pvtemp(nrow) par(j) = temp - stpcrv call mdl(par, npar, xm, n, m, ixm, pvtemp) par(j) = temp pvmcrv = pvtemp(nrow) ! ! estimate curvature by second derivative of model with respect to ! par(j) ! curve = ((pvpcrv+pvmcrv)-2*pv) / (stpcrv*stpcrv) curve = curve + (eta ** third) * (abs(pvpcrv) + & abs(pvmcrv) + 2.0e0 * abs(pv)) / (parmx * parmx) ! ! compare numerical and analytical derivatives using a fudge ! factor of 10.0e0. ! if (abs(curve*stp)*5.0e0 2.0e0*tau*abs(d)) then ! ! numerical derivative computed using new step size does ! not agree with analytic derivative. ! ! check if the problem could be the forward difference quotient ! derivative. ! (fudge factor is 2) ! if (abs(stp*(fd-d)) >= 2.0e0*eta*abs(pv+pvpstp)) then ! ! finite precision could not be the culprit ! msg(1) = 2 msg(j+1) = 2 else ! ! finite precision may be the culprit ! if (msg(1) == 0) msg(1) = 1 msg(j+1) = 1 end if end if end if end if return end subroutine dckdrv ( nmsub, ldstak, xm, n, m, ixm, mdl, & drv, par, npar, neta, ntau, scale, lscale, nrow, nprt ) !*****************************************************************************80 ! !! DCKDRV is the driver to the derivative checking routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! external dckhdr ! the name of the routine which produces the heading ! external drv ! the name of the user supplied subroutine which computes the ! analytic derivatives (jacobian matrix) of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer ixm ! the first dimension of the independent variable array. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the length of the vector ifixed. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations of data. ! integer neta ! the number of accurate digits in the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of unknown parameters in the model. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! integer nrow ! the user-supplied number of the row of the independent ! variable array at which the derivative is to be checked. ! integer ntau ! the number of digits of agreement required between the ! numerical derivatives and the user supplied derivatives. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! real scale(lscale) ! the typical size of the unknown parameters. ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real xm(ixm,m) ! the independent variable array ! implicit none integer & ixm,ldstak,lscale,m,n,neta,npar,nprt,nrow,ntau ! ! array arguments real & par(*),scale(*),xm(*) character & nmsub(6)*1 ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & isubhd,lifixd logical & hlfrpt,page,prtfxd,wide ! ! local arrays integer & ifixed(1) ! ! external subroutines external dckcnt,dcker,dckhdr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! check for errors in input parameters ! call dcker(nmsub, n, m, ixm, npar, ldstak, scale, lscale) if (ierr /= 0) return page = .false. wide = .true. isubhd = 0 prtfxd = .false. ifixed(1) = -1 lifixd = 1 call stkset(ldstak, 4) ! ! pass control of derivative checking to dckcnt ! call dckcnt (xm, n, m, ixm, mdl, drv, par, npar, neta, & ntau, scale, lscale, nrow, nprt, dckhdr, page, wide, isubhd, & hlfrpt, prtfxd, ifixed, lifixd) return end subroutine dcker( nmsub, n, m, ixm, npar, ldstak, scale, lscale ) !*****************************************************************************80 ! !! DCKER does error checking for the derivative checking routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical error(10) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index value. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 lixm(8), llds(8), lm(8), ln(8), lnpar(8), lscl(8), ! * lzero(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of unknown parameters in the model. ! integer nv ! the number of violations found by the scale checking routine. ! real scale(lscale) ! the typical size of the unknown parameters. ! implicit none integer & ixm,ldstak,lscale,m,n,npar ! ! array arguments real & scale(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i,ldsmin,nv logical & head ! ! local arrays logical & error(10) character & lixm(8)*1,llds(8)*1,lm(8)*1,ln(8)*1,lnpar(8)*1, & lscl(8)*1,lzero(8)*1 ! ! external subroutines external eisge,eisle,ervgt,ldscmp ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data lixm(1), lixm(2), lixm(3), lixm(4), lixm(5), lixm(6), & lixm(7), lixm(8) /'i','x','m',' ',' ',' ',' ',' '/ data lm(1), lm(2), lm(3), lm(4), lm(5), lm(6), lm(7), lm(8) /'m', & ' ',' ',' ',' ',' ',' ',' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ', & ' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lnpar(1), lnpar(2), lnpar(3), lnpar(4), lnpar(5), & lnpar(6), lnpar(7), lnpar(8) /'n','p',' ',' ',' ',' ',' ', & ' '/ data lscl(1), lscl(2), lscl(3), lscl(4), lscl(5), & lscl(6), lscl(7), lscl(8) /'s','c','a','l','e',' ',' ', & ' '/ data lzero(1), lzero(2), lzero(3), lzero(4), lzero(5), & lzero(6), lzero(7), lzero(8) /'z','e','r','o',' ',' ',' ',' '/ ! ! error checking ! error(1:10) = .false. ierr = 0 head = .true. call eisge(nmsub, ln, n, 1, 1, head, error(1), ln) call eisge(nmsub, lm, m, 1, 1, head, error(2), lm) call eisge(nmsub, lixm, ixm, n, 3, head, error(3), ln) call eisle(nmsub, lnpar, npar, n, 2, head, error(4), ln) call ldscmp(5, 0, 2*npar+1, 0, 0, 0, 's', & n*npar + npar + n, ldsmin) if ((.not.error(1)) .and. (.not.error(4))) & call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(5), & llds) call ervgt(nmsub, lscl, scale, lscale, 0.0e0, 0, head, 6, nv, & error(9), lzero) do i=1,10 if ( error(i) ) then ierr = 1 return end if end do return end subroutine dckfpa( j, d, par, npar, eta, tau, mdl, xm, n, & nrow, m, ixm, pv, pvtemp, msg, lmsg, fd, parmx, stp, pvpstp, & curve ) !*****************************************************************************80 ! !! DCKFPA checks if arithmetic precision causes poor derivative approximation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real curve ! a measure of the curvature in the model. ! real d ! the scalar in which row nrow of the derivative ! matrix with respect to the jth unknown parameter ! is stored. ! real eta ! the relative noise in the model ! real fd ! the forward difference quotient derivative with respect to the ! jth parameter ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the partial derivative being examined. ! logical large ! an indicator value indicating whether the recommended ! increase in the step size would be greater than parmx. ! integer lmsg ! the length of the vector msg. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer msg(lmsg) ! an array used to store message parameters. ! integer n ! the number of observations. ! integer npar ! the number of unknown parameters in the model. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real parmx ! the maximum of the current parameter estimate and the ! typical value of that parameter ! real pv ! the scalar in which the predicted value from the model for ! row nrow is stored. ! real pvpstp ! the predicted value for row nrow of the model ! based on the current parameter estimates ! for all but the jth parameter value, which is par(j) + stp. ! real pvtemp(n) ! the vector of predicted values from the model. ! real stp ! the step size currently being examined for the finite differenc ! derivative ! real tau ! the agreement tolerance. ! real temp ! a temporary location in which the current estimate of the jth ! parameter is stored. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none real & curve,d,eta,fd,parmx,pv,pvpstp,stp,tau integer & ixm,j,lmsg,m,n,npar,nrow ! ! array arguments real & par(npar),pvtemp(n),xm(ixm,m) integer & msg(lmsg) ! ! subroutine arguments external mdl ! ! real & temp logical & large ! ! check whether finite precision could be the problem ! if (abs(stp*(fd-d)) >= & 10.0e0*eta*(abs(pv)+abs(pvpstp))) then ! ! discrepancy between numerical and analytical derivatives cannot ! be accounted for by finite precision arithmetic ! msg(1) = 2 msg(j+1) = 2 return end if ! ! finite precision arithmetic could be the problem. ! ! try a larger step size ! stp = (eta*(abs(pv)+abs(pvpstp))*sign(1.0e0,par(j))/ & (tau*abs(d))+par(j)) - par(j) large = .false. if (abs(stp) > parmx) then stp = parmx*sign(1.0e0,par(j)) large = .true. end if ! ! calculate numerical derivative usng new, larger, stepsize ! temp = par(j) par(j) = par(j) + stp call mdl(par, npar, xm, n, m, ixm, pvtemp) par(j) = temp pvpstp = pvtemp(nrow) fd = (pvpstp-pv)/stp ! ! check for agreement ! if ((abs(fd-d)) <= 2.0e0*tau*abs(d)) then ! ! forward difference quotient and analytic derivatives agree for ! this step size ! return end if ! ! forward difference quotient and analytic derivatives still ! disagree ! ! check if curvature is the problem ! if (abs(curve*stp) < abs(fd-d) .and. (.not. large)) then ! ! curvature couldnt be the culprit ! msg(1) = 2 msg(j+1) = 2 return else ! ! curvature may be the culprit ! if (msg(1) == 0) msg(1) = 1 if (large) msg(j+1) = 6 if (.not. large) msg(j+1) = 1 return end if return end subroutine dckhdr ( page, wide, isubhd ) !*****************************************************************************80 ! !! DCKHDR prints page headers for the derivative checking routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! full width (true) or not (false). ! implicit none integer & isubhd logical & page,wide ! ! external subroutines external versp if (page) write ( *, 1020) call versp(wide) if (page) write ( *,1000) if (.not.page) write ( *,1010) page = .true. if (isubhd == 0) return write ( *, 1030) return 1000 format ('+derivative checking,', & ' continued') 1010 format ('+', 23('*')/ ' * derivative checking *'/ 1x, 23('*')) 1020 format ('1') 1030 format (//' summary of initial conditions'/ 1x, 30('-')) end subroutine dckls1( n, m, ixm, par, npar, neta, ntau, nrow, scale, nprt ) !*****************************************************************************80 ! !! DCKLS1 sets up a problem for testing the step size selection family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ixm ! the first dimension of the independent variable array. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer neta ! the number of reliable digits in the model. ! integer npar ! the number of unknown parameters in the model. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! integer ntau ! the number of digits of agreement required between the ! numerical derivatives and the user supplied derivatives. ! real par(10) ! the array in which the current estimates of the unknown ! parameters are stored. ! real scale(10) ! a value to indicate use of the default values of ! the typical size of the unknown parameters. ! implicit none integer & ixm,m,n,neta,npar,nprt,nrow,ntau ! ! array arguments real & par(10),scale(10) ! par(1) = 1.0e0 par(2) = 3.125e0 par(3) = 1.0e0 par(4) = 2.0e0 n = 101 m = 1 ixm = 200 npar = 4 scale(1:10) = 1.0e0 scale(2) = 0.01e0 neta = 0 ntau = 0 nrow = 1 nprt = 1 return end subroutine dcklsc ( xm, n, m, ixm, mdl, drv, par, npar, ldstak, & neta, ntau, scale, nrow, nprt ) !*****************************************************************************80 ! !! DCKLSC is the user routine for comparing analytic and numeric derivatives. ! ! Discussion: ! ! This is the user callable subroutine for checking user supplied ! analytic derivatives against numerical derivatives ! for the nonlinear least squares routines (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! external drv ! the name of the user supplied subroutine which computes the ! analytic derivatives (jacobian matrix) of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations of data. ! integer neta ! the number of accurate digits in the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters in the model. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! integer ntau ! the number of digits of agreement required between the ! numerical derivatives and the user supplied derivatives. ! real par(npar) ! the array in which the current estimates of the ! parameters are stored. ! real scale(npar) ! the typical size of the parameters. ! real xm(ixm,m) ! the independent variable. ! implicit none integer & ixm,ldstak,m,n,neta,npar,nprt,nrow,ntau ! ! array arguments real & par(*),scale(*),xm(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer lscale ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external dckdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'd','c','k','l','s','c'/ lscale = npar ! ! pass control of derivative checking to dckdrv ! call dckdrv(nmsub, ldstak, xm, n, m, ixm, mdl, drv, par, npar, & neta, ntau, scale, lscale, nrow, nprt) return end subroutine dckls ( xm, n, m, ixm, mdl, drv, par, npar, ldstak ) !*****************************************************************************80 ! !! DCKLS is the user routine for comparing analytic and numeric derivatives. ! ! Discussion: ! ! This is the user callable subroutine for checking user supplied ! analytic derivatives against numerical derivatives ! for the nonlinear least squares routines (short call). ! !! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! external drv ! the name of the user supplied subroutine which computes the ! analytic derivatives (jacobian matrix) of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations of data. ! integer neta ! the number of accurate digits in the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters in the model. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! integer ntau ! the number of digits of agreement required between the ! numerical derivatives and the user supplied derivatives. ! real par(npar) ! the array in which the current estimates of the ! parameters are stored. ! real scale(1) ! a dummy array, indicating use of default values for ! the typical size of the parameters. ! real xm(ixm,m) ! the independent variable matrix. ! implicit none integer & ixm,ldstak,m,n,npar ! ! array arguments real & par(*),xm(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer lscale,neta,nprt,nrow,ntau ! ! local arrays real & scale(1) character & nmsub(6)*1 ! ! external subroutines external dckdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'd','c','k','l','s',' '/ ! ! set default values ! neta = 0 ntau = 0 scale(1) = 0.0e0 lscale = 1 nprt = 1 nrow = 0 ! ! pass control of derivative checking to dckdrv ! call dckdrv(nmsub, ldstak, xm, n, m, ixm, mdl, drv, par, npar, & neta, ntau, scale, lscale, nrow, nprt) return end subroutine dckmn ( j, d, par, scale, npar, eta, tau, mdl, xm, & n, nrow, m, ixm, pv, pvtemp, msg, lmsg ) !*****************************************************************************80 ! !! DCKMN is the main routine for checking analytic versus numeric derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real d ! the scalar in which row nrow of the derivative ! matrix with respect to the jth unknown parameter ! is stored. ! real eta ! the relative noise in the model ! real fd ! the forward difference quotient derivative with respect to the ! jth parameter ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the partial derivative being examined. ! integer lmsg ! the length of the vector msg. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer msg(lmsg) ! an array used to store message parameters. ! integer n ! the number of observations ! integer npar ! the number of unknown parameters in the model. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real parmx ! the maximum of the current parameter estimate and the ! typical value of that parameter ! real pv ! the scalar in which the predicted value from the model for ! row nrow is stored. ! real pvpstp ! the predicted value for row nrow of the model ! based on the current parameter estimates ! for all but the jth parameter value, which is par(j) + stp. ! real pvtemp(n) ! the vector of predicted value from the model. ! real scale ! the typical size of the jth parameter. ! real stp ! the step size currently being examined for the finite differenc ! derivative ! real tau ! the agreement tolerance. ! real temp ! a temporary location in which the current estimate of the jth ! parameter is stored. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none real & d,eta,pv,scale,tau integer & ixm,j,lmsg,m,n,npar,nrow ! ! array arguments real & par(npar),pvtemp(n),xm(ixm,m) integer & msg(lmsg) ! ! subroutine arguments external mdl real & fd,parmx,pvpstp,stp,temp ! ! calculate the jth partial derivative using forward difference ! quotients and decide if it agrees with user supplied values ! msg(j+1) = 0 parmx = max(abs(par(j)),abs(scale)) if (parmx == 0.0e0) parmx = 1.0e0 ! ! compute initial step size ! stp = (sqrt(eta)*parmx*sign(1.0e0,par(j))+par(j)) - par(j) ! ! compute predicted values ! temp = par(j) par(j) = par(j) + stp call mdl(par, npar, xm, n, m, ixm, pvtemp) par(j) = temp pvpstp = pvtemp(nrow) fd = ( pvpstp - pv ) / stp ! ! check for disagreement ! if ( abs(fd-d) <= tau*abs(d) ) then ! ! numerical and analytic derivatives agree ! ! check if analytic derivative is identically zero, indicating ! the possibility that the derivative should be rechecked at ! another point. ! if (d /= 0.0e0) return ! ! jth analytic and numerical derivatives both are zero. ! if (msg(1) == 0) msg(1) = 1 msg(j+1) = 3 return end if ! ! numerical and analytic derivatives disagree. check why. ! if (d == 0.0e0) then call dckzro(j, par, npar, mdl, xm, n, & nrow, m, ixm, pv, pvtemp, msg, lmsg, fd, parmx, pvpstp, & stp) else call dckcrv(j, d, par, npar, eta, tau, mdl, xm, & n, nrow, m, ixm, pv, pvtemp, msg, lmsg, fd, parmx, & pvpstp, stp) end if return end subroutine dckout ( xm, ixm, n, m, nrow, neta, ntau, npar, msg, & lmsg, par, scale, lscale, hdr, page, wide, isubhd, prtfxd, ifixd ) !*****************************************************************************80 ! !! DCKOUT prints results from the derivative checking routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! character*1 blank ! the character blank. ! character*1 fixed(3) ! the characters used to label the parameters fixed or not. ! logical ftnote(6) ! the array which controls printing of footnotes. ! external hdr ! the name of the routine which produces the heading ! integer i ! an index variable ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixd(i) /= 0, then par(i) will be optimized. if ! ifixd(i) == 0, then par(i) will be held fixed. ! integer imax, imin ! the largest and smallest index value to be printed on each ! line. ! integer index ! the index value to be printed. ! integer isubhd ! an indicator value specifying subheadings to be printed by ! routine hdr. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! an index variable. ! integer k ! an index variable. ! integer lmsg ! the length of the vector msg. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! integer msg(lmsg) ! an array used to store message parameters. ! integer neta ! the number of reliable digits in the model. ! integer npar ! the number of unknown parameters in the model. ! integer nperl ! the number of values to be printed per line. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! integer ntau ! the number of digits of agreement required between the ! approximated derivatives and the user-supplied derivatives. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! real scale(lscale) ! the typical size of the unknown parameters. ! logical wide ! the variable used to indicate whether the heading should ! full width (true) or not (false). ! real xm(ixm,m) ! the independent variable. ! implicit none integer & isubhd,ixm,lmsg,lscale,m,n,neta,npar,nrow,ntau logical & page,prtfxd,wide ! ! array arguments real & par(npar),scale(lscale),xm(ixm,m) integer & ifixd(npar),msg(lmsg) ! ! subroutine arguments external hdr integer & i,imax,imin,index,j,k,nperl character & blank*1 ! ! local arrays logical & ftnote(6) character & fixed(3)*1 data blank /' '/ ! ! initialize array fixed ! fixed(1:3) = blank call hdr(page, wide, isubhd) ! ! set up for footnotes ! ftnote(1:6) = .false. if ( 0 < msg(1) ) then do i=1,npar if ((msg(i+1) == 0) .or. (msg(i+1) == 2)) then cycle end if k = msg(i+1) - 2 if (k == -1) k = 5 ftnote(1) = .true. ftnote(k+1) = .true. end do end if ! ! print report ! write ( *,1000) if ( ftnote(1) ) then write ( *,1040) end if if ( prtfxd ) then write ( *,1160) else write ( *,1170) end if if ( 0.0E+00 < scale(1) ) then do i=1,npar if (prtfxd) call fixprt(ifixd(i), fixed) k = msg(i+1) - 2 if (k == -1) k = 5 if (k == -2) write ( *,1010) i, (fixed(j),j=1,3), par(i), & scale(i) if (k == 0) write ( *,1020) i, (fixed(j),j=1,3), par(i), & scale(i) if (k >= 1) write ( *,1030) i, (fixed(j),j=1,3), par(i), & scale(i), k end do else do i=1,npar if (prtfxd) call fixprt(ifixd(i), fixed) k = msg(i+1) - 2 if (k == -1) k = 5 if (k == -2) write ( *,1180) i, (fixed(j),j=1,3), par(i) if (k == 0) write ( *,1190) i, (fixed(j),j=1,3), par(i) if (k >= 1) write ( *,1200) i, (fixed(j),j=1,3), par(i), k end do end if ! ! print footnotes ! if ( ftnote(1) ) then write ( *,1060) if (ftnote(2)) write ( *,1070) if (ftnote(3)) write ( *,1080) if (ftnote(4)) write ( *,1090) if (ftnote(5)) write ( *,1100) if (ftnote(6)) write ( *,1050) end if write ( *,1110) neta write ( *,1120) ntau ! ! print out row of independent variable which was checked. ! write ( *,1130) nrow nperl = 7 do i=1,m,nperl imin = i imax = min(i+nperl-1,m) write ( *,1140) (index,index=imin,imax) write ( *,1150) (xm(nrow,index),index=imin,imax) end do write ( *,1210) n return 1000 format (//) 1010 format (1x, i3, 5x, 3a1, 2g17.8, 10x, 'ok') 1020 format (1x, i3, 5x, 3a1, 2g17.8, 7x, 'incorrect') 1030 format (1x, i3, 5x, 3a1, 2g17.8, 5x, 'questionable (', i1, ')') 1040 format (62x, '*') 1050 format (/' (5) user-supplied and approximated derivatives', & ' disagree, but',/,5x, ' approximated derivative is questiona', & 'hble because', ' ratio'/5x, ' of relative curvature to rela', & 'tive slope is too', ' high.') 1060 format (/' * numbers in parentheses refer to the following notes.') 1070 format (/' (1) user-supplied and approximated derivatives', & ' agree, but'/5x, ' both are zero. recheck at another row.') 1080 format (/' (2) user-supplied and approximated derivatives', & ' may agree, but'/5x, ' user-supplied derivative is identic', & 'ally zero', ' and approximated'/5x, ' derivative is only a', & 'pproximately zero.', ' recheck at another row.') 1090 format (/' (3) user-supplied and approximated derivatives', & ' disagree, but'/5x, ' user-supplied derivative is identica', & 'lly zero.', ' recheck at'/5x, ' another row.') 1100 format (/' (4) user-supplied and approximated derivatives', & ' disagree, but'/5x, ' approximated derivative is questiona', & 'ble because', ' either ratio'/5x, ' of relative curvature', & ' to relative slope is too', ' high, or'/5x, ' scale(k) is ', & 'wrong.') 1110 format (/' number of reliable digits in model results', 25x, & '(neta)', 1x, i5) 1120 format (/' number of digits in derivative checking', ' agreemen', & 't tolerance', 8x, '(ntau)', 1x, i5) 1130 format (/' row number at which derivatives were checked', 23x, & '(nrow)', 1x, i5/' -values of the independent variables at', & ' this row') 1140 format (10x, 'index', i5, 6i15) 1150 format (10x, 'value', 7(1x, g14.7)/) 1160 format (52x, 'derivative'/7x, 'parameter starting value', 6x, & 'scale', 10x, 'assessment'/1x, 'index', 2x, 'fixed', 6x, & '(par)', 12x, '(scale)'/) 1170 format (17x, 'parameter', 26x, 'derivative'/15x, 'starting val', & 'ue', 8x, 'scale', 10x, 'assessment'/1x, 'index', 13x, & '(par)', 12x, '(scale)'/) 1180 format (1x, i3, 5x, 3a1, g17.8, 7x, 'default', 13x, 'ok') 1190 format (1x, i3, 5x, 3a1, g17.8, 7x, 'default', 10x, 'incorrect') 1200 format (1x, i3, 5x, 3a1, g17.8, 7x, 'default', 8x, 'questionabl', & 'e (', i1, ')') 1210 format (/' number of observations', 48x, '(n)', 1x, i5) end subroutine dckzro ( j, par, npar, mdl, xm, n, nrow, m, ixm, pv, & pvtemp, msg, lmsg, fd, parmx, pvpstp, stp ) !*****************************************************************************80 ! !! DCKZRO rechecks derivative errors where the analytic derivative is zero. ! ! Discussion: ! ! This routine rechecks the derivatives in the case where the finite ! difference derivative disagrees with the analytic derivative and t ! analytic derivative is zero. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real cd ! the central difference quotient derivative with ! respect to the jth parameter. ! real fd ! the forward difference quotient derivative with respect to the ! jth parameter. ! real fplrs ! the floating point largest relative spacing. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the partial derivative being examined. ! integer lmsg ! the length of the vector msg. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer msg(lmsg) ! an array used to store message parameters. ! integer n ! the number of observations. ! integer npar ! the number of unknown parameters in the model. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real parmx ! the maximum of the current parameter estimate and the typical ! value of that parameter. ! real pv ! the scalar in which the predicted value from the model for ! row nrow is stored. ! real pvmstp ! the predicted value for row nrow of the model ! based on the current parameter estimates ! for all but the jth parameter value, which is par(j) - stp. ! real pvpstp ! the predicted value for row nrow of the model ! based on the current parameter estimates ! for all but the jth parameter value, which is par(j) + stp. ! real pvtemp(n) ! the vector of predicted values from the model. ! real stp ! the step size currently being examined for the finite differenc ! derivative ! real temp ! a temporary location in which the current estimate of the jth ! parameter is stored. ! real third ! the value 1/3. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none real & fd,parmx,pv,pvpstp,stp integer & ixm,j,lmsg,m,n,npar,nrow ! ! array arguments real & par(npar),pvtemp(n),xm(ixm,m) integer & msg(lmsg) ! ! subroutine arguments external mdl ! ! real & cd,fplrs,pvmstp,temp,third fplrs = epsilon ( fplrs ) ! ! recalculate numerical derivative using central difference and step ! size of 2*stp ! temp = par(j) par(j) = par(j) - stp call mdl(par, npar, xm, n, m, ixm, pvtemp) par(j) = temp pvmstp = pvtemp(nrow) cd = (pvpstp-pvmstp)/(2.0e0*stp) ! ! check for disagreement ! ! numerical and analytic derivatives now agree, but both equal zero, ! indicating that derivatives should be rechecked at another point. ! if ( cd == 0.0e0 ) then if (msg(1) == 0) msg(1) = 1 msg(j+1) = 3 return end if ! ! numerical and analytic derivative still do not agree. ! ! check if numerical derivative is close to zero. ! third = 1.0e0/3.0e0 ! ! numerical derivative is close to zero ! if (min(abs(cd), abs(fd))*parmx <= abs(pv*fplrs**third)) then if (msg(1) == 0) msg(1) = 1 msg(j+1) = 4 ! ! numerical derivative not close to zero ! else msg(1) = 2 msg(j+1) = 5 end if return end subroutine dcoef ( ndf, nd, iod, npardf, pardf, mbo, work ) !*****************************************************************************80 ! !! DCOEF expands a difference filter. ! ! Discussion: ! ! This routine expands the difference filter specified by ndf, ! iod and nd into pardf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer iod(ndf) ! the order of each of the difference factors. ! integer k ! an index variable. ! integer kk ! an index variable. ! integer l ! an index variable. ! integer mbo ! the maximum back order operator. ! integer nd(ndf) ! the number of times each difference factor is to be applied. ! integer ndf ! the number of difference factors ! integer npardf ! the order of the expanded difference filter. ! integer ntimes ! the number of times a given difference factor is to be applied. ! integer nwork1 ! the number of terms in the first column of work. ! integer nwork2 ! the number of terms in the second column of work ! real pardf(mbo) ! the vector containing the difference filter parameters. ! real work(mbo,2) ! a work array necessary to expand the difference filter. ! implicit none integer & mbo,ndf,npardf ! ! array arguments real & pardf(*),work(*) integer & iod(*),nd(*) ! ! integer & k,kk,l,ntimes,nwork1,nwork2 ! ! external functions integer & nchose external nchose ! ! external subroutines external multbp npardf = 0 do l = 1, ndf if ( nd(l) == 0 ) then cycle end if ntimes = nd(l) nwork1 = iod(l) * nd(l) work(1:nwork1) = 0.0e0 do k = 1, ntimes kk = k * iod(l) work(kk) = real ( ((-1)**(k+1)) * nchose(ntimes, k) ) end do nwork2 = nwork1 + npardf call multbp (work(1), nwork1, pardf, npardf, work(mbo+1), & nwork2, mbo) end do return end subroutine demdrv ( y, n, fd, fc, k, hlp, ampl, phase, iphase, & ndem, nprt, nmsub ) !*****************************************************************************80 ! !! DEMDRV is the driver routine to demodulate a series. ! ! Discussion: ! ! This is the driver routine to demodulate series ! y at frequency fd, to apply a low pass filter with cutoff ! frequency fc, and to extract the amplitude and phase components ! of the resulting filtered series . ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! Parameters: ! ! real ampl(n) ! the array in which the amplitudes are stored. ! real fc ! the cutoff frequency used for the low pass filter. ! real fd ! the demodulation frequency. ! real hlp(k) ! the array in which the low pass filter coefficients are ! stored. ! integer k ! the user supplied number of terms to be used for the low ! pass filter. ! integer n ! the number of observations. ! integer ndem ! the number of values in the demodulated series, i.e., in ! the amplitude and phase arrays. ! character*1 nmsub(6) ! the name of the calling subroutine. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of nprt ! is zero, no output is given, otherwise output is provided. ! real phase(iphase,2) ! the array contianing the primary and secondary phase estimates. ! real y(n) ! the input array containing the observed series. ! implicit none real & fc,fd integer & iphase,k,n,ndem,nprt ! ! array arguments real & ampl(n),hlp(k),phase(iphase,2),y(n) character & nmsub(6)*1 ! ! external subroutines external demodu,demord,demout,fltsl,lpflt,polar ! call demodu (y, n, fd, ampl, phase) call lpflt (fc, k, hlp) call fltsl (ampl, n, k, hlp, ampl, ndem) call fltsl (phase, n, k, hlp, phase, ndem) call polar (ampl, phase, ndem) if (nprt == 0) return call demord (phase, phase(1,2), ndem, n) call demout (fd, fc, k, ampl, phase, iphase, ndem, nmsub) return end subroutine demod ( y, n, fd, fc, k, ldstak ) !*****************************************************************************80 ! !! DEMOD demodulates a series at a given frequency. ! ! Discussion: ! ! This is the user callable routine to demodulate series ! y at frequency fd, to apply a low pass filter with cutoff ! frequency fc, and to extract the amplitude and phase components ! of the resulting filtered series (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! Parameters: ! ! integer ampl ! the starting location in rstak/dstak of ! the array in which the amplitudes are stored. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03, err04, err05, err06, err07 ! values indicating whether an error was detected (true) or not ! (false). ! real fc ! the cutoff frequency used for the low pass filter. ! real fd ! the demodulation frequency. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer hlp ! the starting location in rstak/dstak of ! the array in which the low pass filter coefficients are ! stored. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer k ! the user supplied number of terms to be used for the low ! pass filter. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 lfc(8), lfd(8), lk(8), lkin(8), llds(8), ln(8), ! * lnm1(8), lone(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer n ! the number of observations. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! integer ndem ! the number of values in the demodulated series, i.e., in ! the amplitude and phase arrays. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer phase ! the starting locations in rstak/dstak of ! the array containing the primary and secondary phase estimates. ! real rstak(12) ! the real version of the /cstak/ work area. ! real temp ! a temporary variable used for type conversion. ! real y(n) ! the input array containing the observed series. ! implicit none real & fc,fd integer & k,ldstak,n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & temp integer & ampl,hlp,ifp,ldsmin,nall0,ndem,phase logical & err01,err02,err03,err04,err05,err06,err07,head ! ! local arrays real & rstak(12) character & lfc(8)*1,lfd(8)*1,lk(8)*1,lkin(8)*1,llds(8)*1,ln(8)*1, & lnm1(8)*1,lone(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external demdrv,eisge,eisii,eriodd,ersii,erslfs,ldscmp, & stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'd', 'e', 'm', 'o', 'd', ' '/ data & lfc(1), lfc(2), lfc(3), lfc(4), lfc(5), lfc(6), lfc(7), lfc(8) & / 'f', 'c', ' ', ' ', ' ', ' ', ' ', ' '/ data & lfd(1), lfd(2), lfd(3), lfd(4), lfd(5), lfd(6), lfd(7), lfd(8) & / 'f', 'd', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lkin(1), lkin(2), lkin(3), lkin(4), lkin(5), lkin(6), lkin(7), & lkin(8) / '(', '1', '/', 'k', ')', ' ', ' ', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), llds(7), & llds(8) / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lnm1(1), lnm1(2), lnm1(3), lnm1(4), lnm1(5), lnm1(6), lnm1(7), & lnm1(8) / '(', 'n', '-', '1', ')', ' ', ' ', ' '/ data & lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), lone(7), & lone(8) / 'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ ! ! Perform error checking on input data. ! ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) call ersii(nmsub, lfd, fd, & 0.0e0, 0.5e0, 2, head, err02, lfd, lfd) err03 = .true. if (.not. err01) & call eisii(nmsub, lk, k, 1, n-1, 1, head, err03, lone, lnm1) call eriodd(nmsub, lk, k, 1, head, err04) err05 = .true. if ((.not. err02) .and. (.not. err03) .and. (.not. err04)) then temp = real ( k ) call ersii(nmsub, lfc, fc, 1.0e0/temp, fd, 1, head, err05, & lkin, lfd) end if err06 = .true. if ((.not. err03) .and. (.not. err04) .and. (.not. err05)) & call erslfs(nmsub, fc, k, head, err06) if (err01 .or. err06) then ierr = 1 return end if call ldscmp ( 3, 0, 0, 0, 0, 0, 's', k + 3*n, ldsmin ) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err07, llds) if (err02 .or. err03 .or. err04 .or. err05 .or. err07) then ierr = 1 return end if call stkset (ldstak, 4) nall0 = stkst(1) ifp = 3 ampl = stkget(n, ifp) phase = stkget(2*n, ifp) hlp = stkget(k, ifp) if (ierr == 1) then ierr = 1 return end if call demdrv(y, n, fd, fc, k, rstak(hlp), rstak(ampl), & rstak(phase), n, ndem, 1, nmsub) call stkclr(nall0) if (ierr == 1) then ierr = 1 return end if return end subroutine demods ( y, n, fd, fc, k, ampl, phas, ndem, nprt, ldstak ) !*****************************************************************************80 ! !! DEMODS demodulates a series at a given frequency. ! ! Discussion: ! ! This is the user callable routine to demodulate series ! y at frequency fd, to apply a low pass filter with cutoff ! frequency fc, and to extract the amplitude and phase components ! of the resulting filtered series (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! Parameters: ! ! real ampl(n) ! the array in which the amplitudes are stored. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03, err04, err05, err06, err07 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real fc ! the cutoff frequency used for the low pass filter. ! real fd ! the demodulation frequency. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer hlp ! the starting location in rstak/dstak of ! the array in which the low pass filter coefficients are ! stored. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer io ! a variable used to determine the amount of storage required ! based on printed output requested. ! integer k ! the user supplied number of terms to be used for the low ! pass filter. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 lfc(8), lfd(8), lk(8), lkin(8), llds(8), ln(8), ! * lnm1(8), lone(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer n ! the number of observations. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! integer ndem ! the number of values in the demodulated series, i.e., in ! the amplitude and phase arrays. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be given, where if the value of nprt ! is zero, no output is given, otherwise output is provided. ! real phas(n) ! the array in which the primary phase estimates are returned. ! integer phase ! the starting location in rstak/dstak of ! the array containing the primary and secondary phase estimates. ! real rstak(12) ! the real version of the /cstak/ work area. ! real temp ! a temporary variable used for type conversion. ! real y(n) ! the input array containing the observed series. ! implicit none real & fc,fd integer & k,ldstak,n,ndem,nprt ! ! array arguments real & ampl(*),phas(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & temp integer & hlp,io,ldsmin,nall0,phase logical & err01,err02,err03,err04,err05,err06,err07,head ! ! local arrays real & rstak(12) character & lfc(8)*1,lfd(8)*1,lk(8)*1,lkin(8)*1,llds(8)*1,ln(8)*1, & lnm1(8)*1,lone(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external demdrv,eisge,eisii,eriodd,ersii,erslfs,ldscmp, & scopy,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'd', 'e', 'm', 'o', 'd', 's'/ data & lfc(1), lfc(2), lfc(3), lfc(4), lfc(5), lfc(6), lfc(7), lfc(8) & / 'f', 'c', ' ', ' ', ' ', ' ', ' ', ' '/ data & lfd(1), lfd(2), lfd(3), lfd(4), lfd(5), lfd(6), lfd(7), lfd(8) & / 'f', 'd', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lkin(1), lkin(2), lkin(3), lkin(4), lkin(5), lkin(6), lkin(7), & lkin(8) / '(', '1', '/', 'k', ')', ' ', ' ', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), llds(7), & llds(8) / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lnm1(1), lnm1(2), lnm1(3), lnm1(4), lnm1(5), lnm1(6), lnm1(7), & lnm1(8) / '(', 'n', '-', '1', ')', ' ', ' ', ' '/ data & lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), lone(7), & lone(8) / 'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ ! ! perform error checking on input data. ! ierr = 0 head = .true. if (nprt == 0) then io = 0 else io = 1 end if call eisge(nmsub, ln, n, 17, 1, head, err01, ln) call ersii(nmsub, lfd, fd, 0.0e0, 0.5e0, 2, head, err02, lfd, lfd) err03 = .true. if (.not. err01) & call eisii(nmsub, lk, k, 1, n-1, 1, head, err03, lone, lnm1) call eriodd(nmsub, lk, k, 1, head, err04) err05 = .true. if ((.not. err02) .and. (.not. err03) .and. (.not. err04)) then temp = real ( k ) call ersii(nmsub, lfc, fc, 1.0e0/temp, fd, 1, head, err05, lkin, lfd) end if err06 = .true. if ((.not. err03) .and. (.not. err04) .and. (.not. err05)) & call erslfs(nmsub, fc, k, head, err06) if (err01 .or. err06) then ierr = 1 return end if call ldscmp(2, 0, 0, 0, 0, 0, 's', k + io*2*n, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err07, llds) if (err02 .or. err03 .or. err04 .or. err05 .or. err07) then ierr = 1 return end if call stkset (ldstak, 4) nall0 = stkst(1) hlp = stkget(k, 3) if (nprt == 0) then phase = 1 else phase = stkget(2*n, 3) end if if (ierr == 1) then ierr = 1 return end if if (nprt /= 0) then call demdrv(y, n, fd, fc, k, rstak(hlp), ampl, & rstak(phase), n, ndem, nprt, nmsub) call scopy(ndem, rstak(phase), 1, phas, 1) else call demdrv(y, n, fd, fc, k, rstak(hlp), ampl, & phas, n, ndem, nprt, nmsub) end if call stkclr(nall0) if (ierr == 1) then ierr = 1 return end if return end subroutine demodu ( y, n, fd, ampl, phas ) !*****************************************************************************80 ! !! DEMODU demodulates a series at a given frequency. ! ! Discussion: ! ! This routine demodulates the series y at frequency ! fd. the real and imaginary parts of the demodulated ! series are returned in ampl and phas, respectively. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! Parameters: ! ! real ampl(n) ! the array in which the amplitudes are stored. ! real arg ! a value used in computing the demodulated series. ! real fd ! the demodulation frequency. ! integer i ! an indexing variable. ! integer n ! the number of observations in the series being demodulated. ! real phas(n) ! the arrays containing the primary phase estimates. ! real pi ! the value of pi. ! real y(n) ! the input array array containing the observed series. ! implicit none integer n real ampl(n) real arg real fd integer i real phas(n) real pi real y(n) call getpi(pi) do i = 1, n if (fd == 0.25e0) then ampl(i) = 0.0e0 phas(i) = -2.0e0*y(i) else if (fd == 0.5e0) then ampl(i) = -2.0e0*y(i) phas(i) = 0.0e0 else arg = real (i-1) * fd * 2.0e0 * pi ampl(i) = y(i)*cos(arg)*2.0e0 phas(i) = -y(i)*sin(arg)*2.0e0 end if end do return end subroutine demord ( phas1, phas2, ndem, n ) !*****************************************************************************80 ! !! DEMORD sets up the data for the phase plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer n ! the number of observations in the series being demodulated. ! integer ndem ! the number of values in the demodulated series, i.e., in ! the amplitude and phase arrays. ! real phas1(n), phas2(n) ! the arrays containing the primary and secondary phase ! estimates, respectively. ! implicit none integer & n,ndem ! ! array arguments real & phas1(n),phas2(n) ! ! real & pi integer & i ! ! external subroutines external getpi call getpi(pi) do i = 1, ndem phas2(i) = 0.0e0 if (phas1(i) > 0.0e0) phas2(i) = phas1(i) - 2.0e0*pi if (phas1(i) < 0.0e0) phas2(i) = phas1(i) + 2.0e0*pi end do return end subroutine demout ( fd, fc, k, ampl, phase, iphase, ndem, nmsub ) !*****************************************************************************80 ! !! DEMOUT prints output for the time series demodulation routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ampl(ndem) ! the array in which the amplitudes of the demodulated series ! are stored. ! logical error ! an error flag ! real fc, fd ! the cutoff frequency and the demodulation frequency. ! integer ierr ! the error flag ! integer isym(1) ! a dummy array. ! integer k ! the number of terms in the low pass filter used to smooth ! the demodulated series. ! integer ndem ! the number of values in the demodulated series. ! character*1 nmsub(6) ! the name of the calling subroutine ! real phase(iphase,2) ! the array containing the primary and secondary phase values. ! real pi ! the value of pi. ! real ymn, ymx ! implicit none real & fc,fd integer & iphase,k,ndem ! ! array arguments real & ampl(ndem),phase(iphase,2) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! real & pi,ymn,ymx logical & error ! ! local arrays integer & isym(1) ! ! external subroutines external getpi,versp,vplmt,vpmn ! ! common blocks common /errchk/ierr call versp(.true.) call getpi(pi) write ( *, 1000) fd, fc, k write ( *, 1001) call vplmt(ampl, ampl, ndem, 1, ndem, 0.0e0, 0.0e0, & ymn, ymx, error, nmsub, .false., 1) if (error) then ierr = 1 return end if call vpmn ( ampl, ampl, ndem, 1, ndem, 1, 0, isym, 1, 0, & ymn, ymx, 1.0e0, 1.0e0, .false., 0, 1, 0) write ( *, 1002) call versp(.true.) write ( *, 1003) call vpmn ( phase, phase, ndem, 2, iphase, 1, 2, isym, 1, 0, & -2.0e0*pi, 2.0e0*pi, 1.0e0, 1.0e0, .false., 0, 0, 0) return 1000 format (/' time series demodulation'// & ' demodulation frequency is', f10.8/ & ' cutoff frequency is ', f10.8/ & ' the number of terms in the filter is ', i5///) 1001 format (' plot of amplitude of smoothed demodulated series') 1002 format ('1') 1003 format (' plot of phase of smoothed demodulated series') end subroutine dfault ( iv, v ) !*********************************************************************** ! !! DFAULT supplies default values to IV and V. ! ! Discussion: ! ! Only entries in the first 25 positions of IV and the first 45 ! positions of V are reset. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Output, integer IV(25), contains default values for specific entries. ! ! Output, real V(45), contains default values for specific values. ! implicit none integer :: afctol = 31 integer :: cosmin = 43 integer :: covprt = 14 integer :: covreq = 15 integer :: d0init = 37 integer :: decfac = 22 integer :: delta0 = 44 integer :: dfac = 41 integer :: dinit = 38 integer :: dltfdc = 40 integer :: dltfdj = 36 integer :: dtype = 16 integer :: inits = 25 integer :: epslon = 19 integer :: fuzz = 45 integer :: incfac = 23 integer iv(25) integer :: jtinit = 39 integer :: lmax0 = 35 real machep real mepcrt integer :: mxfcal = 17 integer :: mxiter = 18 integer :: outlev = 19 integer :: parprt = 20 integer :: phmnfc = 20 integer :: phmxfc = 21 integer :: prunit = 21 integer :: rdfcmn = 24 integer :: rdfcmx = 25 integer :: rfctol = 32 integer :: rlimit = 42 integer :: solprt = 22 real sqteps integer :: statpr = 23 integer :: tuner1 = 26 integer :: tuner2 = 27 integer :: tuner3 = 28 integer :: tuner4 = 29 integer :: tuner5 = 30 real v(45) integer :: x0prt = 24 integer :: xctol = 33 integer :: xftol = 34 iv(1) = 12 iv(covprt) = 1 iv(covreq) = 1 iv(dtype) = 1 iv(inits) = 0 iv(mxfcal) = 200 iv(mxiter) = 150 iv(outlev) = -1 iv(parprt) = 1 iv(prunit) = 6 iv(solprt) = 1 iv(statpr) = 1 iv(x0prt) = 1 machep = epsilon ( machep ) v(afctol) = 1.0e-20 if ( 1.0e-10 < machep ) then v(afctol) = machep**2 end if v(cosmin) = max ( 1.0e-06, 1.0e+02 * machep ) v(decfac) = 0.5e+00 sqteps = sqrt ( epsilon ( sqteps ) ) v(delta0) = sqteps v(dfac) = 0.6e+00 v(dinit) = 0.0e+00 mepcrt = machep ** ( 1.0E+00 / 3.0E+00 ) v(dltfdc) = mepcrt v(dltfdj) = sqteps v(d0init) = 1.0e+00 v(epslon) = 0.1e+00 v(fuzz) = 1.5e+00 v(incfac) = 2.0e+00 v(jtinit) = 1.0e-06 v(lmax0) = 100.e+00 v(phmnfc) = -0.1e+00 v(phmxfc) = 0.1e+00 v(rdfcmn) = 0.1e+00 v(rdfcmx) = 4.e+00 v(rfctol) = max ( 1.0E-10, mepcrt**2 ) v(rlimit) = sqrt ( 0.999E+00 * huge ( v(rlimit) ) ) v(tuner1) = 0.1e+00 v(tuner2) = 1.0e-04 v(tuner3) = 0.75e+00 v(tuner4) = 0.5e+00 v(tuner5) = 0.75e+00 v(xctol) = sqteps v(xftol) = 1.0e+02 * machep return end subroutine dfbw ( n, lag, w, lw, df, bw ) !*****************************************************************************80 ! !! DFBW computes degrees of freedom and bandwidth for a given lag window. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real bw ! the bandwidth. ! real df ! the effective degrees of freedom. ! integer k ! an index variable ! integer lag ! the lag window truncation point used for a specific window. ! integer lw ! the length of the vector w. ! integer n ! the number of observations in the series. ! real w(lw) ! the vector of lag windows. ! implicit none real & bw,df integer & lag,lw,n ! ! array arguments real & w(lw) ! ! integer & k bw = 0.0e0 do k = 1, lag bw = bw + w(k+1) * w(k+1) * real ( n - k ) end do bw = 1.0e0 / (w(1)*w(1) + 2.0e0*bw / real ( n ) ) df = 2.0e0 * bw * real ( n ) return end subroutine dfbwm ( n, lag, w, lw, nlppa1, nlppa2, lnlppa, df, bw ) !*****************************************************************************80 ! !! DFBWM computes DOF and BW for a given lag window with missing data. ! ! Discussion: ! ! This routine computes and stores the associated degrees of ! freedom and bandwidth for a given lag window when missing data are ! involved. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real bw ! the bandwidth. ! real df ! the effective degrees of freedom. ! integer k ! an index variable ! integer lnlppa ! the length of the vector nlppa. ! integer lw ! the length of the vector w. ! integer lag ! the lag window truncation point used for a specific window. ! integer n ! the number of observations in the series. ! integer nlppa1(lnlppa), nlppa2(lnlppa) ! the number of lagged product pairs used for each acvf ! estimate. ! real w(lw) ! the vector of lag windows. ! implicit none real & bw,df integer & lag,lnlppa,lw,n ! ! array arguments real & w(lw) integer & nlppa1(lnlppa),nlppa2(lnlppa) ! ! integer & k bw = (w(1)* real ( n ) )**2 / real ( nlppa1(1) ) do k = 1, lag bw = bw + (w(k+1) * real ( n - k ) )**2 * & ( 1.0e0 / real ( nlppa1(k+1) ) + 1.0e0 / real( nlppa2(k+1) ) ) end do bw = real ( n ) / bw df = 2.0e0 * bw * real ( n ) return end subroutine difc ( y, n, nfac, nd, iod, iar, phi, lphi, yf, nyf, ldstak ) !*****************************************************************************80 ! !! DIFC expands a difference filter and performs difference filtering. ! ! Discussion: ! ! This routine expands the difference filter specified by nfac, ! iod and nd into phi and performs the difference filtering ! operation defined by phi, returning the filtered series in yf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03, err04 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer iar ! the number of filter coefficients. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer iod(nfac) ! the order of each of the difference factors. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 llds(8), llphi(8), ln(8) ! the arrays containing the names of various variables ! integer lphi ! the length of the array phi. ! integer n ! the number of observations in the series y. ! integer nall0 ! the number of outstanding work area allocations. ! integer nd(nfac) ! the array containing the number of times the difference ! factors are to be applied. ! integer nfac ! the number of difference factors. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nyf ! the number of observations in the filtered series yf. ! real phi(lphi) ! the vector containing the filter coefficients. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer work ! the starting location for the work vector necessary to ! expand the difference filter. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! implicit none integer & iar,ldstak,lphi,n,nfac,nyf ! ! array arguments real & phi(*),y(*),yf(*) integer & iod(*),nd(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer ldsmin,nall0,work logical & err01,err02,err03,err04,head ! ! local arrays real & rstak(12) character & llds(8)*1,llphi(8)*1,ln(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external dcoef,eisge,erdf,fltar,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'd', 'i', 'f', 'c', ' ', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) & / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data & llphi(1), llphi(2), llphi(3), llphi(4), llphi(5), llphi(6), & llphi(7), llphi(8) & / 'l', 'p', 'h', 'i', ' ', ' ', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. err01 = .false. err02 = .false. err03 = .false. err04 = .false. ! ! call error checking routines ! call eisge(nmsub,ln,n,3,1,head,err01,ln) iar = 0 if (nfac >= 1) then iar = dot_product ( nd(1:nfac), iod(1:nfac) ) call erdf(nmsub,nfac,nd,iod,n,head,err02) if (.not.err02) then call eisge(nmsub,llphi,lphi,iar,9,head,err03,llphi) call ldscmp(1,0,0,0,0,0,'s',2*iar,ldsmin) call eisge(nmsub,llds,ldstak,ldsmin,9,head,err04,llds) end if end if if (err01 .or. err02 .or. err03 .or. err04) then ierr = 1 write ( *, 1000) return end if nyf = n yf(1:nyf) = y(1:nyf) if (nfac <= 0) return call stkset (ldstak, 4) nall0 = stkst(1) phi(1:lphi) = 0.0e0 work = stkget(2*iar, 3) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if call dcoef (nfac,nd,iod,iar,phi,lphi,rstak(work)) call stkclr(nall0) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if call fltar (yf,nyf,iar,phi,yf,nyf) return 1000 format (/' the correct form of the call statement is'// & ' call difc (y, n,'/ & ' + nfac, nd, iod, iar, phi, lphi,'/ & ' + yf, nyf, ldstak)') end subroutine dif ( y, n, yf, nyf ) !*****************************************************************************80 ! !! DIF performs a first difference filtering operation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical err01 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer iar ! the number of filter coefficients. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! character*1 ln(8) ! the arrays containing the names of the variables n. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nyf ! the number of observations in the filtered series yf. ! real phi(1) ! the vector containing the filter coefficients. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! implicit none integer & n,nyf ! ! array arguments real & y(*),yf(*) ! ! scalars in common integer & ierr ! ! integer & iar logical & err01,head ! ! local arrays real & phi(1) character & ln(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,fltar ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'd', 'i', 'f', ' ', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 3, 1, head, err01, ln) if ( err01 ) then ierr = 1 write ( *, 1000) return end if iar = 1 phi(1) = 1.0e0 call fltar (y, n, iar, phi, yf, nyf) return 1000 format (/' the correct form of the call statement is'// & ' call dif (y, n, yf, nyf)') end subroutine difmc ( y, ymiss, n, nfac, nd, iod, iar, phi, lphi, yf, & yfmiss, nyf, ldstak ) !*****************************************************************************80 ! !! DIFMC expands a difference filter and performs the difference filter. ! ! Discussion: ! ! This routine expands the difference filter specified by NFAC, ! IOD and ND into PHI and performs the difference filtering ! operation defined by PHI on a series containing missing data, ! returning the filtered series in YF. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03, err04 ! values indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer iar ! the number of filter coefficients. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer iod(nfac) ! the order of each of the difference factors. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 llds(8), llphi(8), ln(8) ! the arrays containing the names of the variables ldstak, n ! and lphi, respectively. ! integer lphi ! the length of the vector phi. ! integer n ! the number of observations in the series y. ! integer nall0 ! the number of outstanding stack allocations. ! integer nd(nfac) ! the array containing the number of times the difference ! factors are to be applied. ! integer nfac ! the number of difference factors. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nyf ! the number of observations in the filtered series yf. ! real phi(lphi) ! the vector containing the filter coefficients. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer work ! the starting location for the work vector necessary to ! expand the difference filter. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! real yfmiss ! the missing value code used in the filtered series to ! indicate the value could not be computed due to missing data. ! real ymiss ! the missing value code used in the input series to indicate ! an observation is missing. ! implicit none real & yfmiss,ymiss integer & iar,ldstak,lphi,n,nfac,nyf ! ! array arguments real & phi(*),y(*),yf(*) integer & iod(*),nd(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer ldsmin,nall0,work logical & err01,err02,err03,err04,head ! ! local arrays real & rstak(12) character & llds(8)*1,llphi(8)*1,ln(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external dcoef,eisge,erdf,fltarm,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'd', 'i', 'f', 'm', 'c', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) & / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data & llphi(1), llphi(2), llphi(3), llphi(4), llphi(5), llphi(6), & llphi(7), llphi(8) & / 'l', 'p', 'h', 'i', ' ', ' ', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. err01 = .false. err02 = .false. err03 = .false. err04 = .false. ! ! call error checking routines ! call eisge(nmsub,ln,n,3,1,head,err01,ln) iar = 0 if (nfac >= 1) then iar = dot_product ( nd(1:nfac), iod(1:nfac) ) call erdf(nmsub,nfac,nd,iod,n,head,err02) if (.not.err02) then call eisge(nmsub,llphi,lphi,iar,9,head,err03,llphi) call ldscmp(1,0,0,0,0,0,'s',2*iar,ldsmin) call eisge(nmsub,llds,ldstak,ldsmin,9,head,err04,llds) end if end if if (err01 .or. err02 .or. err03 .or. err04) then ierr = 1 write ( *, 1000) return end if nyf = n yf(1:nyf) = y(1:nyf) yfmiss = ymiss if (nfac <= 0) return call stkset (ldstak, 4) nall0 = stkst(1) phi(1:lphi) = 0.0e0 work = stkget(2*iar,3) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if call dcoef (nfac,nd,iod,iar,phi,lphi,rstak(work)) call stkclr(nall0) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if call fltarm (yf,ymiss,nyf,iar,phi,yf,yfmiss,nyf) return 1000 format (/' the correct form of the call statement is'// & ' call difmc (y, ymiss, n,'/ & ' + nfac, nd, iod, iar, phi, lphi,'/ & ' + yf, yfmiss, nyf, ldstak)') end subroutine difm ( y, ymiss, n, yf, yfmiss, nyf ) !*****************************************************************************80 ! !! DIFM performs a first difference filter for a series with missing data. ! ! Discussion: ! ! This routine performs a first difference filtering operation, ! returning the filtered series in yf, for an input series ! containing missing values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical err01 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer iar ! the number of filter coefficients. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! character*1 ln(8) ! the arrays containing the names of the variables n. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nyf ! the number of observations in the filtered series yf. ! real phi(1) ! the vector containing the filter coefficients. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! real yfmiss ! the missing value code used in the filtered series to ! indicate the value could not be computed due to missing data. ! real ymiss ! the missing value code used in the input series to indicate ! an observation is missing. ! implicit none real & yfmiss,ymiss integer & n,nyf ! ! array arguments real & y(*),yf(*) ! ! scalars in common integer & ierr ! ! integer iar logical & err01,head ! ! local arrays real & phi(1) character & ln(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,fltarm ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'd', 'i', 'f', 'm', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 3, 1, head, err01, ln) if ( err01) then ierr = 1 write ( *, 1000) return end if iar = 1 phi(1) = 1.0e0 call fltarm (y, ymiss, n, iar, phi, yf, yfmiss, nyf) return 1000 format (/' the correct form of the call statement is'// & ' call difm (y, ymiss, n, yf, yfmiss, nyf)') end subroutine difser ( y, n, ndf, nd, iod, ydiff, ndiff ) !*****************************************************************************80 ! !! DIFSER performs a differencing operation on a series. ! ! Discussion: ! ! This routine performs the differencing operation ! defined by nd, iod and ndf on the series y, resulting in ! the series ydiff. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer iod(ndf) ! the vector containing the orders of each difference factor. ! integer n ! the number of observations. ! integer nd(ndf) ! the vector containing the number of times each differencing ! factor is applied. ! integer ndf ! the number of difference factors. ! integer ndiff ! the number of observations remaining in the differenced series. ! integer ntimes ! the number of times a given difference factor is to be applied. ! real y(n), ydiff(n) ! the vector containing the series observations and the vector ! in which the differenced series is returned. ! implicit none integer & n,ndf,ndiff ! ! array arguments real & y(*),ydiff(*) integer & iod(*),nd(*) ! ! integer & i,j,k,l,ntimes ydiff(1:n) = y(1:n) ndiff = n do i = 1, ndf ntimes = nd(i) do l = 1, ntimes ndiff = ndiff - iod(i) do j = 1, ndiff k = j + iod(i) ydiff(j) = ydiff(k) - ydiff(j) end do end do end do return end subroutine dotc ( y, ymean, ny, x, xmean, nx, dotxy, ndotxy ) !*****************************************************************************80 ! !! DOTC computes the dot product of two series, centered about their means. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real dotxy ! the dot product of the series (y(i) - ymean) and ! (x(i) - xmean). ! integer i ! an index variable. ! integer m ! the smaller of the number of observations in x and y ! integer ndotxy ! the number of observations used to compute dotxy ! integer nx, ny ! the number of observations in series x and y, respectively. ! real x(nx) ! the vector containing the second series ! real xmean ! the mean of the second series. ! real y(ny) ! the vector containing the first series ! real ymean ! the mean of the first series. ! implicit none real & dotxy,xmean,ymean integer & ndotxy,nx,ny ! ! array arguments real & x(nx),y(ny) ! ! integer & i,m ndotxy = 0 dotxy = 0.0e0 m = min(ny, nx) do i = 1, m dotxy = dotxy + (y(i) - ymean) * (x(i) - xmean) ndotxy = ndotxy + 1 end do return end subroutine dotcm ( y, ymean, ymiss, ny, x, xmean, xmiss, nx, dotxy, ndotxy ) !*****************************************************************************80 ! !! DOTCM computes the dot product of series with missing data. ! ! Discussion: ! ! The series are centered about their respective means. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real dotxy ! the dot product of the series (y(i) - ymean) and ! (x(i) - xmean). ! integer i ! an index variable. ! integer m ! the smaller of the number of observations in x and y ! integer ndotxy ! the number of observations used to compute dotxy ! integer nx, ny ! the number of observations in series x and y, respectively. ! real x(nx) ! the vector containing the second series ! real xmean ! the mean of the second series. ! real xmiss ! the user supplied code which is used to determine whether or ! not an observation in the series is missing. if x(i) = xmiss, ! the value is assumed missing, otherwise it is not. ! real y(ny) ! the vector containing the first series ! real ymean ! the mean of the first series. ! real ymiss ! the user supplied code which is used to determine whether or ! not an observation in the series is missing. if y(i) = ymiss, ! the value is assumed missing, otherwise it is not. ! implicit none real & dotxy,xmean,xmiss,ymean,ymiss integer & ndotxy,nx,ny ! ! array arguments real & x(nx),y(ny) ! ! integer & i,m ! ! external functions logical & mvchk external mvchk ndotxy = 0 dotxy = 0.0e0 m = min(ny, nx) do i = 1, m if ( .not. ( mvchk(y(i), ymiss) .or. mvchk(x(i), xmiss) ) ) then dotxy = dotxy + (y(i) - ymean) * (x(i) - xmean) ndotxy = ndotxy + 1 end if end do return end function dotprd ( p, x, y ) !*****************************************************************************80 ! !! DOTPRD returns the inner product of two vectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer P, the number of entries in the vectors. ! ! Input, real X(P), Y(P), the vectors. ! ! Output, real DOTPRD, the dot product of X and Y. ! implicit none integer p real dotprd integer i real, save :: sqteta = 0.0E+00 real t real x(p) real y(p) dotprd = 0.0E+00 if ( p <= 0 ) then return end if if ( sqteta == 0.0E+00 ) then sqteta = sqrt ( 1.001E+00 * tiny ( sqteta ) ) end if do i = 1, p t = max ( abs ( x(i) ), abs ( y(i) ) ) if ( t < sqteta ) then else if ( 1.0E+00 < t ) then dotprd = dotprd + x(i) * y(i) else t = ( x(i) / sqteta ) * y(i) if ( sqteta <= abs ( t ) ) then dotprd = dotprd + x(i) * y(i) end if end if end do return end subroutine drv1a ( coef, ncoef, xm, n, m, ixm, d ) !*****************************************************************************80 ! !! DRV1A derivative function for NLS family exerciser subroutine MDL1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real coef(ncoef) ! model coefficients ! real d(n,ncoef) ! the first derivative with respect to the ith coefficient ! integer i ! row marker ! integer ixm ! actual first dimension of xm ! integer m ! the number of independent variablesc ! integer n ! the number of observations ! integer ncoef ! the number of coefficients ! real xm(ixm,m) ! independent variables ! integer & ixm,m,n,ncoef ! ! array arguments real & coef(ncoef),d(n,ncoef),xm(ixm,m) d(1:n,1) = xm(1:n,1)**coef(2) d(1:n,2) = coef(1) * (xm(1:n,1)**coef(2)) * log(xm(1:n,1)) return end subroutine drv1b ( par, npar, xm, n, m, ixm, d ) !*****************************************************************************80 ! !! DRV1B is an INCORRECT derivative function for the NLS exerciser MDL1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real d(n,npar) ! the first derivative with respect to the ith coefficient ! integer i ! row marker ! integer ixm ! actual first dimension of xm ! integer m ! the number of independent variablesc ! integer n ! the number of observations ! integer npar ! the number of coefficients ! real par(npar) ! model coefficients ! real xm(ixm,m) ! independent variables ! implicit none integer & ixm,m,n,npar ! ! array arguments real & d(n,npar),par(npar),xm(ixm,m) d(1:n,1) = xm(1:n,1) * par(2) d(1:n,2) = par(1) * ( xm(1:n,1)**par(2) ) * log ( xm(1:n,1) ) return end subroutine drv2 ( par, npar, xm, n, m, ixm, d ) !*****************************************************************************80 ! !! DRV2 is a derivative function for the NLS exerciser routine MD12. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real par(npar) ! model parameters ! real d(n,npar) ! the first derivative with respect to the ith parameter ! integer i ! row marker ! integer ixm ! actual first dimension of xm ! integer m ! the number of independent variablesc ! integer n ! the number of observations ! integer npar ! the number of parameters ! real xm(ixm,m) ! model independent variable ! implicit none integer & ixm,m,n,npar real & d(n,npar),par(npar),xm(ixm,m) d(1:n,1) = xm(1:n,1) d(1:n,2) = xm(1:n,2) d(1:n,3) = xm(1:n,3)**3 return end subroutine drv3 ( par, npar, xm, n, m, ixm, d ) !*****************************************************************************80 ! !! DRV3 is the derivative function for NLS family exerciser subroutine MDL3. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real par(npar) ! model parameters ! real d(n,npar) ! the first derivative with respect to the ith parameter ! integer i ! row marker ! integer ixm ! actual first dimension of xm ! integer m ! the number of independent variablesc ! integer n ! the number of observations ! integer npar ! the number of parameters ! real xm(ixm,m) ! independent variable ! implicit none integer & ixm,m,n,npar ! ! array arguments real & d(n,npar),par(npar),xm(ixm,m) d(1:n,1:npar) = xm(1:n,1:npar) return end subroutine drv4a ( coef, ncoef, xm, n, m, ixm, d ) !*****************************************************************************80 ! !! DRV4A is a (correct) derivative for testing derivative checking routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real coef(ncoef) ! the array in which the current estimates of the unknown ! coefficients are stored. ! real d(n,ncoef) ! the matrix of first partial derivatives (jacobian). ! integer i ! an index variable. ! integer ixm ! the first dimension of the independent variable array xm. ! integer m ! the number of independent variables. ! integer n ! the number of observations of data. ! integer ncoef ! the number of unknown coefficients in the model. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none integer & ixm,m,n,ncoef ! ! array arguments real & coef(ncoef),d(n,ncoef),xm(ixm,m) integer & i do i = 1, n d(i,1) = 1.0e0 d(i,2) = (coef(3)*2.0e0*(xm(i,1)-coef(2))/coef(4)) * & exp(-((xm(i,1)-coef(2))**2)/coef(4)) d(i,3) = exp(-((xm(i,1)-coef(2))**2)/coef(4)) d(i,4) = -coef(3)*(-((xm(i,1)-coef(2))**2) / & (coef(4)**2)) * exp(-((xm(i,1)-coef(2))**2)/coef(4)) end do return end subroutine drv4b ( coef, ncoef, xm, n, m, ixm, d ) !*****************************************************************************80 ! !! DRV4B is an (incorrect) derivative for testing derivative checking routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real coef(ncoef) ! the array in which the current estimates of the unknown ! coefficients are stored. ! real d(n,ncoef) ! the matrix of first partial derivatives (jacobian). ! integer ixm ! the first dimension of the independent variable array xm. ! integer m ! the number of independent variables. ! integer n ! the number of observations of data. ! integer ncoef ! the number of unknown coefficients in the model. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none integer & ixm,m,n,ncoef ! ! array arguments real & coef(ncoef),d(n,ncoef),xm(ixm,m) ! ! integer & i do i = 1, n d(i,1) = 0.0e0 d(i,2) = (coef(3)*2.0e0*(xm(i,1)-coef(2))/coef(4)) * & exp(-((xm(i,1)-coef(2))**2)/coef(4)) d(i,3) = 0.0e0 d(i,4) = coef(3)*(-((xm(i,1)-coef(2))**2) / & (coef(4)**2)) * exp(-((xm(i,1)-coef(2))**2)/coef(4)) end do return end subroutine drv ( par, npar, xm, n, m, ixm, d ) !*****************************************************************************80 ! !! DRV is a dummy derivative function for the NLS family. ! ! Discussion: ! ! To solve an actual problem, the user would write a routine with ! the same calling sequence as this dummy routine. ! ! The user's routine would return the information defining the problem ! being studied. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real d(n,npar) ! the first derivative with respect to the ith parameter ! integer ixm ! actual first dimension of xm ! integer m ! the number of independent variablesc ! integer n ! the number of observations ! integer npar ! the number of parameters ! real par(npar) ! model parameters ! real xm(ixm,m) ! model independent variable ! implicit none integer ixm integer m integer n integer npar real d(n,npar) real par(npar) real xm(ixm,m) ! ! The following assignments are just to keep the compiler from complaining ! about unused variables. ! d(1:n,1:npar) = 0.0 par(1:npar) = 0.0 xm(1:ixm,1:m) = 0.0 return end subroutine dupdat ( d, iv, j, n, nn, p, v ) !*****************************************************************************80 ! !! DUPDAT updates the scale vector for NL2ITR. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input/output, real D(P), the scale vector. ! ! Input, integer IV(*), the NL2SOL integer array. ! ! Input, real J(NN,P), the N by P Jacobian matrix. ! ! Input, integer N, the number of functions. ! ! Input, integer NN, the leading dimension of J. ! ! Input, integer P, the number of variables. ! ! Input, real V(*), the NL2SOL real array. ! implicit none integer nn integer p real d(p) integer d0 integer :: dfac = 41 integer :: dtype = 16 integer i integer iv(*) real j(nn,p) integer :: jtol0 = 86 integer jtoli integer n integer :: niter = 31 integer :: s = 53 integer s1 real sii real t real v(*) real v2norm real vdfac i = iv(dtype) if ( i /= 1 ) then if ( 0 < iv(niter) ) then return end if end if vdfac = v(dfac) d0 = jtol0 + p s1 = iv(s) - 1 do i = 1, p s1 = s1 + i sii = v(s1) t = v2norm ( n, j(1,i) ) if ( 0.0E+00 < sii ) then t = sqrt ( t * t + sii ) end if jtoli = jtol0 + i d0 = d0 + 1 if ( t < v(jtoli) ) then t = max ( v(d0), v(jtoli) ) end if d(i) = max ( vdfac * d(i), t ) end do return end subroutine e9rint ( messg, nw, nerr, save ) !*****************************************************************************80 ! !! E9RINT stores the current error message or prints the old one. ! ! Discussion: ! ! This routine stores the current error message or prints the old one, ! if any, depending on whether or not save = .true. . ! ! character*4 messg(nw) ! logical save ! ! messgp stores at least the first 72 characters of the previous ! message. its length is machine dependent and must be at least ! ! 1 + 71/(the number of characters stored per integer word). ! ! character*4 messgp(36),fmt(14),ccplus ! ! implicit none ! ! scalar arguments integer nerr,nw logical save ! ! array arguments character messg(nw)*4 ! ! integer i,iwunit,nerrp,nwp character ccplus*4 ! ! local arrays character fmt(14)*4,messgp(36)*4 ! ! external functions integer i1mach,i8save external i1mach,i8save ! ! external subroutines external s88fmt ! ! start with no previous message. ! data messgp(1)/'1'/, nwp/0/, nerrp/0/ ! ! set up the format for printing the error message. ! the format is simply (a1,14x,72axx) where xx=i1mach(6) is the ! number of characters stored per integer word. ! data ccplus / '+' / data fmt( 1) / '(' / data fmt( 2) / 'a' / data fmt( 3) / '1' / data fmt( 4) / ',' / data fmt( 5) / '1' / data fmt( 6) / '4' / data fmt( 7) / 'x' / data fmt( 8) / ',' / data fmt( 9) / '7' / data fmt(10) / '2' / data fmt(11) / 'a' / data fmt(12) / 'x' / data fmt(13) / 'x' / data fmt(14) / ')' / ! ! Save the message. ! if ( save ) then nwp=nw nerrp=nerr messgp(1:nw)=messg(1:nw) ! ! Print the message. ! else if ( i8save ( 1, 0, .false. ) /= 0 ) then iwunit=i1mach(4) write ( iwunit, '(a,i4,a)' ) ' Error ', nerrp, ' in ' call s88fmt ( 2, i1mach(6), fmt(12) ) write(iwunit,fmt) ccplus, (messgp(i),i=1,nwp) end if return end subroutine ecvf ( nmsub ) !*****************************************************************************80 ! !! ECVF prints an error message if missing data affects the covariance lags. ! ! Discussion: ! ! This routine prints an error message when the lag value of ! the last covariance computed before one was not computed ! due to missing data does not exceed zero. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! character*1 nmsub(6) ! the array containing the name of this routine. ! implicit none character & nmsub(6)*1 logical & head ! ! external subroutines external ehdr head = .true. call ehdr(nmsub, head) write ( *, 1010) return 1010 format (/ & ' the covariances at lags zero and/or one could', & ' not be computed'/ & ' because of missing data. no further analysis is', & ' possible.') end subroutine ehdr ( nmsub, head ) !*****************************************************************************80 ! !! EHDR prints the heading for the error checking routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! character*1 nmsub(6) ! the characters of the calling routines name. ! implicit none logical & head ! ! array arguments character & nmsub(6)*1 integer i ! ! external subroutines external versp ! if (.not.head) return call versp(.false.) write ( *,1010) write ( *, 1000) (nmsub(i), i=1,6) head = .false. return 1000 format (/' error checking for subroutine ', 6a1/ 1x, 37('-')) 1010 format ('+', 18('*')/' * error messages *'/1x, 18('*')) end subroutine eiage ( nmsub, nmvar, ym, n, m, iym, ymmn, nvmx, & head, msgtyp, nv, error, nmmin ) !*****************************************************************************80 ! !! EIAGE ensures that "not too many" vectors are below a given lower bound. ! ! Discussion: ! ! This routine checks to ensure that no values, or only a maximum ! of nvmx, are not greater than a specified lower bound ymmn, ! with name nmmin. the checking option is specified ! with msgtyp. if an error is found, the error is printed and ! an error flag and the number of violatins are returned. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer iym ! the first dimension of the array ym. ! integer j ! an indexing variable. ! integer m ! the number of columns of data in ym. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 3) the message printed will use nmmin ! otherwise it will use ymmn. ! if (msgtyp = 1 or 3) no violations are allowed. ! if (msgtyp = 2 or 4) the number of violations must ! be less than nvmx . ! integer n ! the number of observations. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling routines name. ! character*1 nmvar(8) ! the characters of the parameters name. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! integer ym(iym,m) ! the array being tested. ! integer ymmn ! the minimum acceptable value. ! implicit none integer & iym,m,msgtyp,n,nv,nvmx,ymmn logical & error,head ! ! array arguments integer & ym(*) character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 integer & i,j ! ! external subroutines external eiagep error = .false. if ((n <= 0) .or. (m <= 0)) return ! ! check for violations ! nv = 0 do i = 1, n do j = 1, m if (ym(i+(j-1)*iym) < ymmn) nv = nv + 1 end do end do if (nv <= nvmx) then return end if ! ! violations found ! error = .true. call eiagep (nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, & nmmin) return end subroutine eiagep ( nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, nmmin ) !*****************************************************************************80 ! !! EIAGEP prints the error messages for ERAGT and ERAGTM. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 3) the message printed will use nmmin ! otherwise it will use ymmn. ! if (msgtyp = 1 or 3) no violations are allowed. ! if (msgtyp = 2 or 4) the number of violations must ! be less than nvmx . ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling routines name. ! character*1 nmvar(8) ! the characters of the parameters name. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! integer ymmn ! the minimum acceptable value. ! implicit none integer & msgtyp,nv,nvmx,ymmn logical & head ! ! array arguments character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 ! ! integer & i ! ! external subroutines external ehdr call ehdr(nmsub, head) if (msgtyp <= 2) then write ( *, 1000) (nmvar(i),i=1,6), ymmn, nv else write ( *, 1005) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv end if if ( msgtyp == 1 ) then write ( *, 1010) (nmvar(i),i=1,6), ymmn else if ( msgtyp == 2 ) then write ( *, 1020) (nmvar(i),i=1,6), ymmn, nvmx else if ( msgtyp == 3 ) then write ( *, 1030) (nmvar(i),i=1,6), (nmmin(i),i=1,8) else if ( msgtyp == 4 ) then write ( *, 1040) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nvmx end if return 1000 format (/ & ' the number of values in array ', 6a1, & ' less than ', i5, ' is ', i6, '.') 1005 format (/ & ' the number of values in array ', 6a1, & ' less than ', 8a1, ' is ', i6, '.') 1010 format( & ' the values in the array ', 6a1, & ' must all be greater than or equal to ', i5, '.') 1020 format( & ' the number of values in the array ', 6a1, & ' less than ', 8a1/ & ' must be less than ', i5, '.') 1030 format( & ' the values in the array ', 6a1, & ' must all be greater than or equal to ', i5, '.') 1040 format( & ' the number of values in the array ', 6a1, & ' less than ', 8a1/ & ' must be less than ', i5, '.') end subroutine eiseq ( nmsub, nmvar1, nval, neq, msgtyp, head, error, nmvar2 ) !*****************************************************************************80 ! !! EISEQ prints an error message if NVAL is not equal to NEQ. ! ! Discussion: ! ! This is a surprisingly cumbersome routine for such a simple task! ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is true and ! msgtyp = 1 the input value was not equal to the number of param ! specified by mspec (arima estimation and forecasting ! integer neq ! the acceptable value for the argument being tested. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar1(8) ! the characters of the name of the argument being checked. ! character*1 nmvar2(8) ! the characters of the name of the argument being checked ! against. ! integer nval ! the input value of the argument being checked. ! implicit none integer & msgtyp,neq,nval logical & error,head ! ! array arguments character & nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1 integer & i ! ! external subroutines external ehdr error = .false. if (nval == neq) return error = .true. call ehdr(nmsub, head) write ( *, 1000) (nmvar1(i), i=1,6), nval ! ! print message for arima routines ! write ( *, 1010) (nmvar1(i), i=1,6), neq return 1000 format (/' the input value of ', 6a1, ' is ', i5, '.') 1010 format( & ' the value of the argument ', 6a1, & ' must be greater than or equal to'/ & 1x, i5, ' = one plus the sum of mspec(1,j)+mspec(3,j) for', & ' j = 1, ..., nfac,'/ & 6x, ' = one plus the number of autoregressive parameters plus'/ & 9x, ' the number of moving average parameters.') end subroutine eisge( nmsub, nmvar1, nval, nmin, msgtyp, head, error, nmvar2 ) !*****************************************************************************80 ! !! EISGE prints a warning if NVAL is less than NMIN. ! ! Discussion: ! ! This routine checks whether the value nval is greater than ! or equal to nmin and prints a diagnostic if it is not. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is true and ! msgtyp = 1 the input value was too small based ! on limits imposed by starpac ! msgtyp = 2 the input value was too small based on other input ! arguments. ! msgtyp = 3 the input value was too small based on other input ! arguments, where the value indicates the first ! dimension of a dimensioned array ! n.b. it is assumed that the dimension name is the ! array name preceded by the letter i. if the ! array name is 6 letters, the dimension name ! should omit the last letter. the dimension ! name will be printed using (nmvar(i),i=1,6), ! and the array name using (nmvar(i),i=2,7). ! msgtyp = 4 the input value was too small based on other input ! arguments, where the value indicates the second ! dimension of a dimensioned array ! n.b. it is assumed that the dimension name is the ! array name preceded by the letter j. if the ! array name is 6 letters, the dimension name ! should omit the last letter. the dimension ! name will be printed using (nmvar(i),i=1,6), ! and the array name using (nmvar(i),i=2,7). ! msgtyp = 5 the argument being checked is ldstak. ! no longer used. ! msgtyp = 6 the argument indicates the first dimension of ! an array being checked against the number of ! unfixed parameters. ! msgtyp = 7 the input value was too small based on other input ! arguments, where the value indicates the ! dimension of a vector. ! n.b. it is assumed that the dimension name is the ! array name preceded by the letter l. if the ! array name is 6 letters, the dimension name ! should omit the last letter. the dimension ! name will be printed using (nmvar(i),i=1,6), ! and the array name using (nmvar(i),i=2,7). ! msgtyp = 8 the input value was too small based on other input ! arguments, where the value indicates the ! dimension of the vectors acov and nlppa. ! msgtyp = 9 the input value was too small based on limits ! imposed by starpac, where the value indicates the ! dimension of a vector. ! n.b. it is assumed that the dimension name is the ! array name preceded by the letter l. if the ! array name is 6 letters, the dimension name ! should omit the last letter. the dimension ! name will be printed using (nmvar(i),i=1,6), ! and the array name using (nmvar(i),i=2,7). ! integer nmin ! the minimum acceptable value for the argument being tested. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar1(8) ! the characters of the name of the argument being checked. ! character*1 nmvar2(8) ! the characters of the name of the argument being checked ! against. ! integer nval ! the input value of the argument being checked. ! implicit none integer & msgtyp,nmin,nval logical & error,head ! ! array arguments character & nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1 integer & i ! ! external subroutines external ehdr error = .false. if (nval >= nmin) return error = .true. call ehdr(nmsub, head) write ( *, 1000) (nmvar1(i), i=1,6), nval if ( msgtyp == 1 ) then write ( *, 1010) (nmvar1(i), i=1,6), nmin else if ( msgtyp == 2 ) then write ( *, 1020) (nmvar1(i), i=1,6), (nmvar2(i), i=1,8) else if ( msgtyp == 3 ) then write ( *, 1030) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), & (nmvar2(i), i=1,8) else if ( msgtyp == 4 ) then write ( *, 1040) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), & (nmvar2(i), i=1,8) else if ( msgtyp == 5 ) then write ( *, 1050) nmin else if ( msgtyp == 6 ) then write ( *, 1060) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6) else if ( msgtyp == 7 ) then write ( *, 1070) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), & (nmvar2(i), i=1,8) else if ( msgtyp == 8 ) then write ( *, 1080) (nmvar1(i), i=1,6), (nmvar2(i), i=1,8) else if ( msgtyp == 9 ) then write ( *, 1090) (nmvar1(i), i=2,7), (nmvar1(i), i=1,6), nmin end if return 1000 format (/' the input value of ', 6a1, ' is ', i5, '.') 1010 format( & ' the value of the argument ', 6a1, & ' must be greater than or equal to ', i5, '.') 1020 format( & ' the value of the argument ', 6a1, & ' must be greater than or equal to ', 8a1, '.') 1030 format( & ' the first dimension of ', 6a1, & ', as indicated by the argument'/ & 1x, 6a1, ', must be greater than or equal to ', 8a1, '.') 1040 format( & ' the second dimension of ', 6a1, & ', as indicated by the argument'/ & 1x, 6a1, ', must be greater than or equal to ', 8a1, '.') 1050 format( & ' the dimension of the double precision vector dstak, as', & ' indicated by'/ & ' the argument ldstak, must be greater than or equal to', & i5, '.') 1060 format( & ' the first dimension of ', 6a1, & ', as indicated by the argument'/ & 1x, 6a1, ', must be greater than or equal to', & ' the number of unfixed parameters.') 1070 format( & ' the length of ', 6a1, & ', as indicated by the argument'/ & 1x, 6a1, ', must be greater than or equal to ', 8a1, '.') 1080 format( & ' the length of acov and nlppa', & ', as indicated by the argument'/ & 1x, 6a1, ', must be greater than or equal to ', 8a1, '.') 1090 format( & ' the length of ', 6a1, & ', as indicated by the argument'/ & 1x, 6a1, ', must be greater than or equal to ', i6, '.') end subroutine eisii ( nmsub, nmvar, ival, ivalmn, ivalmx, msgtyp, & head, error, nmmin, nmmax ) !*****************************************************************************80 ! !! EISII warns if an integer value does not lie within a given range. ! ! Discussion: ! ! The routine checks whether the value ival is within the ! the range ivalmn (inclusive) to ivalmx (inclusive), and prints a ! diagnostic if it is not. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer ival ! the input value of the argument being checked. ! integer ivalmn, ivalmx ! the minimum and maximum of the range within which the ! argument must lie. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is .true. and ! msgtyp = 1 the input value was outside the range determined ! from other input arguments ! msgtyp = 2 the input value was outside the range imposed by ! starpac ! character*1 nmmax(8) ! the name of the argument specifying the maximum. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! implicit none integer & ival,ivalmn,ivalmx,msgtyp logical & error,head ! ! array arguments character & nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 integer & i ! ! external subroutines external ehdr error = .false. if (((ivalmn <= ival) .and. (ival <= ivalmx)) .or. & (ivalmx= 1) .and. & (iseed <= 2**(mdig-1)-1) .and. & (mod(iseed,2) == 1))) then ! ! supplied seed will be used ! iseedu = iseed else ! ! violations found ! iseedu = min( abs(iseed)+mod(abs(iseed),2)-1, 2**(mdig-1)-1) call ehdr(nmsub, head) write ( *, 1010) mdig-1,iseedu end if return 1010 format(/ & ' the value of iseed must be between 0 and 2**',i2,' - 1,'/ & ' inclusive, and, if iseed is not 0, iseed must be odd. the'/ & ' seed actually used by the random number generator has been'/ & ' set to', i10,'.') end subroutine eiveo ( nmsub, nmvar, ivec, n, even, head ) !*****************************************************************************80 ! !! EIVEO checks whether all vector entries are even (or odd). ! ! Discussion: ! ! This routine checks whether each of the values in the input ! vector ivec are even (or odd) and prints a ! diagnostic if they are not. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical even ! an indicator variable designating whether the values of ivec ! should be even (true) or not (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ivec(n) ! the vector being tested. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the parameters name. ! implicit none integer & n logical & even,head ! ! array arguments integer & ivec(*) character & nmsub(6)*1,nmvar(8)*1 ! ! integer & i do i = 1, n if ((even .and. (mod(ivec(i), 2) == 1)) .or. & ((.not.even) .and. (mod(ivec(i), 2) == 1))) go to 20 end do return ! ! violations found ! 20 continue call ehdr(nmsub, head) if ( .not. even ) then write ( *, 1010) (nmvar(i), i = 1, 6) else write ( *, 1020) (nmvar(i), i = 1, 6) end if return 1010 format(/ & ' the values in the vector ', 6a1, & ' must all be odd. the next'/ & ' larger integer will be used in place of even values.') 1020 format(/ & ' the values in the vector ', 6a1, & ' must all be even. the next'/ & ' larger integer will be used in place of odd values.') end subroutine eiveq ( nmsub, nmvar1, ivec, n, ival, neqmn, head, neq, & nne, msgtyp, error, nmvar2, nmvar3 ) !*****************************************************************************80 ! !! EIVEQ warns if the vector does not have at least NEQMN entries equal to IVAL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ivec(n) ! the vector being checked. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is true and ! msgtyp = 1, the input value was too small based on limits ! imposed by starpac. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar1(8) ! the characters of the name of the argument being checked. ! character*1 nmvar2(8) ! the characters of the name of the argument being checked ! against. ! character*1 nmvar3(8) ! the characters of the name of the argument that the elements ! must be equal to. ! integer neq ! the number of elements equal to ival. ! integer neqmn ! the minimum number of elements equal to ival which is ok. ! integer nne ! the number of elements not equal to ival. ! implicit none integer & ival,msgtyp,n,neq,neqmn,nne logical & error,head ! ! array arguments integer & ivec(*) character & nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1,nmvar3(8)*1 ! ! integer & i ! ! external subroutines external ehdr error = .false. if (n <= 0) return ! ! check for values equal to ival ! neq = 0 do i = 1, n if (ivec(i) == ival) neq = neq + 1 end do nne = n - neq if (neq >= neqmn) return ! ! insufficient number of elements equal to ival. ! error = .true. call ehdr(nmsub, head) if (msgtyp == 1) write ( *, 1000) & (nmvar1(i),i=1,8), (nmvar2(i),i=1,8), neq, & (nmvar2(i),i=1,8), (nmvar3(i),i=1,8) return 1000 format( & ' the number of elements in ', 8a1, & ' equal to ', 8a1, ' is ', i6, '.'/ & ' the number of elements equal to ', 8a1, & ' must be greater than or equal to ', 8a1, '.') end subroutine eivii ( nmsub, nmvar, ivec, n, iveclb, ivecub, nvmx, & head, msgtyp, nv, error, nmmin, nmmax ) !*****************************************************************************80 ! !! EIVII warns if too many values are outside given limits. ! ! Discussion: ! ! This routine checks for values in the input vector ivec ! which are outside the (inclusive) limits iveclb to ivecub, prints ! an error message if the number of violations exceeds the largest ! number of violations allowed, and returns the number of ! violations and an error flag indicating the results. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! the value returned from the error checking routines to indicate ! whether an error was detected (true) or not (false). ! logical head ! a flag indicating whether the heading should be printed (true) ! or not (false). ! integer i ! an index argument. ! integer ivec(n) ! the vector being tested. ! integer iveclb, ivecub ! the (inclusive) range that the vector is being tested ! against. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 4) the message printed will use nmmin and ! nmmax, otherwise it will use iveclb and ivecub. ! if (msgtyp = 1 or 4) no violations are allowed. ! if (msgtyp = 2 or 5) the number of violations must ! be less than nvmx . ! if (msgtyp = 3 or 6) violations are counted only if the ! the first element is not in violation. ! integer n ! the number of observations. ! character*1 nmmax(8) ! the name of the argument specifying the maximum. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! implicit none integer & iveclb,ivecub,msgtyp,n,nv,nvmx logical & error,head ! ! array arguments integer & ivec(*) character & nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 integer & i error = .false. if (n <= 0) return if (ivecub ivecub))) return ! ! check for violations ! nv = 0 do i = 1, n if ((ivec(i) ivecub)) nv = nv + 1 end do if (nv <= nvmx) return ! ! violations found ! error = .true. call ehdr(nmsub, head) if (msgtyp <= 3) then write ( *, 1000) (nmvar(i),i=1,6), iveclb, ivecub, nv else write ( *, 1005) (nmvar(i),i=1,6), (nmmin(i),i=1,8), & (nmmax(i),i=1,8), nv end if if ( msgtyp == 1 .or. msgtyp == 4 ) then write ( *, 1010) (nmvar(i),i=1,6) else if ( msgtyp == 2 .or. msgtyp == 5 ) then write ( *, 1020) (nmvar(i),i=1,6), nvmx else if ( msgtyp == 3 .or. msgtyp == 6 ) then write ( *, 1030) (nmvar(i),i=1,6) end if return 1000 format (/ & ' the number of values in vector ', 6a1, & ' outside the range ', i6, ' to'/ & 1x, i6, ', inclusive, is ', i6, '.') 1005 format (/ & ' the number of values in vector ', 6a1, & ' outside the range ', 8a1, ' to'/ & 1x, 8a1, ', inclusive, is ', i6, '.') 1010 format( & ' the values in the vector ', 6a1, & ' must all be within this range.') 1020 format( & ' the number of values in the vector ', 6a1, & ' outside this range'/ & ' must be less than ', i5, '.') 1030 format( & ' if the first value of the vector ', 6a1, & ' is within this range'/ & ' all of the values must be within this range.') end subroutine enfft ( nmsub, nfft, ndiv, n, lyfft, nfft2, head, error ) !*****************************************************************************80 ! !! ENFFT checks that NFFT is suitable for the Singleton FFT routine. ! ! Discussion: ! ! This routine checks whether the value nfft is such that nfft-2 is ! divisible by ndiv and has no prime factors greater than 23, and ! the product of the square free prime factors of nfft - 2 do not ! exceed 209, i.e., the value of nfft meets the requirements of ! the extended length of the series required for any routine ! using the singleton fft providing the proper value of ndiv ! is chosen. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer lyfft ! the length of the vector containing the series to be extended. ! integer n ! the actual number of observations in the series. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! integer nfft ! the user supplied extended series length. ! integer nfft1 ! the maximum of nfft and n+2. ! integer nfft2 ! the smallest extended series length which equals or ! exceeds nfft and which meets the requirements of ! singletons fft code. ! implicit none integer & lyfft,n,ndiv,nfft,nfft2 logical & error,head ! ! array arguments character & nmsub(6)*1 ! ! integer & nfft1 error = .false. ! ! print warning ! if ( nfft < n + 2 ) then call ehdr(nmsub, head) write ( *, 1050) n end if nfft1 = max(nfft, n+2) call setesl(nfft1-2, ndiv, nfft2) if (nfft == nfft2) return ! ! print warning ! call ehdr(nmsub, head) write ( *, 1020) nfft, nfft2 if ( nfft <= lyfft ) then write ( *, 1030) nfft2 return end if error = .true. write ( *, 1040) nfft2, lyfft return 1020 format (/ & ' the input value of the parameter nfft (', i5, & ') does not meet'/ & ' the requirements of singletons fft code. the next', & ' larger value'/ & ' which does is ', i5, '.') 1030 format (/ & ' the value ', i5, ' will be used for the extended series', & ' length.') 1040 format (/ & ' however, the value ', i5, ' exceeds the length lyfft (', & i5, ') of the'/ & ' vector yfft, and therefore cannot be used as the extended'/ & ' series length without redimensioning yfft.') 1050 format (/ & ' the extended series length (nfft) must equal or exceed,'/ & ' the number of observations in the series (n=', i5, ' plus 2.') end subroutine eprint ( ) !*****************************************************************************80 ! !! EPRINT prints the last error message, if any. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none character messg(1)*4 call e9rint(messg,1,1,.false.) return end subroutine eragt ( nmsub, nmvar, ym, n, m, iym, ymmn, nvmx, & head, msgtyp, nv, error, nmmin ) !*****************************************************************************80 ! !! ERAGT warns if too many values are less than a lower bound. ! ! Discussion: ! ! This routine checks to ensure that no values, or only a maximum ! of nvmx, are not greater than a specified lower bound ymmn, ! with name nmmin. the checking option is specified ! with msgtyp. if an error is found, the error is printed and ! an error flag and the number of violatins are returned. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer iym ! the first dimension of the array ym. ! integer j ! an indexing variable. ! integer m ! the number of columns of data in ym. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 3) the message printed will use nmmin ! otherwise it will use ymmn. ! if (msgtyp = 1 or 3) no violations are allowed. ! if (msgtyp = 2 or 4) the number of violations must ! be less than nvmx . ! integer n ! the number of observations. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling routines name. ! character*1 nmvar(8) ! the characters of the parameters name. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! real ym(iym,m) ! the array being tested. ! real ymmn ! the minimum acceptable value. ! implicit none real & ymmn integer & iym,m,msgtyp,n,nv,nvmx logical & error,head ! ! array arguments real & ym(*) character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 integer & i,j ! ! external subroutines external eragtp error = .false. if ((n <= 0) .or. (m <= 0)) return ! ! check for violations ! nv = 0 do i = 1, n do j = 1, m if (ym(i+(j-1)*iym) <= ymmn) nv = nv + 1 end do end do if (nv <= nvmx) return ! ! violations found ! error = .true. call eragtp (nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, & nmmin) return end subroutine eragtm ( nmsub, nmvar, ym, ymmiss, n, m, iym, ymmn, & nvmx, head, msgtyp, nv, error, nmmin ) !*****************************************************************************80 ! !! ERAGTM warns if too many values are less than or equal to a lower bound. ! ! Discussion: ! ! This routine checks to ensure that no values, or only a maximum ! of nvmx, are not greater than a specified lower bound ymmn, ! with name nmmin. the checking option is specified ! with msgtyp. if an error is found, the error is printed and ! an error flag and the number of violatins are returned. ! elements of ym(*, i) equal to ymmiss(i) are exempt from checking. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer iym ! the first dimension of the array ym. ! integer m ! the number of columns of data in ym. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 3) the message printed will use nmmin ! otherwise it will use ymmn. ! if (msgtyp = 1 or 3) no violations are allowed. ! if (msgtyp = 2 or 4) the number of violations must ! be less than nvmx . ! integer n ! the number of observations. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling routines name. ! character*1 nmvar(8) ! the characters of the parameters name. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! real ym(iym,m) ! the array being tested. ! real ymmiss(m) ! missing value codes for each column of ym ! real ymmn ! the minimum acceptable value. ! implicit none real & ymmn integer & iym,m,msgtyp,n,nv,nvmx logical & error,head ! ! array arguments real & ym(*),ymmiss(*) character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 integer & i,j ! ! external functions logical & mvchk external mvchk ! ! external subroutines external eragtp error = .false. if ((n <= 0) .or. (m <= 0)) return ! ! check for violations ! nv = 0 do i = 1, n do j = 1, m if ( .not. mvchk(ym(i+(j-1)*iym), ymmiss(j))) then if (ym(i+(j-1)*iym) <= ymmn) nv = nv + 1 end if end do end do if (nv <= nvmx) then return end if ! ! violations found ! error = .true. call eragtp (nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, & nmmin) return end subroutine eragtp ( nmsub, nmvar, ymmn, nvmx, head, msgtyp, nv, nmmin ) !*****************************************************************************80 ! !! ERAGTP prints the error messages for ERAGT and ERAGTM. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 3) the message printed will use nmmin ! otherwise it will use ymmn. ! if (msgtyp = 1 or 3) no violations are allowed. ! if (msgtyp = 2 or 4) the number of violations must ! be less than nvmx . ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling routines name. ! character*1 nmvar(8) ! the characters of the parameters name. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! real ymmn ! the minimum acceptable value. ! implicit none real & ymmn integer & msgtyp,nv,nvmx logical & head ! ! array arguments character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 integer & i ! ! external subroutines external ehdr ! call ehdr(nmsub, head) if (msgtyp <= 2) then write ( *, 1000) (nmvar(i),i=1,6), ymmn, nv else write ( *, 1005) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv end if if ( msgtyp == 1 ) then write ( *, 1010) (nmvar(i),i=1,6), ymmn else if ( msgtyp == 2 ) then write ( *, 1020) (nmvar(i),i=1,6), ymmn, nvmx else if ( msgtyp == 3 ) then write ( *, 1030) (nmvar(i),i=1,6), (nmmin(i),i=1,8) else if ( msgtyp ==4 ) then write ( *, 1040) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nvmx end if return 1000 format (/ & ' the number of values in array ', 6a1, & ' less than or equal to ', 1pe14.7, ' is ', i6, '.') 1005 format (/ & ' the number of values in array ', 6a1, & ' less than or equal to ', 8a1, ' is ', i6, '.') 1010 format( & ' the values in the array ', 6a1, & ' must all be greater than ', 1pe14.7, '.') 1020 format( & ' the number of values in the array ', 6a1, & ' less than or equal to ', 8a1/ & ' must be less than ', i5, '.') 1030 format( & ' the values in the array ', 6a1, & ' must all be greater than ', 1pe14.7, '.') 1040 format( & ' the number of values in the array ', 6a1, & ' less than or equal to ', 8a1/ & ' must be less than ', i5, '.') end subroutine erdf ( nmsub, ndf, iod, nd, n, head, error ) !*****************************************************************************80 ! !! ERDF checks the values that specify differencing on a time series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ier ! an error indicator. ! integer iod(ndf) ! the vector containing the orders of each difference factor. ! integer mbod ! the maximum backorder due to differencing. ! integer n ! the integer number of observations in each series ! integer nd(ndf) ! the vector containing the number of times each difference ! factor is applied. ! integer ndf ! the number of difference factors to be applied to the series. ! character*1 nmsub(6) ! the characters of the calling subroutine name. ! implicit none integer & n,ndf logical & error,head ! ! array arguments integer & iod(*),nd(*) character & nmsub(6)*1 integer & i,ier,mbod ! ! external subroutines external ehdr error = .false. if (ndf < 0) then call ehdr(nmsub, head) write ( *, 1001) ndf error = .true. return end if if (ndf == 0) return ier = 0 mbod = 0 do i = 1, ndf if ( iod(i) >= 1 .and. nd(i) >= 1) go to 20 ier = 1 go to 40 20 mbod = mbod + iod(i) * nd(i) end do if (mbod <= n - 1) return 40 continue call ehdr(nmsub, head) if (ier == 1) & write ( *, 1002) (i, nd(i), iod(i), i = 1, ndf) if (ier == 0 .and. mbod >= n) write ( *, 1003) mbod, n error = .true. return 1001 format(/' the number of difference factors (ndf) must'/ & ' be greater than or equal to zero. the input value of'/ & ' ndf is ', i6, '.') 1002 format (/' the order of each difference factor (iod) and'/ & ' number of times it is applied (nd) must be greater than'/ & ' equal to one. the input values of these arrays are'/ & ' dif. fact. nd iod'/ & (1x, i13, i5, i6)) 1003 format (/' the maximum backorder due to differencing (mbod)', & /' that is, the sum of nd(i)*iod(i), i = 1, 2, ..., ndf,'/ & ' must be less than or equal to n-1. the computed value for'/ & ' mbod is ', i6, ', while the input value for n is ', i6, '.') end subroutine eriodd ( nmsub, nmvar, nval, msgtyp, head, error ) !*****************************************************************************80 ! !! ERIODD warns if the value of NVAL is inconsistent. ! ! Discussion: ! ! This routine sets error to true if the value nval is not even ! or odd, as specified by the parameter odd. in addition, if this ! is the first error found for the calling subroutine nmsub , ie ! if head is true, then a heading for the calling subroutine ! is also printed out. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer msgtyp ! a variable used to indicate the type of message to be ! printed, where if ! msgtyp = 1, the input value should be odd and ! msgtyp = 2, the input value should be even. ! character*1 nmsub(6) ! the array containing the name of the calling subroutine. ! character*1 nmvar(8) ! the array containing the name of the variable being checked. ! integer nval ! the value of the variable being checked. ! implicit none integer & msgtyp,nval logical & error,head ! ! array arguments character & nmsub(6)*1,nmvar(8)*1 ! ! integer & i error = .false. if ( msgtyp /= 2 ) then if ( mod ( nval, 2 ) /= 1 ) then call ehdr(nmsub, head) write ( *, 1010) (nmvar(i), i = 1, 6), (nmvar(i), i = 1, 6), nval error = .true. end if else if ( mod ( nval, 2 ) /= 0 ) then call ehdr(nmsub, head) write ( *, 1020) (nmvar(i), i = 1, 6), (nmvar(i), i = 1, 6), nval error = .true. end if end if return 1010 format(/ & ' the value of the variable ', 6a1, & ' must be odd. the input value of ', 6a1/ & ' is ', i5, '.') 1020 format(/ & ' the value of the variable ', 6a1, & ' must be even. the input value of ', 6a1/ & ' is ', i5, '.') end subroutine ersei ( nmsub, nmvar, val, valmn, valmx, msgtyp, head, & error, nmmin, nmmax ) !*****************************************************************************80 ! !! ERSEI warns if a value is not between given limits. ! ! Discussion: ! ! This routine checks whether the value val is within the ! the range valmn (exclusive) to valmx (inclusive), and prints a ! diagnostic if it is not. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is .true. and ! msgtyp = 1 the input value was outside the range determined ! from other input arguments ! msgtyp = 2 the input value was outside the range imposed by ! starpac ! character*1 nmmax(8) ! the name of the argument specifying the maximum. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! real val ! the input value of the argument being checked. ! real valmn, valmx ! the minimum and maximum of the range within which the ! argument must lie. ! implicit none real & val,valmn,valmx integer & msgtyp logical & error,head ! ! array arguments character & nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 ! ! integer & i ! ! external subroutines external ehdr error = .false. if (((valmn= valmn) return error = .true. call ehdr(nmsub, head) write ( *, 1000) (nmvar(i),i=1,6), val if ( msgtyp == 1 ) then write ( *, 1010) (nmvar(i),i=1,6), valmn else if ( msgtyp == 2 ) then write ( *, 1020) (nmvar(i),i=1,6), (nmmin(i),i=1,8) end if return 1000 format (/' the input value of ', 6a1, ' is ', g15.8, '.') 1010 format( & ' the value of the argument ', 6a1, & ' must be greater than or equal to ', g21.14, '.') 1020 format( & ' the value of the argument ', 6a1, & ' must be greater than or equal to ', 8a1, '.') end subroutine ersgt ( nmsub, nmvar, val, valmn, msgtyp, head, error, nmmin ) !*****************************************************************************80 ! !! ERSGT warns if the input value is not greater than a specified minumum. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is .true. and ! msgtyp = 1 the input value was too small based ! on limits imposed by starpac ! msgtyp = 2 the input value was too small based on ! limits based on other input arguments. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! real val ! the input value of the argument being checked. ! real valmn ! the minimum value the argument can validly have. ! implicit none real & val,valmn integer & msgtyp logical & error,head ! ! array arguments character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 ! ! integer & i ! ! external subroutines external ehdr error = .false. if (val > valmn) return error = .true. call ehdr(nmsub, head) write ( *, 1000) (nmvar(i),i=1,6), val if ( msgtyp == 1 ) then write ( *, 1010) (nmvar(i),i=1,6), valmn else write ( *, 1020) (nmvar(i),i=1,6), (nmmin(i),i=1,8) end if return 1000 format (/' the input value of ', 6a1, ' is ', g15.8, '.') 1010 format( & ' the value of the argument ', 6a1, & ' must be greater than ', g21.14, '.') 1020 format( & ' the value of the argument ', 6a1, & ' must be greater than ', 8a1, '.') end subroutine ersie ( nmsub, nmvar, val, valmn, valmx, msgtyp, head, & error, nmmin, nmmax ) !*****************************************************************************80 ! !! ERSIE warns if a value is not within a specified range. ! ! Discussion: ! ! This routine checks whether the value val is within the ! the range valmn (inclusive) to valmx (exclusive), and prints a ! diagnostic if it is not. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is .true. and ! msgtyp = 1 the input value was outside the range determined ! from other input arguments ! msgtyp = 2 the input value was outside the range imposed by ! starpac ! character*1 nmmax(8) ! the name of the argument specifying the maximum. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! real val ! the input value of the argument being checked. ! real valmn, valmx ! the minimum and maximum of the range within which the ! argument must lie. ! implicit none real & val,valmn,valmx integer & msgtyp logical & error,head ! ! array arguments character & nmmax(8)*1,nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 ! ! integer & i ! ! external subroutines external ehdr error = .false. if (((valmn <= val) .and. (val= 4) the message printed will use nmmin ! otherwise it will use veclb. ! if (msgtyp = 1 or 4) no violations are allowed. ! if (msgtyp = 2 or 5) the number of violations must ! be less than nvmx . ! if (msgtyp = 3 or 6) violations are counted only if the ! the first element is not in violation. ! integer n ! the number of observations. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! integer nv ! the number of violations found. ! integer nvmn ! the smallest number of non-violations allowed. ! integer nvmx ! the largest number of violations allowed. ! real vec(n) ! the vector being tested. ! real veclb ! the value that the vector is being tested against. ! implicit none real & veclb integer & msgtyp,n,nv,nvmx logical & error,head ! ! array arguments real & vec(*) character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 ! ! integer & i,nvmn ! ! external subroutines external ervgtp error = .false. if (n <= 0) return ! ! test whether testing is necessry ! if ((mod(msgtyp,3) == 0) .and. (vec(1) <= veclb)) return ! ! check for violations ! nv = 0 do i = 1, n if ((vec(i) <= veclb)) nv = nv + 1 end do if (nv <= nvmx) return ! ! violations found ! error = .true. nvmn = n - nvmx call ervgtp (nmsub, nmvar, veclb, nvmn, nvmx, head, msgtyp, nv, & nmmin) return end subroutine ervgtm ( nmsub, nmvar, vec, vcmiss, n, veclb, nvmx, & head, msgtyp, nv, error, nmmin ) !*****************************************************************************80 ! !! ERVGTM ensures that "most" values are greater than a specified lower bound. ! ! Discussion: ! ! This routine checks to ensure that no values, or only a maximum ! of nvmx, are not greater than a specified lower bound veclb, ! with name nmmin. the routine alternatively checks to make sure ! that no values are in violation of this lower bound if the first ! value in the vector is not. the checking option is specified ! with msgtyp. if an error is found, the error is printed and ! an error flag and the number of violatins are returned. ! values of vec equal to vcmiss are exempted from the checking. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical error ! the value returned from the error checking routines to indicate ! whether an error was detected (true) or not (false). ! logical head ! a flag indicating whether the heading should be printed (true) ! or not (false). ! integer i ! an index argument. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 4) the message printed will use nmmin ! otherwise it will use veclb. ! if (msgtyp = 1 or 4) no violations are allowed. ! if (msgtyp = 2 or 5) the number of violations must ! be less than nvmx . ! if (msgtyp = 3 or 6) violations are counted only if the ! the first element is not in violation. ! integer n ! the number of observations. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! integer nv ! the number of violations found. ! integer nvmn ! the smallest number of non-violations allowed. ! integer nvmx ! the largest number of violations allowed. ! real vcmiss ! missing value code in vec. ! real vec(n) ! the vector being tested. ! real veclb ! the value that the vector is being tested against. ! implicit none real & vcmiss,veclb integer & msgtyp,n,nv,nvmx logical & error,head ! ! array arguments real & vec(*) character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 ! ! integer & i,nvmn ! ! external functions logical & mvchk external mvchk ! ! external subroutines external ervgtp error = .false. if (n <= 0) return ! ! test whether testing is necessry ! if ((mod(msgtyp,3) == 0) .and. (vec(1) <= veclb)) return ! ! check for violations ! nv = 0 do i = 1, n if ( .not. mvchk ( vec(i), vcmiss) ) then if ( vec(i) <= veclb ) then nv = nv + 1 end if end if end do if ( nv <= nvmx ) then return end if ! ! violations found ! error = .true. nvmn = n - nvmx call ervgtp (nmsub, nmvar, veclb, nvmn, nvmx, head, msgtyp, nv, & nmmin) return end subroutine ervgtp ( nmsub, nmvar, veclb, nvmn, nvmx, head, msgtyp, nv, nmmin ) !*****************************************************************************80 ! !! ERVGTP prints the error messages for ERVGT and ERVGTM. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical head ! a flag indicating whether the heading should be printed (true) ! or not (false). ! integer i ! an index argument. ! integer msgtyp ! the indicator argument for the type of message. ! if (msgtyp >= 4) the message printed will use nmmin ! otherwise it will use veclb. ! if (msgtyp = 1 or 4) no violations are allowed. ! if (msgtyp = 2 or 5) the number of violations must ! be less than nvmx . ! if (msgtyp = 3 or 6) violations are counted only if the ! the first element is not in violation. ! character*1 nmmin(8) ! the name of the argument specifying the minimum. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the arguments name. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! real veclb ! the value that the vector is being tested against. ! implicit none real & veclb integer & msgtyp,nv,nvmn,nvmx logical & head ! ! array arguments character & nmmin(8)*1,nmsub(6)*1,nmvar(8)*1 integer & i ! ! external subroutines external ehdr call ehdr(nmsub, head) if (msgtyp <= 3) then write ( *, 1000) (nmvar(i),i=1,6), veclb, nv else if (msgtyp >= 7) then write ( *, 1001) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv else write ( *, 1002) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nv end if end if if ( msgtyp == 1 ) then write ( *, 1010) (nmvar(i),i=1,6), veclb else if ( msgtyp == 2 ) then write ( *, 1020) (nmvar(i),i=1,3), veclb, nvmx else if ( msgtyp == 3 ) then write ( *, 1030) (nmvar(i),i=1,6), veclb, veclb else if ( msgtyp == 4 ) then write ( *, 1040) (nmvar(i),i=1,6), (nmmin(i),i=1,8) else if ( msgtyp == 5 ) then write ( *, 1050) (nmvar(i),i=1,6), (nmmin(i),i=1,8), nvmx else if ( msgtyp == 6 ) then write ( *, 1060) (nmvar(i),i=1,6), (nmmin(i),i=1,8), & (nmmin(i),i=1,8) else if ( msgtyp == 7 ) then write ( *, 1070) nvmn, (nmvar(i),i=1,6), (nmmin(i),i=1,8) end if return 1000 format (/ & ' the number of values in vector ', 6a1, & ' less than or equal to ', 1pe14.7, ' is ', i6, '.') 1001 format (/ & ' the number of values in vector ', 6a1, & ' greater than ', 8a1, ' is ', i2, '.') 1002 format (/ & ' the number of values in vector ', 6a1, & ' less than or equal to ', 8a1, ' is ', i6, '.') 1010 format( & ' the values in the vector ', 6a1, & ' must all be greater than ', 1pe14.7, '.') 1020 format( & ' the number of values in the vector ', 6a1, & ' less than or equal to ', 1pe14.7/ & ' must be less than ', i5, '.') 1030 format( & ' since the first value of the vector ', 6a1, & ' is greater than ', 1pe14.7/ & ' all of the values must be greater than ', 1pe14.7, '.') 1040 format( & ' the values in the vector ', 6a1, & ' must all be greater than ', 8a1, '.') 1050 format( & ' the number of values in the vector ', 6a1, & ' less than or equal to ', 8a1/ & ' must be less than ', i5, '.') 1060 format( & ' since the first value of the vector ', 6a1, & ' is greater than ', 8a1/ & ' all of the values must be greater than ', 8a1, '.') 1070 format(/' there must be at least ', i2, ' values in vector ', 6a1/ & ' greater than or equal to ', 8a1, '.') end subroutine ervii ( nmsub, nmvar, y, n, ylb, yub, nvmx, head, msgtyp, & nv, error ) !*****************************************************************************80 ! !! ERVII checks for vector values outside given limits. ! ! Discussion: ! ! This routine checks for values in the input vector y ! which are outside the (inclusive) limits ylb to yub, prints ! an error message if the number of violations exceeds the largest ! number of violations allowed, and returns the number of ! violations and an error flag indicating the results. three ! messages are available, specified by msgtyp . ! if (msgtyp = 0) no violations are allowed. ! if (msgtyp = 1) the number of violations must ! be less than nvmx . ! if (msgtyp = 2) violations are counted only if the ! the first element is not in violation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical error ! the value returned from the error checking routines to indicate ! whether an error was detected (true) or not (false). ! logical head ! a flag indicating whether the heading should be printed (true) ! or not (false). ! integer i ! an index variable. ! integer msgtyp ! the indicator variable for the type of message. ! if (msgtyp = 0) no violations are allowed. ! if (msgtyp = 1) the number of violations must ! be less than nvmx . ! if (msgtyp = 2) violations are counted only if the ! the first element is not in violation. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar(8) ! the characters of the parameters name. ! integer nnv ! the number of values not in violation. ! integer nnvmn ! the smallest number of values not in violation allowed. ! integer nv ! the number of violations found. ! integer nvmx ! the largest number of violations allowed. ! real y(n) ! the vector being tested. ! real ylb, yub ! the (inclusive) range that the vector is being tested ! against. ! implicit none real & ylb,yub integer & msgtyp,n,nv,nvmx logical & error,head ! ! array arguments real & y(*) character & nmsub(6)*1,nmvar(8)*1 ! ! integer & i,nnv,nnvmn ! ! external subroutines external ehdr error = .false. if (n <= 0) then return end if ! ! test whether testing is necessry ! if ((msgtyp == 2) .and. & (y(1) < ylb) .or. (y(1) > yub)) return ! ! check for violations ! nv = 0 do i = 1, n if ((y(i) yub)) nv = nv + 1 end do if (nv <= nvmx) return ! ! violations found ! error = .true. call ehdr(nmsub, head) nnv = n - nv nnvmn = n - nvmx if (msgtyp == 0) then write ( *, 1010) (nmvar(i), i = 1, 6), ylb, yub, nv else if (msgtyp == 1) then write ( *, 1020) (nmvar(i), i = 1, 6), ylb, yub, & nnvmn, nnv else if (msgtyp == 2) then write ( *, 1030) (nmvar(i), i = 1, 6), ylb, yub end if return 1010 format(/ & ' the values in the vector ', 6a1, & ' must all be in the range ', 1pe14.7, ' to'/ & 1x, 1pe14.7, & ', inclusive. the number of values outside this range', & ' is ', i5, '.') 1020 format(/ & ' the number of values in the vector ', 6a1, & ' in the range ', 1pe14.7, ' to'/ & 1x, 1pe14.7, ', inclusive, must equal or exceed ', i5, '.'/ & ' the number of values in this range is ', i5, '.') 1030 format(/ & ' if the first value of the vector ', 6a1, & ' is in the range', 1pe14.7, ' to'/ & 1x, 1pe14.7, & ' inclusive, all of the values must be in this range.') end subroutine ervwt ( nmsub, nmvar1, wt, n, nnzwmn, head, nnzw, & nzw, msgtyp, error, nmvar2 ) !*****************************************************************************80 ! !! ERVWT checks user-supplied weights. ! ! Discussion: ! ! This routine checks user supplied weights to assure there ! are no negative weights, and that there are sufficient positive ! weights for the task. it returns error set to true ! if no errors are found, and set to false otherwise, and in ! addition, returns the number of nonzero weights and the number ! of zero weights. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index argument. ! integer msgtyp ! an argument used to indicate the type of message to be ! printed, where if error is true and ! msgtyp = 1, the input value was too small based on limits ! imposed by starpac. ! msgtyp = 2, the input value was too small based on other ! input arguments. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the characters of the calling subroutines name. ! character*1 nmvar1(8) ! the characters of the name of the argument being checked. ! character*1 nmvar2(8) ! the characters of the name of the argument being checked ! against. ! integer nnzw ! the number of nonzero weights. ! integer nnzwmn ! the minimum number of nonzero weights which is acceptable. ! integer nzw ! the number of zero weights. ! real wt(n) ! the weight vector. ! implicit none logical error logical head integer i integer j integer msgtyp integer n integer nnzw integer nnzwmn integer nzw real & wt(*) character & nmsub(6)*1,nmvar1(8)*1,nmvar2(8)*1 error = .false. if (n <= 0) return ! ! check for negative weights and count number of zero weights. ! nzw = 0 do i = 1, n if (wt(i) < 0.0e0) then error = .true. call ehdr(nmsub, head) write ( *, 1020) (nmvar1(j), j = 1, 6) return end if if (wt(i) == 0.0e0) nzw = nzw + 1 end do nnzw = n - nzw if (nnzw >= nnzwmn) return ! ! insufficient number of positive weights found ! error = .true. call ehdr(nmsub, head) write ( *, 1010) nnzw if (msgtyp == 1) write ( *, 1030) (nmvar1(i), i=1,6), nnzwmn if (msgtyp == 2) write ( *,1040) (nmvar1(i),i=1,6), & (nmvar2(i),i=1,8) return 1010 format(/ & ' the number of nonzero weights found is ', i6, '.') 1020 format(/ & ' negative values were found in the vector ', 6a1, '.'/ & ' all weights must be greater than or equal to zero.') 1030 format( & ' the number of nonzero weights in ', 6a1, & ' must be greater than or equal to ', i6, '.') 1040 format( & ' the number of nonzero weights in ', 6a1, & ' must be greater than or equal to ', 8a1, '.') end subroutine etamdl ( mdl, par, npar, xm, n, m, ixm, eta, neta, & partmp, pv, nrowin ) !*****************************************************************************80 ! !! ETAMDL computes noise and number of good digits in model routine results. ! ! Discussion: ! ! This routine computes the noise and number of good digits in ! results of model routine at row . ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real a, b ! parameters of the fit. ! real eta ! the noise in the model results. ! real fac ! a factor used in the computations. ! real fplrs ! the floating point largest relative spacing. ! integer i ! an indexing variable. ! integer ixm ! actual first dimension of xm ! real j ! the value real ( i-3 ). ! integer k ! an index variable. ! integer m ! number of variables ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! number of observations ! integer neta ! the number of accurate digits in the model results. ! integer npar ! number of parameters ! integer nrow ! the row number actually used. ! integer nrowin ! the input number of the row being checked. ! real par(npar) ! model parameters ! real partmp(npar) ! modified model parameters ! real pv(n) ! predicted values ! real rss(5) ! the residual sum of squares for each value of j. ! real rsssm ! the sum of the residual sum of squares for each set of ! parameter values. ! real rsssmj ! the sum of the residual sum of squares times j for each ! set of parameter values. ! real sqrtmp ! the square root of machine precision (fplrs). ! real xm(ixm,m) ! independent variables ! implicit none real & eta integer & ixm,m,n,neta,npar,nrowin ! ! array arguments real & par(npar),partmp(npar),pv(n),xm(ixm,m) ! ! subroutine arguments external mdl ! ! real & a,b,fac,fplrs,rsssm,rsssmj,sqrtmp integer & i,k,nrow ! ! local arrays real & rss(5) ! ! external subroutines external setrow fplrs = epsilon ( fplrs ) ! ! select first row of independent variables which contains no zeros ! call setrow(nrowin, xm, n, m, ixm, nrow) sqrtmp = sqrt(fplrs) rsssm = 0.0e0 rsssmj = 0.0e0 do i=1,5 do k=1,npar partmp(k) = par(k)*(1.0e0+ real ( i - 3 ) *sqrtmp) end do call mdl(partmp, npar, xm, n, m, ixm, pv) rss(i) = pv(nrow) rsssm = rsssm + rss(i) rsssmj = rsssmj + real ( i - 3 ) *rss(i) end do a = 0.2e00*rsssm b = 0.1e00*rsssmj fac = 1.0e0 if (rss(3) /= 0.0e0) fac = fac/rss(3) do i=1,5 rss(i) = abs((rss(i)-(a+ real ( i - 3 ) *b))*fac) end do eta = max(rss(1),rss(2),rss(3),rss(4),rss(5),fplrs) neta = - int ( log10 ( eta ) ) eta = 10.0e0**(-neta) return end function extend ( x, i, n, sym ) !*****************************************************************************80 ! !! EXTEND returns the I-th term in a series. ! ! Discussion: ! ! This routine returns the I-th term in the series x, ! extending if necessary with even or odd symmetry according ! to the sign of sym, which should be either plus or minus one. ! (the value zero will result in the extended value being zero.) ! this routine is taken from bloomfields book, page 179. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! implicit none integer n real con real extend integer i integer j real sym real x(n) j = i con = 1.0e0 do if ( j < 1 ) then j = 2-j con = con * sym end if if ( j <= n ) then exit end if j = 2*n-j con = con * sym end do extend = x(j) * con return end subroutine factor ( n, npf, ipf, ipfexp ) !*****************************************************************************80 ! !! FACTOR factors an integer. ! ! Discussion: ! ! This routine factors an input integer n and returns ! the number of prime factors in npf , the value of the ! prime factors in the vector ipf , and the exponent ! of each of the prime factors in the vector ipfexp . ! the elements of ipf are stored in increasing order. ! the length of the vectors is sufficient to accomodate ! the prime factors of an integer up to 2 ** 128 (approximately ! 10 ** 40). ! ! This routine is adapted from the factoring routine given ! in acm algorithm 467 (cacm, 1973, vol. 16, no. 11, page 692-694). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! integer idiv, ifcur ! various variables used to factor n . ! integer ipf(50), ipfexp(50) ! the vectors of prime factors of n , and their exponents, ! respectively. ! integer iquot ! a variable used to factor n . ! integer n ! the value to be factored. ! integer npart ! a variable used to factor n . ! integer npf ! the number of factors found in n . ! implicit none integer & n,npf ! ! array arguments integer & ipf(50),ipfexp(50) integer & idiv,ifcur,iquot,npart npf = 0 ifcur = 0 npart = n idiv = 2 do iquot = npart/idiv if ( npart /= idiv*iquot ) then if (iquot <= idiv) then exit end if if (idiv < 3) then idiv = 3 else idiv = idiv + 2 end if else if (idiv <= ifcur) then ipfexp(npf) = ipfexp(npf) + 1 else npf = npf + 1 ipf(npf) = idiv ifcur = idiv ipfexp(npf) = 1 end if npart = iquot end if end do if ( npart <= 1 ) then return else if ( npart <= ifcur ) then ipfexp(npf) = ipfexp(npf) + 1 else npf = npf + 1 ipf(npf) = npart ipfexp(npf) = 1 end if return end subroutine fdump ( ) !*****************************************************************************80 ! !! FDUMP produces a symbolic dump. ! ! Discussion: ! ! This routine is intended to be replaced by a locally written ! version which produces a symbolic dump. Failing this, ! it should be replaced by a version which prints the ! subprogram nesting list. ! ! Normally, the dump information should be printed to all the ! active error output units. The number and value of these ! units can be determined by calling XGETUA. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! None ! implicit none return end subroutine fftct ( x, n2, ix ) !*****************************************************************************80 ! !! FFTCT does a cosine transform of n=2*n2 symmetric data points. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ix ! the dimension of x. ! integer n2 ! the half length of the symmetric data array. n2 must be even. ! real x(ix) ! the n2+2 vector with first half of symmetric data stored in ! the first n2+1 locations. location n2+2 used only for ! workspace. the cosine transform coefficients are returned ! in the first n2+1 locations of x. ! implicit none integer & ix,n2 real & x(ix) real & a2,aa,ab,cd,cn,ex,pi,save,sd,sn integer & i,isn,j,k,m,m1,n1,nk call getpi(pi) a2 = 0.0e0 n1 = n2 + 1 do j=2,n2,2 a2 = a2 + x(j) end do a2 = 2.0e0*a2 m = n2/2 m1 = m + 1 ex = x(2) x(2) = 0.0e0 do i = 4, n1, 2 save = ex - x(i) ex = x(i) x(i) = save end do x(n2+2) = 0.0e0 isn = -2 call realtr(x, x(2), m, isn) call fft(x, x(2), m, m, m, isn) sd = pi / real ( 2 * n2 ) cd = 2.0e0*sin(sd)**2 sd = sin(sd+sd) sn = 0.0e0 cn = 1.0e0 nk = n2 + 2 do j=2,m1 k = nk - j aa = x(j) + x(k) ab = (x(j)-x(k))*0.5e0 ex = cn - (cd*cn+sd*sn) sn = (sd*cn-cd*sn) + sn cn = 0.5e0/(ex*ex+sn*sn) + 0.5e0 sn = cn*sn cn = cn*ex ex = ab/sn x(j) = (aa+ex)*0.5e0 x(k) = (aa-ex)*0.5e0 end do ex = x(1) x(1) = ex + a2 x(n2+1) = ex - a2 x(n2+2) = 0.0e0 return end subroutine fft ( a, b, ntot, n, nspan, isn ) !*****************************************************************************80 ! !! FFT is a multivariate complex Fourier transform. ! ! Discussion: ! ! This routine implements a multivariate complex Fourier transform, ! computed in place using mixed-radix fast Fourier transform algorithm. ! by r. c. singleton, stanford research institute, oct. 1968 ! ! a tri-variate transform with a(n1,n2,n3), b(n1,n2,n3) ! is computed by ! call fft(a,b,n1*n2*n3,n1,n1,1) ! call fft(a,b,n1*n2*n3,n2,n1*n2,1) ! call fft(a,b,n1*n2*n3,n3,n1*n2*n3,1) ! for a single-variate transform, ! ntot = n = nspan = (number of complex data values), f.g. ! call fft(a,b,n,n,n,1) ! the data may alternatively be stored in a single complex ! array a, then the magnitude of isn changed to two to ! give the correct indexing increment and a(2) used to ! pass the initial address for the sequence of imaginary ! values, e.g. ! call fft(a,a(2),ntot,n,nspan,2) ! arrays at(maxf), ck(maxf), bt(maxf), sk(maxf), and np(maxp) ! are used for temporary storage. if the availabel storage ! is insufficient, the program is terminated by a stop. ! maxf must be >= the maximum prime factor of n. ! maxp must be > the number of prime factors of n. ! ! nb. the above description of maxp appears to be incorrect. ! maxp seems to be the maximum size of the square free ! portion k of n. ! ! in addition, if the square-free portion k of n has two or ! more prime factors, then maxp must be >= k-1. ! dimension a(1), b(1) ! array storage in nfac for a maximum of 11 factors of n. ! if n has more than one square-free factor, the product of the ! square-free factors must be <= 210 ! dimension nfac(11), np(209) ! array storage for maximum prime factor of 23 ! dimension at(23), ck(23), bt(23), sk(23) ! ! Parameters: ! ! arrays a and b originally hold the real and imaginary ! components of the data, and return the real and ! imaginary components of the resulting Fourier coefficients. ! multivariate data is indexed according to the fortran ! array element successor function, without limit ! on the number of implied multiple subscripts. ! the subroutine is called once for each variate. ! the calls for a multivariate transform may be in any order. ! ! ntot is the total number of complex data values. ! ! n is the dimension of the current variable. ! ! nspan/n is the spacing of consecutive data values ! while indexing the current variable. ! ! the sign of isn determines the sign of the complex ! exponential, and the magnitude of isn is normally one. ! implicit none integer & maxf1 parameter (maxf1=23) integer & maxp1 parameter (maxp1=209) ! ! scalar arguments integer & isn,n,nspan,ntot ! ! array arguments real & a(*),b(*) ! ! real & aa,aj,ajm,ajp,ak,akm,akp,bb,bj,bjm,bjp,bk,bkm,bkp,c1,c2,c3, & c72,cd,rad,radf,s1,s120,s2,s3,s72,sd integer & i,ii,inc,j,jc,jf,jj,k,k1,k2,k3,k4,kk,ks,kspan,kspnn, & kt,m,maxf,maxp,nn,nt ! ! local arrays real & at(maxf1),bt(maxf1),ck(maxf1),sk(maxf1) integer & nfac(11),np(maxp1) ! ! equivalences equivalence (i,ii) ! ! the following two constants should agree with the array dimensions. ! maxf = maxf1 maxp = maxp1 if (n<2) return ! ! initialize variables ! c1 = 0 c2 = 0 c3 = 0 s1 = 0 s2 = 0 s3 = 0 k1 = 0 k2 = 0 k3 = 0 k4 = 0 inc = isn rad = 8.0e0*atan(1.0e0) s72 = rad/5.0e0 c72 = cos(s72) s72 = sin(s72) s120 = sqrt(0.75e0) if ( isn < 0) then s72 = -s72 s120 = -s120 rad = -rad inc = -inc end if nt = inc*ntot ks = inc*nspan kspan = ks nn = nt - inc jc = ks/n radf = rad * real ( jc ) * 0.5e0 i = 0 jf = 0 ! ! determine the factors of n ! m = 0 k = n do if ( k - ( k / 16 ) * 16 /= 0 ) then exit end if m = m + 1 nfac(m) = 4 k = k / 16 end do j = 3 jj = 9 go to 50 40 m = m + 1 nfac(m) = j k = k/jj 50 if (mod(k,jj) == 0) go to 40 j = j + 2 jj = j**2 if (jj <= k) go to 50 if (k > 4) go to 60 if (k > 4) go to 60 kt = m nfac(m+1) = k if (k /= 1) m = m + 1 go to 100 60 if (k-(k/4)*4 /= 0) go to 70 m = m + 1 nfac(m) = 2 k = k/4 70 kt = m j = 2 80 if (mod(k,j) /= 0) go to 90 m = m + 1 nfac(m) = j k = k/j 90 j = ((j+1)/2)*2 + 1 if (j <= k) go to 80 100 if (kt == 0) go to 120 j = kt 110 m = m + 1 nfac(m) = nfac(j) j = j - 1 if (j /= 0) go to 110 ! ! compute Fourier transform ! 120 sd = radf / real ( kspan ) cd = 2.0e0*sin(sd)**2 sd = sin(sd+sd) kk = 1 i = i + 1 if (nfac(i) /= 2) go to 170 ! ! transform for factor of 2 (including rotation factor) ! kspan = kspan/2 k1 = kspan + 2 130 k2 = kk + kspan ak = a(k2) bk = b(k2) a(k2) = a(kk) - ak b(k2) = b(kk) - bk a(kk) = a(kk) + ak b(kk) = b(kk) + bk kk = k2 + kspan if (kk <= nn) go to 130 kk = kk - nn if (kk <= jc) go to 130 if (kk > kspan) go to 360 140 c1 = 1.0e0 - cd s1 = sd 150 k2 = kk + kspan ak = a(kk) - a(k2) bk = b(kk) - b(k2) a(kk) = a(kk) + a(k2) b(kk) = b(kk) + b(k2) a(k2) = c1*ak - s1*bk b(k2) = s1*ak + c1*bk kk = k2 + kspan if (kk k2) go to 150 ak = c1 - (cd*c1+sd*s1) s1 = (sd*c1-cd*s1) + s1 ! ! the following three statements compensate for truncation error ! c1 = 0.5e0/(ak**2+s1**2) + 0.5e0 s1 = c1*s1 c1 = c1*ak kk = kk + jc if (kk maxf) go to 590 ck(jf) = 1.0e0 sk(jf) = 0.0e0 j = 1 270 ck(j) = ck(k)*c1 + sk(k)*s1 sk(j) = ck(k)*s1 - sk(k)*c1 k = k - 1 ck(k) = ck(j) sk(k) = -sk(j) j = j + 1 if (j jf) jj = jj - jf if (k np(j)) go to 390 j = 1 400 if (kk np(j)) go to 430 j = 1 440 if (kk= m) return kspnn = np(kt+1) ! ! permutation for square-free factors of n ! j = m - kt nfac(j+1) = 1 460 nfac(j) = nfac(j)*nfac(j+1) j = j - 1 if (j /= kt) go to 460 kt = kt + 1 nn = nfac(kt) - 1 if (nn > maxp) go to 590 jj = 0 j = 0 go to 490 470 jj = jj - k2 k2 = kk k = k + 1 kk = nfac(k) 480 jj = kk + jj if (jj >= k2) go to 470 np(j) = jj 490 k2 = nfac(kt) k = kt + 1 kk = nfac(k) j = j + 1 if (j <= nn) go to 480 ! ! determine the permutation cycles of length greater than 1 ! j = 0 go to 510 500 k = kk kk = np(k) np(k) = -kk if (kk /= j) go to 500 k3 = kk 510 j = j + 1 kk = np(j) if (kk<0) go to 510 if (kk /= j) go to 500 np(j) = -j if (j /= nn) go to 510 maxf = inc*maxf ! ! reorder a and b, following the permutation cycles ! go to 580 520 j = j - 1 if (np(j)<0) go to 520 jj = jc 530 kspan = jj if (jj > maxf) kspan = maxf jj = jj - kspan k = np(j) kk = jc*k + ii + jj k1 = kk + kspan k2 = 0 540 k2 = k2 + 1 at(k2) = a(k1) bt(k2) = b(k1) k1 = k1 - inc if (k1 /= kk) go to 540 550 k1 = kk + kspan k2 = k1 - jc*(k+np(k)) k = -np(k) 560 a(k1) = a(k2) b(k1) = b(k2) k1 = k1 - inc k2 = k2 - inc if (k1 /= kk) go to 560 kk = k2 if (k /= j) go to 550 k1 = kk + kspan k2 = 0 570 k2 = k2 + 1 a(k1) = at(k2) b(k1) = bt(k2) k1 = k1 - inc if (k1 /= kk) go to 570 if (jj /= 0) go to 530 if (j /= 1) go to 520 580 j = k3 + 1 nt = nt - kspnn ii = nt - inc + 1 if (nt >= 0) go to 520 return ! ! error finish, insufficient array storage ! 590 isn = 0 write ( *, 1000) ! ! the following stop should be changed to a return when ! the time series routines are modified for starpac. ! stop 1000 format (' ', 17('*')/' * error message *'/1x, 17('*')// & ' array bounds exceeded within subroutine fft.'/ & ' please bring this error to the attention of'/ & ' janet r. donaldson'/ & ' 303-497-5114'/ & ' fts 320-5114') end subroutine fftlen ( n, ndiv, nfft ) !*****************************************************************************80 ! !! FFTLEN computes the value of NFFT for the Singleton FFT routine. ! ! Discussion: ! ! This routine computes the smallest value of nfft which ! equals or exceeds n + 2, such that nfft - 2 is divisible by ! ndiv and has no prime factors greater than 23, and the ! product of the non square prime factors of nfft - 2 do not ! exceed 209. the value of nfft thus meet the requirements of ! the extended length of the series required for any routine ! using the singleton fft providing the proper value of ndiv ! is chosen. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,ndiv,nfft ! ! scalars in common integer & ierr logical & err01,err02,head ! ! local arrays character & ln(8)*1,lndiv(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,setesl ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01, err02 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! character*1 ln(8), lndiv(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer n ! the number upon which nfft is based. ! integer ndiv ! a required factor of nfft - 2. ! integer nfft ! the returned value which meets the above description. ! character*1 nmsub(6) ! the name of the routine calling the error checking ! subroutine. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'f', 'f', 't', 'l', 'e', 'n'/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6) & / 'n', ' ', ' ', ' ', ' ', ' '/ data & ln(7), ln(8) & / ' ', ' '/ data & lndiv(1), lndiv(2), lndiv(3), lndiv(4), lndiv(5), lndiv(6) & / 'n', 'd', 'i', 'v', ' ', ' '/ data & lndiv(7), lndiv(8) & / ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 1, 1, head, err01, ln) call eisge(nmsub, lndiv, ndiv, 1, 1, head, err02, lndiv) if ( err01 .or. err02 ) then ierr = 1 write ( *, 1000) return end if call setesl(n, ndiv, nfft) return 1000 format (/' the correct form of the call statement is'// & ' call fftlen (n, ndiv, nfft)') end subroutine fftr ( yfft, n, nfft, iextnd, nf, ab, lab ) !*****************************************************************************80 ! !! FFTR is the user-callable routine for the Fourier transform of a series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer ierr integer iextnd integer lab integer n integer nf integer nfft ! ! array arguments real & ab(*),yfft(*) real & yextnd integer isn,nfft1,nfft2 logical & err01,err02,err03,head ! ! local arrays character & llab(8)*1,ln(8)*1,nmsub(6)*1 ! ! external subroutines external amean,eisge,fft,realtr ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real ab(lab) ! the vector of the nf real and imaginary components of the ! Fourier coefficients. ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer i ! an index variable. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer iextnd ! the indicator variable used to designate whether zero ! (iextnd == 0) or the series mean (iextnd /= 0) is to be ! used to extend the series. ! integer lab ! the length of the vector ab. ! character*1 llab(8), ln(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer n ! the integer number of observations. ! integer n1 ! the value n+1. ! integer nf ! the number of frequencies at which the periodgram is ! to be computed. ! integer nfft ! the effective length of the series to be transformed. ! integer nfft1 ! the effective series length actually used. ! integer nfft2 ! the effective length of the series stored as a complex ! variable. ! character*1 nmsub(6) ! the array containing the name of this routine. ! real yextnd ! the value used to extend the series. ! real yfft(n) ! the array containing the observed time series. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'f', 'f', 't', 'r', ' ', ' '/ data & llab(1), llab(2), llab(3), llab(4), llab(5), llab(6) & / 'l', 'a', 'b', ' ', ' ', ' '/ data & llab(7), llab(8) & / ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6) & / 'n', ' ', ' ', ' ', ' ', ' '/ data & ln(7), ln(8) & / ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) if (err01) then ierr = 1 write ( *, 1000) return end if call enfft ( nmsub, nfft, 2, n, lab, nfft1, head, err02 ) nf = nfft1/2 call eisge ( nmsub, llab, lab, nfft1, 9, head, err03, llab ) if (err02 .or. err03) then ierr = 1 write ( *, 1000) return end if ! ! Copy the input series to ab, extending appropriately. ! yextnd = 0.0e0 if (iextnd /= 0) call amean (yfft, n, yextnd) ab(1:n) = yfft(1:n) ab(n+1:nfft1) = yextnd nfft2 = (nfft1-2) / 2 isn = 2 call fft (ab(1), ab(2), nfft2, nfft2, nfft2, isn) call realtr (ab(1), ab(2), nfft2, isn) return 1000 format (/' the correct form of the call statement is'// & ' call fftr (yfft, n, nfft, iextnd, nf, ab, lab)') end subroutine fitext ( rss, yss, exact ) !*****************************************************************************80 ! !! FITEXT checks whether the fit is exact to machine precision. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical exact ! an indicator value used to designate whether the fit ! was exact to machine precision (true) or not (false). ! real fplrs ! the floating point largest relative spacing. ! real rss ! the residual sum of squares. ! real rsstst ! the value for testing whether the residual sum of squares ! is zero (to within machine precision). ! real yss ! the sum of squares of the dependent variable y. ! implicit none real & rss,yss logical & exact real & fplrs,rsstst fplrs = epsilon ( fplrs ) ! ! test for exact fit ! exact = .false. rsstst = rss if (yss > 0.0e0) rsstst = rsstst / yss rsstst = sqrt(rsstst) if (rsstst<10.0e0*fplrs) exact = .true. return end subroutine fitpt1 ( n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, & nnzw, weight, iptout ) !*****************************************************************************80 ! !! FITPT1 prints the data summary for nonlinear least squares routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ierr ! the integer value designating whether any errors have ! been detected. ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected. ! integer iptout ! the variable used to control printed output. ! integer ixm ! the first dimension of the independent variable array. ! integer jcolm ! the last column of the independent variable to be printed. ! integer jcol1 ! the first column of the independent variable to be printed. ! integer k ! an index variable. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer nmax ! the maximum number of rows to be printed. ! integer nnzw ! the number of non zero weights. ! real pv(n) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the user supplied weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! implicit none integer & iptout,ixm,m,n,nnzw logical & weight ! ! array arguments real & pv(n),res(n),sdpv(n),sdres(n),wt(n),xm(ixm,m),y(n) ! ! scalars in common integer & ierr ! ! integer & i,jcol1,jcolm,k,nmax ! ! common blocks common /errchk/ierr write ( *,1100) if (weight) then write ( *,1010) else write ( *,1000) end if write ( *, 1110) ! ! test whether column vector xm(*, 1) = vector 1.0e0 ! do i=1,n if (xm(i,1) /= 1.0e0) go to 20 end do go to 30 ! ! not a unit vector ! 20 jcol1 = 1 jcolm = min(m,3) go to 40 ! ! unit vector ! 30 jcolm = min(m,4) jcol1 = min(2,jcolm) 40 k = jcolm - jcol1 + 1 nmax = n if ((iptout == 1) .and. (n >= 45)) nmax = min(n,40) ! ! print observation summary ! call obssum(n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, & weight, k, 1, nmax, jcol1, jcolm) if ( nmax < n ) then do i = 1, 3 if ( k == 1 ) then write ( *,1120) else if ( k == 2 ) then write ( *,1130) else if ( k == 3 ) then write ( *,1140) end if write ( *, 1150) if (weight) write ( *, 1160) end do ! ! print last line of output ! call obssum(n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, & weight, k, n, n, jcol1, jcolm) end if if ((nnzw 0) .and. (ierr /= 4)) write ( *, 1090) return 1000 format (/53x, 'dependent', 7x, 'predicted', 5x, ' std dev of ', & 24x, 'std '/ & 2x, 'row', 13x, 'predictor values', 20x, 'variable', 8x, & ' value', 8x, 'pred value ', 6x, 'residual ', 8x, 'res') 1010 format (/53x, 'dependent', 7x, 'predicted', 5x, ' std dev of ', & 24x, 'std '/ & 2x, 'row', 13x, 'predictor values', 20x, 'variable', 8x, & ' value', 8x, 'pred value ', 6x, 'residual ', 8x, 'res', & 4x, 'weight') 1060 format (// ' * nc - value not computed because', & ' the weight is zero.') 1070 format (// ' * nc - value not computed because either', & ' the weight or the standard deviation of the residual', & ' is zero.') 1080 format (// ' * nc - value not computed because', & ' the standard deviation of the residual is zero.') 1090 format (// ' * nc - value not computed', & ' because convergence problems prevented the covariance', & ' matrix from being computed.') 1100 format (//' results from least squares fit'/ 1x, 31('-')) 1110 format (' ') 1120 format (4x, '.', 25x, '.') 1130 format (4x, '.', 3x, 2(14x, '.')) 1140 format (4x, '.', 10x, '.', 2(14x, '.')) 1150 format ('+', 49x, 11x, '.', 3(15x, '.'), 11x, '.') 1160 format ('+', 130x, '.') end subroutine fitpt2 ( sdres, pv, wt, n, nnzw, weight, res, rss ) !*****************************************************************************80 ! !! FITPT2 prints the four standardized residual plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real annzw ! the number of nonzero weights, used in computing ! the normal probability plot. ! real fac1, fac2 ! factors used in computing the normal probability plot. ! real fplm ! the floating point largest magnitude. ! real gamma ! a value used in computing the normal probability plot. ! character*1 iblank ! the value of the character -blank-. ! integer ierr ! the integer value designating whether any errors have ! been detected. ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected. ! integer ifirst ! the first row of the variables to be plotted. ! integer imid ! the midpoint of the first plot of the second set ! character*1 iminus ! the character minus. ! integer iplot ! an indicator variable designating whether the first or ! second set of two plots are being printed. ! character*1 iplus ! the character plus. ! integer iprb ! the location in the plot string of the symbol for the ! probability plot. ! integer ipv ! the location in the plot string of the symbol for the plot ! versus predicted value. ! integer irow ! the row of the variables being plotted. ! character*1 istar ! the character star. ! integer ix ! the location in the plot string of the symbol for the plots ! versus the independent variable. ! integer k, l ! index variables. ! character*1 line(102) ! the symbols (blanks and characters) for a given line ! of the plot. ! integer n ! the number of observations in each column of data. ! integer ncol, ncolpl, ncolp1, ncolt2 ! the number of columns in the plot, ncol+l, ncol+1, ! and ncol * 2. ! integer nnzw ! the number of non zero weights. ! integer nrow ! the number of columns in the plot. ! real pi ! the value of pi. ! real pv(n) ! the predicted value based on the current coefficient estimates ! real pvdiv ! the value of a division along the -predicted value- axis. ! real pvmax ! the largest value in the vector pv. ! real pvmid ! the midpoint of the range of values in the vector pv. ! real pvmin ! the smallest value in the vector pv. ! real ratio ! a value used to produce the normal probability plot. ! real res(n) ! the residuals from the fit. ! real rowdiv ! the value of a division along the -row- axis. ! real rowmax ! the largest row value. ! real rowmid ! the midpoint of the range of the rows plotted. ! real rowmin ! the smallest row value plotted. ! real rss ! the residual sum of squares. ! real sdres(n) ! the standard deviations of the residuals. ! real w ! the value of the weight for the current value being plotted. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the user supplied weights. ! real ylabel ! the label to be printed along the y axis. ! real ymax ! the largest value along the y axis ! real ymin ! the smallest value along the y axis. ! implicit none real & rss integer & n,nnzw logical & weight ! ! array arguments real & pv(n),res(n),sdres(n),wt(n) ! ! scalars in common integer & ierr real & annzw,dot,fac1,fac2,fplm,gamm,pi,pvdiv,pvmax,pvmid,pvmin, & ratio,rowdiv,rowmax,rowmid,rowmin,w real ylabel, & ymax,ymin integer & i,i1,i2,idot,ifirst,imid,iplot,iprb,ipv,irow,ix,k,l, & ncol,ncolp1,ncolpl,ncolt2,ndot,nrow character & iblank*1,iminus*1,iplus*1,istar*1 ! ! local arrays character & line(102)*1 ! ! external functions logical & mvchk external mvchk ! ! common blocks common /errchk/ierr data iplus/'+'/, iminus/'-'/, istar/'*'/, iblank/' '/ fplm = huge ( fplm ) ! ! check for insufficient points to plot ! if (ierr == 4) then do i = 1, n if (sdres(i) /= fplm) go to 5 end do write ( *, 1090) return end if 5 continue ! ! initialize variables for probability plot ! call getpi(pi) gamm = pi/8.0e0 annzw = real ( nnzw ) fac1 = 1.0e0 / (annzw - 2.0e0*gamm + 1.0e0) fac2 = 10.0e0 ! ! initialize the plot size (in plot units) ! nrow = 26 ncol = 51 ncolp1 = ncol + 1 ncolt2 = 2*ncol imid = (ncol-1)/2 ! ! find the first row of observations with nonzero weights ! ifirst = 1 if ( weight ) then do i=1,n if ( 0.0E+00 < wt(i) ) then ifirst = i exit end if end do end if ! ! begin computations for first set of plots ! iplot = 1 ! ! set x axis limits for standardized residual vs row plot, ! and standardized residuals vs predicted values plot. ! rowmin = real ( ifirst ) pvmin = pv(ifirst) pvmax = pv(ifirst) rowmax = real ( ifirst ) do i=ifirst,n w = 1.0e0 if (weight) w = wt(i) if (w > 0.0e0) then rowmax = real ( i ) if (pv(i) pvmax) pvmax = pv(i) end if end do if ( pvmax <= pvmax ) then if (pvmin == 0.0e0) then pvmin = -0.5e0 pvmax = 0.5e0 else pvmin = pvmin - pvmin/2.0e0 pvmax = pvmax + pvmax/2.0e0 end if end if rowmid = (rowmax+rowmin)/2.0e0 rowdiv = (rowmax-rowmin)/real ( ncol - 1 ) pvmid = (pvmax+pvmin)/2.0e0 pvdiv = (pvmax-pvmin)/ real ( ncol - 1 ) ! ! print titles for first plots ! write ( *,1000) go to 90 ! ! begin computations for second set of plots ! 40 iplot = 2 ! ! print titles for second plots ! write ( *,1050) ! ! write first line of plots ! 90 continue ! ! print plots, one line at a time ! ylabel = 3.75e0 ymax = fplm ymin = 4.05e0 do k=1,nrow ymin = ymin - 0.3e0 if (-3.70e0 >= ymin) ymin = -fplm do l=1,ncol ncolpl = l + ncol line(l) = iblank line(ncolpl) = iblank if ((k /= 1) .and. (k /= nrow)) then cycle end if line(l) = iminus line(ncolpl) = iminus if ( mod(l,10) == 1 .or. l == 1+ncol/2 ) then line(l) = iplus line(ncolpl) = iplus end if end do do i=1,n if (weight) then w = wt(i) else w = 1.0e0 end if if ((w /= 0.0e0) .and. (.not.mvchk(sdres(i),fplm))) then if ((sdres(i) > ymin) .and. (sdres(i) <= ymax)) then if (iplot == 1) then ! ! set plot line for first set of plots ! irow = int(((real( i ) -rowmin)/rowdiv)+1.5e0) line(irow) = istar ipv = int((pv(i)-pvmin)/pvdiv+1.5e0) + ncol line(ipv) = istar else ! ! set plot line for probability plot ! ratio = (annzw-gamm) * fac1 iprb = int(4.91e0*(ratio**0.14e0- & (1.0e0-ratio)**0.14e0)*fac2) + 77 if (iprb <= ncol) iprb = ncol+1 if (iprb >= 103) iprb = 102 line(iprb) = istar annzw = annzw - 1.0e0 if ((annzw<2.0e0) .and. (nnzw <= 10)) then gamm = 1.0e0/3.0e0 end if end if end if end if end do ! ! set plot line for correlation plot ! if (iplot == 2) then if (k <= n-1) then dot = 0.0e0 if (weight) then ndot = 0 do idot = 1, n-k if ((wt(idot) > 0.0e0) .and. & (wt(idot+k) > 0.0e0)) then ndot = ndot + 1 dot = dot + res(idot)*res(idot+k) end if end do if (ndot >= 1) then dot = dot * real ( n - k ) / real ( ndot ) end if else do idot = 1, n-k dot = dot + res(idot) * res(idot+k) end do end if ix = int ( real ( imid ) * dot / rss ) + imid + 1 i1 = min(ix,imid+1) i2 = max(ix,imid+1) line(i1:i2) = istar end if end if if (mod(k,5) == 1) then if (iplot == 1) then write ( *,2020) ylabel, (line(l),l=1,ncol), ylabel, & (line(l),l=ncolp1,ncolt2) else write ( *,1020) k, (line(l),l=1,ncol), ylabel, & (line(l),l=ncolp1,ncolt2) end if ylabel = ylabel - 1.5 else write ( *,1030) (line(l),l=1,102) end if ymax = ymin end do ! ! print bottom line of graphs ! if (iplot == 1) then ! ! print x axis labels for first set of plots ! write ( *,1040) rowmin, rowmid, rowmax, pvmin, pvmid, pvmax go to 40 else ! ! print x axis labels for second set of plots ! write ( *,1070) end if return 1000 format (/20x, ' std res vs row number ', 35x, & ' std res vs predicted values' ) 1020 format (1x, i5, '+', 51a1, '+', 3x, f5.2, '+', 51a1, '+') 1030 format (6x, '-', 51a1, '-', 8x, '-', 51a1, '-') 1040 format (1x, f8.1, 17x, f8.1, 17x, f8.1, 4x, g11.4, 14x, g11.4, & 10x, g11.4) 1050 format (/13x, 'autocorrelation function of residuals', & 23x, ' normal probability plot of std res' ) 1070 format (4x, '-1.00', 22x, '0.0', 21x, '1.00', 5x, '-2.5', 23x, & '0.0', 22x, '2.5') 1090 format (// 1x, 13('*')/ 1x, '* warning *'/ 1x, 13('*')// & ' the standardized residual plots have been suppressed.', & ' none of the standardized residuals could be', & ' computed,'/ & ' because for each observation either the weight or', & ' the standard deviation of the residual is zero.') 2020 format (1x, f5.2, '+', 51a1, '+', 3x, f5.2, '+', 51a1, '+') end subroutine fitsxp ( par, pv, sdpv, res, sdres, vcv, n, npar, ivcv, rsd ) !*****************************************************************************80 ! !! FITSXP generates reporst for least squares exerciser returned storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & rsd integer & ivcv,n,npar ! ! array arguments real & par(npar),pv(n),res(n),sdpv(n),sdres(n),vcv(ivcv,npar) integer & i ! ! external subroutines external lstvec,matprt ! ! variable definitions (alphabetically) ! ! integer i ! index variable ! integer ivcv ! actual first dimension of vcv ! integer n ! number of observations ! integer npar ! number of parameters ! real par(npar) ! the estimated parameters. ! real pv(n) ! predicted values ! real res(n) ! residuals ! real rsd ! residual standard deviation ! real sdpv(n) ! standard deviation of predicted values ! real sdres(n) ! standard deviation of residuals ! real vcv(ivcv,npar) ! variance covarance matrix ! write ( *,1000) write ( *,1002) call lstvec(npar, par) write ( *,1001) do i=1,n write ( *,1010) pv(i), sdpv(i), res(i), sdres(i) end do write ( *,1020) call matprt(vcv, vcv, npar, 1, 1, ivcv) write ( *,1030) rsd return 1000 format(//' returned results from least squares fit'/ 1x, 39('-')) 1001 format (//7x, 'pv', 13x, 'sdpv', 12x, 'res',12x, 'sdres') 1002 format (//' parameters from fit') 1010 format (1x, g14.7, 2x, g14.7, 2x, g14.7, 2x, g14.7) 1020 format (//' variance covariance matrix') 1030 format (//' rsd =', g14.7) end subroutine fitxsp ( par, pv, sdpv, res, sdres, vcv, n, npar, ivcv, & nnzw, npare, rsd ) !*****************************************************************************80 ! !! FITXSP generates reports for least squares exerciser returned storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & rsd integer & ivcv,n,nnzw,npar,npare ! ! array arguments real & par(npar),pv(n),res(n),sdpv(n),sdres(n),vcv(ivcv,npar) integer & i ! ! external subroutines external matprt ! ! variable definitions (alphabetically) ! ! integer ivcv ! actual first dimension of vcv ! integer n ! number of observations ! integer npar ! number of parameters ! integer npare ! number of parameters estimated by routine. ! integer nnzw ! number of nonzero weights. ! real par(npar) ! the estimated parameters. ! real pv(n) ! predicted values ! real res(n) ! residuals ! real rsd ! residual standard deviation ! real sdpv(n) ! standard deviation of predicted values ! real sdres(n) ! standardized residuals. ! real vcv(ivcv,npar) ! variance covarance matrix ! write ( *,1000) do i=1,n if (i <= npar) then write ( *,1010) i,par(i),res(i),pv(i),sdpv(i),sdres(i) else write ( *,1070) i,res(i),pv(i),sdpv(i),sdres(i) end if end do write ( *,1030) call matprt(vcv, vcv, ivcv, 1, 1, ivcv) write ( *,1060) rsd write ( *,1040) nnzw write ( *,1050) npare return 1000 format (/12x, 'par', 12x, 'res', 12x, 'pv', 13x, 'sdpv', 12x, & 'sdres'/) 1010 format (1x, i5, g14.7, 2x, 4(g14.7, 2x)) 1030 format (/' variance covariance matrix') 1040 format (' nnzw = ', i5) 1050 format (' npare = ', i5) 1060 format (/' rsd = ', g14.7) 1070 format (1x, i5, 16x, 4(g14.7, 2x)) end subroutine fixprt ( ifix, fixed ) !*****************************************************************************80 ! !! FIXPRT sets the character array 'FIXED'. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! character*1 fixed(3) ! the characters used to label the parameters fixed or not. ! integer i ! an index variable. ! integer ifix ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifix == 0, then fixed will be set to no. ! if ifix /= 0, then fixed will be set to yes. ! character*1 no(3) ! the characters blank, n, and o ! character*1 yes(3) ! the characters y, e, and s ! implicit none integer & ifix ! ! array arguments character & fixed(3)*1 ! ! local arrays character & no(3)*1,yes(3)*1 data no(1)/' '/, no(2)/'n'/, no(3)/'o'/ data yes(1)/'y'/, yes(2)/'e'/, yes(3)/'s'/ if (ifix /= 0) then fixed(1:3) = yes(1:3) else fixed(1:3) = no(1:3) end if return end subroutine fltar ( y, n, iar, phi, yf, nyf ) !*****************************************************************************80 ! !! FLTAR filters an input series using an autoregressive filter. ! ! Discussion: ! ! This routine filters the input series y using the iar terms ! of the autoregressive filter phi, copying the filtered series ! into yf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iar,n,nyf ! ! array arguments real & phi(*),y(*),yf(*) real & temp integer & i,i1,j,k ! ! variable definitions (alphabetically) ! ! integer i ! an indexing variable. ! integer iar ! the number of filter terms. ! integer i1, j, k ! indexing variables. ! integer n ! the number of observations in the series y. ! integer nyf ! the number of observations in the filtered series yf. ! real phi(iar) ! the array in which the filter coefficients are stored. ! real temp ! a temporary storage location. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! yf(1:n) = y(1:n) nyf = n - iar do i = 1, nyf k = i + iar temp = yf(k) do j = 1, iar k = k - 1 temp = temp - phi(j) * yf(k) end do yf(i) = temp end do i1 = nyf + 1 yf(i1:n) = 0.0e0 return end subroutine fltarm ( y, ymiss, n, iar, phi, yf, yfmiss, nyf ) !*****************************************************************************80 ! !! FLTARM filters a series with missing data, using an autoregressive filter. ! ! Discussion: ! ! This routine filters the input series y, which contains missing ! data, using the iar terms of the autoregressive filter phi, ! copying the filtered series into yf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & yfmiss,ymiss integer & iar,n,nyf ! ! array arguments real & phi(*),y(*),yf(*) real & fplm,temp integer & i,i1,j,k ! ! external functions logical & mvchk external mvchk ! ! variable definitions (alphabetically) ! ! real fplm ! the floating point largest magnitude. ! integer i ! an indexing variable. ! integer iar ! the number of filter terms. ! integer i1, j, k ! indexing variables. ! integer n ! the number of observations in the series y. ! integer nyf ! the number of observations in the filtered series yf. ! real phi(iar) ! the array in which the filter coefficients are stored. ! real temp ! a temporary storage location. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! real yfmiss ! the missing value code used in the filtered series to ! indicate the value could not be computed due to missing data. ! real ymiss ! the missing value code used in the input series to indicate ! an observation is missing. ! fplm = huge ( fplm ) yfmiss = fplm yf(1:n) = y(1:n) nyf = n - iar do i = 1, nyf temp = yfmiss k = i + iar if ( .not. mvchk ( yf(k), ymiss ) ) then temp = yf(k) do j = 1, iar k = k - 1 if ( mvchk(yf(k), ymiss)) then temp = yfmiss exit end if temp = temp - phi(j) * yf(k) end do end if yf(i) = temp end do i1 = nyf + 1 yf(i1:n) = 0.0e0 return end subroutine fltma ( y, n, k, hma, yf, nyf ) !*****************************************************************************80 ! !! FLTMA filters a series using a simple moving average filter. ! ! Discussion: ! ! This routine filters the input series y using the k terms ! of h, copying the filtered series into yf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real hma ! the value of each of the simple moving average linear filter ! coefficients. ! integer i, ii, i1, j ! indexing variables. ! integer k ! the number of filter terms. ! integer n ! the number of observations in the series y. ! integer nyf ! the number of observations in the filtered series yf. ! real sum ! a temporary location used in computing the filtered series. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! implicit none real & hma integer & k,n,nyf ! ! array arguments real & y(n),yf(n) ! ! real & sum integer & i,i1,ii,j yf(1:n) = y(1:n) nyf = n - (k - 1) do i = 1, nyf ii = i - 1 sum = 0.0e0 do j = 1, k ii = ii + 1 sum = sum + hma*yf(ii) end do yf(i) = sum end do i1 = nyf + 1 yf(i1:n) = 0.0e0 return end subroutine fltmd ( x, y, n, kmd, sym ) !*****************************************************************************80 ! !! FLTMD applies a modified Daniel filter to a symmetric series. ! ! Discussion: ! ! This routine applies one modified daniel filter to a symmetric ! series. this routine is adapted from bloomfield's routine moddan. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! Parameters: ! ! real con ! a factor used in the computations. ! integer kmd ! the input filter length. ! integer kused ! the filter length actually used. ! integer lim ! a loop limit. ! integer n ! the number of points in the series to be filtered. ! real sym ! an indicator variable used to designate whether the series ! is symmetric (sym = 1.0e0) or not (sym = -1.0e0). ! real x(n) ! on input, the series to be filtered. on output, the ! smoothed series. ! real y(n) ! on input, a work vector. on output, the input series x. ! implicit none real & sym integer & kmd,n ! ! array arguments real & x(n),y(n) real & con integer & i,j,kused,lim ! ! external functions real & extend external extend y(1:n) = x(1:n) if (kmd <= 0) return kused = kmd + mod(kmd,2) if (kused > n) kused = kused - 2 lim = kused-1 con = 1.0e0 / real ( 2 * kused ) do i = 1, n x(i) = y(i) do j = 1, lim x(i) = x(i) + extend(y, i-j, n, sym) & + extend(y, i+j, n, sym) end do x(i) = (x(i) + (extend(y, i-kused, n, sym) & + extend(y, i+kused, n, sym)) * 0.5e0) * con end do return end subroutine fltsl ( y, n, k, h, yf, nyf ) !*****************************************************************************80 ! !! FTLSL filters an input series. ! ! Discussion: ! ! This routine filters the input series y using the k terms ! of h, copying the filtered series into yf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real h(k) ! the array in which the filter coefficients are stored. ! integer i, ihm, ihp, ikmid, im, ip ! indexing variables. ! integer k ! the number of filter terms. ! integer khalf, kmid ! the half length of the filter and the midpoint of the filter. ! integer n ! the number of observations in the series y. ! integer nyf ! the number of observations in the filtered series yf. ! real temp ! a tempory storage location. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! implicit none integer & k,n,nyf ! ! array arguments real & h(k),y(n),yf(n) real & temp integer & i,i1,ihm,ihp,ikmid,im,ip,j,khalf,kmid yf(1:n) = y(1:n) nyf = n - (k - 1) khalf = (k - 1) / 2 kmid = khalf + 1 do i = 1, nyf ikmid = i + khalf temp = h(kmid) * yf(ikmid) do j = 1, khalf ip = ikmid + j ihp = kmid + j im = ikmid - j ihm = kmid - j temp = temp + h(ihp)*yf(ip) + h(ihm)*yf(im) end do yf(i) = temp end do i1 = nyf + 1 yf(i1:n) = 0.0e0 return end function gami ( a, x ) !*****************************************************************************80 ! !! GAMI evaluates the incomplete Gamma function. ! ! Discussion: ! ! Evaluate the incomplete gamma function defined by ! ! gami = integral from t = 0 to x of exp(-t) * t**(a-1.0) . ! ! gami is evaluated for positive values of a and non-negative values ! of x. a slight deterioration of 2 or 3 digits accuracy will occur ! when gami is very large or very small, because logarithmic variables ! are used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real a real factor real gami real x ! ! external functions real alngam,gamit external alngam,gamit if (a <= 0.0) call xerror ('gami a must be gt zero', 1, 2) if (x<0.0) call xerror ('gami x must be ge zero', 2, 2) gami = 0.0 if (x == 0.0) return ! ! the only error possible in the expression below is a fatal overflow. ! factor = alngam(a) + a*log(x) if (factor > log( huge ( factor ) )) then gami = huge ( gami ) else gami = exp(factor) * gamit(a,x) end if return end function gamit ( a, x ) !*****************************************************************************80 ! !! GAMIT evaluates Tricomi's incomplete Gamma function. ! ! Discussion: ! ! Evaluate Tricomi's incomplete gamma function defined by ! ! gamit = x**(-a)/gamma(a) * integral t = 0 to x of exp(-t) * t**(a-1.) ! ! and analytic continuation for a <= 0.0. gamma(x) is the complete ! gamma function of x. gamit is evaluated for arbitrary real values of ! a and for non-negative values of x (even though gamit is defined for ! x < 0.0), except that for x = 0 and a <= 0.0, gamit is infinite, ! a fatal error. ! ! a slight deterioration of 2 or 3 digits accuracy will occur when ! gamit is very large or very small in absolute value, because log- ! arithmic variables are used. also, if the parameter a is very close ! to a negative integer (but not a negative integer), there is a loss ! of accuracy, which is reported if the result is less than half ! machine precision. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Walter Gautschi, ! An Evaluation Procedure for Incomplete Gamma Functions, ! ACM Transactions on Mathematical Software. ! implicit none real a real aeps real ainta real algap1 real alneps real alng real alx real bot real gamit real h real sga real sgngam real sqeps real t real x real alngam,gamr,r9gmit,r9lgic,r9lgit external alngam,gamr,r9gmit,r9lgic,r9lgit data alneps, sqeps, bot / 3*0.0 / if ( alneps == 0.0) then alneps = -log( 0.5 * epsilon ( alneps ) ) sqeps = sqrt( epsilon ( sqeps ) ) bot = log( tiny ( bot ) ) end if if (x<0.0) call xerror ('gamit x is negative', 2, 2) if (x /= 0.0) alx = log(x) sga = 1.0 if (a /= 0.0) sga = sign (1.0, a) ainta = aint (a+0.5*sga) aeps = a - ainta if ( x <= 0.0) then gamit = 0.0 if (ainta > 0.0 .or. aeps /= 0.0) gamit = gamr(a+1.0) return end if if ( x <= 1.0) then if (a >= (-0.5) .or. aeps /= 0.0) call algams (a+1.0, algap1, & sgngam) gamit = r9gmit ( a, x, algap1, sgngam, alx ) return end if if ( x <= a ) then t = r9lgit (a, x, alngam(a+1.0)) if (t alneps) then t = t - a*alx if (t (-alneps)) h = 1.0 - sga*sgngam*exp(t) if ( abs ( h ) <= sqeps ) then call xerclr call xerror ('gamit result lt half precision', 1, 1) end if t = -a*alx + log(abs(h)) if (t 0 the plot is log/linear ! real phas(101) ! the array in which the phase of the filter is returned. ! real phi(iar) ! the vector containing the filter coefficients. ! logical sym ! the variable used to indicate whether the gain function ! computed was for a symmetric or autoregressive filter. ! real xord(101) ! the x coordinates for the gain function plot ! real yord(101) ! the y coordinates for the gain function plot ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'g', 'f', 'a', 'r', 'f', ' '/ data & liar(1), liar(2), liar(3), liar(4), liar(5), liar(6), liar(7), & liar(8) & / 'i', 'a', 'r', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, liar, iar, 1, 1, head, err01, liar) if ( err01 ) then ierr = 1 write ( *, 1000) return end if sym = .false. nf = 101 fmin = 0.0e0 fmax = 0.5e0 delta = 1.0e0 nprt = -1 ! ! set frequencies at which the gain function is to be estimated ! call setfrq (freq, nf, nprt, fmin, fmax, delta) ! ! compute the gain function ! call gfaest (phi, iar, nf, freq, gain, phas, delta) ! ! set the coordinates for the plot. ! call gford (freq, gain, isort, nf, xord, yord, nord, & ypltmn, ypltmx, nprt, igferr) ! ! plot the results. ! call gfout (xord, yord, nord, freq, phas, nf, iar, sym, fmin, & fmax, ypltmn, ypltmx, nprt, igferr, nmsub) return 1000 format (/' the correct form of the call statement is'// & ' call gfarf (phi, iar)') end subroutine gfarfs ( phi, iar, nf, fmin, fmax, gain, phas, freq, & nprt, ldstak ) !*****************************************************************************80 ! !! GFARFS: short call to compute gain function of autoregressive filter. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin integer & iar,ldstak,nf,nprt ! ! array arguments real & freq(*),gain(*),phas(*),phi(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & delta,fmn,fmx,ypltmn,ypltmx integer & igferr,io,isort,ldsmin,nall0,nord,xord,yord logical & err01,err02,err03,head,sym ! ! local arrays real & rstak(12) integer & istak(12) character & liar(8)*1,llds(8)*1,lnf(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external eisge,gfaest,gford,gfout,ldscmp,setfrq,stkclr, & stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03 ! values indicating whether an error was detected (true) or not ! (false). ! real fmax, fmin ! the minimum and maximum frequency for which the gain ! function is to be estimated. ! real fmn, fmx ! the frequency range actually used. ! real freq(nf) ! the vector of frequencies at which the gain function ! has been estimated. ! real gain(nf) ! the vector in which the gain function estimates are ! stored. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer iar ! the number of filter coefficients. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer igferr ! an error flag indicating whether computations seem ! to have produced reasonable results. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output. ! integer isort ! the starting location in istak for ! the array used for sorting. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! the length of the array dstak. ! integer ldsmin ! the minimum length allowed for the array dstak. ! character*1 liar(8), llds(8), lnf(8) ! the arrays containing the names of checked variables ! integer nall0 ! the number of outstanding stack allocations. ! integer nf ! the number of frequencies at which the gain function ! is to be estimated. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nord ! the number of points to be plotted. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! real phas(nf) ! the array in which the phase of the filter is returned. ! real phi(iar) ! the vector containing the filter coefficients. ! real rstak(12) ! the real version of the /cstak/ work area. ! logical sym ! the variable used to indicate whether the gain function ! computed was for a symmetric or autoregressive filter. ! integer xord ! the starting location in rstak/dstak of ! the x coordinates for the gain function plot ! integer yord ! the starting location in rstak/dstak of ! the y coordinates for the gain function plot ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'g', 'f', 'a', 'r', 'f', 's'/ data & liar(1), liar(2), liar(3), liar(4), liar(5), liar(6), & liar(7), liar(8) /'i', 'a', 'r', ' ', ' ', ' ', ' ', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), llds(7), & llds(8) / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data & lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), lnf(6), lnf(7), lnf(8) & / 'n', 'f', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. io = 1 if (nprt == 0) io = 0 call eisge(nmsub, liar, iar, 1, 1, head, err01, liar) call eisge(nmsub, lnf, nf, 1, 1, head, err02, lnf) if (err02) then ierr = 1 write ( *, 1000) return end if call ldscmp(3*io, 0, nf, 0, 0, 0, 's', 2*io*nf, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds) if (err01.or.err02.or.err03) then ierr = 1 write ( *, 1000) return end if if (nprt /= 0) then call stkset (ldstak, 4) nall0 = stkst(1) else nall0 = 0 end if sym = .false. delta = 1.0e0 ! ! set frequencies at which the gain function is to be estimated ! fmn = max(fmin, 0.0e0) fmx = min(fmax, 0.5e0) if (fmn >= fmx) then fmn = 0.0e0 fmx = 0.5e0 end if call setfrq (freq, nf, 2, fmn, fmx, delta) ! ! compute the gain function ! call gfaest (phi, iar, nf, freq, gain, phas, delta) if (nprt == 0) return ! ! set various pointers for the plotting arrays ! xord = stkget(nf, 3) yord = stkget(nf, 3) isort = stkget(nf, 2) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if ! ! plot the results ! call gford (freq, gain, istak(isort), nf, rstak(xord), & rstak(yord), nord, ypltmn, ypltmx, nprt, igferr) call gfout (rstak(xord), rstak(yord), nord, freq, phas, nf, & iar, sym, fmn, fmx, ypltmn, ypltmx, nprt, igferr, nmsub) call stkclr(nall0) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if return 1000 format (/' the correct form of the call statement is'// & ' call gfarfs (phi, iar,'/ & ' + nf, fmin, fmax, gain, phas, freq, nprt,', & ' ldstak)') end subroutine gford ( freq, gain, isort, nf, xord, yord, & nord, ypltmn, ypltmx, nprt, igferr ) !*****************************************************************************80 ! !! GFORD produces ordinants for the gain function plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & ypltmn,ypltmx integer & igferr,nf,nord,nprt ! ! array arguments real & freq(nf),gain(nf),xord(nf),yord(nf) integer & isort(nf) real & gainmn,gainmx,ymax integer & i,j ! ! external subroutines external spcck ! ! variable definitions (alphabetically) ! ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! estimated. ! real gain(nf) ! the vector in which the gain function is stored. ! real gainmn, gainmx ! the minimum and maximum gain function value to be plotted. ! integer i ! an index variable ! integer igferr ! an error flag indicating whether computations seem ! to have produced reasonable results. ! integer isort(nf) ! the array used for sorting. ! integer j ! an indexing variable. ! integer nf ! the number of frequencies for which the spectral estimates ! are to be estimated. ! integer nord ! the number of ordinates to be plotted. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! real xord(nf) ! the x ordinates for the spectrum plot. ! real ymax ! the maximum actual spectrum value (in decibels) to be plotted. ! real yord(nf) ! the y ordinates for the spectrum plots. ! real ypltmn, ypltmx ! the minimum and maximum vaues to be plotted for the y axis. ! igferr = 0 call spcck ( gain, isort, nf, gainmn, gainmx, nord, igferr ) if (igferr /= 0) then return end if j = 0 ! ! Set ordinates for decibel plots ! if ( nprt < 1 ) then ymax = 10.0e0 * log10(gainmx) ypltmx = 0.0e0 ypltmn = 10.0e0 * log10(gainmn) - ymax do i = 1, nf if ( gainmn <= gain(i) ) then j = j + 1 xord(j) = freq(i) yord(j) = 10.0e0 * log10(gain(i)) - ymax end if end do ! ! Set ordinates for log plots. ! else ypltmx = gainmx ypltmn = gainmn do i = 1, nf if ( gainmn <= gain(i) ) then j = j + 1 xord(j) = freq(i) yord(j) = gain(i) end if end do end if return end subroutine gfout ( xord, yord, nord, freq, phas, nf, & nterm, sym, xpltmn, xpltmx, ypltmn, ypltmx, nprt, igferr, & nmsub ) !*****************************************************************************80 ! !! GFOUT produces the gain function plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! an error flag. ! real freq(nf) ! the vector of frequencies at which the gain function is to ! be estimated. ! integer ierr ! the error flag. ! integer igferr ! an error flag indicating whether computations seem ! to have produced reasonable results. ! integer ilog ! the variable controlling the plot axis type (log or linear) ! integer isym(1) ! a dummy array for the call to PPMN. ! integer nf ! the number of frequencies for which the gain function estimates ! are to be computed. ! character*1 nmsub(6) ! the name of the calling subroutine. ! integer nord ! the number of ordinates to be plotted. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nterm ! the number of terms in the filter for which the gain ! function was computed. ! real phas(nf) ! the array in which the phase of the filter is returned. ! real pi ! the value of pi. ! logical sym ! an indicator variable used to determine if the filter was ! symmetric or not. ! real xmn, xmx ! ... ! real xord(nord) ! the x coordinates for the gain function plot ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real ymn, ymx ! ... ! real yord(nord) ! the y coordinates for the gain function plot ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! implicit none real & xpltmn,xpltmx,ypltmn,ypltmx integer & igferr,nf,nord,nprt,nterm logical & sym ! ! array arguments real & freq(nf),phas(nf),xord(nord),yord(nord) character & nmsub(6)*1 ! ! scalars in common integer & ierr real & pi,xmn,xmx,ymn,ymx integer & ilog logical & error ! ! local arrays integer & isym(1) ! ! common blocks common /errchk/ierr ! ! set output width. ! call versp(.true.) if (sym) write ( *, 1000) nterm if (.not. sym) write ( *, 1003) nterm if ( igferr /= 0 ) then write ( *, 1004) return end if if (nprt >= 1) then ilog = 1 else ilog = 0 end if ! ! Determine the bounds for the x and y axis and complete the ! error checking. ! call pplmt (yord, yord, xord, xord(1), nord, 1, nord, & ypltmn, ypltmx, ymn, ymx, xpltmn, xpltmx, xmn, xmx, & error, nmsub, .false.) if (error) then ierr = 1 return else call ppmn (yord, yord, xord, xord(1), nord, 1, nord, 0, isym, 1, 0, & 0, ymn, ymx, xmn, xmx, .false., ilog) end if if (xpltmn == 0.0e0 .and. xpltmx == 0.5e0) then write ( *, 1002) end if if ( sym ) then return end if write ( *, 1006) call versp(.true.) ! ! Print phase plot for autoregressive filter. ! call getpi(pi) write ( *, 1005) nterm call pplmt (phas, phas, freq, freq(1), nord, 1, nord, & -pi, pi, ymn, ymx, xpltmn, xpltmx, xmn, xmx, & error, nmsub, .false.) if (error) then ierr = 1 return else call ppmn (phas, phas, freq, freq(1), nord, 1, nord, 0, isym, 1, 0, & 0, ymn, ymx, xmn, xmx, .false., 0) end if if (xpltmn /= 0.0e0 .or. xpltmx /= 0.5e0) then return end if write ( *, 1002) return 1000 format (' gain function of ', i3, ' term symmetric', & ' linear filter') 1002 format('+freq'/ & ' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, '6.6667', 4x, & '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, '2.5', 7x, & '2.2222', 4x, '2.') 1003 format (' gain function of ', i3, ' term autoregressive,', & ' or difference, filter') 1004 format (//' the plot has been supressed because fewer than two'/ & ' non zero gain function values were computed.') 1005 format (' phase function of ', i3, ' term autoregressive,', & ' or difference, filter') 1006 format ('1') end subroutine gfsest ( h, k, nf, freq, gain, delta ) !*****************************************************************************80 ! !! GFSEST: gain function of symmetric linear filter with given frequencies. ! ! Discussion: ! ! This routine computes the gain function of an input symmetric ! linear filter at the frequencies specified in freq using the ! transform algorithm shown on page 311 of jenkins and watts. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Gwilym Jenkins, Donald Watts, ! Spectral Analysis and its Applications, ! Holden-Day 1968. ! ! Parameters: ! ! real c ! a value used to compute the gain function. ! real delta ! the sampling interval of the original series. ! real freq(nf) ! the vector of frequencies at which the gain function is to be ! estimated. ! real gain(nf) ! the array in which the gain function estimates are returned. ! real h(k) ! the symmetric linear filter weights. ! integer i, j ! index variables. ! integer k ! the number of terms in the symmetric linear filter. ! integer khalf, kmid ! half the filter length, and the midpoint of the filter, ! respectively. ! integer nf ! the number of frequencies for which the gain function estimates ! are to be estimated. ! real pi ! the value of pi. ! real v0, v1, v2 ! constants used for computing the gain function estimates. ! implicit none real & delta integer & k,nf ! ! array arguments real & freq(nf),gain(nf),h(k) ! ! real & c,pi,v0,v1,v2 integer & i,j,khalf,kmid ! ! external subroutines external getpi call getpi(pi) ! ! compute gain function estimates and their confidence limits. ! kmid = (k+1) / 2 khalf = kmid - 1 do i = 1, nf c = cos(2.0e0 * pi * freq(i)) v0 = 0.0e0 v1 = 0.0e0 do j = 1, khalf v2 = 2.0e0 * c * v1 - v0 + h(j) v0 = v1 v1 = v2 end do gain(i) = abs(delta * (h(kmid) + 2.0e0 * (v1 * c - v0))) end do return end subroutine gfslf ( h, k ) !*****************************************************************************80 ! !! GFSLF: short call for gain function of symmetric linear filter. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & k ! ! array arguments real & h(*) ! ! scalars in common integer & ierr real & delta,fmax,fmin,ypltmn,ypltmx integer & igferr,nf,nord,nprt logical & err01,err02,err03,head,sym ! ! local arrays real & freq(101),gain(101),xord(101),yord(101) integer & isort(101) character & lh(8)*1,lk(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,eriodd,erslf,gford,gfout,gfsest,setfrq ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the sampling interval. ! logical err01, err02, err03 ! values indicating whether an error was detected (true) or not ! (false). ! real fmax, fmin ! the minimum and maximum frequency for which the gain ! function is to be estimated. ! real freq(101) ! the vector of frequencies at which the gain function ! has been estimated. ! real gain(101) ! the vector in which the gain function estimates are ! stored. ! real h(k) ! the array of symmetric linear filter coefficients. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer igferr ! an error flag indicating whether computations seem ! to have produced reasonable results. ! integer isort(101) ! the array used for sorting. ! integer k ! the number of filter terms. ! character*1 lh(8), lk(8) ! the array containing the name of the variables h and k. ! integer nf ! the number of frequencies at which the gain function ! is to be estimated. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nord ! the number of points to be plotted. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! logical sym ! the variable used to indicate whether the gain function ! computed was for a symmetric or autoregressive filter. ! real xord(101) ! the x coordinates for the gain function plot ! real yord(101) ! the y coordinates for the gain function plot ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'g', 'f', 's', 'l', 'f', ' '/ data & lh(1), lh(2), lh(3), lh(4), lh(5), lh(6), lh(7), lh(8) & / 'h', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. ! ! call error checking routines ! call eisge(nmsub, lk, k, 1, 1, head, err01, lk) call eriodd(nmsub, lk, k, 1, head, err02) if ((.not. err01) .and. (.not. err02)) then call erslf(nmsub, lh, k, h, head, err03) else err03 = .false. end if if (err01 .or. err02 .or. err03) then ierr = 1 write ( *, 1000) return end if sym = .true. nf = 101 fmin = 0.0e0 fmax = 0.5e0 delta = 1.0e0 nprt = -1 ! ! set frequencies at which the gain function is to be estimated ! call setfrq (freq, nf, nprt, fmin, fmax, delta) ! ! compute the gain function ! call gfsest (h, k, nf, freq, gain, delta) ! ! plot the results ! call gford (freq, gain, isort, nf, xord, yord, nord, & ypltmn, ypltmx, nprt, igferr) call gfout (xord, yord, nord, freq, gain, nf, k, & sym, fmin, fmax, ypltmn, ypltmx, nprt, igferr, nmsub) return 1000 format (/' the correct form of the call statement is'// & ' call gfslf (h, k)') end subroutine gfslfs ( h, k, nf, fmin, fmax, gain, freq, nprt, ldstak ) !*****************************************************************************80 ! !! GFSLFS: short call for gain function of symmetric linear filter. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin integer & k,ldstak,nf,nprt ! ! array arguments real & freq(*),gain(*),h(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & delta,fmn,fmx,ypltmn,ypltmx integer & igferr,io,isort,ldsmin,nall0,nord,xord,yord logical & err01,err02,err03,err04,err05,head,sym ! ! local arrays real & rstak(12) integer & istak(12) character & lh(8)*1,lk(8)*1,llds(8)*1,lnf(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external eisge,eriodd,erslf,gford,gfout,gfsest,ldscmp, & setfrq,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03, err04, err05 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real fmax, fmin ! the minimum and maximum frequency for which the gain ! function is to be estimated. ! real fmn, fmx ! the frequency range actually used. ! real freq(nf) ! the vector of frequencies at which the gain function ! has been estimated. ! real gain(nf) ! the vector in which the gain function estimates are ! stored. ! real h(k) ! the array of symmetric linear filter coefficients. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer igferr ! an error flag indicating whether computations seem ! to have produced reasonable results. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output. ! integer isort ! the starting location in istak for ! the array used for sorting. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer k ! the number of filter terms. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 lh(8), lk(8), llds(8), lnf(8) ! the arrays containing the names of the checked variables ! integer nall0 ! the number of outstanding stack allocations. ! integer nf ! the number of frequencies at which the gain function ! is to be estimated. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nord ! the number of points to be plotted. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! real rstak(12) ! the real version of the /cstak/ work area. ! logical sym ! the variable used to indicate whether the gain function ! computed was for a symmetric or autoregressive filter. ! integer xord ! the starting location in rstak/dstak of ! the x coordinates for the gain function plot ! integer yord ! the starting location in rstak/dstak of ! the y coordinates for the gain function plot ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'g', 'f', 's', 'l', 'f', 's'/ data & lh(1), lh(2), lh(3), lh(4), lh(5), lh(6), lh(7), lh(8) & / 'h', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), & lk(7), lk(8) /'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), llds(7), & llds(8) / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data & lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), lnf(6), lnf(7), lnf(8) & / 'n', 'f', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. io = 1 if (nprt == 0) io = 0 ! ! call error checking routines ! call eisge(nmsub, lk, k, 1, 1, head, err01, lk) call eriodd(nmsub, lk, k, 1, head, err02) err03 = .true. if ((.not. err01) .and. (.not. err02)) & call erslf(nmsub, lh, k, h, head, err03) call eisge(nmsub, lnf, nf, 1, 1, head, err04, lnf) if (err04) then ierr = 1 write ( *, 1000) return end if call ldscmp(3*io, 0, io*nf, 0, 0, 0, 's', 2*io*nf, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err05, llds) if (err01 .or. err02 .or. err03 .or. err05) then ierr = 1 write ( *, 1000) return end if if (nprt /= 0) then call stkset (ldstak, 4) nall0 = stkst(1) else nall0 = 0 end if sym = .true. delta = 1.0e0 ! ! set frequencies at which the gain function is to be estimated ! fmn = max(fmin, 0.0e0) fmx = min(fmax, 0.5e0) if (fmn >= fmx) then fmn = 0.0e0 fmx = 0.5e0 end if call setfrq (freq, nf, 2, fmn, fmx, delta) ! ! compute the gain function ! call gfsest (h, k, nf, freq, gain, delta) if (nprt == 0) return ! ! set various pointers for the plotting arrays ! xord = stkget(nf, 3) yord = stkget(nf, 3) isort = stkget(nf, 2) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if ! ! plot the results ! call gford (freq, gain, istak(isort), nf, rstak(xord), & rstak(yord), nord, ypltmn, ypltmx, nprt, igferr) call gfout (rstak(xord), rstak(yord), nord, freq, gain, nf, k, & sym, fmn, fmx, ypltmn, ypltmx, nprt, igferr, nmsub) call stkclr(nall0) if (ierr == 1) then ierr = 1 write ( *, 1000) return end if return 1000 format (/' the correct form of the call statement is'// & ' call gfslfs (h, k, nf, fmin, fmax, gain, freq, nprt,', & ' ldstak)') end subroutine gmean ( y, n, ymean ) !*****************************************************************************80 ! !! GMEAN computes the geometric mean of a series. ! ! Discussion: ! ! The series values must be nonzero. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer n ! the number of observations in the series ! real y(n) ! the vector containing the observed series ! real ymean ! the geometric mean of the observed series ! implicit none integer n real ymean real y(n) ymean = sum ( log ( y(1:n) ) ) ymean = exp ( ymean / real ( n ) ) return end subroutine gqtstp ( d, dig, dihdi, ka, l, p, step, v, w ) !*********************************************************************** ! !! GQTSTP computes the Goldfeld-Quandt-Trotter step by More-Hebden technique. ! ! Discussion: ! ! Given the compactly stored lower triangle of a scaled ! hessian approximation and a nonzero scaled gradient vector, ! this routine computes a Goldfeld-Quandt-Trotter step of ! approximate length V(RADIUS) by the More-Hebden technique. ! ! In other words, STEP is computed to approximately minimize ! PSI(STEP) = G' * STEP + 0.5 * STEP' * H * STEP ! such that the 2-norm of D * STEP is at most approximately V(RADIUS), ! where G is the gradient, H is the hessian, and D is a diagonal ! scale matrix whose diagonal is stored in the parameter D. ! ! GQTSTP assumes: ! ! DIG = inverse ( D ) * G, ! DIHDI = inverse ( D ) * H * inverse ( D ). ! ! If G = 0, however, STEP = 0 is returned, even at a saddle point. ! ! If it is desired to recompute STEP using a different value of ! V(RADIUS), then this routine may be restarted by calling it ! with all parameters unchanged except V(RADIUS). This explains ! why STEP and W are listed as I/O. On an initial call, with ! KA < 0, STEP and W need not be initialized and only components ! V(EPSLON), V(STPPAR), V(PHMNFC), V(PHMXFC), V(RADIUS), and ! V(RAD0) of V must be initialized. To compute STEP from a saddle ! point, where the true gradient vanishes and H has a negative ! eigenvalue, a nonzero G with small components should be passed. ! ! This routine is called as part of the NL2SOL package, but it could ! be used in solving any unconstrained minimization problem. ! ! The desired G-Q-T step (references 2, 3, 4) satisfies ! (H + ALPHA*D**2) * STEP = -G for some nonnegative ALPHA such that ! H + ALPHA*D**2 is positive semidefinite. ALPHA and STEP are ! computed by a scheme analogous to the one described in reference 5. ! Estimates of the smallest and largest eigenvalues of the hessian ! are obtained from the Gerschgorin circle theorem enhanced by a ! simple form of the scaling described in reference 6. ! ! Cases in which H + ALPHA*D**2 is nearly or exactly singular are ! handled by the technique discussed in reference 2. In these ! cases, a step of exact length V(RADIUS) is returned for which ! PSI(STEP) exceeds its optimal value by less than ! -V(EPSLON)*PSI(STEP). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! Algorithm 573: ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! ! David Gay, ! Computing Optimal Locally Constrained Steps, ! SIAM Journal on Scientific and Statistical Computing, ! Volume 2, Number 2, pages 186-197, 1981. ! ! Steven Goldfeld, Richard Quandt, Hale Trotter, ! Maximization by Quadratic Hill-climbing, ! Econometrica, ! Volume 34, pages 541-551, 1966. ! ! MD Hebden, ! An Algorithm for Minimization using Exact Second Derivatives, ! Tehcnical Report TP515, ! Theoretical Physics Division, ! AERE, Harwell, Oxon., England, 1973. ! ! Jorge More, ! The Levenberg-Marquardt Algorithm, Implementation and Theory, ! in Springer Lecture Notes in Mathematics, Number 630, ! edited by G A Watson, ! Springer, 1978. ! ! Richard Varga, ! Minimal Gerschgorin Sets, ! Pacific Journal of Mathematics, ! Volume 15, pages 719-729, 1965. ! ! Parameters: ! ! Input, real D(P), the scale vector, that is, the diagonal of the scale ! matrix D mentioned above. ! ! Input, real DIG(P), the scaled gradient vector, inverse ( D ) * G. ! If G = 0, then STEP = 0 and V(STPPAR) = 0 are returned. ! ! Input, real DIHDI((P*(P+1))/2), the lower triangle of the scaled ! hessian approximation, that is, ! inverse ( D ) * H * inverse ( D ), ! stored compactly by rows, in the order (1,1), (2,1), (2,2), (3,1), ! (3,2), and so on. ! ! Input/output, integer KA, the number of Hebden iterations taken so ! far to determine STEP. KA < 0 on input means this is the first ! attempt to determine STEP for the present DIG and DIHDI. ! KA is initialized to 0 in this case. Output with KA = 0 or ! V(STPPAR) = 0 means STEP = -inverse(H)*G. ! ! l (i/o) = workspace of length p*(p+1)/2 for cholesky factors. ! ! p (in) = number of parameters -- the hessian is a p x p matrix. ! ! step (i/o) = the step computed. ! ! v (i/o) contains various constants and variables described below. ! ! w (i/o) = workspace of length 4*p + 6. ! ! entries in v ! ! v(dgnorm) (i/o) = 2-norm of (d**-1)*g. ! v(dstnrm) (output) = 2-norm of d * step. ! v(dst0) (i/o) = 2-norm of d*(h**-1)*g (for pos. def. h only), or ! overestimate of smallest eigenvalue of (d**-1)*h*(d**-1). ! v(epslon) (in) = max. relative error allowed for psi(step). for the ! step returned, psi(step) will exceed its optimal value ! by less than -v(epslon)*psi(step). suggested value = 0.1. ! v(gtstep) (out) = inner product between g and step. ! v(nreduc) (out) = psi(-(h**-1)*g) = psi(Newton step) (for pos. def. ! h only -- v(nreduc) is set to zero otherwise). ! v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step ! (More's sigma). the error v(dstnrm) - v(radius) must lie ! between v(phmnfc)*v(radius) and v(phmxfc)*v(radius). ! v(phmxfc) (in) (see v(phmnfc).) ! suggested values -- v(phmnfc) = -0.25, v(phmxfc) = 0.5. ! v(preduc) (out) = psi(step) = predicted obj. func. reduction for step. ! v(radius) (in) = radius of current (scaled) trust region. ! v(rad0) (i/o) = value of v(radius) from previous call. ! v(STPPAR) (i/o) is normally the Marquardt parameter, i.e. the alpha ! described below under algorithm notes. if h + alpha*d**2 ! (see algorithm notes) is (nearly) singular, however, ! then v(STPPAR) = -alpha. ! implicit none integer p real aki real akk real alphak real d(p) real delta integer dggdmx integer, parameter :: dgnorm = 1 real, save :: dgxfac = 0.0E+00 integer diag integer diag0 real dig(p) real dihdi((p*(p+1))/2) real dotprd real dst integer, parameter :: dst0 = 3 integer, parameter :: dstnrm = 2 integer dstsav integer emax integer emin real, parameter :: epsfac = 50.0E+00 integer, parameter :: epslon = 19 real epso6 integer, parameter :: gtstep = 4 integer i integer inc integer irc integer j integer k integer k1 integer ka integer kalim real, parameter :: kappa = 2.0E+00 real l((p*(p+1))/2) real lk integer lk0 real lsvmin integer, parameter :: nreduc = 6 real oldphi real phi real phimax real phimin integer phipin integer, parameter :: phmnfc = 20 integer, parameter :: phmxfc = 21 integer, parameter :: preduc = 7 real psifac integer q integer q0 real rad integer, parameter :: rad0 = 9 integer, parameter :: radius = 8 logical restrt real root real si real sk real step(p) integer, parameter :: stppar = 5 real sw real t real t1 real twopsi real uk integer uk0 real v(21) real v2norm real w(4*p+7) real wi integer x integer x0 ! ! Store largest absolute entry in inverse(D)*H*inverse(D) at W(DGGDMX). ! dggdmx = p + 1 ! ! Store Gerschgorin over- and underestimates of the largest ! and smallest eigenvalues of inverse(D)*H*inverse(D) at W(EMAX) ! and W(EMIN) respectively. ! emax = dggdmx + 1 emin = emax + 1 ! ! For use in recomputing step, the final values of LK, UK, DST, ! and the inverse derivative of More's PHI at 0, for positive definite ! H, are stored in W(LK0), W(UK0), W(DSTSAV), and W(PHIPIN) ! respectively. ! lk0 = emin + 1 phipin = lk0 + 1 uk0 = phipin + 1 dstsav = uk0 + 1 ! ! Store diagonal of inverse(D)*H*inverse(D) in W(DIAG:DIAG+P-1). ! diag0 = dstsav diag = diag0 + 1 ! ! Store -D * STEP in W(Q:Q+P-1). ! q0 = diag0 + p q = q0 + 1 rad = v(radius) ! ! PHITOL = maximum error allowed in DST = V(DSTNRM) = 2-norm of ! D * STEP. ! phimax = v(phmxfc) * rad phimin = v(phmnfc) * rad ! ! EPSO6 and PSIFAC are used in checking for the special case ! of nearly singular H + ALPHA*D**2. See reference 2. ! psifac = 2.0E+00 * v(epslon) & / ( 3.0E+00 * ( 4.0E+00 * ( v(phmnfc) + 1.0E+00 ) * & ( kappa + 1.0E+00 ) + kappa + 2.0E+00 ) * rad**2 ) ! ! OLDPHI is used to detect limits of numerical accuracy. If ! we recompute step and it does not change, then we accept it. ! oldphi = 0.0E+00 epso6 = v(epslon) / 6.0E+00 irc = 0 restrt = .false. kalim = ka + 50 ! ! Start or restart, depending on KA. ! if ( 0 <= ka ) then ! ! Restart with new radius. ! ! Prepare to return Newton step. ! if ( 0.0E+00 < v(dst0) .and. v(dst0) - rad <= phimax ) then restrt = .true. ka = ka + 1 k = 0 do i = 1, p k = k + i j = diag0 + i dihdi(k) = w(j) end do uk = -1.0E+00 go to 40 end if if ( ka == 0 ) then go to 60 end if dst = w(dstsav) alphak = abs ( v(stppar) ) phi = dst - rad t = v(dgnorm) / rad ! ! Smaller radius. ! if ( rad <= v(rad0) ) then uk = t - w(emin) lk = 0.0E+00 if ( 0.0E+00 < alphak ) then lk = w(lk0) end if lk = max ( lk, t - w(emax) ) if ( 0.0E+00 < v(dst0) ) then lk = max ( lk, ( v(dst0) - rad ) * w(phipin) ) end if ! ! Bigger radius. ! else uk = t - w(emin) if ( 0.0E+00 < alphak ) then uk = min ( uk, w(uk0) ) end if lk = max ( 0.0E+00, -v(dst0), t - w(emax) ) if ( 0.0E+00 < v(dst0) ) then lk = max ( lk, (v(dst0)-rad)*w(phipin) ) end if end if go to 260 end if ! ! Fresh start. ! k = 0 uk = -1.0E+00 ka = 0 kalim = 50 ! ! Store diagonal of DIHDI in W(DIAG0+1:DIAG0+P). ! j = 0 do i = 1, p j = j + i k1 = diag0 + i w(k1) = dihdi(j) end do ! ! Determine W(DGGDMX), the largest element of DIHDI. ! t1 = 0.0E+00 j = p * (p + 1) / 2 do i = 1, j t = abs(dihdi(i)) t1 = max ( t1, t ) end do w(dggdmx) = t1 ! ! Try ALPHA = 0. ! 40 continue call lsqrt ( 1, p, l, dihdi, irc ) ! ! Indefinite H. Underestimate smallest eigenvalue, use this ! estimate to initialize lower bound LK on ALPHA. ! if ( irc == 0 ) then go to 60 end if j = ( irc * ( irc + 1 ) ) / 2 t = l(j) l(j) = 1.0E+00 w(1:irc) = 0.0E+00 w(irc) = 1.0E+00 call litvmu ( irc, w, l, w ) t1 = v2norm ( irc, w ) lk = -t / t1 / t1 v(dst0) = -lk if ( restrt ) then go to 210 end if v(nreduc) = 0.0E+00 go to 70 ! ! Positive definite H. Compute unmodified Newton step. ! 60 continue lk = 0.0E+00 call livmul ( p, w(q), l, dig ) v(nreduc) = 0.5E+00 * dotprd ( p, w(q), w(q) ) call litvmu ( p, w(q), l, w(q) ) dst = v2norm ( p, w(q) ) v(dst0) = dst phi = dst - rad if ( phi <= phimax ) then alphak = 0.0E+00 go to 290 end if if ( restrt ) then go to 210 end if ! ! Prepare to compute Gerschgorin estimates of largest and ! smallest eigenvalues. ! 70 continue v(dgnorm) = v2norm ( p, dig ) if ( v(dgnorm) == 0.0E+00 ) then v(stppar) = 0.0E+00 v(preduc) = 0.0E+00 v(dstnrm) = 0.0E+00 v(gtstep) = 0.0E+00 step(1:p) = 0.0E+00 return end if k = 0 do i = 1, p wi = 0.0E+00 do j = 1, i - 1 k = k + 1 t = abs ( dihdi(k) ) wi = wi + t w(j) = w(j) + t end do w(i) = wi k = k + 1 end do ! ! Underestimate smallest eigenvalue of inverse(D)*H*inverse(D). ! k = 1 t1 = w(diag) - w(1) do i = 2, p j = diag0 + i t = w(j) - w(i) if ( t < t1 ) then t1 = t k = i end if end do sk = w(k) j = diag0 + k akk = w(j) k1 = ( k * ( k - 1 ) ) / 2 + 1 inc = 1 t = 0.0E+00 do i = 1, p if ( i == k ) then inc = i k1 = k1 + inc else aki = abs(dihdi(k1)) si = w(i) j = diag0 + i t1 = 0.5E+00 * (akk - w(j) + si - aki) t1 = t1 + sqrt(t1*t1 + sk*aki) t = max ( t, t1 ) if ( k <= i ) then inc = i end if k1 = k1 + inc end if end do w(emin) = akk - t uk = v(dgnorm) / rad - w(emin) ! ! Compute Gerschgorin overestimate of largest eigenvalue. ! k = 1 t1 = w(diag) + w(1) do i = 2, p j = diag0 + i t = w(j) + w(i) if ( t1 < t ) then t1 = t k = i end if end do sk = w(k) j = diag0 + k akk = w(j) k1 = ( k * ( k - 1 ) ) / 2 + 1 inc = 1 t = 0.0E+00 do i = 1, p if ( i == k ) then inc = i k1 = k1 + inc else aki = abs ( dihdi(k1) ) si = w(i) j = diag0 + i t1 = 0.5E+00 * ( w(j) + si - aki - akk ) t1 = t1 + sqrt ( t1 * t1 + sk * aki ) t = max ( t, t1 ) if ( k <= i ) then inc = i end if k1 = k1 + inc end if end do w(emax) = akk + t lk = max ( lk, v(dgnorm) / rad - w(emax) ) ! ! ALPHAK = current value of ALPHA. We ! use More's scheme for initializing it. ! alphak = abs ( v(stppar) ) * v(rad0) / rad ! ! Compute L0 for positive definite H. ! if ( irc == 0 ) then call livmul ( p, w, l, w(q) ) t = v2norm ( p, w ) w(phipin) = dst / t / t lk = max ( lk, phi * w(phipin) ) end if ! ! Safeguard ALPHAK and add ALPHAK*IDENTITY to inverse(D)*H*inverse(D). ! 210 continue ka = ka + 1 if ( alphak <= -v(dst0) .or. alphak < lk .or. uk <= alphak ) then alphak = uk * max ( 0.001E+00, sqrt ( lk / uk ) ) end if k = 0 do i = 1, p k = k + i j = diag0 + i dihdi(k) = w(j) + alphak end do ! ! Try computing Cholesky decomposition. ! call lsqrt ( 1, p, l, dihdi, irc ) ! ! inverse(D)*H*inverse(D) + ALPHAK*IDENTITY is indefinite. Overestimate ! smallest eigenvalue for use in updating LK. ! if ( irc /= 0 ) then j = ( irc * ( irc + 1 ) ) / 2 t = l(j) l(j) = 1.0E+00 w(1:irc) = 0.0E+00 w(irc) = 1.0E+00 call litvmu ( irc, w, l, w ) t1 = v2norm ( irc, w ) lk = alphak - t / t1 / t1 v(dst0) = -lk go to 210 end if ! ! ALPHAK makes inverse(D)*H*inverse(D) positive definite. ! Compute Q = -D * STEP, check for convergence. ! call livmul ( p, w(q), l, dig ) call litvmu ( p, w(q), l, w(q) ) dst = v2norm ( p, w(q) ) phi = dst - rad if ( phi <= phimax .and. phimin <= phi ) then go to 290 end if if ( phi == oldphi ) then go to 290 end if oldphi = phi if ( 0.0E+00 < phi ) then go to 260 end if ! ! Check for the special case of H + ALPHA*D**2 (nearly) ! singular. delta is >= the smallest eigenvalue of ! inverse(D)*H*inverse(D) + ALPHAK*IDENTITY. ! if ( 0.0E+00 < v(dst0) ) then go to 260 end if delta = alphak + v(dst0) twopsi = alphak * dst * dst + dotprd ( p, dig, w(q) ) if ( delta < psifac * twopsi ) then go to 270 end if ! ! Unacceptable ALPHAK. Update LK, UK, ALPHAK. ! 260 continue if ( kalim <= ka ) then go to 290 end if call livmul ( p, w, l, w(q) ) t1 = v2norm ( p, w ) ! ! The following min is necessary because of restarts. ! if ( phi < 0.0E+00 ) then uk = min ( uk, alphak ) end if alphak = alphak + ( phi / t1 ) * ( dst / t1 ) * ( dst / rad ) lk = max ( lk, alphak ) go to 210 ! ! Decide how to handle nearly singular H + ALPHA*D**2. ! ! If not yet available, obtain machine dependent value dgxfac. ! 270 continue if ( dgxfac == 0.0E+00 ) then dgxfac = epsfac * epsilon ( dgxfac ) end if ! ! Is DELTA so small we cannot handle the special case in ! the available arithmetic? If so, accept STEP as it is. ! if ( dgxfac * w(dggdmx) < delta ) then ! ! Handle nearly singular H + ALPHA*D**2. ! Negate ALPHAK to indicate special case. ! alphak = -alphak ! ! Allocate storage for scratch vector X. ! x0 = q0 + p x = x0 + 1 ! ! Use inverse power method with start from LSVMIN to obtain ! approximate eigenvector corresponding to smallest eigenvalue ! of inverse ( D ) * H * inverse ( D ). ! delta = kappa * delta t = lsvmin ( p, l, w(x), w ) k = 0 ! ! Normalize W. ! do w(1:p) = t * w(1:p) ! ! Complete current inverse power iteration. ! Replace W by inverse ( L' ) * W. ! call litvmu ( p, w, l, w ) t1 = 1.0E+00 / v2norm ( p, w ) t = t1 * t if ( t <= delta ) then exit end if if ( 30 < k ) then go to 290 end if k = k + 1 ! ! Start next inverse power iteration by storing normalized W in X. ! do i = 1, p j = x0 + i w(j) = t1 * w(i) end do ! ! Compute W = inverse ( L ) * X. ! call livmul ( p, w, l, w(x) ) t = 1.0E+00 / v2norm ( p, w ) end do w(1:p) = t1 * w(1:p) ! ! Now W is the desired approximate unit eigenvector and ! T * X = ( inverse(D) * H * inverse(D) + ALPHAK * I ) * W. ! sw = dotprd ( p, w(q), w ) t1 = ( rad + dst ) * ( rad - dst ) root = sqrt ( sw * sw + t1 ) if ( sw < 0.0E+00 ) then root = -root end if si = t1 / (sw + root) ! ! Accept current step if adding SI * W would lead to a ! further relative reduction in PSI of less than V(EPSLON) / 3. ! v(preduc) = 0.5E+00 * twopsi t1 = 0.0E+00 t = si * ( alphak * sw & - 0.5E+00 * si * ( alphak + t * dotprd ( p, w(x), w ) ) ) if ( epso6 * twopsi <= t ) then v(preduc) = v(preduc) + t dst = rad t1 = -si end if do i = 1, p j = q0 + i w(j) = t1 * w(i) - w(j) step(i) = w(j) / d(i) end do v(gtstep) = dotprd ( p, dig, w(q) ) ! ! Save values for use in a possible restart. ! v(dstnrm) = dst v(stppar) = alphak w(lk0) = lk w(uk0) = uk v(rad0) = rad w(dstsav) = dst ! ! Restore diagonal of DIHDI. ! j = 0 do i = 1, p j = j + i k = diag0 + i dihdi(j) = w(k) end do return end if ! ! Successful step. Compute STEP = - inverse ( D ) * Q. ! 290 continue do i = 1, p j = q0 + i step(i) = -w(j) / d(i) end do v(gtstep) = -dotprd ( p, dig, w(q) ) v(preduc) = 0.5E+00 * ( abs ( alphak ) *dst*dst - v(gtstep)) ! ! Save values for use in a possible restart. ! v(dstnrm) = dst v(stppar) = alphak w(lk0) = lk w(uk0) = uk v(rad0) = rad w(dstsav) = dst ! ! Restore diagonal of DIHDI. ! j = 0 do i = 1, p j = j + i k = diag0 + i dihdi(j) = w(k) end do return end subroutine hipass ( y, n, fc, k, hhp, yf, nyf ) !*****************************************************************************80 ! !! HIPASS carries out a high-pass filtering of a series. ! ! Discussion: ! ! This routine carries out hi-pass filtering of the ! series. the filter is the k-term ! least squares approximation to the cutoff filter ! with cutof frequency fc. its transfer function ! has a transition band of width delta surrounding fc, ! where delta = 4*pi/k. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical err01, err02, err03, err04, err05 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real fc ! the user supplied cutoff frequency. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! real hhp(k) ! the array in which the -ideal- high pass filter coefficients ! will be returned. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer k ! the number of filter terms to be computed. ! character*1 lfc(8), lk(8), ln(8) ! the arrays containing the names of the variables fc, k and n. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this routine. ! integer nyf ! the number of observations in the filtered series yf. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! implicit none real fc integer k integer n integer nyf ! ! array arguments real & hhp(*),y(*),yf(*) ! ! scalars in common integer & ierr logical & err01,err02,err03,err04,err05,head ! ! local arrays character & lfc(8)*1,lk(8)*1,ln(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,eisii,eriodd,ersii,erslfs,fltsl,hpflt,lpflt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'h', 'i', 'p', 'a', 's', 's'/ data & lfc(1), lfc(2), lfc(3), lfc(4), lfc(5), lfc(6), lfc(7), lfc(8) & / 'f', 'c', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. ! ! call error checking routines ! call eisge(nmsub, ln, n, 3, 1, head, err01, ln) call ersii(nmsub, lfc, fc, 0.0e0, & 0.5e0, 2, head, err02, lfc, lfc) call eisii(nmsub, lk, k, 1, n, 2, head, err03, lk, lk) call eriodd(nmsub, lk, k, 1, head, err04) if ( err01 .or. err02 .or. err03 .or. err04 ) then ierr = 1 write ( *, 1000) return end if call erslfs(nmsub, fc, k, head, err05) if ( err05 ) then ierr = 1 write ( *, 1000) return end if call lpflt (fc, k, hhp) call hpflt (hhp, k, hhp) call fltsl (y, n, k, hhp, yf, nyf) return 1000 format (/' the correct form of the call statement is'// & ' call hipass (y, n, fc, k, hhp, yf, nyf)') end subroutine histc ( y, n, ncell, ylb, yub, ldstak ) !*****************************************************************************80 ! !! HISTC: long call for producing a histogram. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idp ! the code value for double precision for framework. ! integer ierr ! the code indicating whether or not an error has ! been discovered. 0 means no error, not 0 means ! some error exists. ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer iint ! the code value for integer for framework ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! input parameter. the number of double precision ! elements dimensioned for dstak in the user program. ! integer lsort ! the starting location in istak of the permutation ! vector. ! integer n ! input parameter. the length of y. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! integer ncell ! the user supplied value for the number of cells in the ! histogram. if ncell is less than or equal to zero, the ! number of cells to be used (ncells) will be calculated from ! the number of observations. ! integer ncells ! the number of cells in the histogram. ! character*1 nmsub(6) ! the array containing the name of this routine. ! real rstak(12) ! the real version of the /cstak/ work area. ! real y(n) ! input parameter. the vector of data points on which ! the statistics are computed. y is sorted, but restored ! to its original order afterwards. ! integer ydist ! the starting location in rstak of the distribution vector. ! real ylb ! the lower bound for selecting data from y for the histogram. ! real yub ! the upper bound for selecting data from y for the histogram. ! implicit none real & ylb,yub integer & ldstak,n,ncell ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer & idp,ifp,iint,lsort,nall0,ncells,ydist ! ! local arrays real & rstak(12) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external hster,hstmn,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) ! ! initialize name vectors ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'h', 'i', 's', 't', 'c', ' '/ data idp /4/ data iint /2/ ! ! compute ncells ! if ((ncell <= 0) .and. (n >= 1)) then ncells = min(nint(5.5e0+1.5e0*anint(log10(real(n)))),25) else ncells = ncell end if ! ! check for errors in the input parameters ! call hster(nmsub, y, n, ncells, ldstak, ylb, yub, ierr) ! ! print error message. ! if (ierr /= 0) then write ( *,1000) return end if ! ! set up framework area. ! call stkset (ldstak, idp) nall0 = stkst(1) ! ! set up work vectors ! ifp = 3 lsort = stkget(n,iint) ydist = stkget(ncells,ifp) ! ! compute the histogram. ! call hstmn(y, n, ncells, ylb, yub, istak(lsort), rstak(ydist)) ! ! return the work vectors. ! call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call histc (y, n, ncell, ylb, yub, ldstak)') end subroutine hist ( y, n, ldstak ) !*****************************************************************************80 ! !! HIST: short call for producing a histogram. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idp ! the code value for double precision for framework. ! integer ierr ! the code indicating whether or not an error has ! been discovered. 0 means no error, not 0 means ! some error exists. ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer iint ! the code value for integer for framework ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! input parameter. the number of double precision ! elements dimensioned for dstak in the user program. ! integer lsort ! the starting location in istak of the permutation ! vector. ! integer n ! input parameter. the length of y. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! integer ncells ! the number of cells in the histogram. ! character*1 nmsub(6) ! the array containing the name of this routine. ! real rstak(12) ! the real version of the /cstak/ work area. ! real y(n) ! input parameter. the vector of data points on which ! the statistics are computed. y is sorted, but restored ! to its original order afterwards. ! integer ydist ! the starting location in rstak of the distribution vector. ! real ylb ! the lower bound for selecting data from y for the histogram. ! real yub ! the upper bound for selecting data from y for the histogram. ! implicit none integer & ldstak,n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & ylb,yub integer & idp,ifp,iint,lsort,nall0,ncells,ydist ! ! local arrays real & rstak(12) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external hster,hstmn,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) ! ! initialize name vectors ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'h', 'i', 's', 't', ' ', ' '/ data idp /4/ data iint /2/ data ylb/0.0e0/, yub/0.0e0/ ! ! compute ncells ! if (n >= 1) then ncells = min(nint(5.5e0+1.5e0*anint(log10(real(n)))),25) else ncells = 1 end if ! ! check for errors in the input parameters ! call hster(nmsub, y, n, ncells, ldstak, ylb, yub, ierr) ! ! print error message. ! if (ierr /= 0) then write ( *,1000) return end if ! ! set up framework area. ! call stkset (ldstak, idp) nall0 = stkst(1) ! ! set up work vectors ! ifp = 3 lsort = stkget(n,iint) ydist = stkget(ncells,ifp) ! ! compute the histogram. ! call hstmn(y, n, ncells, ylb, yub, istak(lsort), rstak(ydist)) ! ! return the work vectors. ! call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call hist (y, n, ldstak)') end subroutine hpcoef ( hlp, k, hhp ) !*****************************************************************************80 ! !! HPCOEF computes hi-pass filter given K-term low pass filter coefficients. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! real hhp(k) ! the array in which the high pass filter coefficients ! will be returned. ! real hlp(k) ! the array in which the input low pass filter coefficients ! are stored. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer k ! the number of filter terms to be computed. ! character*1 lhlp(8), lk(8) ! the arrays containing the names of the variables hlp and k. ! character*1 nmsub(6) ! the array containing the name of this routine. implicit none integer & k ! ! array arguments real & hhp(*),hlp(*) ! ! scalars in common integer & ierr logical & err01,err02,err03,head ! ! local arrays character & lhlp(8)*1,lk(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,eriodd,erslf,hpflt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'h', 'p', 'c', 'o', 'e', 'f'/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lhlp(1), lhlp(2), lhlp(3), lhlp(4), lhlp(5), lhlp(6), lhlp(7), & lhlp(8) & / 'h', 'l', 'p', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, lk, k, 1, 1, head, err01, lk) call eriodd(nmsub, lk, k, 1, head, err02) if (err01 .or. err02) then ierr = 1 write ( *, 1000) return end if call erslf(nmsub, lhlp, k, hlp, head, err03) if (err03) then ierr = 1 write ( *, 1000) return end if call hpflt (hlp, k, hhp) return 1000 format (/' the correct form of the call statement is'// & ' call hpcoef (hlp, k, hhp)') end subroutine hpflt ( hlp, k, hhp ) !*****************************************************************************80 ! !! HPFLT compute high pass filter coefficients corresponding to low pass filter. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real hhp(k) ! the array in which the high pass filter coefficients ! will be returned. ! real hlp(k) ! the array in which the input low pass filter coefficients ! are stored. ! integer i ! an index variable. ! integer k ! the number of filter terms to be computed. ! integer kmid ! the midpoint of the filter. ! implicit none integer & k ! ! array arguments real & hhp(k),hlp(k) integer kmid hhp(1:k) = -hlp(1:k) kmid = (k + 1) / 2 hhp(kmid) = hhp(kmid) + 1.0e0 return end subroutine hster ( nmsub, y, n, ncells, ldstak, ylb, yub, ierr ) !*****************************************************************************80 ! !! HSTER does error checking for the HIST family of histogram routines. ! ! Discussion: ! ! This routine checks input parameters to the user ! callable members of the hist family of routines ! for errors and reports any that it finds, besides ! returning a flag indicating that errors have been found. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! output parameter. a flag indicating whether or ! not an error has been found. 0 = ok, 1 = error. ! logical ier1 ! true if n < 3 ! logical ier2 ! true if ldstak < (n + 13)/2. ! logical ier3 ! true if all y values are equal. ! logical ier4 ! true if no data within user limits ! integer ldsmin ! minimum length of framework area in double ! precision elements. ! integer ldstak ! input parameter. the number of locations provided in ! the framework area. ! character*1 llds(8), ln(8), lone(8), ly(8) ! the array(s) containing the name(s) fo the varialbe(s) checked ! for errors ! integer n ! input parameter. the number of elements in y. ! integer ncells ! the number of cells in the histogram. ! character*1 nmsub(6) ! the name of the calling subroutine ! integer nv ! the number of values outside user supplied limits. ! real y(n) ! input parameter. the vector of n observations. ! real ylb ! the lower bound for selecting data from y for the histogram. ! real yub ! the upper bound for selecting data from y for the histogram. ! implicit none logical head logical ier1 logical ier2 logical ier4 integer ierr integer ldstak integer n integer ncells character nmsub(6) real y(*) real ylb real yub ! ! integer & ldsmin,nv ! ! local arrays character & llds(8)*1,ln(8)*1,lone(8)*1,ly(8)*1 ! ! external subroutines external eisge,ldscmp ! ! initialize name vectors ! data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), & ln(7), ln(8) /'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), & lone(7), lone(8) /'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ data ly(1), ly(2), ly(3), ly(4), ly(5), ly(6), & ly(7), ly(8) /'y', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ier1 = .false. ier2 = .false. ier4 = .false. ierr = 0 head = .true. ! ! check to see that there is at least one data points. ! call eisge ( nmsub, ln, n, 1, 2, head, ier1, lone ) if ( ier1 ) then ierr = 1 return end if ! ! check for sufficient work area ! call ldscmp(2, 0, n, 0, 0, 0, 's', ncells, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, ier2, llds) if ( ier2 ) then ierr = 1 return end if ! ! Is any data between user supplied limits? ! if ( ylb < yub .and. 1 <= n ) then call ervii ( nmsub, ly, y, n, ylb, yub, n-1, head, 1, nv, ier4 ) if ( ier4 ) then ierr = 1 end if end if return end subroutine hstmn ( y, n, ncells, ylb, yub, lsort, ydist ) !*****************************************************************************80 ! !! HSTMN is the main routine for producing histograms. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real a(6) ! a vector used for printing the histogram scale. ! real alpha ! the percentage to be trimmed off each end of y for the ! trimmed means calculations. ! real b1sqrt ! beta one - a measure of skewness ! real b2 ! beta two - a measure of kurtosis ! real cfract ! the cumulative distribution ! real cfrctm ! the reverse cumulative distribution ! real cntmx ! the size of the largest cell count ! real fract ! the fraction of the observations in a given cell ! integer iflag ! if 1, then more than 50 obs. fell in a single cell, ! and a scaled histogram will be provided. ! character*1 iplus ! the character + ! integer lsort(n) ! the permutation vector. ! integer mid ! the index of the (an) element of y closest to zero, when ! y has been sorted. ! integer n ! input parameter. the length of y. ! integer ncells ! the number of cells in the frequency distribution. ! integer nhigh ! the index of the largest value in the sorted array ! to be used in the histogram ! integer nlow ! the index of the smallest value in the sorted array ! to be used in the histogram ! integer nobs ! the number of observations actually used in the histogram ! integer num ! the cell count ! integer nums ! the scaled cell count ! real p ! a variable used to determine the scale ! real scale ! the printed increment on the histogram scale ! real sumda ! the sum of the absolute differences from the mean. ! real sumd2 ! the sum of the squares of the differences. ! real sumd3 ! the sum of the cubes of the differences. ! real sumd4 ! the sum of the 4th powers of the differences. ! real sumt1 ! the sum of the alpha trimmed array y. ! real sum1, sum2, sum3 ! various sums of the data. ! real temp ! a temporary storage variable ! real width ! the width of a cell ! real xn ! the foating point representation of n ! real xnn ! the unrounded number of plotting posistions on a scales ! histogram ! real y(n) ! input parameter. the vector of data points on which ! the statistics are computed. y is sorted, but restored ! to its original order afterwards. ! real ydist(ncells) ! the frequency distribution used to create the histogram. ! real yintmp ! the midpoint of the ith cell ! real ylb ! the lower bound for selecting data from y for the histogram. ! real ymax ! the histogram upper bound used ! real ymddsd ! the mean absolute deviation / the standard deviation ! real ymean, ymeant ! the mean of the observations used in the histogram ! real ymed ! the median of the observations used in the histogram ! real ymidrg ! the mid range of the observations used in the histogram ! real ymin ! the histogram lower bound used. ! real yrange ! the range of the observations used in the histogram ! real ysd ! the standard deviation of the observations used in the ! histogram. ! real yub ! the upper bound for selecting data from y for the histogram. ! real yvar ! the variance of the observations. ! implicit none real & ylb,yub integer & n,ncells ! ! array arguments real & y(n),ydist(ncells) integer & lsort(n) real & alpha,b1sqrt,b2,cfract,cfrctm,cntmx,fract,p,scale,sum1,sum2, & sum3,sumd2,sumd3,sumd4,sumda,sumt1,temp,width,xn,xnn,yintmp, & ymax,ymddsd,ymean,ymeant,ymed,ymidrg,ymin,yrange,ysd,yvar integer & i,iflag,j,mid,nhigh,nlow,nobs,num,nums character & iplus*1 ! ! local arrays real & a(6) ! ! external subroutines external geni,srtir,srtri,stat1,sumbs,sumds,sumss,sumts, & versp data iplus /'+'/ data alpha/0.25e0/ ! ! sort data ! call geni(lsort, n, 1, 1) call srtir(lsort, n, y) ! ! fix upper and lower bounds. ! nlow = 1 nhigh = n if ( ylb /= yub ) then ! ! find index of the first value of y >= ylb ! do i=1,n if ( ylb <= y(i) ) then nlow = i exit end if end do ! ! find index of the last value of y <= yub ! do i=1,n j = n - i + 1 if (y(j) <= yub) then nhigh = j exit end if end do end if xn = real ( nhigh-nlow+1 ) nobs = nhigh - nlow + 1 ! ! compute median, extrema, mid-range, range and frequency ! distribution for ncells cells ! call stat1(y(nlow), nobs, ymed, ymin, ymax, ymidrg, yrange, & ncells, ylb, yub, ydist) if ( ylb < yub ) then ymin = ylb ymax = yub end if ! ! compute mean, trimmed mean, standard deviation, ! mean deviation/standard deviation, beta one, and beta two ! call sumbs(y, n, nlow, mid, nhigh) call sumss(y, n, nlow, mid, nhigh, sum1, sum2, sum3, ymean) call sumts(y(nlow), nobs, alpha, sumt1, ymeant) call sumds(y, n, nlow, mid, nhigh, ymean, sumda, sumd2, sumd3, & sumd4) yvar = 0.0e0 ysd = 0.0e0 b1sqrt = 0.0e0 b2 = 0.0e0 ymddsd = 0.0e0 if ( 0.0 < sumd2 .and. 1 < nobs ) then yvar = sumd2 / real ( nobs - 1 ) ysd = sqrt(yvar) b1sqrt = abs((sumd3/xn)/((sumd2/xn)**1.5e0)) b2 = (sumd4/xn)/((sumd2/xn)**2) ymddsd = sumda/(ysd* real ( nobs ) ) end if ! ! output statistics ! call versp(.true.) write ( *,1070) n, y(nlow), y(nhigh), ymin, ymax write ( *,1000) & ncells, nobs, ymeant, y(nlow), ysd, y(nhigh), ymddsd, & ymean, b1sqrt, ymed, b2 write ( *,1010) ! ! check for more than 50 values in interval and find max. value. ! iflag = 0 cntmx = 0.0e0 do i=1,ncells if (ydist(i) > cntmx) cntmx = ydist(i) end do if (nint(cntmx) > 50) iflag = 1 ! ! determine scale. ! if (iflag == 0) then scale = 1.0e0 else p = cntmx/xn scale = 0.05e0 if (p > 0.25e0) scale = 0.1e0 if (p > 0.5e0) scale = 0.2e0 end if ! ! print column headings and histogram scale. ! if (iflag == 0) write ( *,1020) if (iflag /= 0) write ( *,1080) write ( *,1090) if ( iflag == 0 ) then write ( *,1030) (i,i=10,50,10) else a(1) = 0.0e0 do i=1,5 a(i+1) = a(i) + scale end do write ( *,1040) (a(i),i=1,6) end if write ( *,1050) cfract = 0.0e0 cfrctm = 1.0e0 temp = 0.0e0 width = (ymax-ymin)/ real ( ncells ) yintmp = ymin yintmp = yintmp - width/2.0e0 do i=1,ncells num = int(ydist(i)+0.5e0) if (mod(ncells,2) == 1 .and. i == ncells/2+1 & .and. ymin == (-ymax)) then yintmp = 0.0e0 else yintmp = yintmp + width end if fract = ydist(i)/xn cfract = cfract + fract cfrctm = 1.0e0 - temp temp = cfract if (num <= 0) then write ( *,1060) yintmp, cfract, cfrctm, fract, num else if (iflag == 0) then nums = num else xnn = fract*10.0e0/scale nums = int(xnn) nums = max(1, nums + int(xnn-real ( nums ) +0.5e0)) end if write ( *,1060) yintmp, cfract, cfrctm, fract, & num, (iplus,j=1,nums) end if end do ! ! restore data to original order ! call srtri(y, n, lsort) return 1000 format(/' number of cells = ', i15/ & ' observations used = ', i15, 11x, & '25 pct trimmed mean = ', 1pe15.8/ & ' min. observation used = ', e15.8, 11x, & 'standard deviation = ', e15.8/ & ' max. observation used = ', e15.8, 11x, & 'mean dev./std. dev. = ', e15.8/ & ' mean value = ', e15.8, 11x, & 'sqrt(beta one) = ', e15.8/ & ' median value = ', e15.8, 11x, & 'beta two = ', e15.8) 1010 format(//' for a normal distribution, the values (mean', & ' deviation/standard deviation), sqrt(beta one), and beta', & ' two are approximately'/ & ' 0.8, 0.0 and 3.0, respectively. to test the ', & 'null hypothesis of normality, see tables of critical values', & ' pp. 207-208,'/ ' biometrika tables for', & ' statisticians, vol. 1. see pp. 67-68 for a discussion of', & ' these tests.') 1020 format(///5x,'hinterval cum. 1-cum. cell no.',19x, & 'number of observations') 1030 format('+',47x,'0',8x,5(i2,8x)) 1040 format('+',46x,6(f4.2,6x)) 1050 format(4x,42('-'),2x,'+',5('---------+')) 1060 format(3x,1pe13.6,2x,2(0pf5.3,3x),f5.3,1x,i5,4x,50a1) 1070 format (' histogram'// & ' number of observations = ', i15/ & ' minimum observation = ', 1pe15.8/ & ' maximum observation = ', e15.8// & ' histogram lower bound = ', e15.8/ & ' histogram upper bound = ', e15.8) 1080 format(///5x,'hinterval cum. 1-cum. cell no.',23x, & 'cell fraction') 1090 format(5x,'hmid point fract. fract. fract. obs.' ) end function i1mach ( i ) !*****************************************************************************80 ! !! I1MACH returns integer machine constants. ! ! Discussion: ! ! Input/output 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(1:S-1) < A. ! ! I1MACH(7) = A, the base. ! I1MACH(8) = S, the number of base A digits. ! I1MACH(9) = A**S-1, the largest integer. ! ! Floating point numbers ! ! Assume floating point numbers are represented in the T digit ! base B form: ! ! Sign * (B**E) * ((X(1)/B) + ... + (X(T)/B**T) ) ! ! where 0 <= X(I) < B for I=1 to T, 0 < X(1) and EMIN <= E <= EMAX. ! ! I1MACH(10) = B, the base. ! ! Single precision ! ! I1MACH(11) = T, the number of base B digits. ! I1MACH(12) = EMIN, the smallest exponent E. ! I1MACH(13) = EMAX, the largest exponent E. ! ! Double precision ! ! I1MACH(14) = T, the number of base B digits. ! I1MACH(15) = EMIN, the smallest exponent E. ! I1MACH(16) = EMAX, the largest exponent E. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Phyllis Fox, Andrew Hall, Norman Schryer, ! Algorithm 528, ! Framework for a Portable Library, ! ACM Transactions on Mathematical Software, ! Volume 4, Number 2, June 1978, page 176-188. ! ! Parameters: ! ! Input, integer I, chooses the parameter to be returned. ! 1 <= I <= 16. ! ! Output, integer I1MACH, the value of the chosen parameter. ! implicit none integer i integer i1mach if ( i < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 16.' write ( *, '(a,i12)' ) ' I = ', i i1mach = 0 stop else if ( i == 1 ) then i1mach = 5 else if ( i == 2 ) then i1mach = 6 else if ( i == 3 ) then i1mach = 7 else if ( i == 4 ) then i1mach = 6 else if ( i == 5 ) then i1mach = 32 else if ( i == 6 ) then i1mach = 4 else if ( i == 7 ) then i1mach = 2 else if ( i == 8 ) then i1mach = 31 else if ( i == 9 ) then i1mach = 2147483647 else if ( i == 10 ) then i1mach = 2 else if ( i == 11 ) then i1mach = 24 else if ( i == 12 ) then i1mach = -125 else if ( i == 13 ) then i1mach = 128 else if ( i == 14 ) then i1mach = 53 else if ( i == 15 ) then i1mach = -1021 else if ( i == 16 ) then i1mach = 1024 else if ( 16 < i ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'I1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 16.' write ( *, '(a,i12)' ) ' I = ', i i1mach = 0 stop end if return end function i8save ( isw, ivalue, set ) !*****************************************************************************80 ! !! I8SAVE returns the current error number or recovery switch. ! ! Discussion: ! ! if (isw = 1) i8save returns the current error number and ! sets it to ivalue if set = .true. . ! ! if (isw = 2) i8save returns the current recovery switch and ! sets it to ivalue if set = .true. . ! implicit none integer i8save integer isw integer ivalue integer lerror integer lrecov logical set ! ! local arrays integer iparam(2) ! ! equivalences equivalence (iparam(1),lerror), (iparam(2),lrecov) ! ! start execution error free and with recovery turned off. ! data lerror/0/ , lrecov/2/ i8save=iparam(isw) if (set) then iparam(isw)=ivalue end if return end function icnti ( iv, niv, i ) !*****************************************************************************80 ! !! ICNTI counts the number of occurences of a value in an integer vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! input parameter. the integer to count occurences of. ! integer iv(niv) ! input parameter. the vector in which to count. ! integer j ! loop parameter. ! integer niv ! input parameter. the length of iv. ! implicit none integer i integer icnti integer niv ! ! array arguments integer & iv(niv) integer & j icnti = 0 do j = 1, niv if (iv(j) == i) icnti = icnti + 1 end do return end subroutine icopy ( n, isx, incx, isy, incy ) !*****************************************************************************80 ! !! ICOPY copies an integer vector. ! ! Discussion: ! ! This routine is a adaptation of the blas subroutine scopy, ! modified to handle integer arrays. ! ! copy integer isx to integer isy. ! for i = 0 to n-1, copy isx(lx+i*incx) to isy(ly+i*incy), ! where lx = 1 if incx >= 0, else lx = (-incx)*n, and ly is ! defined in a similar way using incy. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an indexing variable. ! integer incx, incy ! the increment used for the copy from one variable to the other. ! integer isx(n) ! the array to be copied from. ! integer isy(n) ! the array to be copied to. ! integer ix, iy ! index variables. ! integer m ! the value of n modulo 7. ! integer mp1 ! the value of m + 1. ! integer n ! the number of observations in the arrays isx and isy. ! integer ns ! the value of n * incx. ! implicit none integer n integer incx integer incy integer & isx(n),isy(n) ! ! integer & i,ix,iy,m,ns if(n <= 0)return if(incx == incy) then ! if(incx-1) 5,20,60 if ( incx < 1 ) then go to 5 else if ( incx == 1 ) then go to 20 else go to 60 end if end if 5 continue ! ! code for unequal or nonpositive increments. ! ix = 1 iy = 1 if(incx<0)ix = (-n+1)*incx + 1 if(incy<0)iy = (-n+1)*incy + 1 do i = 1,n isy(iy) = isx(ix) ix = ix + incx iy = iy + incy end do return ! ! code for both increments equal to 1 ! ! clean-up loop so remaining vector length is a multiple of 7. ! 20 m = mod(n,7) if( m == 0 ) go to 40 isy(1:m) = isx(1:m) if ( n < 7 ) then return end if 40 continue do i = m + 1, n, 7 isy(i) = isx(i) isy(i + 1) = isx(i + 1) isy(i + 2) = isx(i + 2) isy(i + 3) = isx(i + 3) isy(i + 4) = isx(i + 4) isy(i + 5) = isx(i + 5) isy(i + 6) = isx(i + 6) end do return ! ! code for equal, positive, nonunit increments. ! 60 continue ns = n*incx do i=1,ns,incx isy(i) = isx(i) end do return end function imdcon ( k ) !*****************************************************************************80 ! !! IMDCON returns integer machine-dependent constants. ! ! Discussion: ! ! k = 1 means return standard output unit number. ! k = 2 means return alternate output unit number. ! k = 3 means return input unit number. ! (note -- k = 2, 3 are used only by test programs.) ! implicit none integer imdcon integer k integer & mdcon(3) ! ! external functions integer & i1mach external i1mach mdcon(1) = i1mach(2) mdcon(2) = i1mach(3) mdcon(3) = i1mach(1) imdcon = mdcon(k) return end function inits ( os, nos, eta ) !*****************************************************************************80 ! !! INITS initializes an orthogonal series. ! ! Discussion: ! ! Initialize the orthogonal series so that inits is the number of terms ! needed to insure the error is no larger than eta. ordinarily, eta ! will be chosen to be one-tenth machine precision. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! os array of nos coefficients in an orthogonal series. ! nos number of coefficients in os. ! eta requested accuracy of series. ! implicit none integer nos real eta integer inits real os(nos) real err integer i,ii if (nos<1) then call xerror ( 'inits number of coefficients lt 1', 2, 2) end if err = 0.0 do ii=1,nos i = nos + 1 - ii err = err + abs(os(i)) if ( eta < err ) then exit end if end do if (i == nos) then call xerror ('inits eta may be too small', 1, 2) end if inits = i return end function inperl ( ) !*****************************************************************************80 ! !! INPERL computes the number of elements that can be printed on one line. ! ! Discussion: ! ! This routine computes the number of vector elements that can ! be printed in a line of output on the standard output file. ! ! assumptions: ! ! 1) maximum width of line to use (imaxw) is 132. ! 2) number of characters not vector elements per line (iocpl) is 15. ! 3) width of field for an element, including spacing ! between elements (iew) is 15. ! 4) maximum elements per line (imaxe) is 7. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer iew ! width of a field for printing out a vector element, ! including spaces between adjacent elements. ! integer imaxe ! maximum number of array elements per line. ! integer imaxw ! maximum number of characters to allow per line. ! integer iocpl ! number of characters to be introduced to line in addition ! to characters in the element fields. ! integer iwidth ! number of characters in a line on the standard output file. ! implicit none integer inperl integer & iew,imaxe,imaxw,iocpl,iwidth ! ! initializations ! data iew /15/, imaxe /7/, imaxw /132/, iocpl /15/ iwidth = 132 inperl = (min(iwidth, imaxw) - iocpl)/iew inperl = min(inperl, imaxe) return end subroutine ipgdv ( per, nf, n, peri, freq, xaxis, yaxis, isym, lpcv, nprt ) !*****************************************************************************80 ! !! IPGDV produces coordinates for the spectral plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real freq(nf) ! the array in which the frequencies at which the periodogram ! was estimated are stored. ! integer ispcer ! an error indicator for the integrated periodogram computations. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lpcv ! the length of the plot coordinate vectors. ! integer n ! the actual number of observations in the series from which ! the periodogram was computed. ! integer nprt ! the variable controling printed output, where ! if nprt == 0, the output is suppressed, ! if nprt >= 1, the output consists of a page plot. ! integer nf ! the number of frequencies for which the spectral estimates ! are estimated. ! integer npts ! the number of x, y coordinates to be plotted. ! real per(nf) ! the raw periodogram. ! real peri(nf) ! the array containing the integrated periodogram values. ! real xaxis(lpcv), yaxis(lpcv) ! the x, y coordinates for the spectral plots. ! implicit none integer & lpcv,n,nf,nprt ! ! array arguments real & freq(nf),per(nf),peri(nf),xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) ! ! integer & ispcer,npts ! ! external subroutines external ipgmn,ipgord,ipgout call ipgmn(per, nf, peri, ispcer) ! ! set coordinates for the integrated periodogram ! if (ispcer == 0) then if (nprt == 0) return call ipgord(peri, nf, n, freq, xaxis, yaxis, isym, npts, lpcv) end if ! ! plot the integrated periodogram ! call ipgout (xaxis, yaxis, isym, npts, lpcv, ispcer) return end subroutine ipgm ( yfft, n, lyfft, ldstak ) !*****************************************************************************80 ! !! IPGM: short call to compute the integrated periodogram of a series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! integer freq ! the starting location in the stack for ! the array in which the frequencies corresponding to the ! integrated spectrum values are stored. ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer iextnd ! the indicator variable used to designate whether zero ! (iextnd == 0) or the series mean (iextnd /= 0) is to be ! used to extend the series. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer ldsmin ! the minimum length allowed for dstak. ! character*1 llds(8), llyfft(8), ln(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations. ! integer nall0 ! the number of outstanding allocations of the stack at the ! time of this call. ! integer nf ! the number of frequencies at which the periodgram is ! to be computed. ! integer nfft ! the effective length of the series to be transformed. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! the variable controling printed output, where ! if nprt == 0, the output is suppressed, ! if nprt >= 1, the output consists of a page plot. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer xaxis ! the starting location in the stack for ! the array in which the x axis values to be plotted are stored. ! integer yaxis ! the starting location in the stack for ! the array in which the y axis values to be plotted are stored. ! real yfft(lyfft) ! the array containing the observed time series. ! implicit none integer & ldstak,lyfft,n ! ! array arguments real & yfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & freq,iextnd,isym,ldsmin,lpcv,nall0,nf,nfft,nprt, & xaxis,yaxis logical & err01,err02,err03,head ! ! local arrays real & rstak(12) integer & istak(12) character & llds(8)*1,llyfft(8)*1,ln(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external cntr,eisge,ipgdv,ldscmp,pgmmn,setesl,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'i', 'p', 'g', 'm', ' ', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) & /'l','y','f','f','t',' ',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) if (err01) then ierr = 1 write ( *, 1000) return end if ! ! set length of extended series ! call setesl(n, 2, nfft) nf = nfft/2 call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err02, llyfft) call ldscmp(3, 0, nf+103, 0, 0, 0, 's', 2*nfft+206, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds) if (err01 .or. err02 .or. err03) then ierr = 1 write ( *, 1000) return end if ! ! set the size of the work area ! call stkset(ldstak, 4) ! ! set the number of outstanding allocations. ! nall0 = stkst(1) lpcv = nf + 103 nprt = 1 ! ! center the series ! call cntr(yfft, n, yfft) iextnd = 0 ! ! subdivide the stack. ! isym = stkget(lpcv, 2) xaxis = stkget(lpcv, 3) yaxis = stkget(lpcv, 3) freq = xaxis ! ! compute the raw periodogram. ! call pgmmn (yfft, n, nfft, iextnd, nf, yfft, lyfft, rstak(yaxis), & rstak(freq), lpcv, 0, nmsub) ! ! call the main driver for computing (and plotting) the integrated ! periodogram. ! call ipgdv (yfft, nf, n, yfft, rstak(freq), rstak(xaxis), & rstak(yaxis), istak(isym), lpcv, nprt) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call ipgm (yfft, n, lyfft, ldstak)') end subroutine ipgmn ( per, nf, peri, ispcer ) !*****************************************************************************80 ! !! IPGMN computes the integrated periodogram. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! integer ispcer ! an error indicator for the integrated periodogram computations. ! integer nf ! the number of frequencies at which the periodgram is ! computed. ! real per(nf) ! the raw periodogram. ! real peri(nf) ! the array which contains the integrated periodogram. ! real sm ! a value used to compute the integrated periodogram estimates. ! implicit none integer & ispcer,nf ! ! array arguments real & per(nf),peri(nf) real & sm integer & i sm = 0.0e0 do i = 1, nf sm = sm + per(i) peri(i) = sm end do ispcer = 1 if (sm == 0.0e0) return ispcer = 0 peri(1:nf) = peri(1:nf) / sm return end subroutine ipgmp ( per, freq, nf, n, ldstak ) !*****************************************************************************80 ! !! IPGMP: user routine for integrated periodograms of a series (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real freq(nf) ! the array in which the frequencies corresponding to the ! integrated spectrum values are stored. ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer isym ! ... ! integer ldsmin ! the minimum length allowed for dstak. ! character*1 llds(8), ln(8), lnf(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer lpcv ! ... ! integer n ! the actual number of observations in the series from which ! the periodogram was computed. ! integer nall0 ! the number of outstanding allocations of the stack at the ! time of this call. ! integer nf ! the number of frequencies at which the periodgram is ! to be computed. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! the variable controling printed output, where ! if nprt == 0, the output is suppressed, ! if nprt >= 1, the output consists of a page plot. ! real per(nf) ! the raw periodogram. ! integer peri ! the starting location in the stack for ! the vector containing the integrated periodogram. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer xaxis ! the starting location in the stack for ! the array in which the x axis values to be plotted are stored. ! integer yaxis ! the starting location in the stack for ! the array in which the y axis values to be plotted are stored. ! implicit none integer & ldstak,n,nf ! ! array arguments real & freq(*),per(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer isym,ldsmin,lpcv,nall0,nprt,peri,xaxis,yaxis logical & err01,err02,err03,head ! ! local arrays real & rstak(12) integer & istak(12) character & llds(8)*1,ln(8)*1,lnf(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external eisge,ipgdv,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'i', 'p', 'g', 'm', 'p', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ data & lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), lnf(6), lnf(7), lnf(8) & /'n','f',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) call eisge(nmsub, lnf, nf, (n+2)/2, 1, head, err02, lnf) if (err01) then ierr = 1 write ( *, 1000) return end if call ldscmp(4, 0, nf+103, 0, 0, 0, 's', 3*nf+206, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds) if (err02 .or. err03) then ierr = 1 write ( *, 1000) return end if ! ! set the size of the work area ! call stkset(ldstak, 4) ! ! set the number of outstanding allocations. ! nall0 = stkst(1) lpcv = nf + 103 nprt = 1 ! ! subdivide the stack. ! isym = stkget(lpcv, 2) peri = stkget(nf, 3) xaxis = stkget(lpcv, 3) yaxis = stkget(lpcv, 3) ! ! call the main driver for computing (and plotting) the integrated ! periodogram. ! call ipgdv (per, nf, n, rstak(peri), freq, rstak(xaxis), & rstak(yaxis), istak(isym), lpcv, nprt) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call ipgmp (per, freq, nf, n, ldstak)') end subroutine ipgmps ( per, freq, nf, n, ldstak, peri, nprt ) !*****************************************************************************80 ! !! IPGMPS: user routine for the integrated periodogram of a series (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real freq(nf) ! the array in which the frequencies corresponding to the ! integrated spectrum values are stored. ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! character*1 llds(8), ln(8), lnf(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer n ! the actual number of observations in the series from which ! the periodogram was computed. ! integer nall0 ! the number of outstanding allocations of the stack at the ! time of this call. ! integer nf ! the number of frequencies at which the periodgram is ! computed. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! the variable controling printed output, where ! if nprt == 0, the output is suppressed, ! if nprt >= 1, the output consists of a page plot. ! real per(nf) ! the integrated periodogram. ! real peri(nf) ! the vector in which the integrated periodogram is stored. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer xaxis ! the starting location in the stack for ! the array in which the x axis values to be plotted are stored. ! integer yaxis ! the starting location in the stack for ! the array in which the y axis values to be plotted are stored. ! implicit none integer & ldstak,n,nf,nprt ! ! array arguments real & freq(*),per(*),peri(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer isym,ldsmin,lpcv,nall0,xaxis,yaxis logical & err01,err02,err03,head ! ! local arrays real & rstak(12) integer & istak(12) character & llds(8)*1,ln(8)*1,lnf(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external eisge,ipgdv,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'i', 'p', 'g', 'm', 'p', 's'/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ data & lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), lnf(6), lnf(7), lnf(8) & /'n','f',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) call eisge(nmsub, lnf, nf, (n+2)/2, 1, head, err02, lnf) if (err01) then ierr = 1 write ( *, 1000) return end if if (nprt == 0) then ldsmin = 0 else call ldscmp(3, 0, nf+103, 0, 0, 0, 's', 2*nf+206, ldsmin) end if call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds) if (err02 .or. err03) then ierr = 1 write ( *, 1000) return end if ! ! set the size of the work area ! call stkset(ldstak, 4) ! ! set the number of outstanding allocations. ! nall0 = stkst(1) lpcv = nf + 103 ! ! subdivide the stack. ! if (nprt == 0) then isym = 1 xaxis = 1 yaxis = 1 else isym = stkget(lpcv, 2) xaxis = stkget(lpcv, 3) yaxis = stkget(lpcv, 3) end if ! ! call the main driver for computing (and plotting) the integrated ! periodogram. ! call ipgdv (per, nf, n, peri, freq, rstak(xaxis), & rstak(yaxis), istak(isym), lpcv, nprt) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call ipgmps (per, freq, nf, n, ldstak, peri, nprt)') end subroutine ipgms ( yfft, n, lyfft, ldstak, nf, peri, lperi, freq, & lfreq, nprt ) !*****************************************************************************80 ! !! IPGMS: user routine for the integrated periodogram of a series (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03, err04, err05 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real freq(lfreq) ! the array in which the frequencies corresponding to the ! integrated spectrum values are stored. ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer iextnd ! the indicator variable used to designate whether zero ! (iextnd == 0) or the series mean (iextnd /= 0) is to be ! used to extend the series. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lfreq ! the length of the vector freq. ! character*1 llds(8), llfreq(8), llperi(8), llyfft(8), ln(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lperi ! the length of the vector peri. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations. ! integer nall0 ! the number of outstanding allocations of the stack at the ! time of this call. ! integer nf ! the number of frequencies at which the periodgram is ! to be computed. ! integer nfft ! the effective length of the series to be transformed. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! the variable controling printed output, where ! if nprt == 0, the output is suppressed, ! if nprt >= 1, the output consists of a page plot. ! real peri(lperi) ! the vector in which the integrated periodogram is stored. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer xaxis ! the starting location in the stack for ! the array in which the x axis values to be plotted are stored. ! integer yaxis ! the starting location in the stack for ! the array in which the y axis values to be plotted are stored. ! real yfft(lyfft) ! the array containing the observed time series. ! implicit none integer & ldstak,lfreq,lperi,lyfft,n,nf,nprt ! ! array arguments real & freq(*),peri(*),yfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & iextnd,isym,ldsmin,lpcv,nall0,nfft,xaxis,yaxis logical & err01,err02,err03,err04,err05,head ! ! local arrays real & rstak(12) integer & istak(12) character & llds(8)*1,llfreq(8)*1,llperi(8)*1,llyfft(8)*1,ln(8)*1, & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external cntr,eisge,ipgdv,ldscmp,pgmmn,setesl,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'i', 'p', 'g', 'm', 's', ' '/ data & llfreq(1), llfreq(2), llfreq(3), llfreq(4), llfreq(5), & llfreq(6), llfreq(7), llfreq(8) & /'l','f','r','e','q',' ',' ',' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & llperi(1), llperi(2), llperi(3), llperi(4), llperi(5), & llperi(6), llperi(7), llperi(8) & /'l','p','e','r','i',' ',' ',' '/ data & llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) & /'l','y','f','f','t',' ',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) if (err01) then ierr = 1 write ( *, 1000) return end if ! ! set length of extended series ! call setesl(n, 2, nfft) nf = nfft/2 call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err02, llyfft) call eisge(nmsub, llperi, lperi, nf, 9, head, err03, llperi) call eisge(nmsub, llfreq, lfreq, nf, 9, head, err04, llfreq) if (nprt == 0) then ldsmin = 0 else call ldscmp(3, 0, nf+103, 0, 0, 0, 's', 2*nfft+206, ldsmin) end if call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err05, llds) if (err02 .or. err03 .or. err04 .or. err05) then ierr = 1 write ( *, 1000) return end if ! ! set the size of the work area ! call stkset(ldstak, 4) ! ! set the number of outstanding allocations. ! nall0 = stkst(1) lpcv = nf + 103 ! ! center the series ! call cntr(yfft, n, yfft) iextnd = 0 ! ! subdivide the stack. ! if (nprt == 0) then isym = 1 xaxis = 1 yaxis = 1 else isym = stkget(lpcv, 2) xaxis = stkget(lpcv, 3) yaxis = stkget(lpcv, 3) end if ! ! compute the raw periodogram. ! call pgmmn (yfft, n, nfft, iextnd, nf, peri, lperi, rstak(yaxis), & freq, lfreq, 0, nmsub) ! ! call the main driver for computing (and plotting) the integrated ! periodogram. ! call ipgdv (peri, nf, n, peri, freq, rstak(xaxis), & rstak(yaxis), istak(isym), lpcv, nprt) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call ipgms (yfft, n, lyfft, ldstak,'/ & ' + nf, peri, lperi, freq, lfreq, nprt)') end subroutine ipgord ( peri, nf, n, freq, xaxis, yaxis, isym, npts, lpcv ) !*****************************************************************************80 ! !! IPGORD produces coordinates for the spectral plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real ci, cimid ! the width and midpoint of the test interval for white noise. ! real freq(nf) ! the array in which the frequencies at which the periodogram ! was estimated are stored. ! integer i ! an index variable ! integer ii ! an index variable ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lpcv ! the length of the plot coordinate vectors. ! integer n ! the actual number of observations in the series from which ! the periodogram was computed. ! integer nf ! the number of frequencies for which the spectral estimates ! are estimated. ! integer nlim ! the number of points at which the white noise limits are to ! plotted. ! integer npts ! the number of x, y coordinates to be plotted. ! real peri(nf) ! the array containing the integrated periodogram values. ! real s(40) ! values used to compute the confidence limits. ! real xaxis(lpcv), yaxis(lpcv) ! the x, y coordinates for the spectral plots. ! implicit none integer & lpcv,n,nf,npts ! ! array arguments real & freq(nf),peri(nf),xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) real & ci,cimid integer & i,ii,nlim ! ! local arrays real & s(40) data s(1)/0.975e0/, s(2)/0.842e0/, s(3)/0.708e0/ data s(4)/0.624e0/, s(5)/0.563e0/ data s(6)/0.519e0/, s(7)/0.483e0/, s(8)/0.454e0/ data s(9)/0.430e0/, s(10)/0.409e0/ data s(11)/0.391e0/, s(12)/0.375e0/, s(13)/0.361e0/ data s(14)/0.349e0/, s(15)/0.338e0/ data s(16)/0.327e0/, s(17)/0.318e0/, s(18)/0.309e0/ data s(19)/0.301e0/, s(20)/0.294e0/ data s(21)/0.287e0/, s(22)/0.281e0/, s(23)/0.275e0/ data s(24)/0.269e0/, s(25)/0.264e0/ data s(26)/0.259e0/, s(27)/0.254e0/, s(28)/0.250e0/ data s(29)/0.246e0/, s(30)/0.242e0/ data s(31)/0.238e0/, s(32)/0.234e0/, s(33)/0.231e0/ data s(34)/0.227e0/, s(35)/0.224e0/ data s(36)/0.221e0/, s(37)/0.218e0/, s(38)/0.215e0/ data s(39)/0.213e0/, s(40)/0.210e0/ i = n + mod(n,2) - 1 if (i <= 40) then ci = s(i) else ci = 1.36e0 / sqrt(real(i)) end if xaxis(1:nf) = freq(1:nf) yaxis(1:nf) = peri(1:nf) isym(1:nf) = 1 nlim = 101 ii = nf do i = 1, nlim, 2 cimid = real(i-1) / real(nlim-1) if ( 0.0 <= cimid - ci ) then ii = ii + 1 xaxis(ii) = cimid / 2.0e0 yaxis(ii) = cimid - ci isym(ii) = 2 end if if ( cimid + ci <= 1.0e0 ) then ii = ii + 1 xaxis(ii) = cimid / 2.0e0 yaxis(ii) = cimid + ci isym(ii) = 2 end if end do npts = ii return end subroutine ipgout ( xaxis, yaxis, isym, npts, lpcv, ispcer ) !*****************************************************************************80 ! !! IPGOUT produces the integrated periodogram plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ispcer ! an error indicator for the integrated periodogram computations. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lpcv ! the length of the plot coordinate vectors. ! integer npts ! the number of x, y coordinates to be plotted. ! real xaxis(lpcv), yaxis(lpcv) ! the x, y coordinates for the spectral plots. ! implicit none integer & ispcer,lpcv,npts ! ! array arguments real & xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) call versp(.true.) write ( *, 1000) if ( ispcer /= 0 ) then write ( *, 1003) return end if call ppmn (yaxis, yaxis, xaxis, xaxis(1), npts, 1, lpcv, 1, isym, & lpcv, 0, -1, 0.0e0, 1.0e0, 0.0e0, 0.5e0, .false., 0) write ( *, 1002) return 1000 format(' integrated sample periodogram (+)'/ & 5x, ' with 95 per cent test limits for white noise (.)') !1001 format('+freq'/ ! 1 ' period', 9x, 'inf', 7x, '10.', 4x, '5.', 8x, '3.3333', 4x, ! 2 '2.5', 4x, '2.') 1002 format('+freq'/ & ' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, '6.6667', 4x, & '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, '2.5', 7x, & '2.2222', 4x, '2.') 1003 format (///' the integrated periodogram of this series', & ' could not be computed'/ & ' because the variance of the series is zero.') end subroutine iprint ( iprt ) !*****************************************************************************80 ! !! IPRINT sets the logical unit for printed output. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer iprt ! the unit number for output. ! implicit none integer & iprt ! ! external functions integer & i1mach external i1mach iprt = i1mach(2) return end function isamax ( n, x, incx ) !*****************************************************************************80 ! !! ISAMAX indexes the real array element of maximum absolute value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Algorithm 539: ! Basic Linear Algebra Subprograms for Fortran Usage, ! 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 ( samax < abs ( x(i) ) ) then isamax = i samax = abs ( x(i) ) end if end do else if ( 0 <= incx ) 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 ( samax < abs ( x(ix) ) ) then isamax = i samax = abs ( x(ix) ) end if ix = ix + incx end do end if return end subroutine itsmry ( d, iv, p, v, x ) !*********************************************************************** ! !! ITSMRY prints an iteration summary. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, real D(P), the scale vector. ! ! Input/output, integer IV(*), the NL2SOL integer parameter array. ! ! Input, integer P, the number of variables. ! ! Input, real V(*), the NL2SOL real array. ! ! Input, real X(P), the current estimate of the minimizer. ! implicit none integer p integer cov1 integer :: covmat = 26 integer :: covprt = 14 integer :: covreq = 15 real d(p) integer :: dstnrm = 2 integer :: f = 10 integer :: f0 = 13 integer :: fdif = 11 integer :: g = 28 integer g1 integer i integer i1 integer ii integer iv(*) integer iv1 integer m character ( len = 7 ) model(6) integer :: needhd = 39 integer nf integer :: nfcall = 6 integer :: nfcov = 40 integer ng integer :: ngcall = 30 integer :: ngcov = 41 integer :: niter = 31 integer :: nreduc = 6 real nreldf integer ol real oldf integer :: outlev = 19 integer :: preduc = 7 real preldf integer :: prntit = 48 integer :: prunit = 21 integer pu real reldf integer :: reldx = 17 integer :: size = 47 integer :: solprt = 22 integer :: statpr = 23 integer :: stppar = 5 integer :: sused = 57 real v(*) real x(p) integer :: x0prt = 24 data model / & ' G', & ' S', & ' G-S', & ' S-G', & ' G-S-G', & ' S-G-S' / pu = iv(prunit) if ( pu == 0 ) then return end if iv1 = iv(1) ol = iv(outlev) if ( iv1 < 2 .or. 15 < iv1 ) then write ( pu, '(a,i5)' ) 'IV(1) = ', iv1 return end if if ( ol == 0 ) then go to 20 end if if ( 12 <= iv1 ) then go to 20 end if if ( 10 <= iv1 .and. iv(prntit) == 0 ) then go to 20 end if if ( iv1 <= 2 ) then iv(prntit) = iv(prntit) + 1 if ( iv(prntit) < abs ( ol ) ) then return end if end if !10 continue nf = iv(nfcall) - abs ( iv(nfcov) ) iv(prntit) = 0 reldf = 0.0E+00 preldf = 0.0E+00 oldf = v(f0) if ( 0.0E+00 < oldf ) then reldf = v(fdif) / oldf preldf = v(preduc) / oldf end if ! ! Print short summary line. ! if ( ol <= 0 ) then if ( iv(needhd) == 1 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) & ' it nf f reldf preldf reldx' end if iv(needhd) = 0 write(pu,1017) iv(niter), nf, v(f), reldf, preldf, v(reldx) ! ! Print long summary line. ! else if ( iv(needhd) == 1 ) then write ( pu, * ) ' ' write ( pu, * ) & ' it nf f reldf preldf reldx' // & ' model STPPAR size d*step npreldf' end if iv(needhd) = 0 m = iv(sused) if ( 0.0E+00 < oldf ) then nreldf = v(nreduc) / oldf else nreldf = 0.0E+00 end if write(pu,1017) iv(niter), nf, v(f), reldf, preldf, v(reldx), & model(m), v(stppar), v(size), & v(dstnrm), nreldf 1017 format(1x,i5,i6,4e11.3,a7,4e11.3) end if 20 continue if ( iv1 == 1 ) then return else if ( iv1 == 2 ) then return else if ( iv1 == 3 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'X-convergence.' else if ( iv1 == 4 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Relative function convergence.' else if ( iv1 == 5 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'X- and relative function convergence.' else if ( iv1 == 6 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Absolute function convergence.' else if ( iv1 == 7 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Singular convergence.' else if ( iv1 == 8 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'False convergence.' else if ( iv1 == 9 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Function evaluation limit.' else if ( iv1 == 10 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Iteration limit.' else if ( iv1 == 11 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Stopx.' else if ( iv1 == 14 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Bad parameters to ASSESS.' return ! ! Initial call on ITSMRY. ! else if ( iv1 == 12 .or. iv1 == 13 .or. iv1 == 15 ) then if ( iv1 == 15 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'J could not be computed.' if ( 0 < iv(niter) ) then go to 190 end if end if if ( iv1 == 13 ) then write ( pu, * ) ' ' write ( pu, '(a)' ) 'Initial sum of squares overflows.' end if if ( iv(x0prt) /= 0 ) then write ( pu, * ) ' ' write ( pu, * ) ' I Initial X(i) D(i)' write ( pu, * ) ' ' write(pu,1150) (i, x(i), d(i), i = 1, p) end if 1150 format((1x,i5,e17.6,e14.3)) if ( iv1 == 13 ) then return end if iv(needhd) = 0 iv(prntit) = 0 if ( ol == 0 ) then return else if ( ol < 0 ) then write ( pu, '(a)' ) ' ' write ( pu, '(a)' ) & ' it nf f reldf preldf reldx' else if ( 0 < ol ) then write ( pu, '(a)' ) ' ' write ( pu, '(a)' ) & ' it nf f reldf preldf reldx' // & ' model STPPAR size d*step npreldf' end if write ( pu, * ) ' ' write(pu,1160) v(f) 1160 format(' 0 1',e11.3,11x,e11.3) return else return end if ! ! Print various information requested on solution. ! iv(needhd) = 1 if ( iv(statpr) /= 0 ) then oldf = v(f0) if ( 0.0E+00 < oldf ) then preldf = v(preduc) / oldf nreldf = v(nreduc) / oldf else preldf = 0.0E+00 nreldf = 0.0E+00 end if nf = iv(nfcall) - iv(nfcov) ng = iv(ngcall) - iv(ngcov) write ( pu, * ) ' ' write(pu,1180) v(f), v(reldx), nf, ng, preldf, nreldf 1180 format(' function',e17.6,' reldx',e20.6/' func. evals', & i8,9x,'grad. evals',i8/' preldf',e19.6,3x,'npreldf',e18.6) if ( 0 < iv(nfcov) ) then write ( pu, * ) ' ' write ( pu, '(i5,a)' ) iv(nfcov), & ' extra function evaluations for covariance.' end if if ( 0 < iv(ngcov) ) then write ( pu, '(i5,a)' ) iv(ngcov), & ' extra gradient evaluations for covariance.' end if end if 190 continue if ( iv(solprt) /= 0 ) then iv(needhd) = 1 g1 = iv(g) write ( pu, '(a)' ) ' ' write ( pu, '(a)' ) & ' I Final X(I) D(I) G(I)' write ( pu, '(a)' ) ' ' do i = 1, p write ( pu, '(i5,e17.6,2e14.3)' ) i, x(i), d(i), v(g1) g1 = g1 + 1 end do end if if ( iv(covprt) == 0 ) then return end if cov1 = iv(covmat) iv(needhd) = 1 if ( cov1 < 0 ) then if ( -1 == cov1 ) then write ( pu, '(a)' ) 'Indefinite covariance matrix' else if ( -2 == cov1 ) then write ( pu, '(a)' ) 'Oversize steps in computing covariance' end if else if ( cov1 == 0 ) then write ( pu, '(a)' ) 'Covariance matrix not computed' else if ( 0 < cov1 ) then write ( pu, * ) ' ' i = abs ( iv(covreq) ) if ( i <= 1 ) then write ( pu, '(a)' ) 'Covariance = scale * H**-1 * (J'' * J) * H**-1' else if ( i == 2 ) then write ( pu, '(a)' ) 'Covariance = scale * inverse ( H )' else if ( 3 <= i ) then write ( pu, '(a)' ) 'Covariance = scale * inverse ( J'' * J )' end if write ( pu, * ) ' ' ii = cov1 - 1 if ( ol <= 0 ) then do i = 1, p i1 = ii + 1 ii = ii + i write(pu,1270) i, v(i1:ii) end do 1270 format(' row',i3,2x,5e12.4/(9x,5e12.4)) else do i = 1, p i1 = ii + 1 ii = ii + i write(pu,1250) i, v(i1:ii) end do 1250 format(' row',i3,2x,9e12.4/(9x,9e12.4)) end if end if return end function j4save ( which, value, set ) !*****************************************************************************80 ! !! J4SAVE saves variables needed by the library error handling routines. ! ! Discussion: ! ! The internal parameters are initialized to the following values: ! ! #1 = 0, NERR, the index of the most recent error; ! #2 = 0, KONTRL, error control flag (0 means only level 2 errors are fatal, ! and get a printout, while lower level errors get no printout.) ! #3 = 0, IUNIT, the main error output unit (0 means use standard output). ! #4 = 10, MAXMES, the maximum number of times any message is printed. ! #5 = 1, NUNIT, total number of error output units in use. ! #6 = -1, second error output unit (-1 means not being used). ! #7 = -1, third error output unit (-1 means not being used). ! #8 = -1, fourth error output unit (-1 means not being used). ! #9 = -1, fifth error output unit (-1 means not being used). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer WHICH, the index of the item desired. ! 1, NERR, the current error number. ! 2, KONTRL, the current error control flag. ! 3, IUNIT, the current unit number to which error messages are sent. ! (0 means use standard.) ! 4, MAXMES, the maximum times any message is printed (as set by xermax). ! 5, NUNIT, 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 VALUE, the value to be set for the WHICH-th parameter, ! if SET is TRUE. ! ! Input, logical SET. ! TRUE: the WHICH-th parameter will be given the value, VALUE. ! ! Output, integer J4SAVE, the old value of the WHICH-th parameter. ! implicit none integer j4save integer, save, dimension ( 9 ) :: param = (/ & 0, 2, 0, 10, 1, -1, -1, -1, -1 /) logical set integer value integer which if ( which < 1 .or. 9 < which ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'J4SAVE - Fatal error!' write ( *, '(a,i10)' ) ' Illegal input value of WHICH = ', which stop end if j4save = param(which) if ( set ) then param(which) = value end if return end subroutine ldscmp ( narr, nlog, nint, nreal, ndbl, ncmp, & flag, nfp, ldsmin ) !*****************************************************************************80 ! !! LDSCMP computes storage needed for arrays. ! ! Discussion: ! ! Computes ldsmin, the minimum number of double precision locations ! needed by the framework to store narr arrays, comprising nlog ! logical locations, nint integer locations, nreal real locations, ! ndbl double precision locations, and ncmp complex locations, ! together with the nover overhead integer locations that the ! framework always uses and the 3 overhead locations that it uses ! per array stored. (all the locations are assigned out of the ! labeled common cstak, using a stack discipline.) ! ! it is assumed, based upon the fortran standard (ansi x3.9 1966), ! that double precision and complex data elements are twice as long ! as integer and logical elements. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! character*1 flag ! the indicator variable used to designate whether the nfp ! elements are real or double precision, where flag=s indicates ! the nfp elements are real (single precision), and flag=d ! indicates the elements are double precision. ! integer ldsmin ! output parameter. the minimum number of double precision ! locations in cstak required for the quantities of array ! elements and arrays specified by the input parameters. ! integer narr ! input parameter. the number of arrays to be stored in cstak. ! integer ncmp ! input parameter. the number of complex elements in the ! arrays to be stored in cstak. ! integer ndbl ! input parameter. the number of double precision elements in ! the arrays to be stored, in cstak. ! integer nfp ! the number of elements which depend on the precision of the ! version of starpac being used. ! integer nint ! input parameter. the number of integer elements in the ! arrays to be stored in cstak. ! integer nlog ! input parameter. the number of logical elements in the ! arrays to be stored in cstak. ! integer nover ! the number of integer locations that the framework always ! uses for overhead purposes. ! integer nreal ! input parameter. the number of real elements in the arrays ! to be stored in cstak. ! implicit none integer & ldsmin,narr,ncmp,ndbl,nfp,nint,nlog,nreal character & flag*1 integer & nover data nover /10/ ldsmin = (nlog + nint + nreal + 3*narr + nover + 1)/2 & + ndbl + ncmp if (flag == 's') then ldsmin = ldsmin + (nfp+1)/2 else ldsmin = ldsmin + nfp end if return end subroutine linvrt ( n, lin, l ) !*********************************************************************** ! !! LINVRT computes the inverse of a lower triangular matrix. ! ! Discussion: ! ! LIN = inverse ( L ), both N by N lower triangular matrices stored ! compactly by rows. LIN and L may share the same storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer N, the order of L and LIN. ! ! Output, real LIN((N*(N+1))/2), the inverse of L, a lower triangular ! matrix stored by rows. ! ! Input, real L((N*(N+1))/2), a lower triangular matrix stored by rows. ! implicit none integer n integer i integer ii integer j0 integer j1 integer jj integer k integer k0 real l((n*(n+1))/2) real lin((n*(n+1))/2) real t j0 = ( n * ( n + 1 ) ) / 2 do ii = 1, n i = n + 1 - ii lin(j0) = 1.0E+00 / l(j0) if ( i <= 1 ) then return end if j1 = j0 do jj = 1, i - 1 t = 0.0E+00 j0 = j1 k0 = j1 - jj do k = 1, jj t = t - l(k0) * lin(j0) j0 = j0 - 1 k0 = k0 + k - i end do lin(j0) = t / l(k0) end do j0 = j0 - 1 end do return end subroutine litvmu ( n, x, l, y ) !*********************************************************************** ! !! LITVMU solves L' * X = Y, where L is a lower triangular matrix. ! ! Discussion: ! ! This routine solves L' * X = Y, where L is an N by N lower ! triangular matrix stored compactly by rows. X and Y may occupy ! the same storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer N, the order of L. ! ! Output, real X(N), the solution. ! ! Input, real L((N*(N+1))/2), the lower triangular matrix, stored ! by rows. ! ! Input, real Y(N), the right hand side. ! implicit none integer n integer i integer i0 integer ii integer ij integer j real l((n*(n+1))/2) real x(n) real xi real y(n) x(1:n) = y(1:n) i0 = ( n * ( n + 1 ) ) / 2 do ii = 1, n i = n + 1 - ii xi = x(i) / l(i0) x(i) = xi if ( i <= 1 ) then return end if i0 = i0 - i if ( xi /= 0.0E+00 ) then do j = 1, i - 1 ij = i0 + j x(j) = x(j) - xi * l(ij) end do end if end do return end subroutine livmul ( n, x, l, y ) !*********************************************************************** ! !! LIVMUL solves L * X = Y, where L is a lower triangular matrix. ! ! Discussion: ! ! This routine solves L * X = Y, where L is an N by N lower ! triangular matrix stored compactly by rows. X and Y may occupy ! the same storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer N, the order of L. ! ! Output, real X(N), the solution. ! ! Input, real L((N*(N+1))/2), the lower triangular matrix, stored ! by rows. ! ! Input, real Y(N), the right hand side. ! implicit none integer n real dotprd integer i integer j real l((n*(n+1))/2) real t real x(n) real y(n) x(1) = y(1) / l(1) j = 1 do i = 2, n t = dotprd ( i-1, l(j+1), x ) j = j + i x(i) = ( y(i) - t ) / l(j) end do return end subroutine llcnt ( y, wt, lwt, xm, n, m, ixm, npar, res, ldstak, & nprt, par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, & ivcv, llhdr, ifit, nmsub, weight, save ) !*****************************************************************************80 ! !! LLCNT is the controlling subroutine for linear least squares. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer acc ! the starting location in the work area for ! the number of accurate digits. ! integer c ! * ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer fc ! the starting location in the work area for ! the orthonormalization matrix. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ifit ! the indicator value designating whether the fit is of a ! general model (ifit=3) or a polynomial model (ifit=1). ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! single precision and ifp=4 indicates double precision. ! integer iptout(4) ! the variable used to control printed output for each section. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ixm ! the first dimension of the matrix xm. ! integer ldstak ! the length of the vector dstak in common cstak. ! external llhdr ! the name of the routine that produced the heading. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer nall0 ! number of allocations on entry. ! integer ndigit ! the number of digits in the print control value. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(lpar) ! the parameters to be estimated. ! integer pari ! the starting location in the work area of ! the parameters to be estimated. ! integer par1 ! the starting location in the work area for ! the parameters to be estimated ommitting the last ! independent variable. ! real pv(lpv) ! the predicted values. ! integer pvi ! the starting location in the work area for ! the predicted values. ! integer red ! the starting location in the work area for ! the reduction to the sum of squares due to each parameter. ! real res(n) ! the residuals. ! integer resi ! the starting location in the work area for ! the residuals. ! real rsd ! the residual standard deviation. ! integer rsdi ! the starting location in the work area for ! the residual standard deviation. ! real rstak(12) ! the real version of the /cstak/ work area. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! integer sdpvi ! the starting location in the work area for ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! integer sdresi ! the starting location in the work area for ! the standardized residuals. ! integer t ! the starting location in the work area for ! the triangular matrix from the decomposition. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! integer vcvi ! the starting location in the work area for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the weights. ! integer wti ! the starting location in the work area for ! the weights. ! integer wy ! the starting location in the work area for ! the vector containing sqrt(wt)*y. ! real xm(ixm,m) ! the independent variable. ! integer xmw ! the starting location in the work area for ! the matrix containing xm * sqrt(wt). ! real y(n) ! the dependent variable. ! implicit none real & rsd integer & ifit,ivcv,ixm,ldstak,lpar,lpv,lsdpv,lsdres,lwt,m,n,npar, & nprt logical & save,weight ! ! array arguments real & par(*),pv(lpv),res(*),sdpv(lsdpv),sdres(lsdres),vcv(*),wt(lwt),xm(*),y(*) character & nmsub(6)*1 ! ! subroutine arguments external llhdr ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & acc,c,fc,ifp,nall0,ndigit,nnzw,par1,pari,pvi,red,resi, & rsdi,sdpvi,sdresi,t,vcvi,wti,wy,xmw logical & page,wide ! ! local arrays real & rstak(12) integer & iptout(4),istak(12) ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external cpymss,ller,llsmn,prtcnt,scopy,setrv,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) wide = .true. page = .false. ndigit = 4 ifp = 3 ! ! set print control values ! call prtcnt(nprt, ndigit, iptout) ! ! check for errors ! call ller(nmsub, ixm, ivcv, n, npar, lpar, ldstak, wt, lwt, & weight, nnzw, ifit, save) if (ierr /= 0) return call stkset(ldstak, 4) nall0 = stkst(1) ! ! set up subdivision of work areas ! wti = stkget(n,ifp) resi = stkget(n,ifp) rsdi = stkget(1,ifp) pari = stkget(npar,ifp) pvi = stkget(n,ifp) sdpvi = stkget(n,ifp) sdresi = stkget(n,ifp) vcvi = stkget(npar*npar,ifp) wy = stkget(n,ifp) xmw = stkget(n*npar,ifp) red = stkget(npar,ifp) t = stkget(npar*npar,ifp) par1 = stkget(npar,ifp) acc = stkget(npar,ifp) c = stkget(npar,ifp) ! ! equivalenced locations within scrat ! fc = xmw ! ! Set up weight vector. ! if (weight) then call scopy(n, wt, 1, rstak(wti), 1) else call setrv(rstak(wti), n, 1.0e0) end if call llsmn(y, xm, rstak(wti), n, m, npar, ixm, rstak(resi), & rstak(pari), nnzw, rstak(rsdi), rstak(pvi), rstak(sdpvi), & rstak(sdresi), iptout, rstak(wy), rstak(xmw), rstak(vcvi), & rstak(fc), rstak(red), rstak(t), rstak(par1), rstak(acc), ifit, & weight, rstak(c), llhdr, page, wide) call scopy(n, rstak(resi), 1, res, 1) if (save) then rsd = rstak(rsdi) call scopy(npar, rstak(pari), 1, par, 1) call scopy(n, rstak(pvi), 1, pv, 1) call scopy(n, rstak(sdpvi), 1, sdpv, 1) call scopy(n, rstak(sdresi), 1, sdres, 1) call cpymss(npar, npar, rstak(vcvi), npar, vcv, ivcv) end if call stkclr(nall0) if (ierr == 3) ierr = 2 if (ierr == 4) ierr = 3 return end subroutine llcntg ( y, wt, lwt, xm, n, ixm, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save ) !*****************************************************************************80 ! !! LLCNTG is the controlling subroutine for general linear least squares. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ifit ! the indicator value designating whether the lls is of a ! general model (ifit=3) or a polynomial model (ifit=1). ! integer ivcv ! the first dimension of the matrix vcv. ! integer ixm ! the first dimension of the matrix xm. ! integer ldstak ! the length of the vector dstak in common cstak. ! external llhdrg ! the name of the routine that produced the heading. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(lpar) ! the parameters to be estimated. ! real pv(lpv) ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(lwt) ! the weights (a dummy vector in the unweighted case). ! real xm(ixm,m) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none real & rsd integer & ivcv,ixm,ldstak,lpar,lpv,lsdpv,lsdres,lwt,n,npar,nprt logical & save,weight ! ! array arguments real & par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & ifit,m ! ! external subroutines external llcnt,llhdrg ! ! common blocks common /cstak/dstak common /errchk/ierr ifit = 3 m = npar call llcnt(y, wt, lwt, xm, n, m, ixm, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & llhdrg, ifit, nmsub, weight, save) return end subroutine llcntp ( y, wt, lwt, xm, n, ndeg, npar, res, ldstak, & nprt, par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, & ivcv, nmsub, weight, save ) !*****************************************************************************80 ! !! LLCNTP is the controlling subroutine for polynomial linear least squares. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ifit ! the indicator value designating whether the lls is of a ! general model (ifit=3) or a polynomial model (ifit=1). ! integer ivcv ! the first dimension of the matrix vcv. ! integer ixm ! the first dimension of the matrix xm. ! integer ldstak ! the length of the vector dstak in common cstak. ! external llhdrp ! the name of the routine that produced the heading. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer ndeg ! the degree of the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(lpar) ! the parameters to be estimated. ! real pv(lpv) ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(lwt) ! the weights (a dummy vector in the unweighted case). ! real xm(n,1) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none real & rsd integer & ivcv,ldstak,lpar,lpv,lsdpv,lsdres,lwt,n,ndeg,npar,nprt logical & save,weight ! ! array arguments real & par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & ifit,ixm,m ! ! external subroutines external llcnt,llhdrp ! ! common blocks common /cstak/dstak common /errchk/ierr ifit = 1 npar = ndeg + 1 m = 1 ixm = n call llcnt(y, wt, lwt, xm, n, m, ixm, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & llhdrp, ifit, nmsub, weight, save) return end subroutine ller ( nmsub, ixm, ivcv, n, npar, lpar, ldstak, wt, lnwt, & weight, nnzw, ifit, save ) !*****************************************************************************80 ! !! LLER is the error checking routine for the linear least squares routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! logical error(10) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifit ! the indicator value designating whether the lls is of a ! general model (ifit=3) or a polynomial model (ifit=1). ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array. ! integer ldstak ! the length of the array dstak. ! integer ldsmin ! the minimum length allowed for the array dstak. ! character*1 livcv(8), lixm(8), llpar(8), llds(8), ln(8), lnc(8), ! * lndeg(8), lndeg1(8), lnpar(8), ln1(8), lone(8), lwt(8), ! * lzero(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer lpar ! the actual length of the vector p. ! integer lnwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! integer npar ! the number of unknown parameters in the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer nzw ! the number of zero weights. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(lnwt) ! the user supplied weights. ! implicit none integer & ifit,ivcv,ixm,ldstak,lnwt,lpar,n,nnzw,npar logical & save,weight ! ! array arguments real & wt(lnwt) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i,ldsmin,nzw logical & head ! ! local arrays logical & error(10) character & livcv(8)*1,lixm(8)*1,llds(8)*1,llpar(8)*1,ln(8)*1, & ln1(8)*1,lnc(8)*1,lndeg(8)*1,lndeg1(8)*1,lnpar(8)*1, & lone(8)*1,lwt(8)*1,lzero(8)*1 ! ! external subroutines external eisge,eisii,ervwt,ldscmp ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data livcv(1), livcv(2), livcv(3), livcv(4), livcv(5), livcv(6), & livcv(7), livcv(8) /'i','v','c','v',' ',' ',' ',' '/ data lixm(1), lixm(2), lixm(3), lixm(4), lixm(5), lixm(6), & lixm(7), lixm(8) /'i','x','m',' ',' ',' ',' ',' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data llpar(1), llpar(2), llpar(3), llpar(4), llpar(5), llpar(6), & llpar(7), llpar(8) /'l','p','a','r',' ',' ',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lndeg(1), lndeg(2), lndeg(3), lndeg(4), lndeg(5), lndeg(6), & lndeg(7), lndeg(8) /'n','d','e','g',' ',' ',' ',' '/ data lndeg1(1), lndeg1(2), lndeg1(3), lndeg1(4), lndeg1(5), & lndeg1(6), lndeg1(7), lndeg1(8) /'n','d','e','g','+','1', & ' ',' '/ data lnpar(1), lnpar(2), lnpar(3), lnpar(4), lnpar(5), & lnpar(6), lnpar(7), lnpar(8) /'n','p','a','r',' ',' ',' ', & ' '/ data ln1(1), ln1(2), ln1(3), ln1(4), ln1(5), ln1(6), & ln1(7), ln1(8) /'n','-','1',' ',' ',' ',' ',' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), & lone(7), lone(8) /'o','n','e',' ',' ',' ',' ',' '/ data lwt(1), lwt(2), lwt(3), lwt(4), lwt(5), lwt(6), lwt(7), & lwt(8) /'w','t',' ',' ',' ',' ',' ',' '/ data lzero(1), lzero(2), lzero(3), lzero(4), lzero(5), lzero(6), & lzero(7), lzero(8) /'z','e','r','o',' ',' ',' ',' '/ ierr = 0 head = .true. error(1:10) = .false. if ( ifit /= 1 ) then lnc(1:8) = lnpar(1:8) else lnc(1:8) = lndeg1(1:8) end if call eisge(nmsub, ln, n, 1, 1, head, error(1), ln) if (ifit == 3) then call eisii(nmsub, lnpar, npar, 1, n, 1, head, error(2), lone, & ln) end if if (ifit == 1) & call eisii(nmsub, lndeg, npar-1, 0, n-1, 1, head, error(2), & lzero, ln1) call eisge(nmsub, lixm, ixm, n, 3, head, error(4), ln) if (save .and. (ifit == 1)) & call eisge(nmsub, llpar, lpar, npar, 7, head, error(5), lndeg1) if (save) & call eisge(nmsub, livcv, ivcv, npar, 3, head, error(6), lnc) if (error(1) .or. error(2) .or. error(3)) then ierr = 1 return end if nnzw = n if (weight) call ervwt(nmsub, lwt, wt, n, npar, head, nnzw, & nzw, 2, error(8), lnc) call ldscmp(15, 0, 0, 0, 0, 0, 's', & 6*n + npar*(n+2*npar+5) + 1, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(9), llds) do i=1,10 if ( error(i) ) then ierr = 1 return end if end do return end subroutine llhdrg ( page, wide, isubhd ) !*****************************************************************************80 ! !! LLHDRG: page headings for the unrestricted linear least squares routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! implicit none integer & isubhd logical & page,wide ! ! external subroutines external versp if (page) write ( *,1020) call versp(wide) if (page) write ( *,1000) if (.not.page) write ( *,1010) page = .true. if (isubhd == 0) return write ( *,1030) return 1000 format ('+linear least squares estimation', & ' with user-specified model, continued') 1010 format ('+', 63('*')/ & 1x, '* linear least squares estimation', & ' with user-specified model *'/ 1x, 63('*')) 1020 format ('1') 1030 format (//' summary of initial conditions'/ 1x, 30('-')) end subroutine llhdrp ( page, wide, isubhd ) !*****************************************************************************80 ! !! LLHDRP: page headings for polynomial linear least squares routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! implicit none integer & isubhd logical & page,wide ! ! external subroutines external versp if (page) write ( *,1020) call versp(wide) if (page) write ( *,1000) if (.not.page) write ( *,1010) page = .true. if (isubhd == 0) return write ( *,1030) return 1000 format ('+linear least squares estimation', & ' with polynomial model, continued') 1010 format ('+', 59('*')/ & 1x, '* linear least squares estimation', & ' with polynomial model *'/ 1x, & 59('*')) 1020 format ('1') 1030 format (//' summary of initial conditions'/ 1x, 30('-')) end subroutine lls ( y, xm, n, ixm, npar, res, ldstak ) !*****************************************************************************80 ! !! LLS is the general linear model least squares fit routine. ! ! Discussion: ! ! call for general linear model least squares fit ! no weights specified ! no storage other than residuals ! four pages automatic printout ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ixm ! the first dimension of the matrix xm. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(1) ! a dummy array for ! the parameters to be estimated. ! real pv(1) ! a dummy array for ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(1) ! a dummy array for ! the standard deviations of the predicted values. ! real sdres(1) ! a dummy array for ! the standardized residuals. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! a dummy array for ! the weights. ! real xm(ixm,npar) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none integer & ixm,ldstak,n,npar ! ! array arguments real & res(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & rsd integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,nprt logical & save,weight ! ! local arrays real & par(1),pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1) character & nmsub(6)*1 ! ! external subroutines external llcntg ! ! common blocks common /cstak/dstak common /errchk/ierr ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s',' ',' ',' '/ weight = .false. save = .false. nprt = 1111 lpar = 1 lpv = 1 lsdpv = 1 lsdres = 1 ivcv = 1 lwt = 1 call llcntg(y, wt, lwt, xm, n, ixm, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if (ierr /= 1) return write ( *,1000) return 1000 format (//' the correct form of the call statement is'// & ' call lls (y, xm, n, ixm, npar, res, lsdtak)') end subroutine llsmn ( y, x, wt, n, m, npar, ix, res, par, nnzw, & rsd, pv, sdpv, sdres, iptout, wy, xw, vcv, fc, red, & t, par1, acc, ifit, weight, c, llhdr, page, wide ) !*****************************************************************************80 ! !! LLSMN: main program for the linear least squares fitting. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real acc(npar) ! the number of accurate digits. ! real c(npar) ! a work vector. ! real cond ! the condition number of the design matrix. ! logical const ! an indicator value designating whether the first column of ! the design matrix is all ones for a constant. ! real det(2) ! the determinent. ! real df ! the degrees of freedom. ! real fc(n,npar) ! the orthonormalization matrix. ! real fplm ! the floating point largest magnitude. ! real fplrs ! the floating point largest relative spacing. ! real fpspm ! the floating point smallest positive magnitude. ! integer i ! an index. ! integer idf ! the degrees of freedom ! integer idf1 ! the degrees of freedom for the fit without the last independent ! variable. ! integer ier ! the error flag returned by the inversion routines. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ifit ! the indicator value designating whether the fit is of a ! general model (ifit=3) or a polynomial model (ifit=1). ! integer iptout(4) ! the variable used to control printed output for each section. ! integer irefit ! an indicator used to designate whether the fit is of the ! full design matrix (irefit=0) or is omitting the last ! independent variable (irefit=1). ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer ix ! the first dimension of the matrix x. ! external llhdr ! the name of the routine that produced the heading. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer nc ! the number of parameters being fit. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the parameters to be estimated. ! real par1(npar) ! the parameters to be estimated ommitting the last ! independent variable. ! real probt ! ... ! real probt1 ! ... ! real pv(n) ! the predicted values. ! real px ! a work variable. ! real ratio ! the ratio of the parameters to their standard deviations. ! real ratio1 ! the ratio of the parameters computed omitting the last ! independent variable to their standard deviations. ! real red(npar) ! the reduction to the sum of squares due to each parameter. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! real rsd1 ! the residual standard deviation from the fit omitting ! the last independent variable. ! real rss ! the residual sum of squares. ! real rss1 ! the residual sum of squares from the fit omitting ! the last independent variable. ! real rvar ! the residual variance. ! real rvar1 ! the residual variance from the fit omitting ! the last independent variable. ! real r2 ! the multiple correlation parameter. ! real sdc ! the estimated standard deviations of the parameters. ! real sdc1 ! the estimated standard deviations of the parameters omitting ! the last independent variable. ! real sdpv(n) ! the standard deviations of the predicted values. ! real sdres(n) ! the standardized residuals. ! real sm ! a work variable. ! real t(npar,npar) ! the triangular matrix from the decomposition. ! real td ! a work variable. ! real vcv(npar,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(n) ! the weights (a dummy vector in the unweighted case). ! real wtsqrt ! the square root of the weight. ! real wtsum ! the sum of the weights. ! real wtym ! the sum of the weighted dependent variables. ! real wy(n) ! the vector containing sqrt(wt)*y. ! real x(ix,m) ! the independent variable. ! real xw(n,npar) ! the matrix containing x * sqrt(wt). ! real y(n) ! the dependent variable. ! real ysum ! the sum of the weighted dependent variables squared. ! implicit none real & rsd integer & ifit,ix,m,n,nnzw,npar logical & page,weight,wide ! ! array arguments real & acc(npar),c(npar),fc(n,npar),par(npar),par1(npar),pv(n), & red(npar),res(n),sdpv(n),sdres(n),t(npar,npar), & vcv(npar,npar),wt(n),wy(n),x(ix,m),xw(n,npar),y(n) integer & iptout(4) ! ! subroutine arguments external llhdr ! ! scalars in common integer & ierr ! ! real & cond,df,fplm,fplrs,fpspm,probt,probt1,px,r2,ratio,ratio1, & rsd1,rss,rss1,rvar,rvar1,sdc,sdc1,sm,td,wtsqrt,wtsum,wtym,ysum integer & i,idf,idf1,ier,irefit,isubhd,j,k,nc logical & const ! ! local arrays real & det(2) ! ! external functions real & cdft external cdft ! ! external subroutines external accdig,fitpt1,fitpt2,mgs,oanova,vcvout ! ! common blocks common /errchk/ierr fplm = huge ( fplm ) fplrs = epsilon ( fplrs ) fpspm = tiny ( fpspm ) nc = npar idf = nnzw - nc df = real ( idf ) r2 = 0.0 rvar1 = 0.0 rsd1 = 0.0 j = 0 idf1 = 0 const = .false. ysum = 0.0e0 wtsum = 0.0e0 do i=1,n if ( 0.0E+00 < wt(i) ) then ysum = ysum + wt(i)*y(i)*y(i) wtsum = wtsum + wt(i) end if end do ! ! begin fit ! irefit = -1 ! ! if irefit is equal to 1 fit is omitting the last variable ! 50 irefit = irefit + 1 ! ! compute working vectors ! wtym = 0.0e0 i = 0 do k=1,n if (wt(k) <= 0.0e0) then cycle end if wtsqrt = sqrt(wt(k)) i = i + 1 px = wtsqrt do j=1,nc if (ifit == 1 .and. j >= 2) px = px*x(k,1) if (ifit == 3) px = x(k,j)*wtsqrt xw(i,j) = px end do ! ! compute wy ( weights * y vector ) ! wy(i) = y(k)*wtsqrt wtym = wtym + wt(k)*y(k) end do wtym = wtym/wtsum ! ! compute estimated values of parameters ! if (irefit == 1) go to 80 ier = 0 call mgs(xw, wy, nnzw, nc, par, c, t(1,1), t, npar, n, ier) if (ier == 0) go to 90 ierr = 3 isubhd = 0 call llhdr(page, wide, isubhd) write ( *,1160) write ( *,1150) return 80 continue ier = 0 call mgs(xw, wy, nnzw, nc, par1, c, t(1,1), t, npar, n, ier) ! ! compute predicted values (pv) and residuals (res) ! residual sum of squares (rss) and ! residual standard deviation (rsd) and ! sum of weights (wtsum) and ! residual varaince (rvar) ! 90 rss = 0.0e0 rss1 = 0.0e0 do i=1,n sm = 0.0e0 px = 1.0e0 do j=1,nc if (ifit == 1 .and. j >= 2) px = px*x(i,1) if (ifit == 3) px = x(i,j) if (irefit == 0) sm = sm + par(j)*px if (irefit == 1) sm = sm + par1(j)*px end do if (irefit == 0) then pv(i) = sm res(i) = y(i) - pv(i) rss = rss + res(i)*wt(i)*res(i) else rss1 = rss1 + (y(i)-sm)*wt(i)*(y(i)-sm) end if end do if (irefit == 0) go to 130 rvar1 = rss1/(df+1.0e0) rsd1 = sqrt(rvar1) go to 380 130 rvar = 0.0e0 if (df > 0.0e0) rvar = rss/df rsd = sqrt(rvar) ! ! compute multiple correlation parameter squared (r2) ! sm = 0.0e0 const = .true. do i=1,n if ((x(i,1) /= 1.0e0) .and. (ifit == 3)) const = .false. sm = sm + (y(i)-wtym)*wt(i)*(y(i)-wtym) end do r2 = 1.0e0 if (sm > 0.0e0) r2 = 1.0e0-rss/sm ! ! check for -exact- fit ! td = 0.0e0 if (df > 0.0e0) td = sqrt(rss) if (ysum > 0.0e0) td = td/sqrt(ysum) if (td > 10.0e0*fplrs) go to 180 ierr = 0 if ((iptout(1) == 0) .and. (iptout(2) == 0) .and. (iptout(3) == 0) & .and. (iptout(4) == 0)) go to 145 isubhd = 0 call llhdr(page, wide, isubhd) write ( *,1180) write ( *,1020) (i,par(i),i=1,npar) ! ! zero out vcv matrix and sdres and sdpv vectors ! 145 continue sdpv(1:n) = 0.0e0 sdres(1:n) = 0.0e0 vcv(1:npar,1:npar) = 0.0e0 return 180 continue ! ! compute orthonormalization ! do i=1,nc t(i,i) = sqrt(t(i,1)) do j=i,nc if ( i /= j) then t(i,j) = t(i,j)*t(i,i) end if end do end do call strco ( t, npar, nc, cond, c, 1 ) if ( cond /= 0.0e0 ) then cond = 1.0e0/cond else cond = fplm end if call strdi ( t, npar, nc, det, 011, ier ) if (ier /= 0) then ierr = 3 isubhd = 0 call llhdr(page, wide, isubhd) write ( *,1160) write ( *,1120) return end if ! 210 continue do i=1,n do j=1,nc sm = 0.0e0 px = 1.0e0 do k=1,j if (ifit == 1 .and. k >= 2) px = px*x(i,1) if (ifit == 3) px = x(i,k) sm = sm + px*t(k,j) end do fc(i,j) = sm end do end do ! ! compute reduction to rss due to fitting ! do j=1,nc sm = 0.0e0 do i=1,n sm = sm + (fc(i,j))*wt(i)*y(i) end do red(j) = (sm*sm) end do ! ! compute estimated variance covariance matrix ! do i=1,nc do j=i,nc sm = 0.0e0 do k=j,nc sm = sm + t(i,k)*t(j,k) end do if (sqrt(abs(sm))*sqrt(rvar) >= sqrt(fpspm)) then vcv(i,j) = sm*rvar else vcv(i,j) = 0.0e0 end if vcv(j,i) = vcv(i,j) end do end do ! ! refit to predicted values ! i = 0 do k=1,n if (wt(k) <= 0.0e0) then cycle end if wtsqrt = sqrt(wt(k)) i = i + 1 px = wtsqrt do j=1,nc if (ifit == 1 .and. j >= 2) px = px*x(k,1) if (ifit == 3) px = x(k,j)*wtsqrt xw(i,j) = px end do wy(i) = pv(k)*wtsqrt end do ier = 0 call mgs(xw, wy, nnzw, nc, par1, c, t(1,1), t, npar, n, ier) call accdig(par, par1, acc, nc) ! ! compute standard deviation of predicted values (sdpv) ! and standardized residuals (sdres) ! do i=1,n sm = 0.0e0 do j=1,nc sm = 0.0e0 px = 1.0e0 do k=1,nc if (ifit == 1 .and. k >= 2) px = px*x(i,1) if (ifit == 3) px = x(i,k) sm = sm + px*vcv(j,k) end do xw(i,j) = sm end do sm = 0.0e0 px = 1.0e0 do k=1,nc if (ifit == 1 .and. k >= 2) px = px*x(i,1) if (ifit == 3) px = x(i,k) sm = sm + xw(i,k)*px end do sm = max(0.0e0, sm) sdpv(i) = sqrt(sm) sdres(i) = fplm if ( 0.0 < wt(i) ) then if ((rvar/wt(i)-sm) <= 0.0e0) ierr = 4 if (rvar/wt(i)-sm > 0.0e0) & sdres(i) = (res(i)/sqrt(rvar/wt(i)-sm)) end if end do ! ! check for printed output ! if ((iptout(1) == 0) .and. (iptout(2) == 0) .and. & (iptout(3) == 0) .and. (iptout(4) == 0)) return ! ! begin printed output ! ! print first page of output ! if ( iptout(1) /= 0 ) then isubhd = 0 call llhdr(page, wide, isubhd) call fitpt1(n, m, x, y, pv, sdpv, res, sdres, wt, ix, nnzw, & weight, iptout(1)) end if ! ! print plots ! if ( iptout(2) /= 0 ) then isubhd = 0 call llhdr(page, wide, isubhd) call fitpt2 (sdres, pv, wt, n, nnzw, weight, res, rss) end if ! ! print analysis of variance ! if (iptout(3) /= 0) then isubhd = 0 call llhdr(page, wide, isubhd) call oanova(ysum, red, npar, rvar, nnzw, par1 ) end if if (iptout(4) == 0) then return end if if (npar == 1) go to 450 nc = nc - 1 idf1 = nnzw - nc go to 50 380 continue do i=1,nc t(i,i) = sqrt(t(i,1)) do j=i,nc if ( i /= j ) then t(i,j) = t(i,j)*t(i,i) end if end do end do call strdi(t, npar, nc, det, 011, ier) if (ier == 0) go to 420 write ( *,1140) par1(1:nc) = 0.0e0 do i=1,nc t(i,i) = 0.0e0 end do go to 450 420 continue do i=1,nc sm = 0.0e0 do k=i,nc sm = sm + t(i,k)*t(i,k) end do t(i,i) = sm end do ! ! print page headings ! 450 continue isubhd = 0 call llhdr(page, wide, isubhd) ! ! print variance covariance matrix ! call vcvout(npar, vcv, npar, .true.) write ( *,1030) if (npar > 1) write ( *,1040) write ( *,1050) if (npar > 1) write ( *,1060) write ( *, 1170) if (npar >= 2) then do i=1,nc sdc = sqrt(vcv(i,i)) ratio = fplm probt = 0.0e0 if (sdc > 0.0e0) ratio = par(i)/sdc if (sdc > 0.0e0) & probt = (1.0e0-cdft(abs(ratio), nnzw-npar)) * 2.0e0 sdc1 = sqrt(t(i,i))*sqrt(rvar1) ratio1 = fplm probt1 = 0.0e0 if (sdc1 > 0.0e0) ratio1 = par1(i)/sdc1 if (sdc1 > 0.0e0) & probt1 = (1.0e0 - cdft(abs(ratio1), nnzw-npar+1)) * 2.0e0 write ( *,1070) i, par(i), sdc, ratio, probt, acc(i), & par1(i), sdc1, ratio1, probt1 end do end if sdc = sqrt(vcv(npar,npar)) ratio = fplm probt = 0.0e0 if (sdc > 0.0e0) ratio = par(npar)/sdc if (sdc > 0.0e0) & probt = (1.0e0 - cdft(abs(ratio), nnzw-npar)) * 2.0e0 write ( *,1070) npar, par(npar), sdc, ratio, probt, acc(npar) if (npar == 1) write ( *,1080) rsd if (npar > 1) write ( *,1080) rsd, rsd1 write ( *,1090) nnzw, npar, idf if (npar > 1) write ( *,1100) nnzw, nc, idf1 if (const) write ( *,1010) r2 write ( *,1000) cond write ( *,1110) return 1000 format (/' approximate condition number', 10x, g15.7) 1010 format (/' multiple correlation coefficient squared ', f7.4) 1020 format (//' the values computed for the parameters are - '/(5x, & 'par(', i3, ') = ', g15.7)) 1030 format (////1x, 25('-'), 1x, 'estimates from fit', 1x, 24('-')) 1040 format ('+', 72x, 4('-'), 1x, & 'estimates from fit omitting last predictor value', 1x, & 4('-')) 1050 format (/2x, 'estimated parameter', 7x, 'sd of par', 5x, & 't(par=0)', 3x, 'prob(t)', 2x, 'acc dig*') 1060 format ('+', 72x, 'estimated parameter', 7x, 'sd of par', 5x, & 't(par=0)', 3x, 'prob(t)') 1070 format (1x, i3, 2x, g16.9, 3x, g16.9, 2x, g10.4, 1x, f5.3, 2x, & f7.1, 9x, g16.9, 3x, g16.9, 2x, g10.4, 1x, f5.3) 1080 format (//1x, 'residual standard deviation ', 9x, g15.7, 56x, & g15.7) 1090 format (1x, 'based on degrees of freedom', 7x, i4, ' - ', i2, & ' = ', i4) 1100 format ('+', 105x, i4, ' - ', i2, ' = ', i4) 1110 format (//' * the number of correctly computed digits in each p', & 'arameter usually differs by less than 1 from the value g', & 'iven here.') 1120 format (/' the program was unable to compute the variance', & '-covariance matrix.'/ & ' the design matrix is either nearly singular or very', & ' ill conditioned.'/ & ' check your input for errors.') 1140 format ('0estimates for the standard deviation of the estimated', & 'parameters omitting the last independent variable could'/ & ' not be computed. the zeros printed for the estimates of t', & 'he parameters, their standard deviations and their'/ & ' ratios for the fit omitting the last variable are meaningl', & 'ess.') 1150 format (/' the design matrix is singular', & ' to within machine precision.'/ & ' check the design matrix for a linear relationship', & ' between some of the columns.') 1160 format (//1x, 11('*')/ 1x, '* error *'/ 1x, 11('*')) 1170 format (' ') 1180 format (/' the least squares fit of the data to the model is', & ' exact to within machine precision.'/ & ' statistical analysis is not possible.') end subroutine llsp ( y, xm, n, ndeg, res, ldstak ) !*****************************************************************************80 ! !! LLSP does an unweighted polynomial model least squares fit. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! integer ndeg ! the degree of the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(1) ! a dummy array for ! the parameters to be estimated. ! real pv(1) ! a dummy array for ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(1) ! a dummy array for ! the standard deviations of the predicted values. ! real sdres(1) ! a dummy array for ! the standardized residuals. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! a dummy array for ! the weights. ! real xm(n,1) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none integer & ldstak,n,ndeg ! ! array arguments real & res(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & rsd integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,npar,nprt logical & save,weight ! ! local arrays real & par(1),pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1) character & nmsub(6)*1 ! ! common blocks common /cstak/dstak common /errchk/ierr ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s','p',' ',' '/ weight = .false. save = .false. nprt = 1111 lpar = 1 lpv = 1 lsdpv = 1 lsdres = 1 ivcv = 1 lwt = 1 call llcntp(y, wt, lwt, xm, n, ndeg, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if (ierr /= 1) return write ( *,1000) return 1000 format (//' the correct form of the call statement is'// & ' call llsp (y, x, n, ndeg, res, lsdtak)') end subroutine llsps ( y, xm, n, ndeg, res, ldstak, & nprt, lpar, par, npar, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! LLSPS does an unweighted polynomial model least squares fit. ! ! Discussion: ! ! call for polynomial model least squares fit ! no weights specified ! full storage ! user control of automatic printout ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! integer ndeg ! the degree of the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(lpar) ! the parameters to be estimated. ! real pv(n) ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(n) ! the standard deviations of the predicted values. ! real sdres(n) ! the standardized residuals. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the weights (a dummy vector in the unweighted case). ! real xm(n,1) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none real & rsd integer & ivcv,ldstak,lpar,n,ndeg,npar,nprt ! ! array arguments real & par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer lpv,lsdpv,lsdres,lwt logical & save,weight ! ! local arrays real & wt(1) character & nmsub(6)*1 ! ! external subroutines external llcntp ! ! common blocks common /cstak/dstak common /errchk/ierr ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s','p','s',' '/ weight = .false. save = .true. lpv = n lsdpv = n lsdres = n lwt = 1 call llcntp(y, wt, lwt, xm, n, ndeg, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if (ierr /= 0 ) then write ( *,1000) end if return 1000 format (//' the correct form of the call statement is'// & ' call llsps (y, x, n, ndeg, res, lsdtak,'/ & ' + nprt, lpar, par, npar, rsd, pv, sdpv,'/ & ' + sdres, vcv, ivcv)') end subroutine llspw ( y, wt, xm, n, ndeg, res, ldstak ) !*****************************************************************************80 ! !! LLSPW does a weighted polynomial model least squares fit. ! ! Discussion: ! ! call for polynomial model least squares fit ! user supplied weights specified ! no storage other than residuals ! four pages automatic printout ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! integer ndeg ! the degree of the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(1) ! a dummy array for ! the parameters to be estimated. ! real pv(1) ! a dummy array for ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(1) ! a dummy array for ! the standard deviations of the predicted values. ! real sdres(1) ! a dummy array for ! the standardized residuals. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! a dummy array for ! the weights. ! real xm(n,1) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none integer & ldstak,n,ndeg ! ! array arguments real & res(*),wt(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & rsd integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,npar,nprt logical & save,weight ! ! local arrays real & par(1),pv(1),sdpv(1),sdres(1),vcv(1,1) character & nmsub(6)*1 ! ! external subroutines external llcntp ! ! common blocks common /cstak/dstak common /errchk/ierr ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s','p','w',' '/ weight = .true. save = .false. nprt = 1111 lpar = 1 lpv = 1 lsdpv = 1 lsdres = 1 ivcv = 1 lwt = n call llcntp(y, wt, lwt, xm, n, ndeg, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if (ierr /= 0) then write ( *,1000) end if return 1000 format (//' the correct form of the call statement is'// & ' call llspw (y, wt, x, n, ndeg, res, lsdtak)') end subroutine llspws ( y, wt, xm, n, ndeg, res, ldstak, & nprt, lpar, par, npar, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! LLSPWS computes a weighted polynomial model least squares fit. ! ! Discussion: ! ! call for polynomial model least squares fit ! user supplied weights specified ! full storage ! user control of automatic printout ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! integer ndeg ! the degree of the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(lpar) ! the parameters to be estimated. ! real pv(n) ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(n) ! the standard deviations of the predicted values. ! real sdres(n) ! the standardized residuals. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights (a dummy vector in the unweighted case). ! real xm(n,1) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none real & rsd integer & ivcv,ldstak,lpar,n,ndeg,npar,nprt ! ! array arguments real & par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer lpv,lsdpv,lsdres,lwt logical & save,weight ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external llcntp ! ! common blocks common /cstak/dstak common /errchk/ierr ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s','p','w','s'/ weight = .true. save = .true. lpv = n lsdpv = n lsdres = n lwt = n call llcntp(y, wt, lwt, xm, n, ndeg, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if (ierr /= 1) return write ( *,1000) return 1000 format (//' the correct form of the call statement is'// & ' call llspws (y, wt, x, n, ndeg, res, lsdtak,'/ & ' + nprt, lpar, par, npar, rsd, pv, sdpv,'/ & ' + sdres, vcv, ivcv)') end subroutine llss ( y, xm, n, ixm, npar, res, ldstak, & nprt, par, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! LLSS computes an unweighted linear model least squares fit. ! ! Discussion: ! ! call for general linear model least squares fit ! no weights specified ! full storage ! user control of automatic printout ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ixm ! the first dimension of the matrix xm. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(npar) ! the parameters to be estimated. ! real pv(n) ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(n) ! the standard deviations of the predicted values. ! real sdres(n) ! the standardized residuals. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the weights (a dummy vector in the unweighted case). ! real xm(ixm,npar) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none real & rsd integer & ivcv,ixm,ldstak,n,npar,nprt ! ! array arguments real & par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer lpar,lpv,lsdpv,lsdres,lwt logical & save,weight ! ! local arrays real & wt(1) character & nmsub(6)*1 ! ! common blocks common /cstak/dstak common /errchk/ierr ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s','s',' ',' '/ weight = .false. save = .true. lpar = npar lpv = n lsdpv = n lsdres = n lwt = 1 call llcntg(y, wt, lwt, xm, n, ixm, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if ( ierr /= 0) then write ( *,1000) end if return 1000 format (//' the correct form of the call statement is'// & ' call llss (y, xm, n, ixm, npar, res, lsdtak,'/ & ' + nprt, par, rsd, pv, sdpv, sdres, vcv, ivcv)') end subroutine llsw ( y, wt, xm, n, ixm, npar, res, ldstak ) !*****************************************************************************80 ! !! LLSW computes a weighted linear model least squares fit. ! ! Discussion: ! ! call for general linear model least squares fit ! user supplied weights specified ! no storage other than residuals ! four pages automatic printout ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ixm ! the first dimension of the matrix xm. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(1) ! a dummy array for ! the parameters to be estimated. ! real pv(1) ! a dummy array for ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(1) ! a dummy array for ! the standard deviations of the predicted values. ! real sdres(1) ! a dummy array for ! the standardized residuals. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! a dummy array for ! the weights. ! real xm(ixm,npar) ! the independent variable. ! real y(n) ! the dependent variable. ! implicit none integer & ixm,ldstak,n,npar ! ! array arguments real & res(*),wt(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & rsd integer ivcv,lpar,lpv,lsdpv,lsdres,lwt,nprt logical & save,weight ! ! local arrays real & par(1),pv(1),sdpv(1),sdres(1),vcv(1,1) character & nmsub(6)*1 ! ! external subroutines external llcntg ! ! common blocks common /cstak/dstak common /errchk/ierr data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s','w',' ',' '/ weight = .true. save = .false. nprt = 1111 lpar = 1 lpv = 1 lsdpv = 1 lsdres = 1 ivcv = 1 lwt = n call llcntg(y, wt, lwt, xm, n, ixm, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if (ierr /= 1) return write ( *,1000) return 1000 format (//' the correct form of the call statement is'// & ' call llsw (y, wt, xm, n, ixm, npar, res, lsdtak)') end subroutine llsws ( y, wt, xm, n, ixm, npar, res, ldstak, & nprt, par, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! LLSWS performs a general linear model weighted least squares fit. ! ! Discussion: ! ! call for general linear model least squares fit ! user supplied weights specified ! full storage ! user control of automatic printout ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value designating whether any errors were ! detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ivcv ! the first dimension of the matrix vcv. ! integer ixm ! the first dimension of the matrix xm. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpar ! the actual length of the vector p. ! integer lpv ! the actual length of the vector pv. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters. ! integer nprt ! the indicator variable used to designate the amount of ! printed output. ! real par(npar) ! the parameters to be estimated. ! real pv(n) ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! logical save ! the variable used to indicate whether any results other than ! the residuals are to ve saved (true) or not (false). ! real sdpv(n) ! the standard deviations of the predicted values. ! real sdres(n) ! the standardized residuals. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights (a dummy vector in the unweighted case). ! real xm(ixm,npar) ! the independent variable. ! real y(n) ! the dependent variable. ! ! implicit none real & rsd integer & ivcv,ixm,ldstak,n,npar,nprt ! ! array arguments real & par(*),pv(*),res(*),sdpv(*),sdres(*),vcv(*),wt(*),xm(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer lpar,lpv,lsdpv,lsdres,lwt logical & save,weight ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external llcntg ! ! common blocks common /cstak/dstak common /errchk/ierr data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'l','l','s','w','s',' '/ weight = .true. save = .true. lpar = npar lpv = n lsdpv = n lsdres = n lwt = n call llcntg(y, wt, lwt, xm, n, ixm, npar, res, ldstak, nprt, & par, lpar, rsd, pv, lpv, sdpv, lsdpv, sdres, lsdres, vcv, ivcv, & nmsub, weight, save) if (ierr /= 1) return write ( *,1000) return 1000 format (//' the correct form of the call statement is'// & ' call llsws (y, wt, xm, n, ixm, npar, res, lsdtak,'/ & ' + nprt, par, rsd, pv, sdpv, sdres, vcv, ivcv)') end subroutine lmstep ( d, g, ierr, ipivot, ka, p, qtr, r, step, v, w ) !*********************************************************************** ! !! LMSTEP computes a Levenberg-Marquardt step by More-Hebden techniques. ! ! Discussion: ! ! Given the R matrix from the QR decomposition of a jacobian ! matrix, J, as well as Q' times the corresponding ! residual vector, RESID, this subroutine computes a Levenberg- ! Marquardt step of approximate length V(RADIUS) by the More ! technique. ! ! If it is desired to recompute step using a different value of ! V(RADIUS), then this routine may be restarted by calling it ! with all parameters unchanged except V(RADIUS). This explains ! why many parameters are listed as I/O. On an initial call ! with KA = -1, the caller need only have initialized D, G, KA, P, ! QTR, R, V(EPSLON), V(PHMNFC), V(PHMXFC), V(RADIUS), and V(RAD0). ! ! This code implements the step computation scheme described in ! refs. 2 and 4. Fast Givens transformations (see reference 3, ! pages 60-62) are used to compute step with a nonzero Marquardt ! parameter. ! ! A special case occurs if J is nearly singular and V(RADIUS) ! is sufficiently large. In this case the step returned is such ! that twonorm(R)**2 - twonorm(R - J * STEP)**2 differs from its ! optimal value by less than V(EPSLON) times this optimal value, ! where J and R denote the original jacobian and residual. See ! reference 2 for more details. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! ! David Gay, ! Computing Optimal Locally Constrained Steps, ! SIAM Journal on Scientific and Statistical Computing, ! Volume 2, Number 2, pages 186-197, 1981. ! ! Charles Lawson, Richard Hanson, ! Solving Least Squares Problems, ! Prentice Hall, 1974. ! ! Jorge More, ! The Levenberg-Marquardt Algorithm, Implementation and Theory, ! in Springer Lecture Notes in Mathematics, Number 630, ! edited by G A Watson, ! Springer Verlag, Berlin and New York, pages 105-116, 1978. ! ! Parameters: ! ! Input, real D(P), the scale vector. ! ! Input, real G(P), the gradient vector J'*R. ! ! ierr (i/o) = return code from QRFACT or QRFGS -- 0 means r has ! full rank. ! ! ipivot (i/o) = permutation array from QRFACT or QRFGS, which compute ! qr decompositions with column pivoting. ! ! ka (i/o). ka < 0 on input means this is the first call on ! lmstep for the current r and qtr. on output ka con- ! tains the number of Hebden iterations needed to determine ! step. ka = 0 means a Gauss-Newton step. ! ! p (in) = number of parameters. ! ! qtr (in) = Q' * residual. ! ! r (in) = the R matrix, stored compactly by columns. ! ! step (out) = the Levenberg-Marquardt step computed. ! ! v (i/o) contains various constants and variables described below. ! ! w (i/o) = workspace of length p*(p+5)/2 + 4. ! ! entries in v ! ! v(dgnorm) (i/o) = 2-norm of (d**-1)*g. ! v(dstnrm) (i/o) = 2-norm of d * step. ! v(dst0) (i/o) = 2-norm of Gauss-Newton step (for nonsing. j). ! v(epslon) (in) = max. relative error allowed in twonorm(r)**2 minus ! twonorm(r - j * step)**2. (see algorithm notes below.) ! v(gtstep) (out) = inner product between G and STEP. ! v(nreduc) (out) = half the reduction in the sum of squares predicted ! for a Gauss-Newton step. ! v(phmnfc) (in) = tol. (together with v(phmxfc)) for accepting step ! (More's sigma). the error v(dstnrm) - v(radius) must lie ! between v(phmnfc)*v(radius) and v(phmxfc)*v(radius). ! v(phmxfc) (in) (see v(phmnfc).) ! v(preduc) (out) = half the reduction in the sum of squares predicted ! by the step returned. ! v(radius) (in) = radius of current (scaled) trust region. ! v(rad0) (i/o) = value of v(radius) from previous call. ! v(STPPAR) (i/o) = Marquardt parameter (or its negative if the special ! case mentioned below in the algorithm notes occurs). ! implicit none integer p real a real adi real alphak real b real d(p) real d1 real d2 real, parameter :: dfac = 256.0E+00 real dfacsq integer, parameter :: dgnorm = 1 real dotprd real dst integer, parameter :: dst0 = 3 integer, parameter ::dstnrm = 2 integer dstsav real dtol integer, parameter :: epslon = 19 real g(p) integer i integer i1 integer ierr integer ipivot(p) integer j1 integer k integer ka integer kalim integer l real lk integer lk0 real oldphi real phi real phimax real phimin integer phipin integer pp1o2 real psifac real qtr(p) real r(*) real rad integer, parameter :: rad0 = 9 integer res integer res0 integer rmat integer rmat0 real si real sj real sqrtak real step(p) integer, parameter :: stppar = 5 real t real twopsi real uk integer uk0 real v(21) real v2norm real w(p*(p+5)/2 + 4) real wl ! ! subscripts for v ! integer gtstep, nreduc, phmnfc, & phmxfc, preduc, radius parameter ( gtstep=4, nreduc=6, phmnfc=20 ) parameter ( phmxfc=21, preduc=7, radius=8 ) ! ! For use in recomputing STEP, the final values of LK and UK, ! the inverse derivative of More's PHI at 0 (for nonsingular J) ! and the value returned as V(DSTNRM) are stored at W(LK0), ! W(UK0), W(PHIPIN), and W(DSTSAV) respectively. ! lk0 = p + 1 phipin = lk0 + 1 uk0 = phipin + 1 dstsav = uk0 + 1 rmat0 = dstsav ! ! A copy of the R matrix from the QR decomposition of J is ! stored in W starting at W(RMAT), and a copy of the residual ! vector is stored in W starting at W(RES). The loops below ! that update the QR decomposition for a nonzero Marquardt parameter ! work on these copies. ! rmat = rmat0 + 1 pp1o2 = ( p * ( p + 1 ) ) / 2 res0 = pp1o2 + rmat0 res = res0 + 1 rad = v(radius) if ( 0.0E+00 < rad ) then psifac = v(epslon) & / ( ( 8.0E+00 * ( v(phmnfc) + 1.0E+00 ) + 3.0E+00 ) * rad**2 ) end if phimax = v(phmxfc) * rad phimin = v(phmnfc) * rad ! ! DTOL and DFAC are used in rescaling the fast Givens ! representation of the updated QR decomposition. ! dtol = 1.0E+00 / dfac dfacsq = dfac * dfac ! ! OLDPHI is used to detect limits of numerical accuracy. If ! we recompute STEP and it does not change, then we accept it. ! oldphi = 0.0E+00 lk = 0.0E+00 uk = 0.0E+00 kalim = ka + 12 ! ! Start or restart, depending on KA. ! if ( 0 < ka ) then go to 370 end if ! ! Fresh start. Compute V(NREDUC). ! if ( ka < 0 ) then ka = 0 kalim = 12 k = p if ( ierr /= 0 ) then k = abs ( ierr ) - 1 end if v(nreduc) = 0.5E+00 * dotprd ( k, qtr, qtr ) end if ! ! Set up to try initial Gauss-Newton step. ! 20 continue v(dst0) = -1.0E+00 ! ! Compute Gauss-Newton step. ! ! Note that the R matrix is stored compactly by columns in ! R(1), R(2), R(3), ... It is the transpose of a ! lower triangular matrix stored compactly by rows, and we ! treat it as such when using LITVMU and LIVMUL. ! if ( ierr == 0 ) then call litvmu ( p, w, r, qtr ) ! ! Temporarily store permuted -D * STEP in STEP. ! do i = 1, p j1 = ipivot(i) step(i) = d(j1) * w(i) end do dst = v2norm ( p, step ) v(dst0) = dst phi = dst - rad if ( phi <= phimax ) then go to 410 end if ! ! If this is a restart, go to 110. ! if ( 0 < ka ) then go to 110 end if ! ! Gauss-Newton step was unacceptable. Compute L0. ! do i = 1, p j1 = ipivot(i) step(i) = d(j1) * ( step(i) / dst ) end do call livmul ( p, step, r, step ) t = 1.0E+00 / v2norm ( p, step ) w(phipin) = ( t / dst ) * t lk = phi * w(phipin) end if ! ! Compute U0. ! w(1:p) = g(1:p) / d(1:p) v(dgnorm) = v2norm ( p, w ) uk = v(dgnorm) / rad ! ! Special case. RAD <= 0 or (G = 0 and J is singular). ! if ( uk <= 0.0E+00 ) then v(stppar) = 0.0E+00 dst = 0.0E+00 lk = 0.0E+00 uk = 0.0E+00 v(gtstep) = 0.0E+00 v(preduc) = 0.0E+00 step(1:p) = 0.0E+00 v(dstnrm) = dst w(dstsav) = dst w(lk0) = lk w(uk0) = uk v(rad0) = rad return end if ! ! ALPHAK will be used as the current Marquardt parameter. We ! use More's scheme for initializing it. ! alphak = abs ( v(stppar) ) * v(rad0) / rad ! ! Top of loop. Increment KA, copy R to RMAT, QTR to RES. ! 110 continue ka = ka + 1 w(rmat:rmat+pp1o2-1) = r(1:pp1o2) w(res:res+p-1) = qtr(1:p) ! ! Safeguard ALPHAK and initialize fast Givens scale vector. ! if ( alphak <= 0.0E+00 .or. alphak < lk .or. uk <= alphak ) then alphak = uk * max ( 0.001E+00, sqrt ( lk / uk ) ) end if sqrtak = sqrt(alphak) w(1:p) = 1.0E+00 ! ! Add ALPHAK * D and update QR decomposition using fast Givens transform. ! do i = 1, p ! ! Generate, apply first Givens transformation for row I of ALPHAK * D. ! Use STEP to store temporary row. ! l = ( i * ( i + 1 ) ) / 2 + rmat0 wl = w(l) d2 = 1.0E+00 d1 = w(i) j1 = ipivot(i) adi = sqrtak*d(j1) if ( abs(wl) <= adi ) then go to 150 end if 130 continue a = adi / wl b = d2 * a / d1 t = a * b + 1.0E+00 if ( t <= 2.5E+00 ) then w(i) = d1 / t d2 = d2 / t w(l) = t * wl a = -a do j1 = i, p l = l + j1 step(j1) = a * w(l) end do go to 170 end if 150 continue b = wl / adi a = d1 * b / d2 t = a * b + 1.0E+00 if ( 2.5E+00 < t ) then go to 130 end if w(i) = d2 / t d2 = d1 / t w(l) = t * adi do j1 = i, p l = l + j1 wl = w(l) step(j1) = -wl w(l) = a * wl end do 170 continue if ( i == p ) then exit end if ! ! Now use Givens transformations to zero elements of temporary row. ! do i1 = i + 1, p l = ( i1 * ( i1 + 1 ) ) / 2 + rmat0 wl = w(l) si = step(i1-1) d1 = w(i1) ! ! Rescale row I1 if necessary. ! if ( d1 < dtol ) then d1 = d1 * dfacsq wl = wl / dfac k = l do j1 = i1, p k = k + j1 w(k) = w(k) / dfac end do end if ! ! Use Givens transformations to zero next element of temporary row. ! if ( abs ( wl ) < abs ( si ) ) then go to 220 end if if ( si == 0.0E+00 ) then go to 260 end if 200 continue a = si / wl b = d2 * a / d1 t = a * b + 1.0E+00 if ( t <= 2.5E+00 ) then w(l) = t * wl w(i1) = d1 / t d2 = d2 / t do j1 = i1, p l = l + j1 wl = w(l) sj = step(j1) w(l) = wl + b * sj step(j1) = sj - a*wl end do go to 240 end if 220 b = wl / si a = d1 * b / d2 t = a * b + 1.0E+00 if ( 2.5E+00 < t ) then go to 200 end if w(i1) = d2 / t d2 = d1 / t w(l) = t * si do j1 = i1, p l = l + j1 wl = w(l) sj = step(j1) w(l) = a * wl + sj step(j1) = b * sj - wl end do ! ! Rescale temporary row if necessary. ! 240 continue if ( d2 < dtol ) then d2 = d2*dfacsq step(i1:p) = step(i1:p) / dfac end if 260 continue end do end do ! ! Compute step. ! call litvmu ( p, w(res), w(rmat), w(res) ) ! ! Recover STEP and store permuted -D * STEP at W(RES). ! do i = 1, p j1 = ipivot(i) k = res0 + i t = w(k) step(j1) = -t w(k) = t * d(j1) end do dst = v2norm ( p, w(res) ) phi = dst - rad if ( phi <= phimax .and. phimin <= phi ) then go to 430 end if if ( oldphi == phi ) then go to 430 end if oldphi = phi ! ! Check for and handle special case. ! if ( phi <= 0.0E+00 ) then if ( kalim <= ka ) then go to 430 end if twopsi = alphak * dst * dst - dotprd ( p, step, g ) if ( alphak < twopsi * psifac ) then v(stppar) = -alphak go to 440 end if end if if ( phi < 0.0E+00 ) then uk = alphak end if 320 continue do i = 1, p j1 = ipivot(i) k = res0 + i step(i) = d(j1) * ( w(k) / dst ) end do call livmul ( p, step, w(rmat), step ) step(1:p) = step(1:p) / sqrt ( w(1:p) ) t = 1.0E+00 / v2norm ( p, step ) alphak = alphak + t * phi * t / rad lk = max ( lk, alphak ) go to 110 ! ! Restart. ! 370 continue lk = w(lk0) uk = w(uk0) if ( 0.0E+00 < v(dst0) .and. v(dst0) - rad <= phimax ) then go to 20 end if alphak = abs ( v(stppar) ) dst = w(dstsav) phi = dst - rad t = v(dgnorm) / rad ! ! Smaller radius. ! if ( rad <= v(rad0) ) then uk = t if ( alphak <= 0.0E+00 ) then lk = 0.0E+00 end if if ( 0.0E+00 < v(dst0) ) then lk = max ( lk, (v(dst0)-rad)*w(phipin) ) end if if ( phi < 0.0E+00 ) then uk = min ( uk, alphak ) end if go to 320 end if ! ! Bigger radius. ! if ( alphak <= 0.0E+00 .or. t < uk ) then uk = t end if if ( 0.0E+00 < v(dst0) ) then lk = max ( lk, (v(dst0)-rad)*w(phipin) ) else lk = 0.0E+00 end if if ( phi < 0.0E+00 ) then uk = min ( uk, alphak ) end if go to 320 ! ! Acceptable Gauss-Newton step. Recover step from W. ! 410 continue alphak = 0.0E+00 do i = 1, p j1 = ipivot(i) step(j1) = -w(i) end do ! ! Save values for use in a possible restart. ! 430 continue v(stppar) = alphak 440 continue v(gtstep) = dotprd ( p, step, g ) v(preduc) = 0.5E+00 * ( alphak * dst * dst - v(gtstep) ) v(dstnrm) = dst w(dstsav) = dst w(lk0) = lk w(uk0) = uk v(rad0) = rad return end subroutine loglmt ( ilogy, ymn, ymx, ylabel, numrow, istep, dely, & ywidth, nlably, ydmn, ydmx ) !*****************************************************************************80 ! !! LOGLMT adjusts plot limits for log plots, and computes log axis labels. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real dely ! integer ilogy, istep, iyn, iynlog, iyx, iyxlog, j, k ! integer nlably, numrow ! real ylabel(20) ! the y-axis lables. ! real ydmn, ydmx ! the y-axis data limits actually used. ! real ymn, ymx ! the y-axis plot limits actually used. ! real ynlog, ywidth, yxlog ! implicit none real & dely,ydmn,ydmx,ymn,ymx,ywidth integer & ilogy,istep,nlably,numrow ! ! array arguments real & ylabel(20) real & ynlog,yxlog integer & iyn,iynlog,iyx,iyxlog,j,k if (ilogy == 0) then ydmn = ymn ydmx = ymx ! ! determine the value of a division ! dely=ymx-ymn ywidth=dely/ real (numrow-1) ! ! compute evenly spaced labels for non-log axis ! nlably = 0 do j = 1, numrow, istep nlably = nlably + 1 ylabel(nlably) = ymx+ real ( 1 - j ) * ywidth end do if (mod(numrow,istep) == 1) ylabel(nlably) = ymn if (ymx == (-ymn) .and. mod(nlably,2) == 1) then ylabel(nlably/2+1) = 0.0 end if else ydmn = log10(ymn) ydmx = log10(ymx) ! ! adjust axis limits for log axis if necessary ! yxlog=log10(ymx) iyxlog = int ( yxlog ) if (ymx<1.0e0) iyxlog=iyxlog-1 ynlog=log10(ymn) if ((yxlog-ynlog) <= 0.92082e0) then ! ! range is less than .9 decades ! iynlog = int ( ynlog ) if (ymn<1.0e0) iynlog=iynlog-1 if (iyxlog <= iynlog) then ! ! values fall in the same decade ! ynlog = real ( iynlog ) yxlog = ynlog+1.0e0 iyxlog = int ( yxlog ) else ! ! values fall into two decades ! iyn = nint(ymn/(10.0e0**iynlog)) ynlog = min(log10( real ( iyn ) *(10.0e0**iynlog)),ynlog) yxlog = ynlog+1.0e0 iyxlog = int ( yxlog ) end if end if ymx=yxlog ymn=ynlog ! ! determine the value of a division ! dely=ymx-ymn ywidth=dely / real(numrow-1) ! ! compute axis labels ! ylabel(1)=10.0e0**yxlog iyx = int ( ylabel(1) / ( 10.0e0**iyxlog ) ) k=2 if (yxlog-ynlog > 3.0e0) k=5 if (yxlog-ynlog > 6.0e0) k=10 nlably = 1 if (yxlog-ynlog <= 12.0e0) then ! ! set nice labels ! if (k == 10) iyx=1 if (iyx /= 1.and.(iyx-((iyx/k)*k)) /= 0) iyx=((iyx/k)*k) if (iyx <= 1) then iyx=10 iyxlog=iyxlog-1 end if if (ylabel(1)-real ( iyx ) *(10.0e0**iyxlog) > 0.0e0 .and. & yxlog-(yxlog-ynlog)/(2.0e0*real(numrow-1)) > & log10(real(iyx))+real ( iyxlog )) then iyx=iyx+k end if iyx=iyx-k if (iyx <= 0) then iyx=10 iyxlog=iyxlog-1 end if do j=2,20 nlably=nlably+1 ylabel(nlably) = real ( iyx ) * ( 10.0e0**iyxlog ) if (ylabel(nlably) <= 10.0e0**ynlog) then exit end if iyx=iyx-k if (iyx <= 0) then iyx=10 iyxlog=iyxlog-1 end if end do ylabel(nlably)=10.0e0**ynlog else ! ! compute evenly spaced labels ! do j = istep, numrow, istep nlably = nlably + 1 ylabel(nlably) = 10.0e0**(ymx+real ( 1 - j ) * ywidth ) end do end if end if return end subroutine lopass ( y, n, fc, k, hlp, yf, nyf ) !*****************************************************************************80 ! !! LOPASS carries out a low-pass filtering of a series. ! ! Discussion: ! ! this subroutine carries out low-pass filtering of the ! series. the filter is the k-term ! least squares approximation to the cutoff filter ! with cutof frequency fc. its transfer function ! has a transition band of width delta surrounding fc, ! where delta = 4*pi/k. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! ! variable definitions (alphabetically) ! ! logical err01, err02, err03, err04, err05 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real fc ! the user supplied cutoff frequency. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! real hlp(k) ! the array in which the -ideal- high pass filter coefficients ! will be returned. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer k ! the number of filter terms to be computed. ! character*1 lfc(8), lk(8), ln(8) ! the array containing the names of the variables fc, k and n. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nyf ! the number of observations in the filtered series yf. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! implicit none real & fc integer & k,n,nyf ! ! array arguments real & hlp(*),y(*),yf(*) ! ! scalars in common integer & ierr ! ! logical & err01,err02,err03,err04,err05,head ! ! local arrays character & lfc(8)*1,lk(8)*1,ln(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,eisii,eriodd,ersii,erslfs,fltsl,lpflt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'l', 'o', 'p', 'a', 's', 's'/ data & lfc(1), lfc(2), lfc(3), lfc(4), lfc(5), lfc(6), lfc(7), lfc(8) & / 'f', 'c', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 3, 1, head, err01, ln) call ersii(nmsub, lfc, fc, 0.0e0, 0.5e0, 2, head, err02, lfc, lfc) call eisii(nmsub, lk, k, 1, n, 2, head, err03, lk, lk) call eriodd(nmsub, lk, k, 1, head, err04) if (err01 .or. err02 .or. err03 .or. err04) then ierr = 1 write ( *, 1000) return end if call erslfs(nmsub, fc, k, head, err05) if ( err05) then ierr = 1 write ( *, 1000) return end if call lpflt (fc, k, hlp) call fltsl (y, n, k, hlp, yf, nyf) return 1000 format (/' the correct form of the call statement is'// & ' call lopass (y, n, fc, k, hlp, yf, nyf)') end subroutine lpcoef ( fc, k, hlp ) !*****************************************************************************80 ! !! LPCOEF computes a least squares approximation to an ideal low pass filter. ! ! Discussion: ! ! This subroutine computes the k-term least squares ! approximation to an -ideal- low pass filter ! with cutof frequency fc. its transfer function ! has a transition band of width delta surrounding fc, ! where delta = 4*pi/k. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! ! variable definitions (alphabetically) ! ! logical err01, err02, err03, err04 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real fc ! the user supplied cutoff frequency. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! real hlp(k) ! the array in which the -ideal- low pass filter coefficients ! will be returned. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer k ! the number of filter terms to be computed. ! character*1 lfc(8), lk(8) ! the array containing the names of the variables fc and k. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! implicit none real & fc integer & k ! ! array arguments real & hlp(*) ! ! scalars in common integer & ierr logical & err01,err02,err03,err04,head ! ! local arrays character & lfc(8)*1,lk(8)*1,nmsub(6)*1 ! ! external subroutines external eisii,eriodd,ersii,erslfs,lpflt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'l', 'p', 'c', 'o', 'e', 'f'/ data & lfc(1), lfc(2), lfc(3), lfc(4), lfc(5), lfc(6), lfc(7), lfc(8) & / 'f', 'c', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call ersii(nmsub, lfc, fc, 0.0e0, 0.5e0, 2, head, err01, lfc, lfc) call eisii(nmsub, lk, k, 1, k, 2, head, err02, lk, lk) call eriodd(nmsub, lk, k, 1, head, err03) if (err01 .or. err02 .or. err03) then ierr = 1 write ( *, 1000) return end if call erslfs ( nmsub, fc, k, head, err04 ) if (err04) then ierr = 1 write ( *, 1000) return end if call lpflt (fc, k, hlp) return 1000 format (/' the correct form of the call statement is'// & ' call lpcoef (fc, k, hlp)') end subroutine lpflt ( fc, k, hlp ) !*****************************************************************************80 ! !! LPFLT computes the low-pass filter coefficients. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real arg, con ! variables used in the computation of the low pass filter ! coefficients. ! real fc ! the cutoff frequency used for the low pass filter. ! real hlp(k) ! the array in which the input low pass filter coefficients ! are stored. ! integer i ! an index variable. ! integer ihm, ihp ! index variables for symmetric locations around the midpoint ! of the filter. ! integer k ! the number of terms in the filter. ! integer khalf ! the value of the midpoint of k minus 1. ! integer kmid ! the midpoint of the filter. ! real pi ! the value of pi. ! real sum ! a value used for summing. ! implicit none real & fc integer & k ! ! array arguments real & hlp(k) real & arg,con,pi,sum integer & i,ihm,ihp,khalf,kmid ! ! external subroutines external getpi call getpi ( pi ) kmid = ( k + 1 ) / 2 hlp(kmid) = 1.0e0 if ( k == 1 ) then return end if hlp(kmid) = 2.0e0 * fc con = 2.0e0 * pi / real ( k ) sum = hlp(kmid) khalf = ( k - 1 ) / 2 do i = 1, khalf arg = real ( i ) * con ihp = kmid + i hlp(ihp) = sin( real ( i ) * fc * 2.0e0 * pi ) * sin(arg) / & ( real( i ) * pi * arg) ihm = kmid - i hlp(ihm) = hlp(ihp) sum = sum + hlp(ihm) + hlp(ihp) end do hlp(1:k) = hlp(1:k) / sum return end function lsame ( ca, cb ) !*****************************************************************************80 ! !! LSAME returns TRUE if CA is the same letter as CB regardless of case. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, character CA, CB, the character to compare. ! ! Output, logical LSAME, is TRUE if the characters are equal, ! disregarding case. ! implicit none character ca character cb integer inta integer intb logical lsame integer zcode ! ! Test if the characters are equal ! lsame = ( ca == cb ) if ( lsame ) then return end if ! ! Now test for equivalence if both characters are alphabetic. ! zcode = ichar ( 'Z' ) ! ! Use 'Z' rather than 'A' so that ASCII can be detected on Prime ! machines, on which ICHAR returns a value with bit 8 set. ! ICHAR('A') on Prime machines returns 193 which is the same as ! ICHAR('A') on an EBCDIC machine. ! inta = ichar ( ca ) intb = ichar ( cb ) if ( zcode == 90 .or. zcode == 122 ) then ! ! ASCII is assumed - zcode is the ASCII code of either lower or ! upper case 'Z'. ! if ( 97 <= inta .and. inta <= 122 ) then inta = inta - 32 end if if ( 97 <= intb .and. intb <= 122 ) then intb = intb - 32 end if else if ( zcode == 233 .or. zcode == 169 ) then ! ! EBCDIC is assumed - zcode is the EBCDIC code of either lower or ! upper case 'Z'. ! if ( 129 <= inta .and. inta <= 137 .or. & 145 <= inta .and. inta <= 153 .or. & 162 <= inta .and. inta <= 169 ) then inta = inta + 64 end if if ( 129 <= intb .and. intb <= 137 .or. & 145 <= intb .and. intb <= 153 .or. & 162 <= intb .and. intb <= 169 ) then intb = intb + 64 end if else if ( zcode == 218 .or. zcode == 250 ) then ! ! ASCII is assumed, on Prime machines - zcode is the ASCII code ! plus 128 of either lower or upper case 'Z'. ! if ( 225 <= inta .and. inta <= 250 ) then inta = inta - 32 end if if ( 225 <= intb .and. intb <= 250 ) then intb = intb - 32 end if end if lsame = ( inta == intb ) return end subroutine lsqrt ( n1, n, l, a, irc ) !*********************************************************************** ! !! LSQRT computes the Cholesky factor of a lower triangular matrix. ! ! Discussion: ! ! Compute rows N1 through N of the Cholesky factor L of ! A = L * L', where L and the lower triangle of A are both ! stored compactly by rows, and may occupy the same storage. ! ! IRC = 0 means all went well. IRC = J means the leading ! principal J x J submatrix of A is not positive definite, ! and L(J*(J+1)/2) contains the nonpositive reduced J-th diagonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer N1, N, the first and last rows to be computed. ! ! Output, real L((N*(N+1))/2), contains rows N1 through N of the ! Cholesky factorization of A, stored compactly by rows as a lower ! triangular matrix. ! ! Input, real A((N*(N+1))/2), the matrix whose Cholesky factorization ! is desired. ! ! Output, integer IRC, an error flag. If IRC = 0, then the factorization ! was carried out successfully. Otherwise, the principal J x J subminor ! of A was not positive definite. ! implicit none integer n real a(n*(n+1)/2) integer i integer i0 integer ij integer ik integer irc integer j integer j0 integer jk integer k real l(n*(n+1)/2) integer n1 real t real td i0 = ( n1 * ( n1 - 1 ) ) / 2 do i = n1, n td = 0.0E+00 j0 = 0 do j = 1, i - 1 t = 0.0E+00 do k = 1, j - 1 ik = i0 + k jk = j0 + k t = t + l(ik) * l(jk) end do ij = i0 + j j0 = j0 + j t = ( a(ij) - t ) / l(j0) l(ij) = t td = td + t * t end do i0 = i0 + i t = a(i0) - td if ( t <= 0.0E+00 ) then l(i0) = t irc = i return end if l(i0) = sqrt ( t ) end do irc = 0 return end function lstlag ( nlppa, lagmax, lacov ) !*****************************************************************************80 ! !! LSTLAG finds the last computable lag value. ! ! Discussion: ! ! This routine finds the lag value of the last autocovariance ! computed before one could not be computed due to missing data. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & lacov,lagmax integer lstlag ! ! array arguments integer & nlppa(lacov) integer & lag ! ! variable definitions (alphabetically) ! ! integer lacov ! the length of the vector acov. ! integer lag ! the indexing variable indicating the lag value of the ! autocorrelation. ! integer nlppa(lacov) ! the array containing the numbers of lagged product pairs ! used to compute the acvf at each lag. ! ! find the last autocorrelation to be computed before ! one could not be computed due to missing data ! lstlag = -1 if (nlppa(1) <= 0) return do lag = 1, lagmax if (nlppa(lag + 1) < 1) then lstlag = lag - 1 return end if end do lstlag = lagmax return end subroutine lstvcf ( n, vec, lmask, mask ) !*****************************************************************************80 ! !! LSTVCF prints N elements of a masked array. ! ! Discussion: ! ! this subroutine prints the first n elements of the vector ! vec. the i th element of vec is identified with the index ! of the i th zero element of mask. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer imask ! index in mask. ! integer imax, imin ! the largest and smallest indices in vec of the elements to be ! printed. ! integer index ! the index of the value to be printed. ! integer indw(10) ! a work vector for the indices to be printed for vec. ! integer jmax ! index in indw of the largest index to be printed for vec. ! integer lmask ! the length of mask. lmask >= n. ! integer mask(lmask) ! mask vector for vec. the index of the ith element of mask ! equal to zero is the label in the output of the ith element ! of vec. ! integer n ! the number of values to be printed in the input vector. ! integer nperl ! the number of values to be printed per line. ! real vec(n) ! the vector of values to be printed. ! implicit none integer & lmask,n ! ! array arguments real & vec(n) integer & mask(lmask) ! ! integer & i,imask,imax,imin,index,j,jmax,nperl ! ! local arrays integer & indw(10) ! ! external functions integer & inperl external inperl ! ! external subroutines nperl = inperl ( ) ! ! note - inperl( ) is assumed to be at most 10.0e0 if greater, ! increase the dimension of indw. ! imask = 0 do i = 1, n, nperl imin = i imax = min(i+nperl-1, n) jmax = min(n - imin + 1, nperl) do j = 1, jmax do if (imask >= lmask) then write ( *, 1030 ) return end if imask = imask + 1 if (mask(imask) == 0) then exit end if end do indw(j) = imask end do write ( *, 1010) (indw(index), index = 1, jmax) write ( *, 1020) (vec(index), index = imin, imax) end do return 1010 format(10x, 'index', i5, 6i15) 1020 format(10x, 'value', 7(1x, g14.7)/) 1030 format (/' error in starpac. lstvec tried to access more', & ' elements than exist in mask.') end subroutine lstvec ( n, vec ) !*****************************************************************************80 ! !! LSTVEC prints indices and values of a real vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index variable ! integer imax, imin ! the largest and smallest index value to be printed on each ! line. ! integer index ! the index value to be printed. ! integer n ! the number of values to be printed in the input vector. ! integer nperl ! the number of values to be printed per line. ! real vec(n) ! the vector of values to be printed. ! implicit none integer & n ! ! array arguments real & vec(n) integer & i,imax,imin,index,nperl ! ! external functions integer & inperl external inperl ! ! external subroutines nperl = inperl( ) do i = 1, n, nperl imin = i imax = min(i+nperl-1, n) write ( *, 1010) (index, index = imin, imax) write ( *, 1020) (vec(index), index = imin, imax) end do return 1010 format(10x, 'index', i5, 6i15) 1020 format(10x, 'value', 7(1x, g14.7)/) end function lsvmin ( p, l, x, y ) !*********************************************************************** ! !! LSVMIN estimates the smallest singular value of a lower triangular matrix. ! ! Discussion: ! ! This function returns a good over-estimate of the smallest ! singular value of the packed lower triangular matrix L. ! ! The matrix L is a lower triangular matrix, stored compactly by rows. ! ! The algorithm is based on Cline, Moler, Stewart and Wilkinson, ! with the additional provision that LSVMIN = 0 is returned if the ! smallest diagonal element of L in magnitude is not more than the unit ! roundoff times the largest. ! ! The algorithm uses a random number generator proposed by Smith, ! which passes the spectral test with flying colors; see Hoaglin and ! Knuth. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Alan Cline, Cleve Moler, Pete Stewart, James Wilkinson, ! An Estimate of the Condition Number of a Matrix, ! Report TM-310, ! Applied Math Division, ! Argonne National Laboratory, 1977. ! ! DC Hoaglin, ! Theoretical Properties of Congruential Random-Number Generators, ! An Empirical View, ! Memorandum NS-340, ! Department of Statistics, ! Harvard University, 1976. ! ! Donald Knuth, ! The Art of Computer Programming, ! Volume 2, Seminumerical Algorithms, ! Addison Wesley, 1969. ! ! CS Smith, ! Multiplicative Pseudo-Random Number Generators with Prime Modulus, ! Journal of the Association for Computing Machinery, ! Volume 19, pages 586-593, 1971. ! ! Parameters: ! ! Input, integer P, the order of L. ! ! Input, real L((P*(P+1))/2), the elements of the lower triangular ! matrix in row order, that is, L(1,1), L(2,1), L(2,2), L(3,1), L(3,2), ! L(3,3), and so on. ! ! Output, real X(P). If LSVMIN returns a positive value, then X ! is a normalized approximate left singular vector corresponding to ! the smallest singular value. This approximation may be very ! crude. If LSVMIN returns zero, then some components of X are zero ! and the rest retain their input values. ! ! Output, real Y(P). If LSVMIN returns a positive value, then ! Y = inverse ( L ) * X is an unnormalized approximate right singular ! vector corresponding to the smallest singular value. This ! approximation may be crude. If LSVMIN returns zero, then Y ! retains its input value. The caller may pass the same vector for X ! and Y, in which case Y overwrites X, for nonzero LSVMIN returns. ! implicit none integer p real b integer i integer ii integer, save :: ix = 2 integer j integer j0 integer ji integer jj real l((p*(p+1))/2) real lsvmin real psj real sminus real splus real t real v2norm real x(p) real xminus real xplus real y(p) ! ! First check whether to return LSVMIN = 0 and initialize X. ! ii = 0 do i = 1, p x(i) = 0.0E+00 ii = ii + i if ( l(ii) == 0.0E+00 ) then lsvmin = 0.0E+00 return end if end do if ( mod ( ix, 9973 ) == 0 ) then ix = 2 end if ! ! Solve L' * X = B, where the components of B have randomly ! chosen magnitudes in ( 0.5, 1 ) with signs chosen to make X large. ! do j = p, 1, -1 ! ! Determine X(J) in this iteration. Note for I = 1, 2,..., J ! that X(I) holds the current partial sum for row I. ! ix = mod ( 3432 * ix, 9973 ) b = 0.5E+00 * ( 1.0E+00 + real ( ix ) / 9973.0E+00 ) xplus = ( b - x(j) ) xminus = ( -b - x(j) ) splus = abs ( xplus ) sminus = abs ( xminus ) j0 = ( j * ( j - 1 ) ) / 2 jj = j0 + j xplus = xplus / l(jj) xminus = xminus / l(jj) do i = 1, j - 1 ji = j0 + i splus = splus + abs ( x(i) + l(ji) * xplus ) sminus = sminus + abs ( x(i) + l(ji) * xminus ) end do if ( splus < sminus ) then xplus = xminus end if x(j) = xplus ! ! Update partial sums. ! do i = 1, j - 1 ji = j0 + i x(i) = x(i) + l(ji) * xplus end do end do ! ! Normalize X. ! t = 1.0E+00 / v2norm ( p, x ) x(1:p) = t * x(1:p) ! ! Solve L * Y = X. ! return SVMIN = 1 / twonorm ( Y ). ! do j = 1, p psj = 0.0E+00 j0 = ( j * ( j - 1 ) ) / 2 do i = 1, j - 1 ji = j0 + i psj = psj + l(ji) * y(i) end do jj = j0 + j y(j) = ( x(j) - psj ) / l(jj) end do lsvmin = 1.0E+00 / v2norm ( p, y ) return end subroutine ltsqar ( n, a, l ) !*********************************************************************** ! !! LTSQAR sets A to the lower triangle of L' * L. ! ! Discussion: ! ! L is an N by N lower triangular matrix, stored by rows. ! ! A is also stored by rows, and may share storage with L. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer N, the order of L and A. ! ! Output, real A((N*(N+1))/2), the lower triangle of L' * L, ! stored by rows. ! ! Input, real L((N*(N+1))/2), the lower triangular matrix, ! stored by rows. ! implicit none integer n real a((n*(n+1))/2) integer i integer i1 integer ii integer j integer k real l((n*(n+1))/2) integer m ii = 0 do i = 1, n i1 = ii + 1 ii = ii + i m = 1 do j = i1, ii - 1 do k = i1, j a(m) = a(m) + l(j) * l(k) m = m + 1 end do end do do j = i1, ii a(j) = l(ii) * l(j) end do end do return end subroutine madj ( n, p, x, nf, j, uiparm, urparm, ufparm ) !*****************************************************************************80 ! !! MADJ is a sample jacobian routine. ! implicit none integer n integer p real j(n,p) integer nf integer uiparm(*) external ufparm real urparm(*) real x(p) j(1,1) = 2.0e0*x(1) + x(2) j(1,2) = 2.0e0*x(2) + x(1) j(2,1) = cos(x(1)) j(2,2) = 0.0e0 j(3,1) = 0.0e0 j(3,2) = -sin(x(2)) return end subroutine madr ( n, p, x, nf, r, uiparm, urparm, ufparm ) !*****************************************************************************80 ! !! MADR is a sample residual routine. ! implicit none integer n integer p integer nf real r(n) external ufparm integer uiparm(*) real urparm(*) real x(p) r(1) = x(1)**2 + x(2)**2 + x(1)*x(2) r(2) = sin(x(1)) r(3) = cos(x(2)) return end subroutine maflt ( y, n, k, yf, nyf ) !*****************************************************************************80 ! !! MAFLT performs a moving average filtering operation. ! ! Discussion: ! ! this subroutine performs a simple moving average filtering ! operation on an input series y, returning the filtered series ! in yf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! real hma ! the value of each of the simple moving average linear filter ! coefficients. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer k ! the number of filter terms. ! character*1 lk(8), ln(8), lone(8) ! the arrays containing the names of the variables k and n. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nyf ! the number of observations in the filtered series yf. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! implicit none integer & k,n,nyf ! ! array arguments real & y(*),yf(*) ! ! scalars in common integer & ierr ! ! real & hma logical & err01,err02,err03,head ! ! local arrays character & lk(8)*1,ln(8)*1,lone(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,eisii,eriodd,fltma ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'a', 'f', 'l', 't', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), lone(7), & lone(8) / ' ', ' ', 'o', 'n', 'e', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 3, 1, head, err01, ln) call eisii(nmsub, lk, k, 1, n, 1, head, err02, lone, ln) call eriodd(nmsub, lk, k, 1, head, err03) if (err01 .or. err02 .or. err03) then ierr = 1 write ( *, 1000) return end if ! ! compute the simple moving average coefficients ! hma = real ( k ) hma = 1.0e0 / hma call fltma ( y, n, k, hma, yf, nyf ) return 1000 format (/' the correct form of the call statement is'// & ' call maflt (y, n, k, yf, nyf)') end subroutine matprf ( x, y, nc, mode, code, length, mask, lmask ) !*****************************************************************************80 ! !! MATPRF prints a square matrix stored in symmetric form. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer code ! if 1 -single printed, x only (y is dummy arg) ! 2 -double printed line, both x and y ! integer i ! row number ! integer ii ! the index of the (i,i)th element of the vcv matrix ! integer ik ! the index of the (i,k)th element of the vcv matrix ! integer i0 ! the index of the ((i,i)-1)th element of the vcv matrix ! integer imask ! index in mask for labelling of the row dimension. ! integer indw(10) ! a work vector for the indices to be printed for the ! matrix. ! integer j ! first column in the set to be printed ! integer jmask ! index in mask for labelling of the column dimension. ! integer k ! column number in the possible set of nf ! integer ki ! the index of the (k,i)th element of the vcv matrix ! integer kk ! the index of the (k,k)th element of the vcv matrix ! integer km ! last column in the set ! limited to values of j-1 plus a number between 1 and ! nf (inclusive) ! integer kmax ! index in indw of the largest index to be printed for ! matrix. ! integer kn ! last column to print when printing lower triangle ! integer l ! first row to print for this set ! integer lmask ! length of mask. ! integer length ! length of x and y ! integer mask(lmask) ! mask vector for vcv. the index of the ith element of ! mask equal to zero is the label in the output of vcv ! in of the ith row and ith column. ! integer mode ! if 0, lower triangular part printed ! 1, lower triangular part is printed with ! square roots of the diagonal ! 2, lower triangle printed as correlation matrix ! with square roots on the diagonal ! 3, full matrix printed ! 4, full matrix printed with correlation matrix ! printed below the diagonal ! integer nc ! row and column dimension of x ! integer nf ! the number of columns that can be printed, given ! the width iwidth of the output device. ! integer nline ! the number of values to be printed each line. ! real sqxii, sqyii ! the square root of the (i,i)th element of x and y. ! real x(length) ! input symmetric array stored row wise ! real xline(10) ! the current values being printed from array x. ! real y(length) ! array to be printed on the second level if code=2 ! real yline(10) ! the current values being printed from array y. ! implicit none integer & code,length,lmask,mode,nc ! ! array arguments real & x(length),y(length) integer & mask(lmask) ! ! real & sqxii,sqyii integer & i,i0,ii,ik,imask,j,jmask,k,ki,kk,km,kmax,kn,l,nf, & nline ! ! local arrays real & xline(10),yline(10) integer & indw(10) ! ! external functions integer & inperl external inperl nf = inperl( ) l = 1 jmask = 0 ! ! select initial column to print this pass of the report ! do j=1,nc,nf kn = min(nc,j+nf-1) kmax = min(nc-j+1,nf) ! ! generate vector of column head labels ! do k=1,kmax do if ( jmask >= lmask ) then write ( *,1040) return end if jmask = jmask + 1 if ( mask(jmask) == 0 ) then exit end if end do indw(k) = jmask end do ! ! print vector of column head labels ! write ( *,1000) (indw(k),k=1,kmax) write ( *,1030) if (mode <= 2) l = indw(1) ! ! print all rows in column range for this pass ! imask = l - 1 do i=l,nc km = kn if (mode <= 2) km = j + min(i-l,nf-1) nline = 0 i0 = i*(i-1)/2 ii = i0 + i sqxii = sqrt(x(ii)) if (code == 2) then sqyii = sqrt(y(ii)) else sqyii = 1.0e0 end if do k = j, km nline = nline + 1 if ( k <= i ) then ik = i0 + k xline(nline) = x(ik) if (code == 2) yline(nline) = y(ik) else ki = k*(k-1)/2 + i xline(nline) = x(ki) if (code == 2) yline(nline) = y(ki) end if if (((mode == 1) .or. (mode == 2)) .and. (i == k)) then xline(nline) = sqxii if (code == 2) yline(nline) = sqxii end if if (((mode /= 2) .and. (mode /= 4)) .or. (k >= i)) then cycle end if kk = k*(k-1)/2 + k xline(nline) = xline(nline)/(sqxii*sqrt(x(kk))) if (code == 2) then yline(nline) = yline(nline)/(sqyii*sqrt(y(kk))) end if end do do if (imask >= lmask) then write ( *, 1040 ) return end if imask = imask + 1 if ( mask(imask) == 0 ) then exit end if end do write ( *,1010) imask, (xline(k),k=1,nline) if (code == 2) then write ( *,1020) (yline(k),k=1,nline) write ( *,1030) end if end do end do return 1000 format (/' column ', 7(i9, 8x)) 1010 format (' ', i6, 1x, 7(3x, g14.7)) 1020 format (' ', 5x, 7(3x, g14.7)) 1030 format (' ') 1040 format (/' error in starpac. matprf tries to access more', & ' elements than exist in mask.') end subroutine matprt (x, y, nc, mode, code, irdim) !*****************************************************************************80 ! !! MATPRT is a matrix printing routine. ! ! Discussion: ! ! this subroutine takes a square matrix and prints either its ! lower triangular part or the full matrix with or without double ! printing. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer code ! if 1 -single printed line, x only (y is dummy arg) ! 2 -double printed line, both x and y ! integer i ! row number ! integer irdim ! row index of x ! integer iwidth ! the width of the output device. ! integer j ! first column in the set to be printed ! integer k ! column number in the possible set of nf ! integer km ! last column in the set ! limited to values of j-1 plus a number between 1 and ! nf (inclusive) ! integer kn ! last column to print when printing lower triangle ! integer l ! first row to print for this set ! integer mode ! if 0, lower triangular part printed ! 1, full matrix printed ! 2, lower triangular part is printed with ! square roots of the diagonal ! integer nc ! row and column dimension of x ! integer nf ! the number of columns that can be printed, given ! the width iwidth of the output device. ! real temp ! a temporary location ! real x(irdim,nc) ! nc by nc input matrix ! real y(irdim,nc) ! matrix to be printed on the second level if code=2 ! implicit none integer & code,irdim,mode,nc ! ! array arguments real & x(irdim,nc),y(irdim,nc) ! ! real & temp integer & i,iwidth,j,k,km,kn,l,nf iwidth = 132 nf = min(7, (iwidth - 7)/17) l = 1 do j=1,nc, nf kn = min(nc, j+nf-1) write ( *,1000) (k,k=j,kn) write ( *,1030) if ((mode == 00) .or. (mode == 2)) l = j do i=l,nc temp = x(i,i) km = kn if ((mode == 0) .or. (mode == 2)) & km = j + min(i-l, nf-1) if ((mode == 2) .and. ((i >= j) .and. (i <= km))) & x(i,i) = sqrt(x(i,i)) write ( *,1010) i, (x(i,k),k=j,km) if (code == 2) then write ( *,1020) (y(i,k),k=j,km) write ( *,1030) end if x(i,i) = temp end do end do return 1000 format (/4x, 'column ', 7(i9, 8x)) 1010 format (4x, i6, 1x, 7(3x, g14.8)) 1020 format (9x, 7(3x, g14.8)) 1030 format (4x) end subroutine mdflt ( per, nf, nk, kmd, perf, ldstak ) !*****************************************************************************80 ! !! MDFLT is a user routine for a modified Daniels filter of symmetric series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer kmd(nk) ! the array of filter lengths. ! character*1 lkmd(8), llds(8), lnk(8), lnf(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer nall0 ! the number of outstanding stack allocations ! integer nf ! the number of points in the series to be filtered. ! integer nk ! the number of filters to be applied. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! real per(nf) ! the input series to be filtered. ! real perf(nf) ! the filtered series. ! real rstak(12) ! the real version of the /cstak/ work area. ! real sym ! an indicator variable used to designate whether the series ! is symmetric (sym = 1.0e0) or not (sym = -1.0e0). ! integer work ! the starting location in the work area for the work vector. ! implicit none integer & ldstak,nf,nk ! ! array arguments real & per(*),perf(*) integer & kmd(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & sym integer & l,ldsmin,nall0,work logical & err01,err02,err03,head ! ! local arrays real & rstak(12) character & lkmd(8)*1,llds(8)*1,lnf(8)*1,lnk(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external eisge,eiveo,fltmd,ldscmp,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'd', 'f', 'l', 't', ' '/ data & lkmd(1), lkmd(2), lkmd(3), lkmd(4), lkmd(5), & lkmd(6), lkmd(7), lkmd(8) /'k','m','d',' ',' ',' ',' ',' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), & lnf(6), lnf(7), lnf(8) /'n','f',' ',' ',' ',' ',' ',' '/ data & lnk(1), lnk(2), lnk(3), lnk(4), lnk(5), & lnk(6), lnk(7), lnk(8) /'n','k',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, lnf, nf, 17, 1, head, err01, lnf) call eisge(nmsub, lnk, nk, 1, 1, head, err02, lnk) if (.not.err02) call eiveo(nmsub, lkmd, kmd, nk, .true., head) if (err01) then ierr = 1 write ( *, 1000) return end if call ldscmp(1, 0, 0, 0, 0, 0, 's', nf, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err03, llds) if ( err02 .or. err03 ) then ierr = 1 write ( *, 1000) return end if ! ! set the size of the work area ! call stkset(ldstak, 4) nall0 = stkst(1) ! ! subdivide the work area ! work = stkget(nf, 3) ! ! designate the series is symmetric ! sym = 1.0e0 perf(1:nf) = per(1:nf) do l = 1, nk call fltmd(perf, rstak(work), nf, kmd(l), sym) end do call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call mdflt (per, nf, nk, kmd, perf, ldstak)') end subroutine mdl1 ( par, npar, xm, n, m, ixm, pv ) !*****************************************************************************80 ! !! MDL1 is the model function for an NLS exerciser. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real par(npar) ! model parameters ! integer ixm ! actual first dimension of xm ! integer m ! number of variables ! integer n ! number of observations ! integer npar ! number of parameters ! real pv(n) ! predicted values ! real xm(ixm,m) ! independent variables ! implicit none integer & ixm,m,n,npar ! ! array arguments real & par(npar),pv(n),xm(ixm,m) pv(1:n) = par(1) * xm(1:n,1)**par(2) return end subroutine mdl2 ( par, npar, xm, n, m, ixm, pv ) !*****************************************************************************80 ! !! MDL2 is a model function for an NLS exerciser. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! row index ! integer ixm ! actual first dimension of xm ! integer m ! number of variables ! integer n ! number of observations ! integer npar ! number of parameters ! real par(npar) ! model parameters ! real pv(n) ! predicted values ! real xm(ixm,m) ! independent variables ! implicit none integer ixm integer m integer n integer npar real par(npar) real pv(n) real xm(ixm,m) pv(1:n) = par(1) * xm(1:n,1) + par(2) * xm(1:n,2) + par(3) * xm(1:n,3)**3 return end subroutine mdl3 ( par, npar, xm, n, m, ixm, pv ) !*****************************************************************************80 ! !! MDL3 is a model function for an NLS exerciser. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! row index ! integer ixm ! actual first dimension of xm ! integer m ! number of variables ! integer n ! number of observations ! integer npar ! number of parameters ! real par(npar) ! model parameters ! real pv(n) ! predicted values ! real xm(ixm,m) ! independent variables ! implicit none integer & ixm,m,n,npar ! ! array arguments real & par(npar),pv(n),xm(ixm,m) pv(1:n) = par(1) * xm(1:n,1) & + par(2) * xm(1:n,2) & + par(3) * xm(1:n,3) & + par(4) * xm(1:n,4) & + par(5) * xm(1:n,5) return end subroutine mdl4 ( par, npar, xm, n, m, ixm, pv ) !*****************************************************************************80 ! !! MDL4 is a model routine for step size and derivative checking routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index variable. ! integer ixm ! the first dimension of the independent variable array xm. ! integer m ! the number of independent variables. ! integer n ! the number of observations of data. ! integer npar ! the number of unknown coefficients in the model. ! real par(npar) ! the array in which the current estimates of the unknown ! coefficients are stored. ! real pv(n) ! the predicted values from the fit. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none integer & ixm,m,n,npar ! ! array arguments real & par(npar),pv(n),xm(ixm,m) pv(1:n) = par(1) + par(3)*exp(-((xm(1:n,1)-par(2))**2)/par(4)) return end subroutine mdlts1 ( par, npar, xm, n, m, ixm, rests ) !*****************************************************************************80 ! !! MDLTS1 is the user callable routine for estimating box-jenkins arima models. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer i ! an index variable. ! integer iflag ! an indicator variable designating whether the back forecasts ! were essentially zero (iflag=0) or not (iflag=1). ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ixm ! the first dimension of matrix xm. ! integer m ! the number of independent variables. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! integer mspect ! the starting location in the work space for ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfact ! the number of factors in the model ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer nparma ! the length of the vector parma ! integer nrests ! the maximum number of residuals to be computed. ! real par(npar) ! the current estimates of the parameters. ! integer parar ! the starting location in the work array for ! the autoregressive parameters ! integer pardf ! the starting location in the work space for ! the vector containing the difference filter parameters ! integer parma ! the starting location in the work array for ! the moving average parameters ! real pmu ! the value of mu, i.e., the trend or mean. ! real rests(nrests) ! the residuals from the arima model. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer t ! the starting location in the work array for ! a temporary work vector. ! integer temp ! the starting location in the work array for ! a temporary work vector ! real xm(ixm,m) ! the independent variable. ! implicit none integer & ixm,m,n,npar,nrests ! ! array arguments real & par(npar),rests(nrests),xm(ixm,m) ! ! scalars in common integer & iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, & parar,pardf,parma,t,temp ! ! arrays in common double precision dstak(3000) real & pmu integer & i,i1 ! ! local arrays real & rstak(12) integer & istak(12) ! ! external subroutines external mdlts2 ! ! common blocks common /cstak/dstak common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, & nparma,mbo,mbol,t,temp,nrests,iflag ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) ! ! compute residuals ! call mdlts2 (par, rests, xm(1,1), npar, n, nfact, istak(mspect), & pmu, rstak(pardf), npardf, rstak(t), rstak(temp), rstak(parar), & rstak(parma), mbo, n-nrests+1, n, iflag) ! ! Compute predicted values ! i1=nrests-n do i = 1,n i1=i1+1 rests(i) = xm(i1,1)-rests(i1) end do return end subroutine mdlts2 ( par, rests, y, npar, n, nfac, mspect, pmu, & pardf, npardf, t, temp, parar, parma, mbo, n1, n2, iflag ) !*****************************************************************************80 ! !! MDLTS2 is the model routine for Pack's specification of box-jenkins models. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real fplpm ! the floating point largest positive magnitude. ! integer i ! an index variable. ! integer iflag ! an indicator variable designating whether the back forecasts ! were essentially zero (iflag=0) or not (iflag=1). ! integer imod ! an index variable. ! integer ipar ! an index variable. ! integer ipq ! an index variable. ! integer istart ! *** ! integer j ! an index variable. ! integer k ! an index variable. ! integer l ! an index variable. ! integer maxord ! the largest back order. ! integer mbo ! the maximum back order operator. ! integer mbo1 ! the value mbo+1 ! integer mspect(nfac,4) ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfac ! the number of factors in the model ! integer np ! the number of parameters in the expanded term. ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer nparma ! the length of the vector parma ! integer n1 ! the lower bound for rests. ! integer n2 ! the upper bound for rests. ! real par(npar) ! the current estimates of the parameters. ! real parar(mbo) ! the autoregressive parameters ! real pardf(npardf) ! the vector containing the difference filter parameters. ! logical parle1 ! a flag indicating whether all of the moving average parameters ! are less than or equal to 1 (parle1 = .true.) or not ! (parle1 = .false.) ! real parma(mbo) ! the moving average parameters ! real pmu ! the value of mu, i.e., the trend or mean. ! real resmax ! the largest possible residual which will still avoid overflow. ! real rests(n1:n2) ! the predicted value of the fit. ! real t(2*mbo) ! a temporary work vector. ! real temp(mbo) ! a temporary work vector ! real wtest ! the test value used to determine if the differenced series ! back forecast is effectively zero or not. ! real y(n) ! the dependent variable. ! implicit none integer n integer n1 integer n2 integer nfac integer npar real fplpm integer iflag integer mbo integer mspect(nfac,4) integer npardf real par(npar) real parar(*) real pardf(*) logical parle1 real parma(*) real pmu real resmax real rests(n1:n2) real t(*) real temp(*) real wtest real y(n) integer & i,imod,imod1,ipar,ipq,istart,j,k,l,maxord,mbo1,np,nparar, & nparma fplpm = huge ( fplpm ) ! ! DEBUG: ! Is FPLPM way too huge? ! fplpm = 1.0E+30 ! ! Zero the parameter arrays parar and parma. ! t(1:mbo) = 0.0e0 temp(1:mbo) = 0.0e0 np = 0 ipar = 0 nparar = 0 istart = 0 ! ! expand the model and store autoregressive parameters in parar ! and moving average parameters in parma ! do ipq = 1, 3, 2 do l=1,nfac if (mspect(l,ipq) /= 0) then maxord = mspect(l,ipq)*mspect(l,4) do k = mspect(l,4), maxord, mspect(l,4) ipar = ipar + 1 temp(k) = temp(k) + par(ipar) do i = 1, np temp(k+i) = temp(k+i) - t(i)*par(ipar) end do end do np = np + maxord t(1:np) = temp(1:np) end if end do if (ipq /= 3) then ipar = ipar + 1 pmu = par(ipar) nparar = np do k =1, nparar parar(k) = t(k) t(k) = 0.0e0 temp(k) = 0.0e0 end do np = 0 end if end do nparma = np parle1 = .true. do k =1, nparma parma(k) = t(k) if (abs(parma(k)) > 1.0e0) parle1 = .false. end do ! ! compute fitted values and residuals for model. ! ! compute w, the differenced series minus its mean, and store in ! rests(npardf+1) to rests(n2) ! do i = npardf+1, n2, 1 rests(i) = y(i) - pmu do j = 1,npardf rests(i) = rests(i) - pardf(j)*y(i-j) end do end do wtest = abs(rests(npardf+1))*0.01 ! ! back forecast the error, e, for i = n-nparar to npardf+1, and ! the differenced series for i = npardf to n1 ! mbo1 = mbo+1 iflag = 0 do i = n2-nparar,npardf+1,-1 imod = mod(i+1-n1,mbo1) + 1 t(imod) = rests(i) do j = 1,nparar t(imod) = t(imod) - parar(j)*rests(i+j) end do do j = 1,nparma if ((i+j > npardf) .and. (i+j <= n)) & t(imod) = t(imod) + parma(j)*t(mod(i+j+1-n1,mbo1)+1) end do end do do i = npardf,n1,-1 imod = mod(i+1-n1,mbo1) + 1 rests(i) = 0.0e0 do j = 1,nparar rests(i) = rests(i) + parar(j) * rests(i+j) end do do j = 1,nparma if ((i+j > npardf) .and. (i+j <= n)) & rests(i) = rests(i) - & parma(j)*t(mod(i+j+1-n1,mbo1)+1) end do istart = i if ((istart <= 1) .and. (abs(rests(i)) <= wtest)) go to 180 end do iflag = 1 ! ! compute residuals and store values in rests ! 180 continue do i = istart,n2,1 imod = mod(i+1-n1,mbo1) + 1 t(imod) = rests(i) do j = 1,nparar if (i-j >= istart) then t(imod) = t(imod) - parar(j)*rests(i-j) end if end do ! ! Compute residuals where there is no chance of overflow. ! if ( parle1 ) then do j = 1, nparma if (i-j >= istart) then t(imod) = t(imod) + parma(j)*t(mod(i-j+1-n1,mbo1)+1) end if end do ! ! Compute residuals where there is a chance of overflow. ! else do j = 1, nparma if ( istart <= i - j ) then imod1 = mod(i-j+1-n1,mbo1)+1 if ( parma(j) /= 0.0e0 .and. t(imod1) /= 0.0e0 ) then if ( log ( abs ( parma(j) ) ) & + log ( abs ( t(imod1) ) ) < log(fplpm) .and. & sign ( 1.0e0, t(imod) ) /= & sign ( 1.0e0, parma(j) * t(imod1) ) ) then t(imod) = t(imod) + parma(j) * t(imod1) else if ( log ( abs ( parma(j) ) ) & + log ( abs ( t(imod1) ) ) < & log ( fplpm - abs ( t(imod) ) ) ) then t(imod) = t(imod) + parma(j) * t(imod1) else go to 300 end if end if end if end do end if if (i-mbo >= istart) then rests(i-mbo) = t(mod(i-mbo+1-n1,mbo1)+1) end if end do do i = n-mbo+1,n rests(i) = t(mod(i-mbo+2-n1,mbo1)+1) end do rests(n1:istart-1) = 0.0e0 return ! ! Set residuals to largest possible value. ! 300 continue resmax = sqrt ( fplpm / real ( n2 - n1 + 1 ) ) rests(n1:n2) = resmax return end subroutine mdlts3 ( par, npar, xm, n, m, ixm, rests ) !*****************************************************************************80 ! !! MDLTS3 is the user callable routine for estimating Box-Jenkins ARIMA models. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer iflag ! an indicator variable designating whether the back forecasts ! were essentially zero (iflag=0) or not (iflag=1). ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ixm ! the first dimension of matrix xm. ! integer m ! the number of independent variables. ! integer mbo ! the maximum back order operator. ! integer mbol ! the maximum back order on the left ! integer mspect ! the starting location in the work space for ! the array containing the values of p, d, q, and s for each fact ! integer n ! the number of observations. ! integer nfact ! the number of factors in the model ! integer npar ! the number of parameters in the model. ! integer nparar ! the number of autoregressive parameters ! integer npardf ! the order of the expanded difference filter. ! integer nparma ! the length of the vector parma ! integer nrests ! the maximum number of residuals to be computed. ! real par(npar) ! the current estimates of the parameters. ! integer parar ! the starting location in the work array for ! the autoregressive parameters ! integer pardf ! the starting location in the work space for ! the vector containing the difference filter parameters ! integer parma ! the starting location in the work array for ! the moving average parameters ! real pmu ! the value of mu, i.e., the trend or mean. ! real rests(nrests) ! the residuals from the arima model. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer t ! the starting location in the work array for ! a temporary work vector. ! integer temp ! the starting location in the work array for ! a temporary work vector ! real xm(ixm,m) ! the independent variable. ! implicit none integer & ixm,m,n,npar integer nrests ! ! array arguments real & par(npar),rests(nrests),xm(ixm,m) ! ! scalars in common integer & iflag,mbo,mbol,mspect,nfact,nparar,npardf,nparma, & parar,pardf,parma,t,temp ! ! arrays in common double precision dstak(3000) ! ! real & pmu ! ! local arrays real & rstak(12) integer & istak(12) ! ! external subroutines external mdlts2 common /cstak/dstak common /mdltsc/mspect,nfact,pardf,npardf,parar,nparar,parma, & nparma,mbo,mbol,t,temp,nrests,iflag ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) ! ! compute residuals ! call mdlts2 ( par, rests, xm(1,1), npar, n, nfact, istak(mspect), & pmu, rstak(pardf), npardf, rstak(t), rstak(temp), rstak(parar), & rstak(parma), mbo, n-nrests+1, n, iflag ) return end subroutine mgs ( a, b, n, np, x, c, d, r, ir, ia, ier ) !*****************************************************************************80 ! !! MGS solves a linear system using modified Gram-Schmidt algorithm. ! ! Discussion: ! ! this routine computes the solution x to the linear system of ! equations ax=b, using the method of modified gram-schmidt. ! the matrix a is decomposed into three matrices ! q an orthogonal matrix ! d a diagonal matrix and ! r an upper triangular matrix ! the solution vector x is the vector which solves the system ! of equations rx = c ! x, a, and b are not preserved on output ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real a(ia,np) ! the coefficients matrix (not preserved on output) ! real b(n) ! the constant column matrix of the system (not preserved ! on output) ! real c(np) ! the matrix c described above ! real d(np) ! the diagonal elements of the matrix d described above ! integer ia ! the row dimension of a. ! integer ir ! the row dimension of r. ! integer n ! the number of observations ! integer np ! the number of parameters ! real r(ir,np) ! the upper elements of the matrix r described above ! real x(np) ! the solution matrix ! implicit none integer & ia,ier,ir,n,np ! ! array arguments real & a(ia,np),b(n),c(np),d(np),r(ir,np),x(np) ! ! real & sm1,sm2 integer & i,j,jj,k,npjjmj ier = 0 sm1 = 0.0e0 sm2 = 0.0e0 do i=1,n sm1 = a(i,1)*a(i,1) + sm1 sm2 = a(i,1)*b(i) + sm2 end do if (sm1 == 0.0e0) then ier = 1 return end if d(1) = sm1 c(1) = sm2/sm1 do k=2,np do j=k,np sm1 = 0.0e0 do i=1,n sm1 = a(i,k-1)*a(i,j) + sm1 end do r(k-1,j) = sm1/d(k-1) a(1:n,j) = a(1:n,j) - a(1:n,k-1) * r(k-1,j) end do sm1 = 0.0e0 sm2 = 0.0e0 do i=1,n b(i) = b(i) - a(i,k-1)*c(k-1) sm1 = a(i,k)*a(i,k) + sm1 sm2 = a(i,k)*b(i) + sm2 end do if (sm1 == 0.0e0) then ier = 1 return end if d(k) = sm1 c(k) = sm2/sm1 end do ! ! complete backsolve ! x(np) = c(np) if (np == 1) then return end if do i=2,np k = np + 1 - i jj = k + 1 sm1 = 0.0e0 do j=jj,np npjjmj = np + jj - j sm1 = r(k,npjjmj)*x(npjjmj) + sm1 end do x(k) = c(k) - sm1 end do return end subroutine modsum ( nfac, mspect ) !*****************************************************************************80 ! !! MODSUM prints the model summary for the ARIMA routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer nfac ! the number of factors in the model ! integer mspect(nfac,4) ! the array containing the values of p, d, q, and s for each fact ! implicit none integer & nfac ! ! array arguments integer & mspect(nfac,4) integer & i,j ! ! print model specification ! write ( *, 1002) (i, (mspect(i,j),j=1,4), i=1,nfac) return 1002 format(// & ' model specification'// & ' factor (p d q) s'// & (7x, i6, 6x, 4i6)) end subroutine mppc ( ym, x, n, m, iym, ilog, isize, nout, ylb, yub, xlb, xub ) !*****************************************************************************80 ! !! MPPC produces a simple page plot with multiple Y-axis values. ! ! Discussion: ! ! This is the long call version. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! vector of observations for the y coordinates ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! implicit none real & xlb,xub,ylb,yub integer & ilog,isize,iym,m,n,nout ! ! array arguments real & x(*),ym(*) ! ! scalars in common integer & ierr ! ! real & xmiss integer ischck,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'p', 'p', 'c', ' ', ' '/ xmiss = 1.0e0 multi = .true. ischck = 2 miss = .false. lisym = 1 call ppcnt (ym, ym, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 end if return end subroutine mpp ( ym, x, n, m, iym ) !*****************************************************************************80 ! !! MPP produces a simple page plot with multiple Y-axis values. ! ! Discussion: ! ! This is the short call version. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! vector of observations for the y coordinates ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! implicit none integer & iym,m,n ! ! array arguments real & x(*),ym(*) ! ! scalars in common integer & ierr ! ! real & xlb,xmiss,xub,ylb,yub integer & ilog,ischck,isize,lisym,nout logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'p', 'p', ' ', ' ', ' '/ xmiss = 1.0e0 multi = .true. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 2 isize = -1 nout = 0 miss = .false. lisym = 1 call ppcnt (ym, ym, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 end if return end subroutine mppl ( ym, x, n, m, iym, ilog ) !*****************************************************************************80 ! !! MPPL produces a simple page plot with multiple Y-axis values, and log option. ! ! Discussion: ! ! this is the user callable routine which produces a simple page ! plot with multiple y-axis values (log option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! vector of observations for the y coordinates ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! implicit none integer & ilog,iym,m,n ! ! array arguments real & x(*),ym(*) ! ! scalars in common integer & ierr ! ! real & xlb,xmiss,xub,ylb,yub integer ischck,isize,lisym,nout logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'p', 'p', 'l', ' ', ' '/ xmiss = 1.0e0 multi = .true. ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 2 isize = -1 nout = 0 miss = .false. lisym = 1 call ppcnt (ym, ym, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mppl (ym, x, n, m, iym, ilog)') end subroutine mppmc ( ym, ymmiss, x, xmiss, n, m, iym, ilog, isize, & nout, ylb, yub, xlb, xub ) !*****************************************************************************80 ! !! MPPMC: produce a page plot with multiply Y-axis values, and missing data. ! ! Discussion: ! ! This is the user callable routine which produces a simple page ! plot with multiple y-axis values and with missing ! observations (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,m) ! vector of observations for the y coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! implicit none real & xlb,xmiss,xub,ylb,yub integer & ilog,isize,iym,m,n,nout ! ! array arguments real & x(*),ym(*),ymmiss(*) ! ! scalars in common integer & ierr ! ! integer ischck,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'p', 'p', 'm', 'c', ' '/ multi = .true. ischck = 2 miss = .true. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mppmc (ym, ymmiss, x, xmiss, n, m, iym, ilog,'/ & ' + isize, nout, ylb, yub, xlb, xub)') end subroutine mppm ( ym, ymmiss, x, xmiss, n, m, iym ) !*****************************************************************************80 ! !! MPPM: produce a page plot with multiple Y-axis values and missing data. ! ! Discussion: ! ! this is the user callable routine which produces a simple page ! plot with multiple y-axis values and with missing ! observations (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! vector of observations for the y coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! implicit none real & xmiss integer & iym,m,n ! ! array arguments real & x(*),ym(*),ymmiss(*) ! ! scalars in common integer & ierr ! ! real & xlb,xub,ylb,yub integer & ilog,ischck,isize,lisym,nout logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'p', 'p', 'm', ' ', ' '/ multi = .true. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 2 isize = -1 nout = 0 miss = .true. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mppm (ym, ymmiss, x, xmiss, n, m, iym)') end subroutine mppml ( ym, ymmiss, x, xmiss, n, m, iym, ilog ) !*****************************************************************************80 ! !! MPPML: plot multiple Y-axis values with missing data, log option. ! ! Discussion: ! ! This is the user callable routine which produces a simple page ! plot with multiple y-axis values and with missing ! observations (log option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xmiss integer & ilog,iym,m,n ! ! array arguments real & x(*),ym(*),ymmiss(*) ! ! scalars in common integer & ierr ! ! real & xlb,xub,ylb,yub integer ischck,isize,lisym,nout logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! vector of observations for the y coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'p', 'p', 'm', 'l', ' '/ multi = .true. ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 2 isize = -1 nout = 0 miss = .true. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mppml (ym, ymmiss, x, xmiss, n, m, iym, ilog)') end subroutine msgx ( ier ) !*****************************************************************************80 ! !! MSGX prints the returned and expected values for the error flag IERR. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ier ! ! scalars in common integer & ierr ! ! common blocks common /errchk/ierr ! ! varible definitions (alphabetically) ! ! integer ier ! expected value of error flag ierr ! integer ierr ! returned error flag found in the common errchk ! write ( *,1000) ier, ierr if (ier /= ierr) write ( *,1010) return 1000 format(/' expected value for ierr is ', i1/' returned value', & ' for ierr is', i2) 1010 format(' possible error, unexpected value for error flag') end subroutine multbp ( t, lt, c, lc, temp, ltemp, mbo ) !*****************************************************************************80 ! !! MULTBP multiplies two difference factors from Box-Jenkins time series model. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real c(mbo) ! the second factor on input and the expanded factor on output. ! integer lc ! the largest order of the second factor on input, and ! the largest order of the expanded factor on output. ! integer lt ! the largest order of the first factor. ! integer ltemp ! the length of the vector temp. ! integer mbo ! the maximum back order operator. ! real t(2*mbo) ! a temporary work vector. ! real temp(mbo) ! a temporary work vector ! implicit none integer mbo real c(mbo) integer i integer j integer ji integer lc integer lt integer ltemp real t(2*mbo) real temp(mbo) temp(1:lc) = c(1:lc) temp(lc+1:ltemp) = 0.0e0 do j=1,lt temp(j) = temp(j) + t(j) do i=1,lc ji = j + i temp(ji) = temp(ji) - c(i)*t(j) end do end do c(1:ltemp) = temp(1:ltemp) lc = ltemp return end function mvchk ( x, xmiss ) !*****************************************************************************80 ! !! MVCHK checks whether the input value equals the flag value for missing data. ! ! Discussion: ! ! This routine checks whether x = xmiss (mvchk = true) or not ! (mvchk = false) in a manner which will prevent very large or ! very small missing value codes from causing an overflow. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real x ! the value to be checked. ! real xmiss ! the user supplied code which is used to determine whether or ! not an observation is missing. if x = xmiss, ! the value is assumed missing, otherwise it is not. ! implicit none logical mvchk real x real xmiss if ((x > 0.0e0 .and. xmiss < 0.0e0) .or. & (x < 0.0e0 .and. xmiss > 0.0e0)) then mvchk = .false. else if (abs(x) == abs(xmiss)) then mvchk = .true. else mvchk = .false. end if return end subroutine mvpc ( ym, n, m, iym, ns, ilog, isize, ylb, yub, xlb, xinc ) !*****************************************************************************80 ! !! MVPC produces a vertical plot with multiple Y-axis values. ! ! Discussion: ! ! This is the user callable routine which produces a vertical ! plot with multiple y-axis values (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xinc,xlb,ylb,yub integer & ilog,isize,iym,m,n,ns ! ! array arguments real & ym(*) ! ! scalars in common integer & ierr ! ! integer & ibar,irlin,ischck,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(iym,m) ! multivariate observations for the y coordinates ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'v', 'p', 'c', ' ', ' '/ multi = .true. irlin = -1 ibar = -1 ischck = 2 miss = .false. lisym = 1 call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mvpc (ym, n, m, iym, ns, ilog,'/ & ' + isize, ylb, yub, xlb, xinc)') end subroutine mvp ( ym, n, m, iym, ns ) !*****************************************************************************80 ! !! MVP produces a vertical plot with multiple Y-axis values. ! ! Discussion: ! ! This is the user callable routine which produces a vertical ! plot with multiple y-axis values (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iym,m,n,ns ! ! array arguments real & ym(*) ! ! scalars in common integer & ierr ! ! real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,ischck,isize,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(iym,m) ! multivariate observations for the y coordinates ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'v', 'p', ' ', ' ', ' '/ multi = .true. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 2 isize = -1 miss = .false. lisym = 1 irlin = -1 ibar = 0 call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mvp (ym, n, m, iym, ns)') end subroutine mvpl ( ym, n, m, iym, ns, ilog ) !*****************************************************************************80 ! !! MVPL produces a vertical plot with multiple y-axis values (log plot option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ilog,iym,m,n,ns ! ! array arguments real & ym(*) ! ! scalars in common integer & ierr ! ! real & xinc,xlb,ylb,yub integer & ibar,irlin,ischck,isize,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(iym,m) ! multivariate observations for the y coordinates ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'v', 'p', 'l', ' ', ' '/ multi = .true. ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 2 isize = -1 miss = .false. lisym = 1 irlin = -1 ibar = 0 call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mvpl (ym, n, m, iym, ns, ilog)') end subroutine mvpmc ( ym, ymmiss, n, m, iym, ns, ilog, isize, & ylb, yub, xlb, xinc ) !*****************************************************************************80 ! !! MVPMC: vertical plot with missing data, multiple y-axis values (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xinc,xlb,ylb,yub integer & ilog,isize,iym,m,n,ns ! ! array arguments real & ym(*),ymmiss(*) ! ! scalars in common integer & ierr ! ! integer & ibar,irlin,ischck,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(iym,m) ! multivariate observations for the y coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'v', 'p', 'm', 'c', ' '/ multi = .true. irlin = -1 ibar = -1 ischck = 2 miss = .true. lisym = 1 call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mvpmc (ym, ymmiss, n, m, iym, ns, ilog,'/ & ' + isize, ylb, yub, xlb, xinc)') end subroutine mvpm ( ym, ymmiss, n, m, iym, ns ) !*****************************************************************************80 ! !! MVPM: vertical plot with missing data, multiple y-axis values (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iym,m,n,ns ! ! array arguments real & ym(*),ymmiss(*) ! ! scalars in common integer & ierr ! ! real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,ischck,isize,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(iym,m) ! multivariate observations for the y coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'v', 'p', 'm', ' ', ' '/ multi = .true. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 2 isize = -1 miss = .true. lisym = 1 irlin = -1 ibar = 0 call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mvpm (ym, ymmiss, n, m, iym, ns)') end subroutine mvpml ( ym, ymmiss, n, m, iym, ns, ilog ) !*****************************************************************************80 ! !! MVPML: vertical plot with missing data, multiple y-axis values (log option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ilog,iym,m,n,ns ! ! array arguments real & ym(*),ymmiss(*) ! ! scalars in common integer & ierr ! ! real & xinc,xlb,ylb,yub integer & ibar,irlin,ischck,isize,lisym logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(iym,m) ! multivariate observations for the y coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'm', 'v', 'p', 'm', 'l', ' '/ multi = .true. ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 2 isize = -1 miss = .true. lisym = 1 irlin = -1 ibar = 0 call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym ) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call mvpml (ym, ymmiss, n, m, iym, ns, ilog)') end function nchose ( n, k ) !*****************************************************************************80 ! !! NCHOSE combines difference factors from a Box-Jenkins time series model. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer i integer k integer kk integer n integer nchose integer nn if ( n <= k ) then nchose = 1 return end if kk = min ( k, n - k ) nn = 1 do i = 1, kk nn = ( nn * ( n - i + 1 ) ) / i end do nchose = nn return end subroutine nl2itr ( d, iv, j, n, nn, p, r, v, x ) !*****************************************************************************80 ! !! NL2ITR carries out iterations for NL2SOL. ! ! Discussion: ! ! Parameters IV, N, P, V, and X are the same as the corresponding ! ones to NL2SOL, except that V can be shorter, since the part of V ! that NL2SOL uses for storing D, J, and R is not needed. ! ! Moreover, compared with NL2SOL, IV(1) may have the ! two additional output values 1 and 2, which are explained below, ! as is the use of IV(TOOBIG) and IV(NFGCAL). The values IV(D), ! IV(J), and IV(R), which are output values from NL2SOL (and ! NL2SNO), are not referenced by NL2ITR or the subroutines it calls. ! ! On a fresh start, that is, a call on NL2ITR with IV(1) = 0 or 12, ! NL2ITR assumes that R = R(X), the residual at X, and J = J(X), ! the corresponding jacobian matrix of R at X. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! ! iv(1) = 1 means the caller should set r to r(x), the residual at x, ! and call nl2itr again, having changed none of the other ! parameters. an exception occurs if r cannot be evaluated ! at x (e.g. if r would overflow), which may happen because ! of an oversized step. in this case the caller should set ! iv(toobig) = iv(2) to 1, which will cause nl2itr to ig- ! nore r and try a smaller step. the parameter nf that ! nl2sol passes to CALCR (for possible use by calcj) is a ! copy of iv(nfcall) = iv(6). ! iv(1) = 2 means the caller should set j to j(x), the jacobian matrix ! of r at x, and call nl2itr again. the caller may change ! d at this time, but should not change any of the other ! parameters. the parameter nf that nl2sol passes to ! calcj is iv(nfgcal) = iv(7). if j cannot be evaluated ! at x, then the caller may set iv(nfgcal) to 0, in which ! case nl2itr will return with iv(1) = 15. ! ! Parameters: ! ! Input, real D(N), the scale vector. ! ! Input/output, integer IV(*), the NL2SOL integer parameter array. ! ! j n by p jacobian matrix (lead dimension nn). ! ! n number of observations (components in r). ! ! nn lead dimension of j. ! ! p number of parameters (components in x). ! ! r residual vector. ! ! v floating-point value array. ! ! x parameter vector. ! implicit none integer n integer nn integer p real d(p) integer dig1 real dotprd real e integer g01 integer g1 integer h0 integer h1 integer i integer ipiv1 integer ipivi integer ipivk integer ipk integer iv(60+p) real j(nn,p) integer k integer km1 integer l integer lky1 integer lmat1 integer lstgst integer m integer pp1o2 integer qtr1 real r(n) integer rd0 integer rd1 integer rdk real rdof1 integer rsave1 integer s1 integer smh integer sstep integer step1 logical stopx integer stpmod integer, parameter :: stppar = 5 real sttsst real t real t1 integer temp1 integer temp2 real v(93 + 2*n + (p*(3*p+31))/2) real v2norm integer w1 real x(p) integer x01 ! ! external functions and subroutines ! external assess, covclc, dotprd, dupdat, gqtstp, itsmry, lmstep, & parchk, qapply, rptmul, slupdt, slvmul, stopx, & v2norm ! ! subscripts for iv and v ! integer cnvcod, cosmin, covmat, covprt, covreq, dgnorm, dig, & dinit, dstnrm, dtype, d0init, f, fdif, fuzz, & f0, g, gtstep, h, ierr, incfac, inits, ipivot, ipiv0, irc, & jtinit, jtol1, kagqt, kalm, lky, lmat, lmax0, mode, model, & mxfcal, mxiter, nfcall, nfgcal, nfcov, ngcov, ngcall, & niter, nvsave, phmxfc, preduc, qtr, radfac, radinc, & radius, rad0, rd, restor, rlimit, rsave, s, size, step, & stglim, stlstg, sused, switch, toobig, tuner4, & tuner5, vsave1, w, wscale, xirc, x0 ! ! iv subscript values ! parameter ( cnvcod=34, covmat=26, covprt=14 ) parameter (covreq=15, dig=43, dtype=16, g=28, h=44 ) parameter (ierr=32, inits=25, ipivot=61, ipiv0=60 ) parameter (irc=3, kagqt=35, kalm=36, lky=37, lmat=58 ) parameter (mode=38, model=5, mxfcal=17, mxiter=18 ) parameter (nfcall=6, nfgcal=7, nfcov=40, ngcov=41 ) parameter (ngcall=30, niter=31, qtr=49 ) parameter (radinc=8, rd=51, restor=9, rsave=52, s=53 ) parameter (step=55, stglim=11, stlstg=56, sused=57 ) parameter (switch=12, toobig=2, w=59, xirc=13, x0=60) ! ! v subscript values. ! parameter (cosmin=43, dgnorm=1, dinit=38, dstnrm=2) parameter ( d0init=37, f=10, fdif=11, fuzz=45 ) parameter ( f0=13, gtstep=4, incfac=23 ) parameter ( jtinit=39, jtol1=87, lmax0=35 ) parameter ( nvsave=9, phmxfc=21, preduc=7 ) parameter ( radfac=16, radius=8, rad0=9, rlimit=42 ) parameter ( size=47, tuner4=29, tuner5=30 ) parameter ( vsave1=78, wscale=48) i = iv(1) if ( i == 1 ) then go to 20 end if if ( i == 2 ) then go to 50 end if ! ! Check validity of iv and v input values. ! ! If iv(1) = 0, then PARCHK calls dfault(iv, v). ! call parchk ( iv, n, nn, p, v ) i = iv(1) - 2 if ( 10 < i ) then return end if go to (350, 350, 350, 350, 350, 350, 195, 160, 195, 10), i ! ! Initialization and storage allocation. ! 10 continue iv(niter) = 0 iv(nfcall) = 1 iv(ngcall) = 1 iv(nfgcal) = 1 iv(mode) = -1 iv(stglim) = 2 iv(toobig) = 0 iv(cnvcod) = 0 iv(covmat) = 0 iv(nfcov) = 0 iv(ngcov) = 0 iv(kalm) = -1 iv(radinc) = 0 iv(s) = jtol1 + 2*p pp1o2 = p * (p + 1) / 2 iv(x0) = iv(s) + pp1o2 iv(step) = iv(x0) + p iv(stlstg) = iv(step) + p iv(dig) = iv(stlstg) + p iv(g) = iv(dig) + p iv(lky) = iv(g) + p iv(rd) = iv(lky) + p iv(rsave) = iv(rd) + p iv(qtr) = iv(rsave) + n iv(h) = iv(qtr) + n iv(w) = iv(h) + pp1o2 iv(lmat) = iv(w) + 4*p + 7 ! ! Length of w = p*(p+9)/2 + 7. lmat is contained in w. ! if ( 0.0E+00 <= v(dinit) ) then d(1:p) = v(dinit) end if if ( 0.0E+00 < v(jtinit) ) then v(jtol1:jtol1+p-1) = v(jtinit) end if i = jtol1 + p if ( 0.0E+00 < v(d0init) ) then v(i:i+p-1) = v(d0init) end if v(rad0) = 0.0E+00 v(stppar) = 0.0E+00 v(radius) = v(lmax0) / ( 1.0E+00 + v(phmxfc) ) ! ! Set initial model and S matrix. ! iv(model) = 1 if ( iv(inits) == 2 ) then iv(model) = 2 end if s1 = iv(s) if ( iv(inits) == 0 ) then v(s1:s1+pp1o2-1) = 0.0E+00 end if ! ! Compute function value (half the sum of squares). ! 20 continue t = v2norm ( n, r ) if ( v(rlimit) < t ) then iv(toobig) = 1 end if if ( iv(toobig) == 0 ) then v(f) = 0.5E+00 * t**2 end if !30 continue if ( iv(mode) == 0 ) then go to 350 end if if ( 0 < iv(mode) ) then go to 730 end if !40 continue if ( iv(toobig) /= 0 ) then iv(1) = 13 call itsmry ( d, iv, p, v, x ) return end if go to 60 ! ! Make sure jacobian could be computed. ! 50 continue if ( iv(nfgcal) == 0 ) then iv(1) = 15 call itsmry ( d, iv, p, v, x ) return end if ! ! Compute gradient. ! 60 continue iv(kalm) = -1 g1 = iv(g) do i = 1, p v(g1) = dot_product ( r(1:n), j(1:n,i) ) g1 = g1 + 1 end do if ( 0 < iv(mode) ) then go to 710 end if ! ! Update D and make copies of R for possible use later. ! if ( 0 < iv(dtype) ) then call dupdat ( d, iv, j, n, nn, p, v ) end if rsave1 = iv(rsave) v(rsave1:rsave1+n-1) = r(1:n) qtr1 = iv(qtr) v(qtr1:qtr1+n-1) = r(1:n) ! ! Compute inverse ( D ) * gradient. ! g1 = iv(g) dig1 = iv(dig) k = dig1 do i = 1, p v(k) = v(g1) / d(i) k = k + 1 g1 = g1 + 1 end do v(dgnorm) = v2norm ( p, v(dig1) ) if ( iv(cnvcod) /= 0 ) then go to 700 end if if ( iv(mode) == 0 ) then go to 570 end if iv(mode) = 0 ! ! Main loop. ! ! Print iteration summary, check iteration limit. ! 150 continue call itsmry ( d, iv, p, v, x ) 160 k = iv(niter) if ( iv(mxiter) <= k ) then iv(1) = 10 call itsmry ( d, iv, p, v, x ) return end if 170 continue iv(niter) = k + 1 ! ! Update radius. ! if ( k /= 0 ) then step1 = iv(step) do i = 1, p v(step1) = d(i) * v(step1) step1 = step1 + 1 end do step1 = iv(step) v(radius) = v(radfac) * v2norm ( p, v(step1) ) end if ! ! Initialize for start of next iteration. ! x01 = iv(x0) v(f0) = v(f) iv(kagqt) = -1 iv(irc) = 4 iv(h) = -abs ( iv(h) ) iv(sused) = iv(model) ! ! Copy X to X0. ! v(x01:x01+p-1) = x(1:p) ! ! Check STOPX and function evaluation limit. ! 190 if ( .not. stopx ( ) ) then go to 200 end if iv(1) = 11 go to 205 ! ! Come here when restarting after function evaluation limit or STOPX. ! 195 continue if ( v(f) < v(f0) ) then v(radfac) = 1.0E+00 k = iv(niter) go to 170 end if 200 continue if ( iv(nfcall) < iv(mxfcal) + iv(nfcov) ) then go to 210 end if iv(1) = 9 205 continue if ( v(f0) <= v(f) ) then call itsmry ( d, iv, p, v, x ) return end if ! ! In case of STOPX or function evaluation limit with ! improved V(F), evaluate the gradient at X. ! iv(cnvcod) = iv(1) go to 560 ! ! Compute candidate step. ! 210 continue step1 = iv(step) w1 = iv(w) ! ! Compute Levenberg-Marquardt step. ! if ( iv(model) /= 2 ) then qtr1 = iv(qtr) if ( iv(kalm) < 0 ) then rd1 = iv(rd) if ( -1 == iv(kalm) ) then call qrfact ( nn, n, p, j, v(rd1), iv(ipivot), iv(ierr), & 0, v(w1) ) end if call qapply ( nn, n, p, j, v(qtr1), iv(ierr) ) end if h1 = iv(h) ! ! Copy R matrix to H. ! if ( h1 <= 0 ) then h1 = -h1 iv(h) = h1 k = h1 rd1 = iv(rd) v(k) = v(rd1) do i = 2, p call vcopy ( i-1, v(k+1), j(1,i) ) k = k + i rd1 = rd1 + 1 v(k) = v(rd1) end do end if g1 = iv(g) call lmstep ( d, v(g1), iv(ierr), iv(ipivot), iv(kalm), p, & v(qtr1), v(h1), v(step1), v, v(w1) ) ! ! Compute Goldfeld-Quandt-Trotter step (augmented model). ! else if ( iv(h) <= 0 ) then ! ! Set H to inverse ( D ) * ( J' * J + s) ) * inverse ( D ). ! h1 = -iv(h) iv(h) = h1 s1 = iv(s) ! ! J is in its original form. ! if ( iv(kalm) == -1 ) then do i = 1, p t = 1.0E+00 / d(i) do k = 1, i v(h1) = t * ( dotprd ( n, j(1,i), j(1,k) ) + v(s1) ) / d(k) h1 = h1 + 1 s1 = s1 + 1 end do end do ! ! LMSTEP has applied QRFACT to J. ! else smh = s1 - h1 h0 = h1 - 1 ipiv1 = iv(ipivot) t1 = 1.0E+00 / d(ipiv1) rd0 = iv(rd) - 1 rdof1 = v(rd0 + 1) do i = 1, p l = ipiv0 + i ipivi = iv(l) h1 = h0 + ( ipivi*(ipivi-1) ) / 2 l = h1 + ipivi m = l + smh ! ! v(l) = h(ipivot(i), ipivot(i)) ! v(m) = s(ipivot(i), ipivot(i)) ! t = 1.0E+00 / d(ipivi) rdk = rd0 + i e = v(rdk)**2 if ( 1 < i ) then e = e + dotprd ( i-1, j(1,i), j(1,i) ) end if v(l) = (e + v(m)) * t**2 if ( i /= 1 ) then l = h1 + ipiv1 if ( ipivi < ipiv1 ) then l = l + ((ipiv1-ipivi)*(ipiv1+ipivi-3)) / 2 end if m = l + smh ! ! v(l) = h(ipivot(i), ipivot(1)) ! v(m) = s(ipivot(i), ipivot(1)) ! v(l) = t * (rdof1 * j(1,i) + v(m)) * t1 do k = 2, i - 1 ipk = ipiv0 + k ipivk = iv(ipk) l = h1 + ipivk if ( ipivi < ipivk ) then l = l + ((ipivk-ipivi)*(ipivk+ipivi-3)) / 2 end if m = l + smh ! ! v(l) = h(ipivot(i), ipivot(k)) ! v(m) = s(ipivot(i), ipivot(k)) ! km1 = k - 1 rdk = rd0 + k v(l) = t * ( dotprd ( km1, j(1,i), j(1,k) ) + & v(rdk)*j(k,i) + v(m)) / d(ipivk) end do end if end do end if end if ! ! Compute actual Goldfeld-Quandt-Trotter step. ! h1 = iv(h) dig1 = iv(dig) lmat1 = iv(lmat) call gqtstp ( d, v(dig1), v(h1), iv(kagqt), v(lmat1), p, v(step1), & v, v(w1) ) end if ! ! Compute R(X0 + STEP). ! !310 continue if ( iv(irc) /= 6 ) then x01 = iv(x0) step1 = iv(step) x(1:p) = v(step1:step1+p-1) + v(x01:x01+p-1) iv(nfcall) = iv(nfcall) + 1 iv(1) = 1 iv(toobig) = 0 return end if ! ! Assess candidate step. ! 350 continue step1 = iv(step) lstgst = iv(stlstg) x01 = iv(x0) call assess ( d, iv, p, v(step1), v(lstgst), v, x, v(x01) ) ! ! If necessary, switch models and/or restore R. ! if ( iv(switch) /= 0 ) then iv(h) = -abs ( iv(h) ) iv(sused) = iv(sused) + 2 v(1:nvsave) = v(vsave1:vsave1+nvsave-1) end if !360 continue if ( iv(restor) /= 0 ) then rsave1 = iv(rsave) r(1:n) = v(rsave1:rsave1+n-1) end if l = iv(irc) - 4 stpmod = iv(model) if ( 0 < l ) then go to (410,440,450,450,450,450,450,450,640,570), l end if ! ! Decide whether to change models. ! e = v(preduc) - v(fdif) sstep = iv(lky) s1 = iv(s) call slvmul ( p, v(sstep), v(s1), v(step1) ) sttsst = 0.5E+00 * dotprd ( p, v(step1), v(sstep) ) if ( iv(model) == 1 ) then sttsst = -sttsst end if ! ! Switch models. ! if ( abs ( e ) <= abs ( e + sttsst) * v(fuzz) ) then go to 400 end if iv(model) = 3 - iv(model) if ( iv(model) == 1 ) then iv(kagqt) = -1 end if if (iv(model) == 2 .and. 0 < iv(kalm) ) then iv(kalm) = 0 end if if ( -2 < l ) then go to 480 end if iv(h) = -abs ( iv(h) ) iv(sused) = iv(sused) + 2 v(vsave1:vsave1+nvsave-1) = v(1:nvsave) go to 420 400 if ( -3 < l ) then go to 480 end if ! ! Recompute STEP with decreased radius. ! v(radius) = v(radfac) * v(dstnrm) go to 190 ! ! Recompute STEP, saving V values and R if necessary. ! 410 continue v(radius) = v(radfac) * v(dstnrm) 420 continue if ( v(f) < v(f0) ) then rsave1 = iv(rsave) v(rsave1:rsave1+n-1) = r(1:n) end if go to 190 ! ! Compute step of length V(LMAX0) for singular convergence test. ! 440 continue v(radius) = v(lmax0) go to 210 ! ! Convergence or false convergence. ! 450 continue iv(cnvcod) = l if ( v(f0) <= v(f) ) then go to 700 end if if ( iv(xirc) == 14 ) then go to 700 end if iv(xirc) = 14 ! ! Process acceptable step. ! 480 iv(covmat) = 0 ! ! Set LKY = J(X0)' * R(X). ! lky1 = iv(lky) ! ! Jacobian has not been modified. ! if ( iv(kalm) < 0 ) then do i = 1, p v(lky1) = dotprd ( n, j(1,i), r ) lky1 = lky1 + 1 end do ! ! QRFACT has been applied to J. Store copy of R in QTR and ! apply Q to it. ! else qtr1 = iv(qtr) v(qtr1:qtr1+n-1) = r(1:n) call qapply ( nn, n, p, j, v(qtr1), iv(ierr) ) ! ! Multiply top P-vector in QTR by permuted upper triangle ! stored by QRFACT in J and RD. ! rd1 = iv(rd) temp1 = iv(stlstg) call rptmul ( 3, iv(ipivot), j, nn, p, v(rd1), v(qtr1), v(lky1), & v(temp1) ) end if ! ! See whether to set V(RADFAC) by gradient tests. ! !510 continue if ( iv(irc) == 3 ) then step1 = iv(step) temp1 = iv(stlstg) temp2 = iv(x0) ! ! Set TEMP1 = hessian * STEP for use in gradient tests ! ! STEP computed using Gauss-Newton model. ! QRFACT has been applied to J. ! if ( stpmod /= 2 ) then rd1 = iv(rd) call rptmul ( 2, iv(ipivot), j, nn, p, v(rd1), & v(step1), v(temp1), v(temp2) ) ! ! STEP computed using augmented model. ! else h1 = iv(h) k = temp2 do i = 1, p v(k) = d(i) * v(step1) k = k + 1 step1 = step1 + 1 end do call slvmul ( p, v(temp1), v(h1), v(temp2) ) do i = 1, p v(temp1) = d(i) * v(temp1) temp1 = temp1 + 1 end do end if end if ! ! Save old gradient and compute new one. ! 560 continue iv(ngcall) = iv(ngcall) + 1 g1 = iv(g) g01 = iv(w) v(g01:g01+p-1) = v(g1:g1+p-1) iv(1) = 2 return ! ! Initializations -- g0 = g - g0, etc. ! 570 continue g01 = iv(w) g1 = iv(g) v(g01:g01+p-1) = - v(g01:g01+p-1) + v(g1:g1+p-1) step1 = iv(step) temp1 = iv(stlstg) temp2 = iv(x0) ! ! Set V(RADFAC) by gradient tests. ! ! Set TEMP1 = d**-1 * (hessian * STEP + ( G(x0) - G(x) ) ). ! if ( iv(irc) == 3 ) then k = temp1 l = g01 do i = 1, p v(k) = (v(k) - v(l)) / d(i) k = k + 1 l = l + 1 end do ! ! Do gradient tests. ! if ( v2norm ( p, v(temp1) ) <= v(dgnorm) * v(tuner4) .or. & dotprd ( p, v(g1), v(step1) ) < v(gtstep) * v(tuner5) ) then v(radfac) = v(incfac) end if end if ! ! Finish computing LKY = ( J(X) - J(X0) )' * R. ! ! Currently LKY = J(X0)' * R. ! lky1 = iv(lky) v(lky1:lky1+p-1) = - v(lky1:lky1+p-1) + v(g1:g1+p-1) ! ! Determine sizing factor V(SIZE). ! ! Set TEMP1 = S * STEP. ! s1 = iv(s) call slvmul ( p, v(temp1), v(s1), v(step1) ) t1 = abs ( dotprd ( p, v(step1), v(temp1) ) ) t = abs ( dotprd ( p, v(step1), v(lky1) ) ) v(size) = 1.0E+00 if ( t < t1 ) then v(size) = t / t1 end if ! ! Update S. ! call slupdt ( v(s1), v(cosmin), p, v(size), v(step1), v(temp1), & v(temp2), v(g01), v(wscale), v(lky1) ) iv(1) = 2 go to 150 ! ! Bad parameters to ASSESS. ! 640 iv(1) = 14 call itsmry ( d, iv, p, v, x ) return ! ! Convergence obtained. Compute covariance matrix if desired. ! 700 continue if ( ( iv(covreq) == 0 .and. iv(covprt) == 0 ) .or. & iv(covmat) /= 0 .or. & 7 <= iv(cnvcod) ) then iv(1) = iv(cnvcod) iv(cnvcod) = 0 call itsmry ( d, iv, p, v, x ) return end if iv(mode) = 0 710 continue call covclc ( i, d, iv, j, n, nn, p, r, v, x ) if ( i == 3 ) then iv(ngcov) = iv(ngcov) + 1 iv(ngcall) = iv(ngcall) + 1 iv(1) = 2 else if ( i == 4 ) then if ( iv(niter) == 0 ) then iv(mode) = -1 else iv(mode) = 0 end if iv(1) = iv(cnvcod) iv(cnvcod) = 0 call itsmry ( d, iv, p, v, x ) else iv(nfcov) = iv(nfcov) + 1 iv(nfcall) = iv(nfcall) + 1 iv(restor) = i iv(1) = 1 end if return 730 continue if ( iv(restor) == 1 .or. iv(toobig) /= 0 ) then go to 710 end if iv(nfgcal) = iv(nfcall) iv(ngcov) = iv(ngcov) + 1 iv(ngcall) = iv(ngcall) + 1 iv(1) = 2 return end subroutine nl2sno ( n, p, x, calcr, iv, v, uiparm, urparm, ufparm ) !*****************************************************************************80 ! !! NL2SNO is like NL2SOL, but uses a finite difference jacobian. ! ! Discussion: ! ! NL2SNO is like NL2SOL, but without calcj -- minimize nonlinear sum of ! squares using finite-difference jacobian approximations ! ! The parameters for NL2SNO are the same as those for NL2SOL ! except that CALCJ is omitted. Instead of calling ! CALCJ to obtain the jacobian matrix of R at X, NL2SNO computes ! an approximation to it by forward finite differences. See ! V(DLTFDJ) below. NL2SNO uses function values only when comput- ! the covariance matrix, rather than the functions and gradients ! that NL2SOL may use. To do so, NL2SNO sets IV(COVREQ) to -1 if ! IV(COVPRT) = 1 with IV(COVREQ) = 0 and to minus its absolute ! value otherwise. Thus V(DELTA0) is never referenced and only ! V(DLTFDC) matters. See NL2SOL for a description of V(DLTFDC). ! ! The number of extra calls on CALCR used in computing the jacobian ! approximation are not included in the function evaluation ! count IV(NFCALL) and are not otherwise reported. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! ! Parameters: ! ! V(DLTFDJ) helps choose the step size used when computing the ! finite-difference jacobian matrix. For differences involving X(I), ! the step size first tried is ! V(DLTFDJ) * max ( abs ( X(I) ), 1/D(I)), ! where D is the current scale vector; see reference 1. If this step is ! too big, so that CALCR sets NF to 0, then smaller steps are tried ! until the step size is shrunk below 1000 * MACHEP, where MACHEP ! is the unit roundoff. Default = sqrt ( MACHEP ). ! implicit none integer p external calcr integer, parameter :: covprt = 14 integer, parameter :: covreq = 15 integer, parameter :: d = 27 integer d1 integer, parameter :: dinit = 38 integer dk integer, parameter :: dltfdj = 36 integer, parameter :: dtype = 16 real h real, parameter :: hfac = 1000.0E+00 real, save :: hlim = 0.0E+00 integer i integer iv(60+p) integer, parameter :: j = 33 integer j1 integer j1k integer k integer n integer nf integer, parameter :: nfcall = 6 integer, parameter :: nfgcal = 7 integer, parameter :: r = 50 integer r1 integer rn logical strted integer, parameter :: toobig = 2 external ufparm integer uiparm(*) real urparm(*) real v(93 + n*p + 3*n + (p*(3*p+33))/2) real x(p) real xk d1 = 94 + 2 * n + ( p * ( 3 * p + 31 ) ) / 2 iv(d) = d1 r1 = d1 + p iv(r) = r1 j1 = r1 + n iv(j) = j1 rn = j1 - 1 if ( iv(1) == 0 ) then call dfault ( iv, v ) end if iv(covreq) = -abs ( iv(covreq) ) if ( iv(covprt) /= 0 .and. iv(covreq) == 0 ) then iv(covreq) = -1 end if strted = .true. if ( iv(1) /= 12 ) then go to 80 end if strted = .false. iv(nfcall) = 1 iv(nfgcal) = 1 ! ! Initialize scale vector D to ones for computing initial jacobian. ! if ( 0 < iv(dtype) ) then v(d1:d1+p-1) = 1.0E+00 end if 10 continue nf = iv(nfcall) call calcr ( n, p, x, nf, v(r1), uiparm, urparm, ufparm ) if ( strted ) then if ( nf <= 0 ) then iv(toobig) = 1 end if go to 80 end if if ( nf <= 0 ) then iv(1) = 13 call itsmry ( v(d1), iv, p, v, x ) return end if ! ! Compute finite-difference jacobian. ! 30 continue j1k = j1 dk = d1 do k = 1, p xk = x(k) h = v(dltfdj) * max ( abs ( xk ), 1.0E+00 / v(dk) ) dk = dk + 1 do x(k) = xk + h nf = iv(nfgcal) call calcr ( n, p, x, nf, v(j1k), uiparm, urparm, ufparm ) if ( 0 < nf ) then exit end if if ( hlim == 0.0E+00 ) then hlim = hfac * epsilon ( hlim ) end if h = -0.5E+00 * h if ( abs ( h ) < hlim ) then iv(1) = 15 call itsmry ( v(d1), iv, p, v, x ) return end if end do x(k) = xk do i = r1, rn v(j1k) = ( v(j1k) - v(i) ) / h j1k = j1k + 1 end do end do strted = .true. 80 continue call nl2itr ( v(d1), iv, v(j1), n, n, p, v(r1), v, x ) if ( iv(1) < 2 ) then go to 10 else if ( iv(1) == 2 ) then go to 30 end if return end subroutine nl2sol ( n, p, x, calcr, calcj, iv, v, uiparm, urparm, ufparm ) !*****************************************************************************80 ! !! NL2SOL minimizes a nonlinear sum of squares using an analytic jacobian. ! ! Purpose: ! ! Given a P-vector X of parameters, CALCR computes an N-vector ! R = R(X) of residuals corresponding to X. R(X) probably arises ! from a nonlinear model involving P parameters and N observations. ! ! This routine interacts with NL2ITR to seek a parameter vector X ! that minimizes the sum of the squares of the components of R(X), ! i.e., that minimizes the sum-of-squares function ! F(X) = R(X)' * R(X) / 2. R(X) is assumed to be a twice ! continuously differentiable function of X. ! ! See reference 1 for a description of the algorithm used. ! On problems which are naturally well scaled, better performance ! may be obtained by setting V(D0INIT) = 1.0 and IV(DTYPE) = 0, ! which will cause the scale vector D to be set to all ones. ! ! After a return with IV(1) <= 11, it is possible to restart, ! that is, to change some of the IV and V input values and continue ! the algorithm from the point where it was interrupted. IV(1) ! should not be changed, nor should any entries of IV ! and V other than the input values (those supplied by DFAULT). ! ! Those who do not wish to write a CALCJ which computes the jacobian ! matrix analytically should call NL2SNO rather than NL2SOL. ! NL2SNO uses finite differences to compute an approximate jacobian. ! ! Those who would prefer to provide R and J (the residual and ! jacobian) by reverse communication rather than by writing subroutines ! CALCR and CALCJ may call on NL2ITR directly. See the comments at the ! beginning of NL2ITR. ! ! Those who use NL2SOL interactively may wish to supply their ! own STOPX function, which should return TRUE if the break key ! has been pressed since stopx was last invoked. This makes it possible ! to externally interrupt NL2SOL (which will return with ! IV(1) = 11 if STOPX returns TRUE). ! ! Storage for J is allocated at the end of V. Thus the caller ! may make V longer than specified above and may allow CALCJ to use ! elements of J beyond the first N*P as scratch storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! ! Parameters: ! ! Input, integer N, the number of observations, that is, the number of ! components in R(X). P <= N. ! ! Input, integer P, the number of parameters, or components in X. P must ! be positive. ! ! Input/output, real X(P). On input, X is an initial guess at the ! desired parameter estimate. On output, X contains the best parameter ! estimate found. ! ! Input, external CALCR, a subroutine which, given X, computes R(X). ! CALCR must be declared external in the calling program. ! It is invoked by ! call calcr ( n, p, x, nf, r, uiparm, urparm, ufparm ) ! When CALCR is called, NF is the invocation count for CALCR. It is ! included for possible use with CALCJ. If X is out of bounds, for ! instance, if it would cause overflow in computing R(X), then CALCR ! should set NF to 0. This will cause a shorter step to be attempted. ! The other parameters are as described above and below. CALCR ! should not change N, P, or X. ! ! Input, external CALCJ, a subroutine which, given X, computes the ! jacobian matrix J of R at X, that is, the N by P matrix whose ! (I,K) entry is the partial derivative of the I-th component of R ! with respect to X(K). CALCJ must be declared external in the ! calling program. It is invoked by ! call calcj(n,p,x,nf,j,uiparm,urparm,ufparm) ! NF is the invocation count for CALCR at the time R(X) was evaluated. ! The X passed to CALCJ is usually the one passed to CALC on either its ! most recent invocation or the one prior to it. If CALCR saves ! intermediate results for use by CALCJ, then it is possible to tell ! from NF whether they are valid for the current X (or which copy is ! valid if two copies are kept). If J cannot be computed at X, ! then CALCJ should set NF to 0. In this case, NL2SOL will return ! with IV(1) = 15. The other parameters to CALCJ are as described ! above and below. CALCJ should not change N, P, or X. ! ! Input/output, integer IV(60+P), helps control the NL2SOL algorithm ! and is used to store various intermediate quantities. Of particular ! interest are the initialization/return code IV(1) and the entries ! in that control printing and limit the number of iterations and ! function evaluations. See the section on IV input values. ! ! v........ (input/output) a floating-point value array of length at ! least 93 + n*p + 3*n + p*(3*p+33)/2 that helps con- ! trol the nl2sol algorithm and that is used to store ! various intermediate quantities. of particular in- ! terest are the entries in v that limit the length of ! the first step attempted (lmax0), specify conver- ! gence tolerances (afctol, rfctol, xctol, xftol), ! and help choose the step size used in computing the ! covariance matrix (delta0). see the section on ! (selected) v input values below. ! ! uiparm... (input) user integer parameter array passed without change ! to calcr and calcj. ! ! urparm... (input) user floating-point parameter array passed without ! change to calcr and calcj. ! ! ufparm... (input) user external subroutine or function passed without ! change to calcr and calcj. ! ! iv input values (from subroutine dfault) ! ! iv(1)... on input, iv(1) should have a value between 0 and 12...... ! 0 and 12 mean this is a fresh start. 0 means that ! dfault(iv, v) is to be called to provide all default ! values to iv and v. 12 (the value that dfault assigns to ! iv(1)) means the caller has already called dfault(iv, v) ! and has possibly changed some iv and/or v entries to non- ! default values. default = 12. ! iv(covprt)... iv(14) = 1 means print a covariance matrix at the solu- ! tion. (this matrix is computed just before a return with ! iv(1) = 3, 4, 5, 6.) ! iv(covprt) = 0 means skip this printing. default = 1. ! iv(covreq)... iv(15) = nonzero means compute a covariance matrix ! just before a return with iv(1) = 3, 4, 5, 6. in ! this case, an approximate covariance matrix is obtained ! in one of several ways. let k = abs(iv(covreq)) and let ! scale = 2*f(x)/max(1,n-p), where 2*f(x) is the residual ! sum of squares. if k = 1 or 2, then a finite-difference ! hessian approximation h is obtained. if h is positive ! definite (or, for k = 3, if the jacobian matrix j at x ! is nonsingular), then one of the following is computed... ! k = 1.... scale * h**-1 * (j**t * j) * h**-1. ! k = 2.... scale * h**-1. ! k = 3.... scale * (j**t * j)**-1. ! (j**t is the transpose of j, while **-1 means inverse.) ! if iv(covreq) is positive, then both function and grad- ! ient values (calls on calcr and calcj) are used in com- ! puting h (with step sizes determined using v(delta0) -- ! see below), while if iv(covreq) is negative, then only ! function values (calls on calcr) are used (with step ! sizes determined using v(dltfdc) -- see below). if ! iv(covreq) = 0, then no attempt is made to compute a co- ! variance matrix (unless iv(covprt) = 1, in which case ! iv(covreq) = 1 is assumed). see iv(covmat) below. ! default = 1. ! iv(dtype).... iv(16) tells how the scale vector D (see ref. 1) should ! be chosen. 1 <= iv(dtype) means choose d as described ! below with v(dfac). iv(dtype) <= 0 means the caller ! has chosen d and has stored it in v starting at ! v(94 + 2*n + p*(3*p + 31)/2). default = 1. ! iv(inits).... iv(25) tells how the S matrix (see ref. 1) should be ! initialized. 0 means initialize S to 0 (and start with ! the Gauss-Newton model). 1 and 2 mean that the caller ! has stored the lower triangle of the initial S rowwise in ! v starting at v(87+2*p). iv(inits) = 1 means start with ! the Gauss-Newton model, while iv(inits) = 2 means start ! with the augmented model (see ref. 1). default = 0. ! iv(mxfcal)... iv(17) gives the maximum number of function evaluations ! (calls on calcr, excluding those used to compute the co- ! variance matrix) allowed. if this number does not suf- ! fice, then nl2sol returns with iv(1) = 9. default = 200. ! iv(mxiter)... iv(18) gives the maximum number of iterations allowed. ! it also indirectly limits the number of gradient evalua- ! tions (calls on calcj, excluding those used to compute ! the covariance matrix) to iv(mxiter) + 1. if iv(mxiter) ! iterations do not suffice, then nl2sol returns with ! iv(1) = 10. default = 150. ! iv(outlev)... iv(19) controls the number and length of iteration sum- ! mary lines printed (by itsmry). iv(outlev) = 0 means do ! not print any summary lines. otherwise, print a summary ! line after each abs(iv(outlev)) iterations. if iv(outlev) ! is positive, then summary lines of length 117 (plus carri- ! age control) are printed, including the following... the ! iteration and function evaluation counts, current func- ! tion value (v(f) = half the sum of squares), relative ! difference in function values achieved by the latest step ! (i.e., reldf = (f0-v(f))/f0, where f0 is the function ! value from the previous iteration), the relative function ! reduction predicted for the step just taken (i.e., ! preldf = v(preduc) / f0, where v(preduc) is described ! below), the scaled relative change in x (see v(reldx) ! below), the models used in the current iteration (g = ! Gauss-Newton, s=augmented), the Marquardt parameter ! STPPAR used in computing the last step, the sizing factor ! used in updating s, the 2-norm of the scale vector d ! times the step just taken (see ref. 1), and npreldf, i.e., ! v(nreduc)/f0, where v(nreduc) is described below -- if ! npreldf is positive, then it is the relative function ! reduction predicted for a Newton step (one with ! STPPAR = 0). if npreldf is zero, either the gradient ! vanishes (as does preldf) or else the augmented model ! is being used and its hessian is indefinite (with preldf ! positive). if npreldf is negative, then it is the nega- ! of the relative function reduction predicted for a step ! computed with step bound v(lmax0) for use in testing for ! singular convergence. ! if iv(outlev) is negative, then lines of maximum ! length 79 (or 55 is iv(covprt) = 0) are printed, includ- ! ing only the first 6 items listed above (through reldx). ! default = 1. ! iv(parprt)... iv(20) = 1 means print any nondefault v values on a ! fresh start or any changed v values on a restart. ! iv(parprt) = 0 means skip this printing. default = 1. ! iv(prunit)... iv(21) is the output unit number on which all printing ! is done. iv(prunit) = 0 means suppress all printing. ! (setting iv(prunit) to 0 is the only way to suppress the ! one-line termination reason message printed by itsmry.) ! default = standard output unit (unit 6 on most systems). ! iv(solprt)... iv(22) = 1 means print out the value of x returned (as ! well as the corresponding gradient and scale vector d). ! iv(solprt) = 0 means skip this printing. default = 1. ! iv(statpr)... iv(23) = 1 means print summary statistics upon return- ! ing. these consist of the function value (half the sum ! of squares) at x, v(reldx) (see below), the number of ! function and gradient evaluations (calls on calcr and ! calcj respectively, excluding any calls used to compute ! the covariance), the relative function reductions predict- ! ed for the last step taken and for a Newton step (or per- ! haps a step bounded by v(lmax0) -- see the descriptions ! of preldf and npreldf under iv(outlev) above), and (if an ! attempt was made to compute the covariance) the number of ! calls on calcr and calcj used in trying to compute the ! covariance. iv(statpr) = 0 means skip this printing. ! default = 1. ! iv(x0prt).... iv(24) = 1 means print the initial x and scale vector d ! (on a fresh start only). iv(x0prt) = 0 means skip this ! printing. default = 1. ! ! (selected) iv output values ! ! iv(1)........ on output, iv(1) is a return code.... ! 3 = x-convergence. the scaled relative difference be- ! tween the current parameter vector x and a locally ! optimal parameter vector is very likely at most ! v(xctol). ! 4 = relative function convergence. the relative differ- ! ence between the current function value and its lo- ! cally optimal value is very likely at most v(rfctol). ! 5 = both x- and relative function convergence (i.e., the ! conditions for iv(1) = 3 and iv(1) = 4 both hold). ! 6 = absolute function convergence. the current function ! value is at most v(afctol) in absolute value. ! 7 = singular convergence. the hessian near the current ! iterate appears to be singular or nearly so, and a ! step of length at most v(lmax0) is unlikely to yield ! a relative function decrease of more than v(rfctol). ! 8 = false convergence. the iterates appear to be converg- ! ing to a noncritical point. this may mean that the ! convergence tolerances (v(afctol), v(rfctol), ! v(xctol)) are too small for the accuracy to which ! the function and gradient are being computed, that ! there is an error in computing the gradient, or that ! the function or gradient is discontinuous near x. ! 9 = function evaluation limit reached without other con- ! vergence (see iv(mxfcal)). ! 10 = iteration limit reached without other convergence ! (see iv(mxiter)). ! 11 = stopx returned .true. (external interrupt). see the ! usage notes below. ! 13 = f(x) cannot be computed at the initial x. ! 14 = bad parameters passed to assess (which should not ! occur). ! 15 = the jacobian could not be computed at x (see calcj ! above). ! 16 = n or p (or parameter nn to nl2itr) out of range -- ! p <= 0 or n < p or nn < n. ! 17 = restart attempted with n or p (or par. nn to nl2itr) ! changed. ! 18 = iv(inits) is out of range. ! 19...45 = v(iv(1)) is out of range. ! 50 = iv(1) was out of range. ! 87...(86+p) = jtol(iv(1)-86) (i.e., v(iv(1)) is not ! positive (see v(dfac) below). ! iv(covmat)... iv(26) tells whether a covariance matrix was computed. ! if (iv(covmat) is positive, then the lower triangle of ! the covariance matrix is stored rowwise in v starting at ! v(iv(covmat)). if iv(covmat) = 0, then no attempt was ! made to compute the covariance. if iv(covmat) = -1, ! then the finite-difference hessian was indefinite. and ! and if iv(covmat) = -2, then a successful finite-differ- ! encing step could not be found for some component of x ! (i.e., calcr set nf to 0 for each of two trial steps). ! note that iv(covmat) is reset to 0 after each successful ! step, so if such a step is taken after a restart, then ! the covariance matrix will be recomputed. ! iv(d)........ iv(27) is the starting subscript in v of the current ! scale vector d. ! iv(g)........ iv(28) is the starting subscript in v of the current ! least-squares gradient vector (j**t)*r. ! iv(nfcall)... iv(6) is the number of calls so far made on calcr (i.e., ! function evaluations, including those used in computing ! the covariance). ! iv(nfcov).... iv(40) is the number of calls made on calcr when ! trying to compute covariance matrices. ! iv(ngcall)... iv(30) is the number of gradient evaluations (calls on ! calcj) so far done (including those used for computing ! the covariance). ! iv(ngcov).... iv(41) is the number of calls made on calcj when ! trying to compute covariance matrices. ! iv(niter).... iv(31) is the number of iterations performed. ! iv(r)........ iv(50) is the starting subscript in v of the residual ! vector r corresponding to x. ! ! (selected) v input values (from subroutine dfault) ! ! v(afctol)... v(31) is the absolute function convergence tolerance. ! if nl2sol finds a point where the function value (half ! the sum of squares) is less than v(afctol), and if nl2sol ! does not return with iv(1) = 3, 4, or 5, then it returns ! with iv(1) = 6. default = max(10**-20, machep**2), where ! machep is the unit roundoff. ! v(delta0)... v(44) is a factor used in choosing the finite-difference ! step size used in computing the covariance matrix when ! iv(covreq) = 1 or 2. for component i, step size ! v(delta0) * max(abs(x(i)), 1/d(i)) * sign(x(i)) ! is used, where d is the current scale vector (see ref. 1). ! (if this step results in calcr setting nf to 0, then -0.5 ! times this step is also tried.) default = machep**0.5, ! where machep is the unit roundoff. ! v(dfac)..... v(41) and the d0 and jtol arrays (see v(d0init) and ! v(jtinit)) are used in updating the scale vector d when ! 0 < iv(dtype). (d is initialized according to ! v(dinit).) let d1(i) = ! max(sqrt(jcnorm(i)**2 + max(s(i,i),0)), v(dfac)*d(i)), ! where jcnorm(i) is the 2-norm of the i-th column of the ! current jacobian matrix and s is the s matrix of ref. 1. ! if iv(dtype) = 1, then d(i) is set to d1(i) unless ! d1(i) < jtol(i), in which case d(i) is set to ! max(d0(i), jtol(i)). ! if 2 <= iv(dtype), then d is updated during the first ! iteration as for iv(dtype) = 1 (after any initialization ! due to v(dinit)) and is left unchanged thereafter. ! default = 0.6. ! v(dinit).... v(38), if nonnegative, is the value to which the scale ! vector d is initialized. default = 0. ! v(dltfdc)... v(40) helps choose the step size used when computing the ! covariance matrix when iv(covreq) = -1 or -2. for ! differences involving x(i), the step size first tried is ! v(dltfdc) * max(abs(x(i)), 1/d(i)), ! where d is the current scale vector (see ref. 1). (if ! this step is too big the first time it is tried, i.e., if ! calcr sets nf to 0, then -0.5 times this step is also ! tried.) default = machep**(1/3), where machep is the ! unit roundoff. ! v(d0init)... v(37), if positive, is the value to which all components ! of the d0 vector (see v(dfac)) are initialized. if ! v(dfac) = 0, then it is assumed that the caller has ! stored d0 in v starting at v(p+87). default = 1.0. ! v(jtinit)... v(39), if positive, is the value to which all components ! of the jtol array (see v(dfac)) are initialized. if ! v(jtinit) = 0, then it is assumed that the caller has ! stored jtol in v starting at v(87). default = 10**-6. ! v(lmax0).... v(35) gives the maximum 2-norm allowed for d times the ! very first step that nl2sol attempts. it is also used ! in testing for singular convergence -- if the function ! reduction predicted for a step of length bounded by ! v(lmax0) is at most v(rfctol) * abs(f0), where f0 is ! the function value at the start of the current iteration, ! and if nl2sol does not return with iv(1) = 3, 4, 5, or 6, ! then it returns with iv(1) = 7. default = 100. ! v(rfctol)... v(32) is the relative function convergence tolerance. ! if the current model predicts a maximum possible function ! reduction (see v(nreduc)) of at most v(rfctol)*abs(f0) at ! the start of the current iteration, where f0 is the ! then current function value, and if the last step attempt- ! ed achieved no more than twice the predicted function ! decrease, then nl2sol returns with iv(1) = 4 (or 5). ! default = max(10**-10, machep**(2/3)), where machep is ! the unit roundoff. ! v(tuner1)... v(26) helps decide when to check for false convergence ! and to consider switching models. this is done if the ! actual function decrease from the current step is no more ! than v(tuner1) times its predicted value. default = 0.1. ! v(xctol).... v(33) is the x-convergence tolerance. if a Newton step ! (see v(nreduc)) is tried that has v(reldx) <= v(xctol) ! and if this step yields at most twice the predicted func- ! tion decrease, then nl2sol returns with iv(1) = 3 (or 5). ! (see the description of v(reldx) below.) ! default = machep**0.5, where machep is the unit roundoff. ! v(xftol).... v(34) is the false convergence tolerance. if a step is ! tried that gives no more than v(tuner1) times the predict- ! ed function decrease and that has v(reldx) <= v(xftol), ! and if nl2sol does not return with iv(1) = 3, 4, 5, 6, or ! 7, then it returns with iv(1) = 8. (see the description ! of v(reldx) below.) default = 100*machep, where ! machep is the unit roundoff. ! v(*)........ dfault supplies to v a number of tuning constants, with ! which it should ordinarily be unnecessary to tinker. see ! version 2.2 of the nl2sol usage summary (which is an ! appendix to ref. 1). ! ! (selected) v output values ! ! v(dgnorm)... v(1) is the 2-norm of (d**-1)*g, where g is the most re- ! cently computed gradient and d is the corresponding scale ! vector. ! v(dstnrm)... v(2) is the 2-norm of d * step, where step is the most re- ! cently computed step and d is the current scale vector. ! v(f)........ v(10) is the current function value (half the sum of ! squares). ! v(f0)....... v(13) is the function value at the start of the current ! iteration. ! v(nreduc)... v(6), if positive, is the maximum function reduction ! possible according to the current model, i.e., the func- ! tion reduction predicted for a Newton step (i.e., ! step = -h**-1 * g, where g = (j**t) * r is the current ! gradient and h is the current hessian approximation -- ! h = (j**t)*j for the Gauss-Newton model and ! h = (j**t)*j + s for the augmented model). ! v(nreduc) = zero means h is not positive definite. ! if v(nreduc) is negative, then it is the negative of ! the function reduction predicted for a step computed with ! a step bound of v(lmax0) for use in testing for singular ! convergence. ! v(preduc)... v(7) is the function reduction predicted (by the current ! quadratic model) for the current step. this (divided by ! v(f0)) is used in testing for relative function ! convergence. ! v(reldx).... v(17) is the scaled relative change in x caused by the ! current step, computed as ! max(abs(d(i)*(x(i)-x0(i)), 1 <= i <= p) / ! max(d(i)*(abs(x(i))+abs(x0(i))), 1 <= i <= p), ! where x = x0 + step. ! implicit none integer p external calcj external calcr integer, parameter :: d = 27 integer d1 integer iv(60+p) integer, parameter :: j = 33 integer j1 integer n integer nf integer, parameter :: nfcall = 6 integer, parameter :: nfgcal = 7 integer, parameter :: r = 50 integer r1 logical strted integer, parameter :: toobig = 2 external ufparm integer uiparm(*) real urparm(*) real v(93 + n*p + 3*n + (p*(3*p+33))/2) real x(p) d1 = 94 + 2*n + ( p * ( 3 * p + 31 ) ) / 2 iv(d) = d1 r1 = d1 + p iv(r) = r1 j1 = r1 + n iv(j) = j1 strted = .true. if ( iv(1) /= 0 .and. iv(1) /= 12 ) then go to 40 end if strted = .false. iv(nfcall) = 1 iv(nfgcal) = 1 10 continue nf = iv(nfcall) call calcr ( n, p, x, nf, v(r1), uiparm, urparm, ufparm ) if ( strted ) then if ( nf <= 0 ) then iv(toobig) = 1 end if go to 40 end if if ( nf <= 0 ) then iv(1) = 13 call itsmry ( v(d1), iv, p, v, x ) return end if 30 continue call calcj ( n, p, x, iv(nfgcal), v(j1), uiparm, urparm, ufparm ) if ( iv(nfgcal) == 0 ) then iv(1) = 15 call itsmry ( v(d1), iv, p, v, x ) return end if strted = .true. 40 continue call nl2itr ( v(d1), iv, v(j1), n, n, p, v(r1), v, x ) if ( iv(1) == 2 ) then go to 30 end if if ( iv(1) < 2 ) then go to 10 end if return end subroutine nl2x ( ) !*****************************************************************************80 ! !! NL2X tests nl2sol and nl2sno on madsen example. ! implicit none real & urparm(1),v(147),x(2) integer & iv(62),uiparm(1) ! ! external subroutines external madj,madr,nl2sno,nl2sol,ufparm ! x(1) = 3.0e0 x(2) = 1.0e0 iv(1) = 0 call nl2sol(3, 2, x, madr, madj, iv, v, uiparm, urparm, ufparm) iv(1) = 12 x(1) = 3.0e0 x(2) = 1.0e0 call nl2sno(3, 2, x, madr, iv, v, uiparm, urparm, ufparm) return end subroutine nlcmp ( y, weight, wt, lwt, n, npar, npare, & res, d, rd, cond, vcvl, lvcvl, nnzw, idf, rsshlf, rss, rsd, & yss, exact, pvt, sdpvt, sdrest, iskull ) !*****************************************************************************80 ! !! NLCMP computes statistics for the NLS family when weights are involved. ! ! Discussion: ! ! this routine computes various statistics and values returned ! and/or printed by the nls family of routines when weights are ! involved. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real cond ! the condition number of d. ! real d(n,npar) ! the first derivative of the model (jacobian). ! logical exact ! an indicator value used to designate whether the fit ! was exact to machine precision (true) or not (false). ! real fac ! a factor used to correct for zero weighted observations in ! the variance covariance computation. ! real fplm ! the floating point largest magnitude. ! integer i ! an index variable. ! integer idf ! the degrees of freedom in the fit. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer iskull(10) ! an error message indicator variable. ! integer j ! an index variable. ! integer jk ! the index of the (j,k)th element of the variance-covariance ! matrix. ! integer k ! an index variable. ! integer lvcvl ! the dimension of vector vcvl. ! integer lwt ! the dimension of vector wt. ! integer n ! the number of observations. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! real pvt(n) ! the predicted value based on the current parameter estimates. ! real rd(n) ! the diagonal elements of the r matrix of the q - r ! factorization of d. ! real res(n) ! the residuals from the fit. ! real rsd ! the residual standard deviation. ! real rss ! the residual sum of squares. ! real rsshlf ! half the residual sum of squares. ! real rvar ! the residual variance. ! real sdpvt(n) ! the standard deviations of the predicted values. ! real sdrest(n) ! the standardized residuals. ! real sm ! a variable used for summation. ! real tj ! ... ! real vcvl(lvcvl) ! the lower half of the variance-covariance matrix, stored ! row wise. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real wti ! the actual weight used for the ith observation. ! real wtsum ! the sum of the weights. ! real y(n) ! the dependent variable. ! real yss ! the sum of the squares about the mean y value. ! real ywtsm ! the sum of the values y(i)*wt(i), i=1,n. ! real ywtysm ! the sum of the values y(i)*wt(i)*wt(i), i=1,n. ! implicit none integer n integer npar real cond logical exact integer i integer idf integer ierr integer j integer jk integer k real rsd real rss real rsshlf real rvar logical weight real yss real ywtsm integer & lvcvl,lwt,nnzw,npare ! ! array arguments real & d(n,npar),pvt(n),rd(n),res(n),sdpvt(n),sdrest(n),vcvl(lvcvl), & wt(lwt),y(n) integer & iskull(10) ! ! real & fac,fplm,sm,tj,wti,wtsum,ywtysm ! ! external subroutines external fitext ! ! common blocks common /errchk/ierr fplm = huge ( fplm ) ! ! compute residuals ! res(1:n) = y(1:n) - pvt(1:n) ! ! compute various statistics ! idf = nnzw - npare rss = 2.0e0*rsshlf if (idf >= 1) then rvar = rss / real ( idf ) else rvar = 0.0E+00 end if rsd = sqrt(rvar) ywtsm = 0.0e0 ywtysm = 0.0e0 wtsum = 0.0e0 if ( .not. weight ) then ywtsm = sum ( y(1:n) ) ywtysm = sum ( y(1:n)**2 ) wtsum = real ( n ) else ywtsm = dot_product ( wt(1:n), y(1:n) ) ywtysm = dot_product ( wt(1:n), y(1:n)**2 ) wtsum = sum ( wt(1:n) ) end if yss = max(ywtysm-(ywtsm*ywtsm)/wtsum,0.0e0) call fitext(rss, yss, exact) if (rd(npare) /= 0.0e0) then cond = abs(rd(1)/rd(npare)) else cond = fplm end if if (ierr /= 0) then return end if ! ! correct for degrees of freedom if necessary because of zero ! weighted observations. ! if ( n /= nnzw ) then fac = real ( n - npare ) if (idf >= 1) then fac = fac / real ( idf ) end if vcvl(1:lvcvl) = vcvl(1:lvcvl)*fac end if ! ! if the residual sum of squares is identically zero, then ! no further computations are necessary ! if ((idf <= 0) .or. exact) return ! ! if the standard deviations of the predicted values and ! standardized residuals are not saved or printed, then no ! further computations are necessary. ! ! compute the standard deviations of the predicted values (sdpvt) ! do i=1,n sm = 0.0e0 do j=1,npare tj = 0.0e0 do k=1,npare if (j >= k) then jk = j*(j-1)/2 + k else jk = k*(k-1)/2 + j end if tj = tj + vcvl(jk)*d(i,k) end do sm = sm + d(i,j)*tj end do if (sm<0.0e0) sm = 0.0e0 sdpvt(i) = sqrt(sm) sdrest(i) = fplm wti = 1.0e0 if (weight) wti = wt(i) if (wti /= 0.0e0) then if (rvar/wti-sm <= 0.0e0) then sdrest(i) = fplm iskull(1) = 1 iskull(4) = 1 ierr = 4 else sdrest(i) = res(i)/sqrt(rvar/wti-sm) end if end if end do return end subroutine nlcnta ( y, wt, lwt, xm, n, m, ixm, mdl, drv, par, npar, & res, ldstak, ifixed, lifixd, idrvck, mit, stopss, stopp, & scale, lscale, delta, ivcvop, nprt, rsd, pv, lpv, sdpv, lsdpv, & sdres, lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare ) !*****************************************************************************80 ! !! NLCNTA: controlling routine for NLS regression with analytic derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,rsd,stopp,stopss integer & idrvck,ivcv,ivcvop,ixm,ldstak,lifixd,lpv,lscale,lsdpv, & lsdres,lwt,m,mit,n,nnzw,npar,npare,nprt logical & save,weight ! ! array arguments real & par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),vcv(*),wt(*), & xm(*),y(*) integer & ifixed(*) character & nmsub(6)*1 ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & isubhd,ldsmin,lstp,ndigit,neta,nrow,ntau logical & aprxdv,hlfrpt,page,prtfxd,wide ! ! local arrays real & stp(1) integer & iptout(5) ! ! external functions integer & icnti external icnti ! ! external subroutines external dckcnt,ldscmp,nlcnt,nldrva,nler,nlhdra,prtcnt,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer idrvck ! the variable used to indicate whether the derivatives are ! to be checked (idrvck = 1) or not (idrvck = 0). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer iptout(5) ! the variable used to control printed output for each section. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ivcvop ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivcvop le 0 indicates the the default option will be used ! ivcvop eq 1 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivcvop eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivcvop eq 3 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivcvop eq 4 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivcvop eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivcvop eq 6 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivcvop ge 7 indicates the default option will be used ! integer ixm ! the first dimension of the independent variable array. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! integer neta ! the number of accurate digits in the model results. ! external nldrva ! the name of the routine which calculates the derivatives. ! external nlhdra ! the name of the routine which produces the heading. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! integer nrow ! the number of the row of the independent variable array at ! which the derivative is to be checked. ! integer ntau ! the number of digits of agreement required between the ! numerically approximated derivatives and the user supplied ! drvitives. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! real pv(lpv) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(lscale) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(1) ! the dummy step size array. ! real vcv(ivcv,npar) ! the variance-covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! hlfrpt = .false. aprxdv = .false. prtfxd = .true. stp(1) = 0.0e0 lstp = 1 neta = 0 ntau = 0 nrow = 0 wide = .true. page = .false. ndigit = 5 ierr = 0 if ((ifixed(1) >= 0) .and. (npar >= 1)) then npare = icnti(ifixed,npar,0) else npare = npar end if call ldscmp(6, 0, 60+2*npar, 0, 0, 0, 's', & 94+n*(3+npar)+npare*(3*npare+35)/2, ldsmin) call nler (nmsub, weight, wt, lwt, n, m, ixm, & ifixed, lifixd, npar, npare, & ldstak, ldsmin, stp, lstp, scale, lscale, ivcv, save, nnzw) if (ierr /= 0) return call stkset(ldstak, 4) ! ! set print control values ! call prtcnt(nprt, ndigit, iptout) ! ! check derivatives, if desired ! if ( idrvck /= 0 ) then isubhd = 1 call dckcnt(xm, n, m, ixm, mdl, drv, par, npar, neta, ntau, & scale, lscale, nrow, iptout(1), nlhdra, page, wide, isubhd, & hlfrpt, prtfxd, ifixed, lifixd) if ( 3 <= ierr ) then ierr = 1 return end if end if ierr = 0 call nlcnt(y, wt, lwt, xm, n, m, ixm, mdl, nldrva, aprxdv, drv, & par, npar, res, ifixed, lifixd, stp, lstp, mit, stopss, stopp, & scale, lscale, delta, ivcvop, rsd, pv, lpv, sdpv, lsdpv, & sdres, lsdres, vcv, ivcv, weight, save, nnzw, npare, nlhdra, & page, wide, iptout, ndigit, hlfrpt) return end subroutine nlcnt ( y, wt, lwt, xm, n, m, ixm, mdl, nldrv, aprxdv, & drv, par, npar, res, ifixed, lifixd, stp, lstp, mit, stopss, & stopp, scale, lscale, delta, ivaprx, rsd, pv, lpv, sdpv, & lsdpv, sdres, lsdres, vcv, ivcv, weight, save, nnzw, npare, & nlhdr, page, wide, iptout, ndigit, hlfrpt ) !*****************************************************************************80 ! !! NLCNT controlling subroutine for nonlinear least squares regression. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! integer d ! the starting location in rstak/dstak of ! the array in which the numerical derivatives with respect to ! each parameter are stored. ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd ! the starting location in istak of ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer iiwork ! the dimension of the integer work vector iwork. ! integer iptout(5) ! the variable used to control printed output for each section. ! integer irwork ! the dimension of the real work vector rwork. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer iwork ! the starting location in istak of ! the integer work space vector used by the nl2 subroutines. ! integer ixm ! the first dimension of the independent variable array. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lvcvl ! the length of the vector containing ! the lower half of the vcv matrix, stored row wise. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. ! integer n ! the number of observations. ! integer nall0 ! number of allocations on entry. ! integer ndigit ! the number of digits in the print control value. ! external nldrv ! the name of the routine which calculates the derivatives. ! external nlhdr ! the name of the routine which produces the heading. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! integer pare ! the starting location in rstak/dstak of ! the current estimates of the parameters, but only ! those to be optimized (not those whose values are fixed). ! real pv(lpv) ! the predicted value based on the current parameter estimates ! integer pvi ! the starting location in rstak/dstak of ! the predicted values. ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! real rstak(12) ! the real version of the /cstak/ work area. ! integer rwork ! the starting location in rstak/dstak of ! the real work vector used by the nl2 subroutines. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(lscale) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! integer sdpvi ! the starting location in rwork of ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! integer sdresi ! the starting location in rwork of the ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(lstp) ! the step size array. ! real vcv(ivcv,npar) ! the variance-covariance matrix. ! integer vcvl ! the starting location in rwork of ! the variance-covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! implicit none real & delta,rsd,stopp,stopss integer & ivaprx,ivcv,ixm,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,m, & mit,n,ndigit,nnzw,npar,npare logical & aprxdv,hlfrpt,page,save,weight,wide ! ! array arguments real & par(*),pv(lpv),res(*),scale(*),sdpv(lsdpv),sdres(lsdres),stp(*),vcv(*), & wt(*),xm(*),y(*) integer & ifixed(lifixd),iptout(5) ! ! subroutine arguments external drv,mdl,nldrv,nlhdr ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & d,ifixd,ifp,iiwork,irwork,iwork,lvcvl,nall0,pare,pvi, & rwork,sdpvi,sdresi,vcvl ! ! local arrays real & rstak(12) integer & istak(12) ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external cpyasf,cpyvii,nlmn,scopy,setiv,stkclr ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) nall0 = stkst(1) ifp = 3 ierr = 0 ! ! subdivide work area for least squares analysis ! iiwork = npare + 60 irwork = 94 + 2*n + npare*(3*npare+33)/2 ifixd = stkget(npar,2) iwork = stkget(iiwork,2) d = stkget(n*npar,ifp) pare = stkget(npare,ifp) pvi = stkget(n,ifp) rwork = stkget(irwork,ifp) if (ierr == 1) return ! ! set values for ifixd ! if (ifixed(1) >= 0) call cpyvii(npar, ifixed, 1, istak(ifixd), 1) if (ifixed(1)<0) call setiv(istak(ifixd), npar, 0) call nlmn(y, weight, nnzw, wt, lwt, xm, n, m, ixm, mdl, nldrv, & aprxdv, drv, istak(ifixd), par, rstak(pare), npar, res, page, & wide, hlfrpt, stp, lstp, mit, stopss, stopp, scale, lscale, & delta, ivaprx, iptout, ndigit, rsd, rstak(pvi), sdpvi, & sdresi, vcvl, lvcvl, rstak(d), istak(iwork), iiwork, & rstak(rwork), irwork, nlhdr, npare) if ( save ) then sdpvi = rwork + sdpvi - 1 sdresi = rwork + sdresi - 1 vcvl = rwork + vcvl - 1 call scopy(n, rstak(pvi), 1, pv, 1) call scopy(n, rstak(sdpvi), 1, sdpv, 1) call scopy(n, rstak(sdresi), 1, sdres, 1) call cpyasf(npare, rstak(vcvl), lvcvl, vcv, ivcv) end if call stkclr(nall0) return end subroutine nlcntn ( y, wt, lwt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivcvop, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare ) !*****************************************************************************80 ! !! NLCNTN controlling routine for NLS regression with approximate derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,rsd,stopp,stopss integer & ivcv,ivcvop,ixm,ldstak,lifixd,lpv,lscale,lsdpv,lsdres, & lstp,lwt,m,mit,n,nnzw,npar,npare,nprt logical & save,weight ! ! array arguments real & par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), & wt(*),xm(*),y(*) integer & ifixed(*) character & nmsub(6)*1 ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & exmpt integer & ifp,is,isubhd,ldsmin,nall0,ndigit,neta,stpi logical & aprxdv,hlfrpt,page,prtfxd,wide ! ! local arrays real & rstak(12) integer & iptout(5),istak(12) ! ! external functions integer & icnti,stkget,stkst external icnti,stkget,stkst ! ! external subroutines external drv,ldscmp,nlcnt,nldrvn,nler,nlhdrn,prtcnt,scopy,stkclr, & stkset,stpcnt ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (dstak(1),rstak(1)) ! ! variable definitions (alphabetically) ! ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real exmpt ! the proportion of observations for which the computed ! numerical derivatives wrt a given parameter are exempted ! from meeting the derivative acceptance criteria. ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer iptout(5) ! the variable used to control printed output for each section. ! integer is ! a value used to determine the amount of work space needed ! based on whether step sizes are input or are to be calculated. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isubhd ! an integer value specifying subheadings to be printed. ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ivcvop ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivcvop le 0 indicates the the default option will be used ! ivcvop eq 1 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivcvop eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivcvop eq 3 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivcvop eq 4 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivcvop eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivcvop eq 6 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivcvop ge 7 indicates the default option will be used ! integer ixm ! the first dimension of the independent variable array. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. ! integer n ! the number of observations. ! integer nall0 ! number of allocations on entry. ! integer ndigit ! the number of digits in the print control value. ! integer neta ! the number of accurate digits in the model results. ! external nldrvn ! the name of the routine which calculates the derivatives. ! external nlhdrn ! the name of the routine which produces the heading. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! real pv(lpv) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! real rstak(12) ! the real version of the /cstak/ work area. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(lscale) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(lsdpv) ! the standard deviations of the predicted values. ! real sdres(lsdres) ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(lstp) ! the step size array. ! integer stpi ! the starting location in rstak/dstak of ! the step size array. ! real vcv(ivcv,npar) ! the variance-covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! hlfrpt = .false. aprxdv = .true. prtfxd = .true. exmpt = -1.0e0 neta = 0 wide = .true. page = .false. ndigit = 5 ierr = 0 if ((ifixed(1) >= 0) .and. (npar >= 1)) then npare = icnti(ifixed,npar,0) else npare = npar end if if (stp(1) <= 0.0e0) then is = 1 else is = 0 end if call ldscmp(14, 0, max(is*2*(n+npar),60+npar+npare), 0, 0, 0, & 's', & max(is*(9*n+max(n,npar)),94+n*(3+npar)+npare*(3*npare+37)/2), & ldsmin) call nler (nmsub, weight, wt, lwt, n, m, ixm, & ifixed, lifixd, npar, npare, & ldstak, ldsmin, stp, lstp, scale, lscale, ivcv, save, nnzw) if (ierr /= 0) return call stkset(ldstak, 4) ! ! set print control values ! call prtcnt(nprt, ndigit, iptout) ! ! subdivide workspace for step sizes ! nall0 = stkst(1) ifp = 3 stpi = stkget(npar,ifp) ! ! copy supplied step sizes to work space ! call scopy(lstp, stp, 1, rstak(stpi), 1) if (ierr == 0) then ! ! select step sizes, if desired ! isubhd = 1 if (stp(1) <= 0.0e0) call stpcnt(xm, n, m, ixm, mdl, par, npar, & rstak(stpi), exmpt, neta, scale, lscale, iptout(1), nlhdrn, & page, wide, isubhd, hlfrpt, prtfxd, ifixed, lifixd) call nlcnt(y, wt, lwt, xm, n, m, ixm, mdl, nldrvn, aprxdv, drv, & par, npar, res, ifixed, lifixd, rstak(stpi), npar, mit, & stopss, stopp, scale, lscale, delta, ivcvop, rsd, pv, lpv, & sdpv, lsdpv, sdres, lsdres, vcv, ivcv, weight, save, nnzw, & npare, nlhdrn, page, wide, iptout, ndigit, hlfrpt) end if call stkclr(nall0) return end subroutine nldrva ( mdl, drv, done, ifixd, par, npar, xm, n, m, & ixm, pv, d, weight, wt, lwt, stp, lstp, scl, lscl ) !*****************************************************************************80 ! !! NLDRVA computes the analytic derivative matrix from the user DERIV routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,lscl,lstp,lwt,m,n,npar logical & done,weight ! ! array arguments real & d(n,npar),par(npar),pv(n),scl(lscl),stp(lstp),wt(lwt), & xm(ixm,m) integer & ifixd(npar) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! real & wtsqrt integer & i,j,jpk ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real d(n,npar) ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! logical done ! the variable used to indicate whether this is the final ! computation of the jacobian or not. ! integer i ! an indexing variable. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the parameter being examined. ! integer jpk ! the index of the packed parameters. ! integer lscl ! the actual length of the vector scl. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer npar ! the number of parameters in the model. ! real par(npar) ! the current estimates of the parameters. ! real pv(n) ! the predicted values based on the current parameter estimates ! real scl(lscl) ! the scale values. ! real stp(lstp) ! the selected relative step sizes. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real wtsqrt ! the square root of the ith weight. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! ! compute jacobian ! call drv(par, npar, xm, n, m, ixm, d) jpk = 0 do j=1,npar if (ifixd(j) /= 0) then cycle end if jpk = jpk + 1 do i=1,n wtsqrt = 1.0e0 if (weight .and. (.not.done)) wtsqrt = sqrt(wt(i)) d(i,jpk) = -wtsqrt*d(i,j) end do end do return end subroutine nldrvn ( mdl, drv, done, ifixd, par, npar, xm, n, m, & ixm, pvt, d, weight, wt, lwt, stpt, lstpt, scl, lscl ) !*****************************************************************************80 ! !! NLDRVN approximates the derivative matrix. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,lscl,lstpt,lwt,m,n,npar logical & done,weight ! ! array arguments real & d(n,npar),par(npar),pvt(n),scl(lscl),stpt(lstpt),wt(lwt), & xm(ixm,m) integer & ifixd(npar) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! real & pj,stpj,wtsqrt integer & i,j,jpk ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real d(n,npar) ! the first derivative of the model (jacobian). ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! logical done ! the variable used to indicate whether this is the final ! computation of the jacobian or not. ! integer i ! an index variable. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer ixm ! the first dimension of matrix xm. ! integer j ! an index variable. ! integer jpk ! an index variable. ! integer lscl ! the dimension of vector scl. ! integer lstpt ! the dimension of vector stpt. ! integer lwt ! the dimension of vector wt. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer npar ! the number of parameters in the model. ! real par(npar) ! the current estimates of the parameters. ! real pj ! a temporary location for storage of the jth parameter. ! real pvt(n) ! the predicted value based on the current parameter estimates. ! real scl(lscl) ! the scale values. ! real stpt(lstpt) ! the step size array. ! real stpj ! the jth step size. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real wtsqrt ! the square root of the user supplied weights. ! real xm(ixm,m) ! the independent variable. ! ! compute finite-difference jacobian of the optimized parameters ! jpk = 0 do j=1,npar if (ifixd(j) == 0) then jpk = jpk + 1 pj = par(j) if (scl(jpk) == 0.0e0) then if (par(j) /= 0.0e0) then stpj = stpt(j)*sign(1.0e0,par(j))*abs(par(j)) else stpj = stpt(j) end if else stpj = stpt(j)* & sign(1.0e0,par(j))*max(abs(par(j)),1.0e0/ & abs(scl(jpk))) end if stpj = stpj + par(j) stpj = stpj - par(j) par(j) = pj + stpj call mdl(par, npar, xm, n, m, ixm, d(1,j)) do i=1,n wtsqrt = 1.0e0 if (weight .and. (.not.done)) wtsqrt = sqrt(wt(i)) d(i,jpk) = wtsqrt*(pvt(i)-d(i,j))/stpj end do par(j) = pj end if end do return end subroutine nler ( nmsub, weight, wt, lwt, n, m, ixm, ifixed, lifixd, npar, & npare, ldstak, ldsmin, stp, lstp, scale, lscale, ivcv, save, nnzw ) !*****************************************************************************80 ! !! NLER does error checking routine for nonlinear least squares estimation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ivcv,ixm,ldsmin,ldstak,lifixd,lscale,lstp,lwt,m,n,nnzw, & npar,npare logical & save,weight ! ! array arguments real & scale(*),stp(*),wt(*) integer & ifixed(lifixd) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i,nfix,nnfix,nv,nzw logical & head ! ! local arrays logical & error(20) character & lifix(8)*1,livcv(8)*1,lixm(8)*1,llds(8)*1,lm(8)*1, & ln(8)*1,lnpar(8)*1,lnpare(8)*1,lone(8)*1,lscl(8)*1, & lstep(8)*1,lwgt(8)*1,lzero(8)*1 ! ! external subroutines external eisge,eiveq,ervgt,ervwt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical error(20) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ifixed(lifixd) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 ! + lifix(8), livcv(8), lixm(8), llds(8), lm(8), ln(8), lnpar(8), ! + lnpare(8), lone(8), lscl(8), lstep(8), lwgt(8), lzero(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer lscale ! the actual length of the vector scale. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer nzw ! the number of zero weights. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(lscale) ! the typical size of the parameters. ! real stp(lstp) ! the step size array. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! ! ! set up name arrays ! data lifix(1), lifix(2), lifix(3), lifix(4), lifix(5), & lifix(6), lifix(7), lifix(8) /'i','f','i','x','e','d',' ',' '/ data livcv(1), livcv(2), livcv(3), livcv(4), livcv(5), & livcv(6), livcv(7), livcv(8) /'i','v','c','v',' ',' ',' ',' '/ data lixm(1), lixm(2), lixm(3), lixm(4), lixm(5), lixm(6), & lixm(7), lixm(8) /'i','x','m',' ',' ',' ',' ',' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data lm(1), lm(2), lm(3), lm(4), lm(5), lm(6), lm(7), lm(8) /'m', & ' ',' ',' ',' ',' ',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lnpar(1), lnpar(2), lnpar(3), lnpar(4), lnpar(5), & lnpar(6), lnpar(7), lnpar(8) /'n','p','a','r',' ',' ',' ', & ' '/ data lnpare(1), lnpare(2), lnpare(3), lnpare(4), lnpare(5), & lnpare(6), lnpare(7), lnpare(8) /'n','p','a','r','e',' ',' ', & ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), & lone(6), lone(7), lone(8) /'o','n','e',' ',' ',' ',' ',' '/ data lscl(1), lscl(2), lscl(3), lscl(4), lscl(5), & lscl(6), lscl(7), lscl(8) /'s','c','a','l','e',' ',' ', & ' '/ data lstep(1), lstep(2), lstep(3), lstep(4), lstep(5), & lstep(6), lstep(7), lstep(8) /'s','t','p',' ',' ',' ',' ',' '/ data lwgt(1), lwgt(2), lwgt(3), lwgt(4), lwgt(5), & lwgt(6), lwgt(7), lwgt(8) /'w','t',' ',' ',' ',' ',' ',' '/ data lzero(1), lzero(2), lzero(3), lzero(4), lzero(5), & lzero(6), lzero(7), lzero(8) /'z','e','r','o',' ',' ',' ',' '/ error(1:20) = .false. ierr = 0 head = .true. nnzw = n call eisge(nmsub, lnpar, npar, 1, 2, head, error(1), lone) if (error(1)) then error(7) = .true. else if (ifixed(1)<0) then call eisge(nmsub, ln, n, npar, 2, head, error(7), lnpar) if (weight) then call ervwt(nmsub, lwgt, wt, lwt, npar, head, nnzw, & nzw, 2, error(3), lnpar) end if else call eiveq(nmsub, lifix, ifixed, npar, 0, 1, head, nnfix, & nfix, 1, error(2), lzero, lone) if (.not.error(2)) then call eisge(nmsub, ln, n, npare, 2, head, error(7), lnpare) if (weight) then call ervwt(nmsub, lwgt, wt, lwt, npare, head, nnzw, & nzw, 2, error(3), lnpare) end if end if end if end if call eisge(nmsub, lm, m, 1, 2, head, error(4), lone) if (.not.error(7)) & call eisge(nmsub, lixm, ixm, n, 3, head, error(5), ln) if (.not.error(1)) then if ((.not.error(2)) .and. (.not.error(7))) & call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(6), & llds) call ervgt(nmsub, lstep, stp, lstp, 0.0e0, 0, head, 6, nv, & error(8), lzero) call ervgt(nmsub, lscl, scale, lscale, 0.0e0, 0, head, 6, nv, & error(12), lzero) if (save) & call eisge(nmsub, livcv, ivcv, npare, 3, head, error(15), & lnpare) end if do i=1,20 if ( error(i) ) then ierr = 1 return end if end do return end subroutine nlerr ( icnvcd, iskull ) !*****************************************************************************80 ! !! NLERR sets the error flag ierr based on the convergence code returned by NL2. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index variable. ! integer icnvcd ! the convergence code from nl2. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer iskull(10) ! an error message indicator variable. ! implicit none integer & icnvcd ! ! array arguments integer & iskull(10) ! ! scalars in common integer & ierr ! ! common blocks common /errchk/ierr ! ! initialize message indicator variable ! iskull(1:10) = 0 ! ! set error flag ! go to (10, 10, 20, 20, 20, 20, 40, 50, 60, 60, 10, 30, 10, 10, & 10), icnvcd ! ! bad value ! 10 ierr = 1 return ! ! acceptable stopping condition ! 20 ierr = 0 return ! ! initial variance computation overflows ! 30 ierr = 2 iskull(2) = 1 return ! ! singular convergence ! 40 ierr = 3 iskull(3) = 1 return ! ! false convergence ! 50 ierr = 5 iskull(5) = 1 return ! ! iteration or function evaluation limit ! 60 ierr = 6 iskull(6) = 1 return end subroutine nlfin ( y, weight, nnzw, wt, lwt, xm, n, m, ixm, ifixd, & par, npar, npare, res, page, wide, iptout, ndigit, rsshlf, rsd, & pv, sdpv, sdres, rd, vcvl, lvcvl, d, nlhdr, ivcvpt, iskull ) !*****************************************************************************80 ! !! NLFIN completes the NLS analysis once the estimates have been found. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! implicit none real & rsd,rsshlf integer & ivcvpt,ixm,lvcvl,lwt,m,n,ndigit,nnzw,npar,npare logical & page,weight,wide ! ! array arguments real & d(n,npar),par(npar),pv(n),rd(npare),res(n),sdpv(n),sdres(n), & vcvl(lvcvl),wt(lwt),xm(ixm,m),y(n) integer & ifixd(npar),iptout(ndigit),iskull(10) ! ! subroutine arguments external nlhdr ! ! scalars in common integer & ierr real & cond,rss,yss integer & idf logical & exact,prtfsm ! ! external subroutines external nlcmp,nlout ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real cond ! the condition number of d. ! real d(n,npar) ! the derivative of the model (jacobian). ! logical exact ! an indicator value used to designate whether the fit ! was exact to machine precision (true) or not (false). ! integer idf ! the degrees of freedom in the fit. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) have been held fixed. ! if ifixed(i) == 0, then par(i) have been optimized. ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer iskull(10) ! an error message indicator variable. ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! integer ixm ! the first dimension of the independent variable array. ! integer lvcvl ! the length of the vector containing ! the lower half of the vcv matrix, stored row wise. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! external nlhdr ! the name of the routine which produces the heading. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! real par(npar) ! the array in which the current estimates of the ! parameters are stored. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical prtfsm ! the variable used to indicate whether any of the summary ! information is to be printed (true) or not (false). ! real pv(n) ! the predicted value based on the current parameter estimates ! real rd(npare) ! the diagonal elements of the r matrix of the q - r ! factorization of d. ! real res(n) ! the residuals from the fit. ! real rsshlf ! half the residual sum of squares. ! real rsd ! the value of the residual standard deviation at the solution. ! real rss ! the residual sum of squares. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! real vcvl(lvcvl) ! the lower half of the vcv matrix, stored row wise. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! real yss ! the sum of squares of the dependent variable y. ! ! ! compute returned and/or printed values. ! call nlcmp (y, weight, wt, lwt, n, npar, npare, res, & d, rd, cond, vcvl, lvcvl, nnzw, idf, rsshlf, rss, rsd, yss, & exact, pv, sdpv, sdres, iskull) prtfsm = ((iptout(3) /= 0) .or. (iptout(4) /= 0) .or. & (iptout(5) /= 0) .or. (ierr /= 0)) ! ! print summary information if desired or if an error flag ! has been set. ! if (prtfsm) call nlout(y, weight, nnzw, wt, lwt, xm, n, m, ixm, & ifixd, par, npar, npare, res, iptout, ndigit, page, idf, cond, & rss, rsd, yss, exact, pv, sdpv, sdres, vcvl, lvcvl, ivcvpt, & iskull, nlhdr, wide) return end subroutine nlhdra ( page, wide, isubhd ) !*****************************************************************************80 ! !! NLHDRA prints headings for NLS estimation using analytic derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & isubhd logical & page,wide ! ! ! external subroutines external versp ! ! variable definitions (alphabetically) ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! if (page) write ( *, 1020) call versp(wide) if (page) write ( *,1000) if (.not.page) write ( *,1010) page = .true. if (isubhd == 0) return write ( *, 1030) return 1000 format ('+nonlinear least squares estimation', & ' with user-supplied derivatives, continued') 1010 format ('+', 71('*')/ & 1x, '* nonlinear least squares estimation', & ' with user-supplied derivatives *'/ 1x, 71('*')) 1020 format ('1') 1030 format (//' summary of initial conditions'/ 1x, 30('-')) end subroutine nlhdrn ( page, wide, isubhd ) !*****************************************************************************80 ! !! NLHDRN prints headings for NLS estimation using approximate derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & isubhd logical & page,wide ! ! ! external subroutines external versp ! ! variable definitions (alphabetically) ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! if (page) write ( *, 1020) call versp(wide) if (page) write ( *,1000) if (.not.page) write ( *,1010) page = .true. if (isubhd == 0) return write ( *, 1030) return 1000 format ('+nonlinear least squares estimation', & ' with numerically approximated derivatives, continued') 1010 format ('+', 82('*')/ & 1x, '* nonlinear least squares estimation', & ' with numerically approximated derivatives *'/ 1x, 82('*')) 1020 format ('1') 1030 format (//' summary of initial conditions'/ 1x, 30('-')) end subroutine nlinit ( n, ifixd, par, npar, pare, npare, mit, & stopss, stopp, scale, lscale, delta, ivaprx, aprxdv, ivcvpt, & iwork, iiwork, rwork, irwork, scl ) !*****************************************************************************80 ! !! NLINIT initializes the NLS routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! implicit none real & delta,stopp,stopss integer & iiwork,irwork,ivaprx,ivcvpt,lscale,mit,n,npar,npare,scl logical & aprxdv ! ! array arguments real & par(npar),pare(npar),rwork(irwork),scale(lscale) integer & ifixd(npar),iwork(iiwork) ! ! scalars in common integer & ierr ! ! integer & afctol,cnvcod,covprt,covreq,dinit,dtype,iscl,j,lmax0, & mxfcal,mxiter,niter,outlev,prunit,rfctol,sclj,solprt, & statpr,x0prt,xctol ! ! external functions real & rmdcon external rmdcon ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer afctol ! the location in rwork of the absolute convergence tolerance. ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! integer cnvcod ! a value used to control the printing of iteration reports. ! integer covprt ! the location in iwork of the variable used to indicate whether ! the covariance matrix is to be printed by the nl2 code, where ! iwork(covprt) = 0 indicates it is not. ! integer covreq ! the location in iwork of the variable used to indicate how ! the covariance matrix is to be computed by the nl2 code, where ! iwork(covreq) = 3 indicates the covariance matrix is to be comp ! as the residual variance times the inverse of the jacobian matr ! transposed times the jacobian matrix . ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! integer dinit ! the location in iwork of the value used to indicate ! whether or not user supplied scale values are to be ! used, where the (nl2) default value of rwork(dinit) = 0.0e0 ! inidcates no, and the value rwork(dinit) = -1.0e0 indicates ! yes. ! integer dtype ! the location in iwork of the value indicating whether the ! scale values have been supplied by the user (iwork(dtype) <= ! or the default values are to be used (iwork(dtype) > 0). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer iiwork ! the dimension of the integer work vector iwork. ! integer irwork ! the dimension of the real work vector rwork. ! integer iscl ! the location in iwork indicating the starting location in ! rwork of the scale vector. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! integer iwork(iiwork) ! the integer work space vector used by the nl2 subroutines. ! integer j ! the index of the parameter being examined. ! integer lmax0 ! the location in rwork of the value indicating the ! maximum change allowed in the model parameters at the ! first iteration. ! integer mit ! the maximum number of iterations allowed. ! integer mxfcal ! the location in iwork of the variable designating the ! maximum number of function calls allowed, excluding ! calls necessary to compute the derivatives and variance ! covariance matrix. ! integer mxiter ! the location in iwork of the variable designating the ! maximum number of iterations allowed. ! integer n ! the number of observations. ! integer niter ! the location in iwork of the number of the current iteration. ! integer npar ! the number of unknown parameters in the model. ! integer npare ! the number of unknown parameters to be optimized. ! integer outlev ! the location in iwork of the parameter used to control the ! printing of the iteration reports by nl2. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real pare(npar) ! the current estimates of the unknown parameters, but only ! those to be optimized (not those whose values are fixed). ! integer prunit ! the location in iwork of the parameter used to control ! the print unit used by nl2. iwork(prunit) = 0 means ! dont print anything. ! integer rfctol ! the location in rwork of the relative function convergence ! tolerance. ! real rwork(irwork) ! the real work vector used by the nl2 subroutines. ! real scale(lscale) ! the typical size of the unknown parameters. ! integer scl ! the index in rwork of the 1st value of the user supplied scale ! value. ! integer sclj ! the index in rwork of the jth value of the user supplied scale ! value. ! integer solprt ! the location in iwork of the parameter used to control printing ! by nl2 of the final solution. ! integer statpr ! the location in iwork of the parameter used to control printing ! by nl2 of summary statistics. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! integer xctol ! the location in rstak/dstak of the p convergence tolerance. ! integer x0prt ! the location in iwork of the parameter used to control printin ! by nl2 of the initial parameter and scale values. ! ! iwork subscript values ! data cnvcod /34/, covprt /14/, covreq /15/, dinit /38/, dtype & /16/, iscl /27/, mxfcal /17/, mxiter /18/, & niter /31/, outlev /19/, prunit /21/, solprt /22/, statpr & /23/, x0prt /24/ ! ! rwork subscript values ! data afctol /31/, lmax0 /35/, rfctol /32/, xctol /33/ ! ! pack parameters into pare ! call nlspk(par, ifixd, npar, pare, npar) ! ! set nl2sol default values ! call dfault(iwork, rwork) ! ! set non nl2 default values ! iwork(mxiter) = mit if (mit <= 0) iwork(mxiter) = 21 iwork(mxfcal) = 2*iwork(mxiter) ! ! set stopping criterion ! rwork(afctol) = rmdcon(1) if ( stopss >= epsilon ( stopss ) .and. stopss <= 0.1 ) then rwork(rfctol) = stopss end if if ((stopp >= 0.0e0) .and. (stopp <= 1.0e0)) & rwork(xctol) = stopp ! ! set scale values ! scl = 94 + 2*n + npare*(3*npare+31)/2 iwork(iscl) = scl if ( scale(1) <= 0.0e0 ) then iwork(dtype) = 1 ! ! initialize scale values for first iteration ! sclj = scl - 1 do j=1,npar if (ifixd(j) == 0) then sclj = sclj + 1 if (par(j) == 0.0e0) rwork(sclj) = 1.0e0 if (par(j) /= 0.0e0) rwork(sclj) = 1.0e0/abs(par(j)) end if end do else iwork(dtype) = 0 rwork(dinit) = -1.0e0 sclj = scl - 1 do j=1,npar if ( ifixd(j) == 0) then sclj = sclj + 1 rwork(sclj) = 1.0e0/max(abs(scale(j)),abs(par(j))) end if end do end if if (delta <= 0.0e0) then rwork(lmax0) = 100.0e0 else rwork(lmax0) = delta end if ! ! set nl2 covariance computation control parameter ! if ((ivaprx <= 1) .or. (ivaprx == 4) .or. (ivaprx >= 7)) & iwork(covreq) = 3 if ((ivaprx == 2) .or. (ivaprx == 5)) iwork(covreq) = 2 if ((ivaprx == 3) .or. (ivaprx == 6)) iwork(covreq) = 1 if ((ivaprx >= 4) .and. (ivaprx <= 6)) & iwork(covreq) = -iwork(covreq) if (aprxdv) iwork(covreq) = -iabs(iwork(covreq)) if ((ivaprx <= 1) .or. (ivaprx == 4) .or. (ivaprx >= 7)) & ivcvpt = 1 if ((ivaprx == 2) .or. (ivaprx == 5)) ivcvpt = 2 if ((ivaprx == 3) .or. (ivaprx == 6)) ivcvpt = 3 ! ! initialize the iteration counter ! iwork(niter) = 0 ! ! set nl2 print control parameters ! iwork(cnvcod) = 0 iwork(covprt) = 0 iwork(outlev) = 0 iwork(prunit) = 0 iwork(solprt) = 0 iwork(statpr) = 0 iwork(x0prt) = 0 return end subroutine nlism ( nlhdr, page, wide, hlfrpt, npar, m, n, nnzw, & weight, ifixd, par, scale, iwork, iiwork, rwork, irwork, res, & aprxdv, stp, lstp, npare ) !*****************************************************************************80 ! !! NLISM prints an initial summary for the nonlinear least squares routines. ! ! Discussion: ! ! This routine prints an initial summary of the starting ! estimates and the control parameters for the nonlinear ! least squares subroutines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iiwork,irwork,lstp,m,n,nnzw,npar,npare logical & aprxdv,hlfrpt,page,weight,wide ! ! array arguments real & par(npar),res(n),rwork(irwork),scale(npar),stp(lstp) integer & ifixd(npar),iwork(iiwork) ! ! subroutine arguments external nlhdr real & rsd,rss integer & i,isubhd,lmax0,mxfcal,mxiter,rfctol,xctol ! ! external functions real & snrm2 external snrm2 ! ! variable definitions (alphabetically) ! ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer i ! an index variable ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer iiwork ! the dimension of the integer work vector iwork. ! integer irwork ! the dimension of the real work vector rwork. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer iwork(iiwork) ! the integer work space vector used by the nl2 subroutines. ! integer lmax0 ! the location in rwork of the value indicating the ! maximum change allowed in the model parameters at the ! first iteration. ! integer lstp ! the actual length of the vector stp. ! integer m ! the number of independent variables. ! integer mxfcal ! the location in iwork of the variable designating the ! maximum number of function calls allowed, excluding ! calls necessary to compute the derivatives and covariance ! matrix. ! integer mxiter ! the location in iwork of the variable designating the ! maximum number of iterations allowed. ! integer n ! the number of observations. ! external nlhdr ! the name of the routine which produces the heading. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of unknown parameters in the model. ! integer npare ! number of parameters estimated by routine. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real res(n) ! the residuals from the fit. ! integer rfctol ! the location in rwork of the relative function convergence ! tolerance. ! real rsd ! the residual standard deviation at the initial parameter values ! real rss ! the residual sum of squares at the initial parameter values ! real rwork(irwork) ! the real work vector used by the nl2 subroutines. ! real scale(npar) ! the typical size of the unknown parameters. ! real stp(lstp) ! the selected relative step sizes. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! full width (true) or not (false). ! integer xctol ! the location in rstak/dstak of the p convergence tolerance. ! ! iwork subscript values ! data mxfcal/17/, mxiter/18/ ! ! rwork subscript values ! data lmax0/35/, rfctol/32/, xctol/33/ if (.not.hlfrpt) then isubhd = 1 call nlhdr(page, wide, isubhd) if (aprxdv) then write ( *, 1260) else write ( *, 1270) end if do i = 1, npar if (ifixd(i) == 0) then if (scale(1) > 0.0e0) then if (aprxdv) then write ( *, 1410) i, par(i), scale(i), stp(i) else write ( *, 1410) i, par(i), scale(i) end if else if (aprxdv) then write ( *, 1310) i, par(i), stp(i) else write ( *, 1310) i, par(i) end if end if else if (aprxdv) then write ( *, 1510) i, par(i) else write ( *, 1610) i, par(i) end if end if end do write ( *, 1160) n end if if (weight) write ( *, 1170) nnzw write ( *, 1180) m write ( *, 1070) iwork(mxiter) write ( *, 1090) iwork(mxfcal) write ( *, 1080) write ( *, 1100) rwork(rfctol) write ( *, 1110) rwork(xctol) write ( *, 1120) rwork(lmax0) rsd = snrm2(n, res, 1) rss = rsd * rsd if (nnzw-npare >= 1) rsd = rsd /sqrt(real(nnzw-npare)) write ( *, 1200) rss write ( *, 1210) rsd return 1070 format (/' maximum number of iterations allowed', 32x, '(mit)', & 1x, i5) 1080 format(/' convergence criterion for test based on the'/) 1090 format(/' maximum number of model subroutine calls', & ' allowed', 26x, i5) 1100 format (5x, ' forecasted relative change in residual', & ' sum of squares', 7x, '(stopss)', 1x, g11.4) 1110 format(5x, ' maximum scaled relative change in the parameters', & 13x, '(stopp)', 1x, g11.4) 1120 format(//' maximum change allowed in the parameters', & ' at the first iteration', 3x, '(delta)', 1x, g11.4) 1160 format (/' number of observations', 48x, '(n)', 1x, i5) 1170 format (/' number of non zero weighted observations', 27x, & '(nnzw)', 1x, i5) 1180 format (/' number of independent variables', 39x, '(m)', 1x, i5) 1200 format (/' residual sum of squares for input parameter', & ' values', 24x, g11.4) 1210 format (/' residual standard deviation for input parameter', & ' values', 14x, '(rsd)', 1x, g11.4) 1260 format (//50x, 'step size for'/ & 50x, 'approximating'/ & 7x, 'parameter starting value', 6x, 'scale', 10x, & 'derivative'/ & 1x, 'index', 2x, 'fixed', 6x, '(par)', 12x, '(scale)', 11x, & '(stp)'/) 1270 format (//6x, 'parameter starting values', 5x, 'scale'/ & 1x, 'index', 2x, 'fixed', 6x, '(par)', 11x, '(scale)'/) 1310 format (1x, i3, 5x, ' no', g17.8, 7x, 'default', 3x, g17.8) 1410 format (1x, i3, 5x, ' no', 3g17.8) 1510 format (1x, i3, 5x, 'yes', g17.8, 9x, '---', 14x, '---') 1610 format (1x, i3, 5x, 'yes', g17.8, 9x, '---') end subroutine nlitrp ( nlhdr, head, page, wide, iptout, npar, nnzw, & iwork, iiwork, rwork, irwork, ifixd, pare, npare ) !*****************************************************************************80 ! !! NLITRP prints iteration reports for nonlinear least squares regression. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iiwork,iptout,irwork,nnzw,npar,npare logical & head,page,wide ! ! array arguments real & pare(npar),rwork(irwork) integer & ifixd(npar),iwork(iiwork) ! ! subroutine arguments external nlhdr ! ! real & rsd,rss,rssc,rsspc integer & dst0,f,f0,fdif,isubhd,mxiter,nfcall,niter, & nreduc,preduc,reldx,stppar character & lettrn*1,lettry*1 ! ! local arrays character & ischkd(2)*1 ! ! external subroutines external lstvcf ! ! variable definitions (alphabetically) ! ! integer dst0 ! the location in rwork of the value of the 2 norm of d times ! the newton step. ! integer f ! the location in rwork of the value of half the residual ! sum of squares at the current parameter values. ! integer fdif ! the location in rwork of the difference between the ! residual sum of squares at the beginning and end of the ! current iteration. ! integer f0 ! the location in rwork of the value of half the residual ! variance at the beginning of the current iteration. ! logical head ! the variable used to indicate whether a heading is to be ! printed during a given call to the iteration report (true) ! or not (false). ! integer icase ! an indicater variable used to designate the message to be ! printed. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer iiwork ! the dimension of the integer work vector iwork. ! integer irwork ! the dimension of the real work vector rwork. ! character*1 ischkd(2) ! the indicator used to designate whether the ! test value was checked for convergence (y) or not (n). ! integer isubhd ! an integer value specifying subheadings to be printed. ! integer iwork(iiwork) ! the integer work space vector used by the nl2 subroutines. ! character*1 lettrn, lettry ! the letters n and y, respectively. ! integer mxiter ! the location in iwork of the variable designating the ! maximum number of iterations allowed. ! integer nfcall ! the location in iwork of the number of function evaluations. ! integer niter ! the location in iwork of the number of the current iteration. ! external nlhdr ! the name of the routine which produces the heading. ! integer npar ! the number of unknown parameters in the model. ! integer npare ! the number of unknown parameters to be optimized. ! integer nnzw ! the number of non zero weights. ! integer nreduc ! the location in rwork of the value used to check if the ! hessian approximation is positive definite. if ! if rwork(nreduc) == 0, the hessian is singular, otherwise ! it is not. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real pare(npar) ! the current estimates of the unknown parameters, but only ! those to be optimized (not those whose values are fixed). ! integer preduc ! the location in rwork of the predicted function reduction ! for the current step. ! integer reldx ! the location in rwork of the scaled relative change in ! the parameter values caused by the current iteration. ! real rsd ! the residual standard deviation. ! real rss ! the residual sum of squares. ! real rssc ! the change in the residual sum of squares caused by this ! iteration. ! real rsspc ! the predicted change in the residual sum of squares at this ! iteration. ! real rwork(irwork) ! the real work vector used by the nl2 subroutines. ! integer stppar ! the location in rwork of the marquardt lambda parameter. ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! data lettrn /'n'/, lettry /'y'/ ! ! iwork subscript values ! data mxiter /18/, nfcall /6/, niter /31/ ! ! rwork subscript values ! data dst0 /3/, f /10/, fdif /11/, f0 /13/, nreduc /6/, preduc & /7/, reldx /17/, stppar /5/ if (iwork(1) == 10) then write ( *,1100) return end if if ((iptout == 1) .and. (iwork(niter) /= 1) .and. & (iwork(niter) /= iwork(mxiter)) .and. (iwork(1) <= 2)) return isubhd = 0 if (head) call nlhdr(page, wide, isubhd) head = .false. if (mod(iwork(niter),4) == 0) head = .true. write ( *,1000) iwork(niter) ! ! compute statistics to be printed ! rss = 2.0e0*rwork(f) rsd = sqrt(rss) if (nnzw-npare >= 1) rsd = rsd/sqrt(real(nnzw-npare)) rssc = 0.0e0 if (rwork(f0) > 0.0e0) rssc = rwork(fdif)/rwork(f0) rsspc = 0.0e0 if (rwork(f0) > 0.0e0) rsspc = rwork(nreduc)/rwork(f0) ! ! reference nl2 subroutine assess, statement label 300 to 320 ! ischkd(1) = lettrn ischkd(2) = lettrn if ( rwork(fdif) <= 2.0e0*rwork(preduc) ) then if ( 0.0 <= rwork(dst0) ) then if (rwork(nreduc) >= 0.0e0) ischkd(1) = lettry if (rwork(stppar) == 0.0e0) ischkd(2) = lettry end if end if write ( *,1010) iwork(nfcall), rsd, rss, rssc, rsspc, & ischkd(1), rwork(reldx), ischkd(2) if (npare= npar) write ( *,1150) call lstvcf(npare, pare, npar, ifixd) ! ! print final iteration message ! if ( iwork(1) == 3 ) then write ( *,1030) else if ( iwork(1) == 4 ) then write ( *,1040) else if ( iwork(1) == 5 ) then write ( *,1050) else if ( iwork(1) == 6 ) then write ( *,1060) else if ( iwork(1) == 7 ) then write ( *,1070) else if ( iwork(1) == 8 ) then write ( *,1080) else if ( iwork(1) == 9 ) then write ( *,1090) else if ( iwork(1) == 10 ) then write ( *,1100) else if ( iwork(1) == 11 ) then write ( *,1110) else if ( iwork(1) == 12 ) then write ( *,1120) else if ( iwork(1) == 13 ) then write ( *,1130) else if ( iwork(1) == 14 ) then write ( *,1140) end if return 1000 format (//' iteration number', i5/1x, 22('-')) 1010 format (5x, 'model', 53x, 'forecasted'/5x, 'calls', 9x, 'rsd', & 13x, 'rss', 8x, 'rel chng rss', 4x, 'rel chng rss', 4x, & 'rel chng par'/62x, 'value', 3x, 'chkd', 4x, 'value', 3x, & 'chkd'/3x, i7, 3(2x, g14.4), 2(g12.4, 3x, a1)) 1020 format (/5x, ' current parameter values', ' (only unfixed para', & 'meters are listed)') 1030 format (/' ***** parameter convergence *****') 1040 format (/' ***** residual sum of squares convergence *****') 1050 format (/' ***** parameter and residual sum of squares', & ' convergence *****') 1060 format (/'the residual sum of squares is exactly zero') 1070 format (/' ***** singular convergence *****') 1080 format (/' false convergence') 1090 format (/'limit on number of calls to the model subroutine reached') 1100 format (/'iteration limit reached') 1110 format (/'stopx ' ) 1120 format (/'initial residual sum of squares overflows ') 1130 format (/'bad parameters to assess ') 1140 format (/'derivative matrix could not be computed ') 1150 format (/5x, ' current parameter values') end subroutine nlmn ( y, weight, nnzw, wt, lwt, xm, n, m, ixm, mdl, & nldrv, aprxdv, drv, ifixd, par, pare, npar, res, page, wide, & hlfrpt, stp, lstp, mit, stopss, stopp, scale, lscale, delta, & ivaprx, iptout, ndigit, rsd, pv, sdpvi, sdresi, vcvl, lvcvl, d, & iwork, iiwork, rwork, irwork, nlhdr, npare ) !*****************************************************************************80 ! !! NLMN: controlling routine for nonlinear least squares regression. ! ! Discussion: ! ! This is the controlling routine for performing nonlinear ! least squares regression using the nl2 software package ! (implementing the method of dennis, gay and welsch). ! this subroutine was adapted from subroutine nl2sol. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! John Dennis, David Gay, Roy Welsch, ! An Adaptive Nonlinear Least Squares Algorithm, ! ACM Transactions on Mathematical Software, ! Volume 7, Number 3, 1981. ! implicit none real & delta,rsd,stopp,stopss integer & iiwork,irwork,ivaprx,ixm,lscale,lstp,lvcvl,lwt,m,mit,n, & ndigit,nnzw,npar,npare,sdpvi,sdresi,vcvl logical & aprxdv,hlfrpt,page,weight,wide ! ! array arguments real & d(n,npar),par(npar),pare(npar),pv(n),res(n),rwork(irwork), & scale(lscale),stp(lstp),wt(lwt),xm(ixm,m),y(n) integer & ifixd(npar),iptout(ndigit),iwork(iiwork) ! ! subroutine arguments external drv,mdl,nldrv,nlhdr ! ! scalars in common integer & ierr real & wtsqrt integer & cnvcod,covmat,i,icnvcd,ivcvpt,qtr,rd,rdi,rsave,rsshlf,s, & scl logical & cmpdrv,done,head,newitr,prtsmy ! ! local arrays integer & iskull(10) ! ! external subroutines external nl2itr,nlerr,nlfin,nlinit,nlism,nlitrp,nlsupk ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical aprxdv ! the variable used to indicate whether numerical ! approximations to the derivative were used (true) or not ! (false). ! logical cmpdrv ! the variable used to indicate whether derivatives must be ! computed (true) or not (false). ! integer cnvcod ! a value used to control the printing of iteration reports. ! integer covmat ! the location in iwork of the starting location in rwork ! of the beginning of the vcv matrix. ! real d(n,npar) ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter. ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! logical done ! the variable used to indicate whether this is the final ! computation of the jacobian or not. ! logical head ! the variable used to indicate whether a heading is to be ! printed during a given call to the iteration report (true) ! or not (false). ! logical hlfrpt ! the variable which indicates whether the derivative ! checking routine has already printed part of the ! initial summary (true) or not (false). ! integer i ! an indexing variable. ! integer icnvcd ! the location in iwork of ! the convergence condition. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer iiwork ! the dimension of the integer work vector iwork. ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer irwork ! the dimension of the real work vector rwork. ! integer iskull(10) ! an error message indicator variable. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! integer iwork(iiwork) ! the integer work space vector used by the nl2 subroutines. ! integer ixm ! the first dimension of the independent variable array. ! integer lscale ! the actual length of the vector scale. ! integer lstp ! the actual length of the vector stp. ! integer lvcvl ! the length of the vector containing ! the lower half of the vcv matrix, stored row wise. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! logical newitr ! a flag used to indicate whether a new iteration has been ! completed (true) or not (false). ! external nldrv ! the name of the routine which calculated the derivatives ! external nlhdr ! the name of the routine which produces the heading. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the current estimates of the parameters. ! real pare(npar) ! the current estimates of the parameters, but only ! those to be optimized (not those whose values are fixed). ! logical prtsmy ! the variable used to indicate whether the summary ! information is to be printed (true) or not (false). ! real pv(n) ! the predicted values. ! integer qtr ! the location in iwork of the starting location in rwork ! the array q transpose r. ! integer rd ! the location in iwork of the starting location in rwork of ! the diagonal elements of the r matrix of the q - r ! factorization of d. ! integer rdi ! the location in rwork of the diagonal elements of the r ! matrix of the q - r factorization of d. ! real res(n) ! the residuals from the fit. ! integer rsave ! the location in iwork of the starting location in rwork ! the array rsave. ! real rsd ! the value of the residual standard deviation at the solution. ! integer rsshlf ! the location in rwork of ! half the residual sum of squares. ! real rwork(irwork) ! the real work vector used by the nl2 subroutines. ! integer s ! the location in iwork of the starting location in rwork ! the array of second order terms of the hessian. ! real scale(lscale) ! the typical size of the parameters. ! integer scl ! the index in rwork of the 1st value of the user supplied scale ! value. ! integer sdpvi ! the starting location in rwork of ! the standard deviations of the predicted values. ! integer sdresi ! the starting location in rwork of the ! the standardized residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! predicted decrease in the residual standard deviation (computed ! by starpac) to the current residual sum of squares estimate. ! real stopss ! the stopping criterion forthe test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(lstp) ! the dummy step size array. ! integer vcvl ! the starting location in rwork of the lower half of the ! vcv matrix, stored row wise. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real wtsqrt ! the square root of the user supplied weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! iwork subscript values ! data cnvcod /34/, icnvcd /1/, covmat /26/, qtr /49/, rd /51/, & rsave /52/, s/53/ data rsshlf /10/ ! ! initialize control parameters ! call nlinit (n, ifixd, par, npar, pare, npare, mit, stopss, & stopp, scale, lscale, delta, ivaprx, aprxdv, ivcvpt, iwork, & iiwork, rwork, irwork, scl) cmpdrv = .true. done = .false. head = .true. newitr = .false. prtsmy = (iptout(1) /= 0) ! ! compute residuals ! 10 call mdl(par, npar, xm, n, m, ixm, pv) do i=1,n wtsqrt = 1.0e0 if (weight) wtsqrt = sqrt(wt(i)) res(i) = wtsqrt*(y(i)-pv(i)) end do ! ! print initial summary ! if ( prtsmy ) then call nlism(nlhdr, page, wide, hlfrpt, npar, m, n, nnzw, weight, & ifixd, par, scale, iwork, iiwork, rwork, irwork, res, aprxdv, & stp, lstp, npare) prtsmy = .false. end if if (.not.cmpdrv) go to 50 cmpdrv = .false. 40 continue ! ! print iteration report if desired ! if ((iptout(2) /= 0) .and. newitr) call nlitrp(nlhdr, head, page, & wide, iptout(2), npar, nnzw, iwork, iiwork, rwork, irwork, & ifixd, pare, npare) ! ! compute jacobian ! if (done) call mdl(par, npar, xm, n, m, ixm, pv) call nldrv (mdl, drv, done, ifixd, par, npar, xm, n, m, ixm, & pv, d, weight, wt, lwt, stp, lstp, rwork(scl), npare) if (done) go to 70 ! ! compute next iteration ! 50 call nl2itr(rwork(scl), iwork, d, n, n, npare, res, rwork, pare) ! ! unpack parameters ! call nlsupk(pare, npare, par, ifixd, npar) newitr = (iwork(cnvcod) == 0) ! if (iwork(1)-2) 10, 40, 60 if ( iwork(1) < 2 ) then go to 10 else if ( iwork(1) == 2 ) then go to 40 else go to 60 end if 60 done = .true. go to 40 70 continue ! ! set error flags, if necessary ! call nlerr(iwork(icnvcd), iskull) ! ! finish computations and print any desired results ! ! equivalence locations within rwork. ! sdpvi = iwork(rsave) sdresi = iwork(qtr) vcvl = iwork(covmat) if (vcvl >= 1) go to 80 vcvl = iwork(s) if ( ierr == 0 ) then iskull(1) = 1 iskull(7) = 1 ierr = 7 end if 80 continue lvcvl = npare * ( npare + 1 ) / 2 rdi = iwork(rd) call nlfin ( y, weight, nnzw, wt, lwt, xm, n, m, ixm, ifixd, par, & npar, npare, res, page, wide, iptout, ndigit, rwork(rsshlf), & rsd, pv, rwork(sdpvi), rwork(sdresi), rwork(rdi), rwork(vcvl), & lvcvl, d, nlhdr, ivcvpt, iskull ) return end subroutine nlout ( y, weight, nnzw, wt, lwt, xm, n, m, ixm, ifixd, & par, npar, npare, res, iptout, ndigit, page, idf, cond, rss, & rsd, yss, exact, pv, sdpv, sdres, vcvl, lvcvl, ivcvpt, iskull, & nlhdr, wide ) !*****************************************************************************80 ! !! NLOUT prints the final summary report for nonlinear least squares routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & cond,rsd,rss,yss integer & idf,ivcvpt,ixm,lvcvl,lwt,m,n,ndigit,nnzw,npar,npare logical & exact,page,weight,wide ! ! array arguments real & par(npar),pv(n),res(n),sdpv(n),sdres(n),vcvl(lvcvl),wt(lwt), & xm(ixm,m),y(n) integer & ifixd(npar),iptout(ndigit),iskull(10) ! ! subroutine arguments external nlhdr ! ! scalars in common integer & ierr real & fplm,pll,pul,ratio,sdpar,t integer & i,ipk,ipk2,isubhd ! ! external functions real & ppft external ppft ! ! external subroutines external fitpt1,fitpt2,nlskl,vcvotf ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real cond ! the condition number of d. ! logical exact ! an indicator value used to designate whether the fit ! was exact to machine precision (true) or not (false). ! real fplm ! the floating point largest magnitude. ! integer i ! an indexing variable. ! integer idf ! the degrees of freedom in the fit. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. ! if ifixed(i) /= 0, then par(i) will be held fixed. ! if ifixed(i) == 0, then par(i) will be optimized. ! integer ipk ! an index. ! integer ipk2 ! the index of the "diagonal" element of the vcv ! matrix. ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer iskull(10) ! an error message indicator variable. ! integer isubhd ! an integer value specifying subheadings to be printed. ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! integer ixm ! the first dimension of the independent variable array. ! integer lvcvl ! the length of the vector contaning ! the lower half of the vcv matrix, stored row wise. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer ndigit ! the number of digits in the print control value. ! external nlhdr ! the name of the routine which produces the heading. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! real par(npar) ! the parameter estimates. ! logical page ! the variable used to indicate whether or not the output ! is to begin on a new page. ! real pll, pul ! the lower and upper confidence limits for a given parameter. ! real pv(n) ! the predicted value based on the current parameter estimates ! real ratio ! the ratio of a given parameter value to its standard error. ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! real rss ! the residual sum of squares. ! real sdpar ! the standard deviation of a given parameter value. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! real t ! the value of the 97.5 percent point function for the ! t distribution. ! real vcvl(lvcvl) ! the lower half of the vcv matrix, stored row wise. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real wt(lwt) ! the user supplied weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! real yss ! the sum of squares of the dependent variable y. ! fplm = huge ( fplm ) if ((ierr >= 1) .and. (ierr /= 4)) go to 60 ! ! Test for exact fit ! if ((idf <= 0) .or. exact) go to 70 ! ! Print error heading if necessary ! if (ierr == 4) call nlskl(iskull, page, wide, nlhdr) ! ! Print primary report ! if ((ierr /= 0) .or. (iptout(3) /= 0)) then isubhd = 0 call nlhdr(page, wide, isubhd) call fitpt1(n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, nnzw, & weight, max(1, iptout(3))) end if ! ! Print standardized residual plots ! if ( iptout(4) /= 0) then isubhd = 0 call nlhdr(page, wide, isubhd) call fitpt2 (sdres, pv, wt, n, nnzw, weight, res, rss) end if ! ! Print the covariance and correlation matrix ! if ((ierr == 0) .and. (iptout(5) == 0)) return isubhd = 0 call nlhdr(page, wide, isubhd) if ( ierr /= 0 .or. 1 < iptout(5) ) then call vcvotf(npare, vcvl, lvcvl, .true., npar, ifixd, ivcvpt) end if ! ! Print analysis summary ! write ( *,1000) write ( *,1010) t = ppft(0.975e0,idf) ipk = 0 do i=1,npar if (ifixd(i) == 0) then ipk = ipk + 1 ipk2 = ipk*(ipk-1)/2 + ipk ratio = fplm sdpar = sqrt(vcvl(ipk2)) if (sdpar > 0.0e0) ratio = par(i)/sdpar pll = par(i) - t*sdpar pul = par(i) + t*sdpar write ( *,1020) i, par(i), sdpar, ratio, pll, pul else write ( *,1030) i, par(i) end if end do write ( *,1040) rss, rsd, nnzw, npare, idf write ( *,1050) cond if (rss > yss) write ( *,1060) return ! ! Print out error heading ! 60 call nlskl(iskull, page, wide, nlhdr) if (ierr <= 2) return ! ! Print secondary report ! 70 continue isubhd = 0 call nlhdr(page, wide, isubhd) if (ierr /= 0) write ( *,1080) write ( *,1000) write ( *,1100) do i=1,npar if (ifixd(i) == 0) then write ( *,1110) i, par(i) else write ( *,1120) i, par(i) end if end do write ( *,1040) rss, rsd, nnzw, npare, idf if (ierr /= 3) write ( *,1050) cond if ((ierr == 0) .and. (.not.exact) .and. (idf <= 0)) & write(*,1070) if ((ierr == 0) .and. exact) write ( *,1090) if (ierr == 0) then sdres(1:n) = 0.0e0 sdpv(1:n) = 0.0e0 return end if sdres(1:n) = fplm sdpv(1:n) = fplm ! ! Print out error exit statistics ! call fitpt1 ( n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, nnzw, & weight, max(iptout(3),1) ) ! ! Wipe out sdres vector ! sdres(1:n) = fplm ! ! Wipe out vcv matrix ! vcvl(1:lvcvl) = fplm return 1000 format (///' estimates from least squares fit'/1x, 33('-')) 1010 format (//69x, 'approximate'/61x, '95 percent confidence limits '& /1x, 'index', 2x, 'fixed', 3x, 'parameter', 8x, 'sd of par', & 7x, 'ratio', 12x, 'lower', 12x, 'upper'/) 1020 format (1x, i3, 5x, ' no', 2g17.8, 2x, g10.4, 2g17.8) 1030 format (1x, i3, 5x, 'yes', g17.8, 10x, '---', 8x, '---', 15x, & '---', 14x, '---') 1040 format (//' residual sum of squares ', 8x, g15.7//' resid', & 'ual standard deviation ', 8x, g15.7/' based on degrees o', & 'f freedom', 5x, i4, ' - ', i3, ' = ', i4) 1050 format (/' approximate condition number', 10x, g15.7) 1060 format (' the residual sum of squares after the least squares', & ' fit is greater than'/' the sum of squares about the mean ', & 'y observation. the', ' model is less'/' representative o', & 'f the data than a simple average. data', ' and model shou', & 'ld'/' be checked to be sure that they are compatable.') 1070 format (/' the degrees of freedom for this problem is zero.', & ' statistical analysis of the results is not possible.') 1080 format (//' the following summary should be used to', ' analyze', & ' the above mentioned problems.') 1090 format (/' the least squares fit of the data to the model is', & ' exact to within machine precision.'/' statistical analysi', & 's of the results is not possible.') 1100 format (//1x, 'index', 2x, 'fixed', 3x, 'parameter') 1110 format (1x, i3, 5x, ' no', g17.8) 1120 format (1x, i3, 5x, 'yes', g17.8) end subroutine nlsc ( y, xm, n, m, ixm, mdl, par, npar, res, ldstak, & ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, nprt ) !*****************************************************************************80 ! !! NLSC: NLS regression, approximate derivatives (control call) ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using numerically approximated derivatives ! (control call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,stopp,stopss integer & ivaprx,ixm,ldstak,m,mit,n,npar,nprt ! ! array arguments real & par(*),res(*),scale(*),stp(*),xm(*),y(*) integer & ifixed(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & rsd integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,nnzw, & npare logical & save,weight ! ! local arrays real & pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1) character & nmsub(6)*1 ! ! external subroutines external nlcntn ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(npar) ! the step size array. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the dummy array for the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','c',' ',' '/ weight = .false. save = .false. wt(1) = 1.0e0 lifixd = npar lpv = 1 lscale = npar lstp = npar lsdpv = 1 lsdres = 1 lwt = 1 ivcv = 1 call nlcntn(y, wt, lwt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlsc (y, xm, n, m, ixm, nlsmdl,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, stp, mit, stopss, stopp,'/ & ' + scale, delta, ivaprx, nprt)') end subroutine nlsdc ( y, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, idrvck, mit, stopss, stopp, scale, delta, & ivaprx, nprt ) !*****************************************************************************80 ! !! NLSDC: NLS regression, analytic derivatives, user parameters. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using analytic derivatives with user ! supplied control parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,stopp,stopss integer & idrvck,ivaprx,ixm,ldstak,m,mit,n,npar,nprt ! ! array arguments real & par(*),res(*),scale(*),xm(*),y(*) integer & ifixed(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & rsd integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lwt,nnzw,npare logical & save,weight ! ! local arrays real & pv(1),sdpv(1),sdres(1),vcv(1,1),wt(1) character & nmsub(6)*1 ! ! external subroutines external nlcnta ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idrvck ! the variable used to indicate whether or not the derivatives we ! checked or not. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real vcv(1,1) ! the starting location in rstak/dstak of ! the covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the dummy array for the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','d','c',' '/ weight = .false. save = .false. wt(1) = 1.0e0 lifixd = npar lpv = 1 lscale = npar lsdpv = 1 lsdres = 1 lwt = 1 ivcv = 1 call nlcnta(y, wt, lwt, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, lifixd, idrvck, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlsdc (y, xm, n, m, ixm, nlsmdl, nlsdrv,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, idrvck, mit, stopss, stopp,'/ & ' + scale, delta, ivaprx, nprt)') end subroutine nlsd ( y, xm, n, m, ixm, mdl, drv, par, npar, res, ldstak ) !*****************************************************************************80 ! !! NLSD: nonlinear least squares regression, analytic derivatives (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,ldstak,m,n,npar ! ! array arguments real & par(*),res(*),xm(*),y(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & delta,rsd,stopp,stopss integer & idrvck,ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres, & lwt,mit,nnzw,npare,nprt logical & save,weight ! ! local arrays real & pv(1),scale(1),sdpv(1),sdres(1),vcv(1,1),wt(1) integer & ifixed(1) character & nmsub(6)*1 ! ! external subroutines external nlcnta ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idrvck ! the variable used to indicate whether or not the derivatives we ! checked or not. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(1) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the dummy array for the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','d',' ',' '/ weight = .false. save = .false. wt(1) = 1.0e0 idrvck = 1 mit = -1 stopss = -1.0e0 stopp = -1.0e0 scale(1) = -1.0e0 delta = -1.0e0 nprt = -1 ifixed(1) = -1 ivaprx = 0 lifixd = 1 lpv = 1 lscale = 1 lsdpv = 1 lsdres = 1 lwt = 1 ivcv = 1 call nlcnta(y, wt, lwt, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, lifixd, idrvck, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlsd (y, xm, n, m, ixm, nlsmdl, nlsdrv,'/ & ' + par, npar, res, ldstak)') end subroutine nlsds ( y, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, idrvck, mit, stopss, stopp, scale, delta, & ivaprx, nprt, npare, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! NLSDS: NLS regression, analytic derivatives, user parameters. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using analytic derivatives with user ! supplied control parameters, and with computed values returned ! to the user. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,rsd,stopp,stopss integer & idrvck,ivaprx,ivcv,ixm,ldstak,m,mit,n,npar,npare,nprt ! ! array arguments real & par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),vcv(*),xm(*), & y(*) integer & ifixed(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer lifixd,lpv,lscale,lsdpv,lsdres,lwt,nnzw logical & save,weight ! ! local arrays real & wt(1) character & nmsub(6)*1 ! ! external subroutines external nlcnta ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idrvck ! the variable used to indicate whether or not the derivatives we ! checked or not. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(n) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! the typical size of the parameters. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real vcv(ivcv,npar) ! the covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the dummy array for the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','d','s',' '/ weight = .false. save = .true. wt(1) = 1.0e0 lifixd = npar lpv = n lscale = npar lsdpv = n lsdres = n lwt = 1 call nlcnta(y, wt, lwt, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, lifixd, idrvck, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlsds (y, xm, n, m, ixm, nlsmdl, nlsdrv,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, idrvck, mit, stopss, stopp,'/ & ' + scale, delta, ivaprx, nprt,'/ & ' + npare, rsd, pv, sdpv, sdres, vcv, ivcv)') end subroutine nls ( y, xm, n, m, ixm, mdl, par, npar, res, ldstak ) !*****************************************************************************80 ! !! NLS: NLS regression with numeric derivatives, short call. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using numerically approximated derivatives ! (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,ldstak,m,n,npar ! ! array arguments real & par(*),res(*),xm(*),y(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & delta,rsd,stopp,stopss integer ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt, & mit,nnzw,npare,nprt logical & save,weight ! ! local arrays real & pv(1),scale(1),sdpv(1),sdres(1),stp(1),vcv(1,1),wt(1) integer & ifixed(1) character & nmsub(6)*1 ! ! external subroutines external nlcntn ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(1) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(1) ! the step size array. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the dummy array for the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s',' ',' ',' '/ weight = .false. save = .false. wt(1) = 1.0e0 stp(1) = -1.0e0 mit = -1 stopss = -1.0e0 stopp = -1.0e0 scale(1) = -1.0e0 delta = -1.0e0 nprt = -1 ifixed(1) = -1 ivaprx = 0 lifixd = 1 lpv = 1 lstp = 1 lscale = 1 lsdpv = 1 lsdres = 1 lwt = 1 ivcv = 1 call nlcntn(y, wt, lwt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nls (y, xm, n, m, ixm, nlsmdl,'/ & ' + par, npar, res, ldstak)') end subroutine nlskl ( iskull, page, wide, nlhdr ) !*****************************************************************************80 ! !! NLSKL prints warning messages for the nonlinear least squares routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none logical & page,wide ! ! array arguments integer & iskull(10) ! ! subroutine arguments external nlhdr ! ! integer & isubhd ! ! variable definitions (alphabetically) ! ! external nlhdr ! the name of the routine which produces the heading. ! integer iskull(10) ! an error message indicator variable. ! integer isubhd ! an integer value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether or not the output ! is to begin on a new page. ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! isubhd = 0 call nlhdr(page, wide, isubhd) if (wide) then write ( *,1010) write ( *,1020) write ( *,1000) end if write ( *,1060) ! ! vcv computation not completed ! if (iskull(7) /= 0) write ( *,1120) ! ! maximum number of iterations reached before convergence ! if (iskull(6) /= 0) write ( *,1100) ! ! false convergence ! if (iskull(5) /= 0) write ( *,1090) ! ! meaningless vcv matrix ! if (iskull(4) /= 0) write ( *,1080) ! ! problem is computationally singular ! if (iskull(3) /= 0) write ( *,1070) ! ! initial residual sum of squares computation overflowed ! if (iskull(2) /= 0) write ( *,1110) return 1000 format (///) 1010 format (/'WARNING') 1020 format ('WARNING'/) 1060 format (' ** error summary **') 1070 format (/' this model and data are computationally singular.', & ' check your input for errors.') 1080 format (/' at least one of the standardized residuals', ' could', & ' not be computed because the standard deviation', ' of the ', & 'residual was zero.'/' the validity of the covariance matri', & 'x is questionable.') 1090 format (/' the iterations do not appear to be converging', & ' to a minimum', ' (false convergence), indicating that the', & ' convergence', ' criteria stopss'/' and stopp may be too ', & 'small for the accuracy of the model', ' and derivatives,', & ' that there is an error in the derivative matrix, or'/ & ' that the model', ' is discontinuous near the current coef', & 'ficient estimates.') 1100 format (/' program did not converge in the number of iterations', & ' or number of', ' model subroutine calls allowed.') 1110 format (/' the residual sum of squares could not be computed', & ' using the starting', ' model coefficient values.') 1120 format (/' the variance-covariance matrix could not be', & ' computed at the solution.') end subroutine nlspk ( par, mask, npar, ppar, nppar ) !*****************************************************************************80 ! !! NLSPK packs the unmasked elements of one vector into another. ! ! Discussion: ! ! This routine packs a vector par into a vector ppar, by ! omitting from the packed version those elements of the ! unpacked version corresponding to elements of mask which ! have the value 1. other elements of mask should be zero. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & npar,nppar ! ! array arguments real & par(npar),ppar(nppar) integer & mask(npar) ! ! integer & i,ippar ! ! variable definitions (alphabetically) ! ! real par(npar) ! input parameter. the unpacked vector. ! integer i ! loop parameter. ! integer ippar ! current element of ppar. ranges from 0 (on initialization) ! to nppar. ! integer mask(npar) ! input parameter. the mask governing the packing of par. ! elements of mask are 1 if the corresponding element of par ! is to be eliminated in ppar, 0 if it is to be included. ! integer npar ! input parameter. the length of par. ! integer nppar ! input parameter. the length of ppar. ! real ppar(nppar) ! output parameter. the packed version of par. see initial ! description. ! ippar = 0 do i=1,npar if ( mask(i) == 0 ) then ippar = ippar + 1 ppar(ippar) = par(i) end if end do return end subroutine nlss ( y, xm, n, m, ixm, mdl, par, npar, res, ldstak, & ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, nprt, & npare, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! NLSS: interface, nonlinear least squares reqression, approximate derivatives. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using numerically approximated derivatives ! (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,rsd,stopp,stopss integer & ivaprx,ivcv,ixm,ldstak,m,mit,n,npar,npare,nprt ! ! array arguments real & par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), & xm(*),y(*) integer & ifixed(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,nnzw logical & save,weight ! ! local arrays real & wt(1) character & nmsub(6)*1 ! ! external subroutines external nlcntn ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(n) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(npar) ! the step size array. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(1) ! the dummy array for the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','s',' ',' '/ weight = .false. save = .true. wt(1) = 1.0e0 lifixd = npar lpv = n lscale = npar lstp = npar lsdpv = n lsdres = n lwt = 1 call nlcntn(y, wt, lwt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlss (y, xm, n, m, ixm, nlsmdl,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, stp, mit, stopss, stopp,'/ & ' + scale, delta, ivaprx, nprt,'/ & ' + npare, rsd, pv, sdpv, sdres, vcv, ivcv)') end subroutine nlsupk ( pare, npare, par, mask, npar ) !*****************************************************************************80 ! !! NLSUPK unpacks a vector into another, using a mask vector. ! ! Discussion: ! ! This routine unpacks a vector pare into a vector par, by ! placing succeding elements of pare into elements of par ! which correspond to elements of mask with the value 1. ! other elements of mask should be 0. the number of elements ! npare in pare should equal the number of elements of ! mask which are 1. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real par(npar) ! the current estimates of the parameters. ! integer jpk ! an index variable. ! integer mask(npar) ! input parameter. the mask governing the packing of par. ! elements of mask are 1 if the corresponding element of par ! was eliminated in pare, 0 if it was included. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be optimized. ! real pare(npare) ! the current estimates of the parameters being optimized, ! not including those whose values are fixed. ! implicit none integer npar integer npare integer mask(npar) real par(npar) real pare(npare) ! ! integer & i,jpk jpk = 0 do i=1,npar if ( mask(i) == 0 ) then jpk = jpk + 1 par(i) = pare(jpk) end if end do return end subroutine nlswc ( y, wt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, & nprt ) !*****************************************************************************80 ! !! NLSWC: nonlinear least squares regression, weights, approximate derivatives. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using numerically approximated derivatives ! and weights (control call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,stopp,stopss integer & ivaprx,ixm,ldstak,m,mit,n,npar,nprt ! ! array arguments real & par(*),res(*),scale(*),stp(*),wt(*),xm(*),y(*) integer & ifixed(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & rsd integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt,nnzw, & npare logical & save,weight ! ! local arrays real & pv(1),sdpv(1),sdres(1),vcv(1,1) character & nmsub(6)*1 ! ! external subroutines external nlcntn ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(npar) ! the step size array. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','w','c',' '/ weight = .true. save = .false. lifixd = npar lpv = 1 lscale = npar lstp = npar lsdpv = 1 lsdres = 1 lwt = n ivcv = 1 call nlcntn(y, wt, lwt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlswc (y, wt, xm, n, m, ixm, nlsmdl,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, stp, mit, stopss, stopp, scale,'/ & ' + delta, ivaprx, nprt)') end subroutine nlswdc ( y, wt, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, idrvck, mit, stopss, stopp, scale, delta, & ivaprx, nprt ) !*****************************************************************************80 ! !! NLSWDC: NLS regression, analytic derivatives, weights, user parameters. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using analytic derivatives, weights, and ! user supplied control parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,stopp,stopss integer & idrvck,ivaprx,ixm,ldstak,m,mit,n,npar,nprt ! ! array arguments real & par(*),res(*),scale(*),wt(*),xm(*),y(*) integer & ifixed(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & rsd integer ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lwt,nnzw,npare logical & save,weight ! ! local arrays real & pv(1),sdpv(1),sdres(1),vcv(1,1) character & nmsub(6)*1 ! ! external subroutines external nlcnta ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idrvck ! the variable used to indicate whether the derivatives are ! to be checked (idrvck = 1) or not (idrvck = 0). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ifixed(i).eq ! then par(i) will be held fixed. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real vcv(1,1) ! a dummy array for ! the variance-covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','w','d','c'/ weight = .true. save = .false. lifixd = npar lpv = 1 lscale = npar lsdpv = 1 lsdres = 1 lwt = n ivcv = 1 call nlcnta(y, wt, lwt, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, lifixd, idrvck, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlswdc (y, wt, xm, n, m, ixm, nlsmdl, nlsdrv,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, idrvck, mit, stopss, stopp,'/ & ' + scale, delta, ivaprx, nprt)') end subroutine nlswd ( y, wt, xm, n, m, ixm, mdl, drv, par, npar, res, ldstak ) !*****************************************************************************80 ! !! NLSWD: NLS regression, analytic derivatives, weights (short call). ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using analytic derivatives and weights ! (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,ldstak,m,n,npar ! ! array arguments real & par(*),res(*),wt(*),xm(*),y(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & delta,rsd,stopp,stopss integer & idrvck,ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres, & lwt,mit,nnzw,npare,nprt logical & save,weight ! ! local arrays real & pv(1),scale(1),sdpv(1),sdres(1),vcv(1,1) integer & ifixed(1) character & nmsub(6)*1 ! ! external subroutines external nlcnta ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idrvck ! the variable used to indicate whether or not the derivatives we ! checked or not. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ifixed(i).eq ! then par(i) will be held fixed. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of indendent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(1) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','w','d',' '/ weight = .true. save = .false. idrvck = 1 mit = -1 stopss = -1.0e0 stopp = -1.0e0 scale(1) = -1.0e0 delta = -1.0e0 nprt = -1 ifixed(1) = -1 ivaprx = 0 lifixd = 1 lpv = 1 lscale = 1 lsdpv = 1 lsdres = 1 lwt = n ivcv = 1 call nlcnta(y, wt, lwt, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, lifixd, idrvck, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlswd (y, wt, xm, n, m, ixm, nlsmdl, nlsdrv,'/ & ' + par, npar, res, ldstak)') end subroutine nlswds ( y, wt, xm, n, m, ixm, mdl, drv, par, & npar, res, ldstak, ifixed, idrvck, mit, stopss, stopp, scale, & delta, ivaprx, nprt, nnzw, npare, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! NLSWDS: NLS regression with analytic derivatives, weights, user parameters. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using analytic derivatives, weights, and ! user supplied control parameters, and with computed values ! returned to the user. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,rsd,stopp,stopss integer & idrvck,ivaprx,ivcv,ixm,ldstak,m,mit,n,nnzw,npar,npare,nprt ! ! array arguments real & par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),vcv(*),wt(*), & xm(*),y(*) integer & ifixed(*) ! ! subroutine arguments external drv,mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer lifixd,lpv,lscale,lsdpv,lsdres,lwt logical & save,weight ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external nlcnta ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! external drv ! the name of the user supplied subroutine which computes the ! derivative (jacobian) matrix of the model. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idrvck ! the variable used to indicate whether the derivatives are ! to be checked (idrvck = 1) or not (idrvck = 0). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ifixed(i).eq ! then par(i) will be held fixed. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(n) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! the typical size of the parameters. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual standard deviation (computed ! by starpac) to the current residual sum of squares estimate. ! real vcv(ivcv,npar) ! the variance-covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'n', 'l', 's', 'w', 'd', 's'/ weight = .true. save = .true. lifixd = npar lpv = n lscale = npar lsdpv = n lsdres = n lwt = n call nlcnta(y, wt, lwt, xm, n, m, ixm, mdl, drv, par, npar, res, & ldstak, ifixed, lifixd, idrvck, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *, 1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlswds (y, wt, xm, n, m, ixm, nlsmdl, nlsdrv,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, idrvck, mit, stopss, stopp,'/ & ' + scale, delta, ivaprx, nprt,'/ & ' + nnzw, npare, rsd, pv, sdpv, sdres, vcv,', & ' ivcv)') end subroutine nlsw ( y, wt, xm, n, m, ixm, mdl, par, npar, res, ldstak ) !*****************************************************************************80 ! !! NLSW: NLS regression with approximate derivatives and weights. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using numerically approximated derivatives ! and weights (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,ldstak,m,n,npar ! ! array arguments real & par(*),res(*),wt(*),xm(*),y(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & delta,rsd,stopp,stopss integer ivaprx,ivcv,lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt, & mit,nnzw,npare,nprt logical & save,weight ! ! local arrays real & pv(1),scale(1),sdpv(1),sdres(1),stp(1),vcv(1,1) integer & ifixed(1) character & nmsub(6)*1 ! ! external subroutines external nlcntn ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(1)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(1) ! a dummy array for ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(1) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(1) ! a dummy array for ! the standard deviation of the predicted value. ! real sdres(1) ! a dummy array for ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(1) ! the step size array. ! real vcv(1,1) ! a dummy array for ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','w',' ',' '/ weight = .true. save = .false. stp(1) = -1.0e0 mit = -1 stopss = -1.0e0 stopp = -1.0e0 scale(1) = -1.0e0 delta = -1.0e0 nprt = -1 ifixed(1) = -1 ivaprx = 0 lifixd = 1 lpv = 1 lstp = 1 lscale = 1 lsdpv = 1 lsdres = 1 lwt = n ivcv = 1 call nlcntn(y, wt, lwt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlsw (y, wt, xm, n, m, ixm, nlsmdl,'/ & ' + par, npar, res, ldstak)') end subroutine nlsws ( y, wt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, stp, mit, stopss, stopp, scale, delta, ivaprx, & nprt, nnzw, npare, rsd, pv, sdpv, sdres, vcv, ivcv ) !*****************************************************************************80 ! !! NLSWS: NLS regression with approximate derivatives and weights. ! ! Discussion: ! ! This is the user callable subroutine for nonlinear least ! squares regression using numerically approximated derivatives ! and weights (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,rsd,stopp,stopss integer & ivaprx,ivcv,ixm,ldstak,m,mit,n,nnzw,npar,npare,nprt ! ! array arguments real & par(*),pv(*),res(*),scale(*),sdpv(*),sdres(*),stp(*),vcv(*), & wt(*),xm(*),y(*) integer & ifixed(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer lifixd,lpv,lscale,lsdpv,lsdres,lstp,lwt logical & save,weight ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external nlcntn ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifixed(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ifixed(i).eq ! then par(i) will be held fixed. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the actual length of the vector ifixed. ! integer lpv ! the actual length of the vector pv. ! integer lscale ! the actual length of the vector scale. ! integer lsdpv ! the actual length of the vector sdpv. ! integer lsdres ! the actual length of the vector sdres. ! integer lstp ! the actual length of the vector stp. ! integer lwt ! the actual length of the vector wt. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimate. n ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer nnzw ! the number of non zero weights. ! integer npar ! the number of parameters in the model. ! integer npare ! the number of parameters to be estimated. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(npar) ! the current estimates of the parameters. ! real pv(n) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real rsd ! the value of the residual standard deviation at the solution. ! logical save ! the variable used to indicate whether any results other than ! the residuals and parameters are to be saved (true) or not ! (false). ! real scale(npar) ! a value to indicate use of the default values of ! the typical size of the parameters. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual sum of squares (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(npar) ! the step size array. ! real vcv(ivcv,npar) ! the variance covariance matrix. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'n','l','s','w','s',' '/ weight = .true. save = .true. lifixd = npar lpv = n lscale = npar lstp = npar lsdpv = n lsdres = n lwt = n call nlcntn(y, wt, lwt, xm, n, m, ixm, mdl, par, npar, res, & ldstak, ifixed, lifixd, stp, lstp, mit, stopss, stopp, scale, & lscale, delta, ivaprx, nprt, rsd, pv, lpv, sdpv, lsdpv, sdres, & lsdres, vcv, ivcv, nmsub, weight, save, nnzw, npare) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call nlsws (y, wt, xm, n, m, ixm, nlsmdl,'/ & ' + par, npar, res, ldstak,'/ & ' + ifixed, stp, mit, stopss, stopp,'/ & ' + scale, delta, ivaprx, nprt,'/ & ' + nnzw, npare, rsd, pv, sdpv, sdres, vcv,', & ' ivcv)') end subroutine nlsx1 ( mod, par, npar, pv, sdpv, res, sdres, vcv, n, & ivcv, nnzw, npare, rsd ) !*****************************************************************************80 ! !! NLSX1 sets the starting parameter values for NLSX. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & rsd integer & ivcv,mod,n,nnzw,npar,npare ! ! array arguments real & par(npar),pv(n),res(n),sdpv(n),sdres(n),vcv(ivcv,ivcv) ! ! scalars in common integer & ierr ! ! external subroutines external setrv ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ivcv ! the actual first dimension of vcv. ! integer mod ! an indicator value used to designate the model for which ! the parameters are to be set. ! integer n ! the number of observations. ! integer npar ! the number of parameters in the model. ! to be provided. ! integer npare ! the number of parameters estimated by the routine. ! integer nnzw ! the number of nonzero weights. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real pv(n) ! the predicted values. ! real res(n) ! the residuals. ! real rsd ! the residual standard deviation. ! real sdpv(n) ! the standard deviation of the predicted values. ! real sdres(n) ! the standardized residuals. ! real vcv(ivcv,ivcv) ! the variance covariance matrix. ! if ( mod == 1 ) then par(1) = 0.725e0 par(2) = 4.0e0 else if ( mod == 2 ) then par(1) = 1.0e0 par(2) = 2.0e0 par(3) = 3.0e0 else if ( mod == 3 ) then par(1) = 6.0e0 par(2) = 5.0e0 par(3) = 4.0e0 par(4) = 3.0e0 par(5) = 2.0e0 else if ( mod == 4 ) then call setrv(par, npar, 0.0e0) else if ( mod == 5 ) then call setrv(par, npar, 0.5e0) else if ( mod == 6 ) then par(1) = 100.0e0 par(2) = 15.0e0 end if res(1:n) = -1.0e0 pv(1:n) = -1.0e0 sdpv(1:n) = -1.0e0 sdres(1:n) = -1.0e0 vcv(1:ivcv,1:ivcv) = -1.0e0 nnzw = -1 npare = -1 rsd = -1.0e0 ierr = -1 return end subroutine nlsx2 ( n, m, ixm, npar, ifixed, stp, idrvck, mit, & stopss, stopp, scale, delta, ivaprx, nprt, ivcv ) !*****************************************************************************80 ! !! NLSX2 sets a problem for testing the NLS family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,stopp,stopss integer & idrvck,ivaprx,ivcv,ixm,m,mit,n,npar,nprt ! ! array arguments real & scale(10),stp(10) integer & ifixed(10) ! ! real & sqmeps ! ! external functions real & rmdcon external rmdcon ! ! variable definitions (alphabetically) ! ! real delta ! the maximum change allowed in the model parameters at the ! first iteration. ! integer idrvck ! the variable used to indicate whether the derivatives are ! to be checked (idrvck = 1) or not (idrvck = 0). ! integer ifixed(10) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! ifixed(i)<0, then all par(i),i=1,npar, will be optimized.. ! integer ivaprx ! an indicator value used to designate which option is to be used ! to compute the variance covariance matrix (vcv), where ! ivaprx le 0 indicates the the default option will be used ! ivaprx eq 1 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 2 indicates the vcv is to be computed by ! inverse(hessian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 3 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using both the model subroutine the user supplied ! derivative subroutine when it is available ! ivaprx eq 4 indicates the vcv is to be computed by ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! using only the model subroutine ! ivaprx eq 5 indicates the vcv is to be computed by ! inverse(hessian) ! using only the model subroutine ! ivaprx eq 6 indicates the vcv is to be computed by ! inverse(transpose(jacobian)*jacobian) ! using only the model subroutine ! ivaprx ge 7 indicates the default option will be used ! integer ivcv ! the first dimension of the variance covariance matrix vcv. ! integer ixm ! the first dimension of the independent variable array. ! integer m ! the number of independent variables. ! integer mit ! the maximum number of iterations allowed. ! integer n ! the number of observations. ! integer npar ! the number of unknown parameters in the model. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real scale(10) ! a value to indicate use of the default values of ! the typical size of the unknown parameters. ! real sqmeps ! the square root of machine precision ! real stopp ! the stopping criterion for the test based on the maximum scaled ! relative change in the elements of the model parameter vector ! real stopss ! the stopping criterion for the test based on the ratio of the ! predicted decrease in the residual standard deviation (computed ! by starpac) to the current residual sum of squares estimate. ! real stp(10) ! the step size array. ! sqmeps = sqrt( epsilon ( sqmeps ) ) n = 6 m = 1 ixm = 10 npar = 2 mit = 500 stp(1:10) = sqmeps scale(1:10) = 1.0e0 ifixed(1) = -1 idrvck = 0 stopss = 10.0e-5 stopp = 10.0e-5 delta = 0.5e0 nprt = 11111 ivaprx = 3 ivcv = 6 return end subroutine nrandc ( y, n, iseed, ymean, sigma ) !*****************************************************************************80 ! !! NRANDC generates pseudorandom normally distributed values. ! ! Discussion: ! ! This routine generates n normally distributed pseudo- ! random numbers with mean ymean and standard deviation sigma. the ! numbers generated are determined by iseed. they are returned in y ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & sigma,ymean integer & iseed,n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! integer & i,iseedu logical & err01,err02,head ! ! local arrays character & ln(8)*1,lone(8)*1,lsigma(8)*1,lzero(8)*1,nmsub(6)*1 ! ! external functions real & randn external randn ! ! external subroutines external eisge,eisrng,ersge ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01, err02 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading sould be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! the index of the computing loop ! integer ierr ! the integer value returned by theis routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been found. ! integer iseed ! the iseed to the random number generator. ! iseed must lie between 0 and 2**((min(32,i1mach(8)+1))-1) -1, ! inclusive. if iseed is not equal to 0, iseed must be odd. ! integer iseedu ! the value of the seed actually used. ! character*1 ln(8), lone(8), lsigma(8), lzero(8) ! the array(s) containing the name(s) of the variables(s) checked ! for errors ! integer n ! the length of data set generated ! character*1 nmsub(6) ! the name of this subroutine ! real sigma ! the standard deviation of the generated values. ! real y(n) ! the generated random values. ! real ymean ! the mean of the generated values. ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'n', 'r', 'a', 'n', 'd', 'c'/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), & ln(7), ln(8)/'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), & lone(7), lone(8)/'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ data lsigma(1),lsigma(2),lsigma(3),lsigma(4),lsigma(5),lsigma(6), & lsigma(7),lsigma(8)/'s', 'i', 'g', 'm', 'a', ' ', ' ', ' '/ data lzero(1), lzero(2), lzero(3), lzero(4), lzero(5), lzero(6), & lzero(7), lzero(8)/'z', 'e', 'r', 'o', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 1, 2, head, err01, lone) call ersge(nmsub, lsigma, sigma, 0.0e0, 2, head, err02, lzero) call eisrng(nmsub, iseed, iseedu, head) if (err01.or.err02) then write ( *,1000) ierr = 1 else ! ! generate the pseudo-random numbers ! y(1) = randn(iseedu) do i=1,n y(i) = randn(0)*sigma + ymean end do end if return 1000 format (/' the correct form of the call statement is'// & ' call nrandc (y, n, iseed, ymean, sigma)') end subroutine nrand ( y, n, iseed ) !*****************************************************************************80 ! !! NRAND generates pseudorandom normally distributed values. ! ! Discussion: ! ! This routine generates n normally distributed pseudo- ! random numbers with zero mean and unit standard deviation. the ! numbers generated are determined by iseed. they are returned in y ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iseed,n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! integer & i,iseedu logical & err01,head ! ! local arrays character & ln(8)*1,lone(8)*1,nmsub(6)*1 ! ! external functions real & randn external randn ! ! external subroutines external eisge,eisrng ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading sould be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! the index of the computing loop ! integer ierr ! the integer value returned by theis routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been found. ! integer iseed ! the iseed to the random number generator. ! iseed must lie between 0 and 2**((min(32,i1mach(8)+1))-1) -1, ! inclusive. if iseed is not equal to 0, iseed must be odd. ! integer iseedu ! the value of the seed actually used. ! character*1 ln(8), lone(8) ! the array(s) containing the name(s) of the variables(s) checked ! for errors ! integer n ! the length of data set generated ! character*1 nmsub(6) ! the name of this subroutine ! real y(n) ! the generated random values. ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'n', 'r', 'a', 'n', 'd', ' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), & ln(7), ln(8)/'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), & lone(7), lone(8)/'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 1, 2, head, err01, lone) call eisrng(nmsub, iseed, iseedu, head) if (err01) then write ( *,1000) ierr = 1 return end if ! ! generate the pseudo-random numbers ! y(1) = randn(iseedu) do i=1,n y(i) = randn(0) end do return 1000 format (/' the correct form of the call statement is'// & ' call nrand(y, n, iseed)') end function numxer ( nerr ) !*****************************************************************************80 ! !! NUMXER returns the most recent error number. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, integer NERR, the most recent error number. ! ! Output, integer NUMXER, the most recent error number. ! implicit none integer j4save integer nerr integer numxer logical set integer value integer which which = 1 value = 0 set = .false. nerr = j4save ( which, value, set ) numxer = nerr return end subroutine oanova ( ysum, red, npar, rvar, nnzw, temp ) !*****************************************************************************80 ! !! OANOVA computes and prints analysis of variance. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & rvar,ysum integer & nnzw,npar ! ! array arguments real & red(npar),temp(npar) real & asum,cr,f1,f2,fplm,pf1,pf2,resms,resss,ssu,v1f2,vr integer & i,k,nsua ! ! external functions real & cdff external cdff ! ! variable definitions (alphabetically) ! ! real fplm ! the floating point largest magnitude. ! integer npar ! the number of parameters. ! integer nnzw ! the number of non zero weights. ! real red(npar) ! the reduction to the sum of squares due to each parameter. ! real rvar ! the residual variance. ! real temp(npar) ! a work vector. ! real ysum ! the sum of the weighted dependent variables squared. ! fplm = huge ( fplm ) resms = ysum / real ( nnzw ) nsua = nnzw write ( *,1000) asum = 0.0e0 vr = real ( nnzw - npar ) resss = vr*rvar temp(npar) = resss do i=2,npar k = npar + 2 - i temp(k-1) = temp(k) + red(k) end do v1f2 = real ( npar + 1 ) ssu = real ( nnzw ) do i=1,npar nsua = nsua - 1 asum = asum + red(i) ssu = ssu - 1.0e0 cr = asum / real ( i ) resms = 0.0e0 if (ssu > 0.0e0) resms = temp(i)/ssu v1f2 = v1f2 - 1.0e0 ! ! never pool ! if ( rvar <= 0.0e0 ) then f1 = fplm f2 = fplm pf1 = 0.0e0 pf2 = 0.0e0 else f1 = red(i)/rvar pf1 = 1.0e0 - cdff(f1,1.0e0,vr) ! ! test higher sub-hypotheses ! f2 = (temp(i)+red(i)-resss)/v1f2/rvar pf2 = 1.0e0 - cdff(f2,v1f2,vr) end if write ( *,1010) i, red(i), cr, i, resms, nsua, f1, pf1, f2, & pf2 end do write ( *,1020) resss, nsua write ( *,1030) ysum, nnzw return 1000 format (////50x, 'analysis of variance'/24x, '-dependent on or', & 'der variables are entered unless vectors are orthogonal-'// & 1x, ' par sum of squares', 63x, & '------ par=0 ------ ------ pars=0 -----'/ & 1x, 'index', 4x, 'red due to par', 7x, 'cum ms red', & 6x, 'df(msred)', 6x, 'cum res ms', 6x, 'df(rms)', 5x, & 'f', 8x, 'prob(f)', 7x, 'f', 8x, 'prob(f)'/) 1010 format (1x, i3, 6x, g16.9, 3x, g16.9, 1x, i6, 8x, g16.9, 1x, i5, & 4x, g12.6, f7.3, 4x, g12.6, f7.3) 1020 format (/1x, 'residual ', 1x, g14.7, 20x, i6) 1030 format (1x, 'total ', 1x, g14.7, 20x, i6) end subroutine obssm2 ( n, y, pvt, sdpvt, res, sdrest, ifirst, ilast ) !*****************************************************************************80 ! !! OBSSM2 lists the data summary for the arima estimation routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ifirst,ilast,n ! ! array arguments real & pvt(n),res(n),sdpvt(n),sdrest(n),y(n) ! ! scalars in common integer & ierr ! ! real & fplm integer & i ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real fplm ! the floating point largest magnitude. ! integer i ! an index variable. ! integer ierr ! the value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr >= 1, errors were detected. ! integer ifirst, ilast ! the first and last indices to be listed. ! integer n ! the number of observations. ! real pvt(n) ! the predicted value based on the current parameter estimates. ! real res(n) ! the residuals from the fit. ! real sdpvt(n) ! the standard deviations of the predicted values. ! real sdrest(n) ! the standardized residuals. ! real y(n) ! the dependent variable. ! fplm = huge ( fplm ) do i=ifirst,ilast ! ! print data summary. ! if ((sdpvt(i) /= fplm) .and. (sdrest(i) /= fplm)) & write ( *, 1060) i, y(i), pvt(i), sdpvt(i), res(i), & sdrest(i) if ((sdpvt(i) /= fplm) .and. (sdrest(i) == fplm)) & write ( *, 1050) i, y(i), pvt(i), sdpvt(i), res(i) if ((sdpvt(i) == fplm) .and. (sdrest(i) == fplm)) & write ( *, 1080) i, y(i), pvt(i), res(i) end do return 1050 format (1x, i4, 4e16.8, 4x, 'nc *', 1x, e9.3) 1060 format (1x, i4, 4e16.8, 1x, f7.2, 1x, e9.3) 1080 format (1x, i4, 2e16.8, 8x, 'nc *', 4x, e16.8, 4x, 'nc *', & 1x, e9.3) end subroutine obssum ( n, m, xm, y, pv, sdpv, res, sdres, wt, ixm, & weight, k, ifirst, ilast, jcol1, jcolm ) !*****************************************************************************80 ! !! OBSSUM lists the data summary for the least squares subroutines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ifirst,ilast,ixm,jcol1,jcolm,k,m,n logical & weight ! ! array arguments real & pv(n),res(n),sdpv(n),sdres(n),wt(n),xm(ixm,m),y(n) ! ! scalars in common integer & ierr ! ! real & fplm integer & i,j character & string*20,fmt1*160,fmt2*160,fmt3*160 ! ! external functions logical & mvchk external mvchk ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! character*160 fmt1,fmt2,fmt3 ! the formats used to print the information. ! real fplm ! the floating point largest magnitude. ! integer i ! an indexing variable. ! integer ierr ! the integer value designating whether any errors have ! been detected. ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected. ! integer ifirst, ilast ! the first and last indices to be listed. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the parameter being examined. ! integer jcolm ! the last column of the independent variable to be printed. ! integer jcol1 ! the first column of the independent variable to be printed. ! integer k ! an index variable. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! real pv(n) ! the predicted value based on the current parameter estimates ! real res(n) ! the residuals from the fit. ! real sdpv(n) ! the standard deviation of the predicted value. ! real sdres(n) ! the standard deviations of the residuals. ! character*20 string ! character string used to build the formats. ! logical weight ! the variable used to indicate whether weighted analysis is to ! be performed (true) or not (false). ! real wt(n) ! the user supplied weights. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! real y(n) ! the array of the dependent variable. ! fplm = huge ( fplm ) ! ! construct format ! if (k == 1) then string = '1x,i4,15x,g15.8,15x,' else if (k == 2) then string = '1x,i4,7x,2g15.8,8x, ' else string = '1x,i4,3g15.8, ' end if write (fmt1,1020) string write (fmt2,1030) string write (fmt3,1040) string do i=ifirst, ilast if (mvchk(sdpv(i),fplm)) then if (weight) then write ( *, fmt1) i, (xm(i,j),j=jcol1,jcolm), & y(i), pv(i), res(i), wt(i) else write ( *, fmt1) i, (xm(i,j),j=jcol1,jcolm), & y(i), pv(i), res(i) end if else if (mvchk(sdres(i),fplm)) then if (weight) then write ( *, fmt2) i, (xm(i,j),j=jcol1,jcolm), & y(i), pv(i), sdpv(i), res(i), wt(i) else write ( *, fmt2) i, (xm(i,j),j=jcol1,jcolm), & y(i), pv(i), sdpv(i), res(i) end if else if (weight) then write ( *, fmt3) i, (xm(i,j),j=jcol1,jcolm), & y(i), pv(i), sdpv(i), res(i), & sdres(i), wt(i) else write ( *, fmt3) i, (xm(i,j),j=jcol1,jcolm), & y(i), pv(i), sdpv(i), res(i), & sdres(i) end if end if end if end do return 1020 format ('(',a20,'2g16.8,8x,''nc *'',4x,g16.8,4x,''nc *'',1x,e9.3)') 1030 format ('(',a20,'4g16.8,4x,''nc *'',1x,e9.3)') 1040 format ('(',a20,'4g16.8,1x,f7.2,1x,e9.3)') end subroutine parchk ( iv, n, nn, p, v ) !*********************************************************************** ! !! PARCHK checks the NL2SOL parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real, save :: big = 0.0E+00 character ( len = 4 ) cngd(3) character ( len = 4 ) dflt(3) integer i integer iv(*) integer iv1 integer jtolp integer k integer l integer m real machep integer n integer nn integer, parameter :: nvdflt = 27 integer p integer, parameter :: parsv1 = 51 integer, parameter :: prunit = 21 integer pu real, save :: teensy = 1.0E+00 real v(*) real vk real vm(27) character ( len = 8 ) vn(27) real vx(27) character ( len = 4 ) which(3) ! ! iv and v subscripts ! integer dtype, dtype0, d0init, epslon, inits, jtinit, jtol0, & jtol1, oldn, oldnn, oldp, parprt parameter (dtype=16, dtype0=29, d0init=37, epslon=19 ) parameter ( inits=25, jtinit=39, jtol0=86, jtol1=87 ) parameter ( oldn=45, oldnn=46, oldp=47, parprt=20 ) data vn / & 'epslon..', 'phmnfc..', 'phmxfc..', 'decfac..', 'incfac..', & 'rdfcmn..', 'rdfcmx..', 'tuner1..', 'tuner2..', 'tuner3..', & 'tuner4..', 'tuner5..', 'afctol..', 'rfctol..', 'xctol...', & 'xftol...', 'lmax0...', 'dltfdj..', 'd0init..', 'dinit...', & 'jtinit..', 'dltfdc..', 'dfac....', 'rlimit..', 'cosmin..', & 'delta0..', 'fuzz....' / data vm(1)/1.0e-3/, vm(2)/-0.99e+0/, vm(3)/1.0e-3/, vm(4)/1.0e-2/, & vm(5)/1.2e+0/, vm(6)/1.e-2/, vm(7)/1.2e+0/, vm(8)/0.e+0/, & vm(9)/0.e+0/, vm(10)/1.e-3/, vm(11)/-1.e+0/, vm(15)/0.e+0/, & vm(16)/0.e+0/, vm(19)/0.e+0/, vm(20)/-10.e+0/, vm(21)/0.e+0/, & vm(23)/0.e+0/, vm(24)/1.e+10/, vm(27)/1.01e+0/ data vx(1)/0.9e+0/, vx(2)/-1.e-3/, vx(3)/1.e+1/, vx(4)/0.8e+0/, & vx(5)/1.e+2/, vx(6)/0.8e+0/, vx(7)/1.e+2/, vx(8)/0.5e+0/, & vx(9)/0.5e+0/, vx(10)/1.e+0/, vx(11)/1.e+0/, vx(14)/0.1e+0/, & vx(15)/1.e+0/, vx(16)/1.e+0/, vx(18)/1.e+0/, vx(22)/1.e+0/, & vx(23)/1.e+0/, vx(25)/1.e+0/, vx(26)/1.e+0/, vx(27)/1.e+2/ data cngd(1),cngd(2),cngd(3)/'---c','hang','ed v'/ data dflt(1),dflt(2),dflt(3)/'nond','efau','lt v'/ if ( iv(1) == 0 ) then call dfault ( iv, v ) end if pu = iv(prunit) iv1 = iv(1) if ( iv1 == 12 ) then if ( nn < n .or. n < p .or. p < 1 ) then iv(1) = 16 if ( pu /= 0 ) then write ( pu, '(a)' ) ' ' write ( pu, '(a)' ) ' Bad NN, N or P:' write ( pu, '(a)' ) ' ' write ( pu, '(a,i5)' ) ' NN = ', nn write ( pu, '(a,i5)' ) ' N = ', n write ( pu, '(a,i5)' ) ' P = ', p end if return end if k = iv(21) call dfault ( iv(21), v(33) ) iv(21) = k iv(dtype0) = iv(dtype+20) iv(oldn) = n iv(oldnn) = nn iv(oldp) = p which(1) = dflt(1) which(2) = dflt(2) which(3) = dflt(3) else if ( n /= iv(oldn) .or. & nn /= iv(oldnn) .or. & p /= iv(oldp) ) then iv(1) = 17 if ( pu /= 0 ) then write ( pu, '(a)' ) ' ' write ( pu, '(a)' ) '(NN,N,P) changed from:' write ( pu, '(a,i8)' ) ' NN = ', iv(oldnn) write ( pu, '(a,i8)' ) ' N = ', iv(oldn) write ( pu, '(a,i8)' ) ' P = ', iv(oldp) write ( pu, '(a)' ) ' to:' write ( pu, '(a,i8)' ) ' NN = ', nn write ( pu, '(a,i8)' ) ' N = ', n write ( pu, '(a,i8)' ) ' P = ', p end if return end if if ( iv1 < 1 .or. 11 < iv1 ) then iv(1) = 50 if ( pu /= 0 ) then write(pu,60) iv1 end if 60 format(' iv(1) =', i5, ' should be between 0 and 12.') return end if which(1) = cngd(1) which(2) = cngd(2) which(3) = cngd(3) end if if ( big <= teensy ) then teensy = tiny ( teensy ) machep = epsilon ( machep ) big = huge ( big ) vm(12) = machep vx(12) = big vm(13) = teensy vx(13) = big vm(14) = machep vm(17) = teensy vx(17) = big vm(18) = machep vx(19) = big vx(20) = big vx(21) = big vm(22) = machep vx(24) = sqrt ( 0.999E+00 * huge ( vx(24) ) ) vm(25) = machep vm(26) = machep end if m = 0 if ( 0 <= iv(inits) .and. iv(inits) <= 2 ) then go to 110 end if m = 18 if (pu /= 0 ) then write(pu,100) iv(inits) end if 100 format('inits... iv(25) =',i4,' should be between 0 and 2.') 110 continue k = epslon do i = 1, nvdflt vk = v(k) if ( vm(i) <= vk .and. vk <= vx(i) ) then go to 130 end if m = k if ( pu /= 0 ) then write(pu,120) vn(i), k, vk, vm(i), vx(i) end if 120 format( a8, '.. v(',i2, ') =', e11.3, & ' should be between ',e11.3, ' and', d11.3 ) 130 continue k = k + 1 end do ! ! Check JTOL values. ! if ( iv1 /= 12 .or. v(jtinit) <= 0.0E+00 ) then jtolp = jtol0 + p do i = jtol1, jtolp if ( v(i) <= 0.0E+00 ) then k = i - jtol0 if ( pu /= 0 ) then write(pu,150) k, i, v(i) end if 150 format( 'jtol(', i3, ') = v(', i3, ') =', e11.3, & ' should be positive.' ) m = i end if end do end if if ( m /= 0 ) then iv(1) = m return end if !180 continue if ( pu == 0 .or. iv(parprt) == 0 ) then return end if if ( iv1 == 12 .and. iv(inits) /= 0 ) then m = 1 write(pu,190) iv(inits) 190 format( 'nondefault values....inits..... iv(25) =', i3) end if if ( iv(dtype) /= iv(dtype0) ) then if ( m == 0 ) then write(pu,215) which end if m = 1 write ( pu, '(a,i3)' ) 'DTYPE..... IV(16) = ', iv(dtype) end if k = epslon l = parsv1 do i = 1, nvdflt if ( v(k) /= v(l) ) then if ( m == 0 ) then write(pu,215) which end if 215 format(3a4,'alues....') m = 1 write(pu,220) vn(i), k, v(k) 220 format(1x,a8,'.. v(',i2,') =',e15.7) end if k = k + 1 l = l + 1 end do iv(dtype0) = iv(dtype) v(parsv1:parsv1+nvdflt-1) = v(epslon:epslon+nvdflt-1) if ( iv1 /= 12 ) then return end if if ( v(jtinit) <= 0.0E+00 ) then write ( pu, '(a)' ) '(Initial) JTOL array' write ( pu, '(6e12.3)' ) v(jtol1:jtol0+p) end if if ( v(d0init) <= 0.0E+00 ) then k = jtol1 + p write ( pu, '(a)' ) '(Initial) D0 array' write ( pu, '(6e12.3)' ) v(k:k+p-1) end if return end subroutine parzen ( lag, w, lw ) !*****************************************************************************80 ! !! PARZEN computes and stores the Parzen lag window. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer k ! an index variable ! integer l ! the value lag/2. ! integer lag ! the lag window truncation point used for a specific window. ! integer lw ! the length of the vector w. ! real w(lw) ! the vector of lag windows. ! implicit none integer lw integer k integer l integer lag real w(lw) l = lag/2 w(1) = 1.0e0 do k = 1, l w(k+1) = real(k) / real(lag) w(k+1) = 1.0e0 + 6.0e0 * w(k+1) * w(k+1) * (w(k+1) - 1.0e0) end do l = l + 1 do k = l, lag w(k+1) = 1.0e0 - real(k) / real(lag) w(k+1) = 2.0e0 * w(k+1) * w(k+1) * w(k+1) end do return end subroutine pgmest ( yfft, nfft, nf, cnst, per, lper ) !*****************************************************************************80 ! !! PGMEST computes the periodogram estimates. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real cnst ! the variance of the observed time series times the number of ! observations in the series if called by ipgm, ! or 1.0e0 if called by pgm. ! real fac ! a factor used for computations of the integrated periodogram. ! integer i ! an index variable ! integer isn ! a code used for the fft. ! integer lper ! the length of the periodogram array. ! integer nf ! the number of frequencies at which the periodogram is ! computed. ! integer nfft ! the effective number of observations for the fft transform. ! integer nfft2 ! the effective number of complex observations for the fft ! transform. ! real per(lper) ! the periodogram. ! real yfft(nfft) ! the centered series. ! implicit none real & cnst integer & lper,nf,nfft ! ! array arguments real & per(lper),yfft(nfft) real & fac integer & i,isn,nfft2 ! ! external subroutines external fft,realtr ! ! compute the Fourier coefficients ! nfft2 = (nfft-2) / 2 isn = 2 call fft (yfft(1), yfft(2), nfft2, nfft2, nfft2, isn) call realtr (yfft(1), yfft(2), nfft2, isn) fac = 0.5e0 / (cnst * real ( nfft - 2 ) ) nf = nfft2 + 1 do i = 1, nf per(i) = (yfft(2*i-1)*yfft(2*i-1) + yfft(2*i)*yfft(2*i)) * fac end do return end subroutine pgm ( yfft, n, lyfft, ldstak ) !*****************************************************************************80 ! !! PGM is the user callable routine for the raw periodogram of a series. ! ! Discussion: ! ! This is the short call version. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ldstak,lyfft,n ! ! array arguments real & yfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) integer & freq,iextnd,ldsmin,nall0,nf,nfft,nprt,yaxis logical & err01,err02,err03,head ! ! local arrays real & rstak(12) character & llds(8)*1,llyfft(8)*1,ln(8)*1,nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external eisge,ldscmp,pgmmn,setesl,stkclr,stkset ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! logical err01, err02, err03 ! value(s) indicating whether an error was detected (true) or not ! (false). ! integer freq ! the starting location in the stack for ! the array in which the frequencies corresponding to the ! integrated spectrum values are stored. ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer iextnd ! the indicator variable used to designate whether zero ! (iextnd == 0) or the series mean (iextnd /= 0) is to be ! used to extend the series. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer ldsmin ! the minimum length allowed for dstak. ! character*1 llds(8), llyfft(8), ln(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations. ! integer nall0 ! the number of outstanding allocations of the stack at the ! time of this call. ! integer nf ! the number of frequencies at which the periodgram is ! to be computed. ! integer nfft ! the effective length of the series to be transformed. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! the variable controling printed output, where ! if nprt <= -2, the output consists of a page plot of the ! periodogram on a log-linear scale, ! if nprt == -1, the output consists of a page plot of the ! periodogram in decibels on a linear scale, ! if nprt == 0, the output is suppressed, ! if nprt == 1, the output consists of a vertical plot of the ! periodogram in decibels on a linear scale. ! if nprt >= 2, the output consists of a vertical plot of the ! periodogram on a log-linear scale, ! real rstak(12) ! the real version of the /cstak/ work area. ! integer yaxis ! the starting location in the stack for ! the array in which the y axis values to be plotted are stored. ! real yfft(lyfft) ! the array containing the observed time series. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'g', 'm', ' ', ' ', ' '/ data & llds(1), llds(2), llds(3), llds(4), llds(5), & llds(6), llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data & llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) & /'l','y','f','f','t',' ',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) if (err01) then ierr = 1 write ( *, 1000) return end if ! ! set length of extended series ! call setesl(n, 2, nfft) call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err02, llyfft) call ldscmp(2, 0, 0, 0, 0, 0, 's', nfft, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 2, head, err03, llds) if (err01 .or. err02 .or. err03) then ierr = 1 write ( *, 1000) return end if ! ! set the size of the work area ! call stkset(ldstak, 4) ! ! set the number of outstanding allocations. ! nall0 = stkst(1) nprt = -1 iextnd = 0 ! ! subdivide the work array ! yaxis = stkget(nfft/2, 3) freq = stkget(nfft/2, 3) call pgmmn (yfft, n, nfft, iextnd, nf, yfft, lyfft, rstak(yaxis), & rstak(freq), nfft/2, nprt, nmsub) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call pgm (yfft, n, lyfft, ldstak)') end subroutine pgmmn ( yfft, n, nfft, iextnd, nf, per, lper, yaxis, & freq, lfreq, nprt, nmsub ) !*****************************************************************************80 ! !! PGMMN is the main routine for computing the raw periodogram. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iextnd,lfreq,lper,n,nf,nfft,nprt ! ! array arguments real & freq(lfreq),per(lper),yaxis(lfreq),yfft(nfft) character & nmsub(6)*1 real & yextnd integer n1 ! ! external subroutines external amean,pgmest,pgord,pgout,setfrq ! ! variable definitions (alphabetically) ! ! real freq(lfreq) ! the array in which the frequencies corresponding to the ! integrated spectrum values are stored. ! integer i ! an index variable. ! integer iextnd ! the indicator variable used to designate whether zero ! (iextnd == 0) or the series mean (iextnd /= 0) is to be ! used to extend the series. ! integer lfreq ! the length of the array freq. ! integer lper ! the length of the array per. ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the periodgram is ! to be computed. ! integer nfft ! the effective length of the series to be transformed. ! character*1 nmsub(6) ! the name of the calling subroutine ! integer nprt ! the variable controling printed output, where ! if nprt <= -2, the output consists of a page plot of the ! periodogram on a log-linear scale, ! if nprt == -1, the output consists of a page plot of the ! periodogram in decibels on a linear scale, ! if nprt == 0, the output is suppressed, ! if nprt == 1, the output consists of a vertical plot of the ! periodogram in decibels on a linear scale. ! if nprt >= 2, the output consists of a vertical plot of the ! periodogram on a log-linear scale, ! real per(lper) ! the array in which the periodogram is stored. ! real yaxis(lfreq) ! the array in which the y axis values to be plotted are stored. ! real yextnd ! the value used to extend the series. ! real yfft(nfft) ! the array containing the observed time series. ! yextnd = 0.0e0 if (iextnd /= 0) call amean (yfft, n, yextnd) ! ! extend the periodogram array by its mean or zero to the ! extended length nfft. ! n1 = n + 1 yfft(n1:nfft) = yextnd ! ! compute the periodogram. ! call pgmest (yfft, nfft, nf, 1.0e0, per, lper) ! ! set frequencies for periodogram values ! call setfrq (freq, nf, 1, 0.0e0, 0.5e0, 1.0e0) if (nprt == 0) return ! ! set y coordinates for periodogram plot. ! call pgord (per, nf, yaxis, nprt) ! ! plot periodogram if output not suppressed ! call pgout (yaxis, freq, nf, nprt, nmsub) return end subroutine pgms ( yfft, n, nfft, lyfft, iextnd, nf, per, lper, & freq, lfreq, nprt ) !*****************************************************************************80 ! !! PGMS computes the (raw) periodogram of a series (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & iextnd,lfreq,lper,lyfft,n,nf,nfft,nprt ! ! array arguments real & freq(*),per(*),yfft(*) ! ! scalars in common integer & ierr integer & nfft2 logical & err01,err02,err03,err04,err05,head ! ! local arrays character & llfreq(8)*1,llper(8)*1,llyfft(8)*1,ln(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,pgmmn ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01, err02, err03, err04, err05 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real freq(lfreq) ! the array in which the frequencies corresponding to the ! integrated spectrum values are stored. ! logical head ! a variable used to indicate whether a heading is needed for ! error messages (true) or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer iextnd ! the indicator variable used to designate whether zero ! (iextnd == 0) or the series mean (iextnd /= 0) is to be ! used to extend the series. ! integer lfreq ! the length of the array freq. ! character*1 llfreq(8), llper(8), llyfft(8), ln(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer lper ! the length of the array per. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations. ! integer nf ! the number of frequencies at which the periodgram is ! to be computed. ! integer nfft ! the effective length of the series to be transformed. ! integer nfft2 ! the effective series length actually used. ! integer nprt ! the variable controling printed output, where ! if nprt <= -2, the output consists of a page plot of the ! periodogram on a log-linear scale, ! if nprt == -1, the output consists of a page plot of the ! periodogram in decibels on a linear scale, ! if nprt == 0, the output is suppressed, ! if nprt == 1, the output consists of a vertical plot of the ! periodogram in decibels on a linear scale. ! if nprt >= 2, the output consists of a vertical plot of the ! periodogram on a log-linear scale, ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! real per(lper) ! the array in which the periodogram is stored. ! real yfft(lyfft) ! the array containing the observed time series. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'g', 'm', 's', ' ', ' '/ data & llfreq(1), llfreq(2), llfreq(3), llfreq(4), llfreq(5), & llfreq(6), llfreq(7), llfreq(8) & /'l','f','r','e','q',' ',' ',' '/ data & llper(1), llper(2), llper(3), llper(4), llper(5), & llper(6), llper(7), llper(8) /'l','p','e','r',' ',' ',' ',' '/ data & llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) & /'l','y','f','f','t',' ',' ',' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge ( nmsub, ln, n, 17, 1, head, err01, ln ) if ( err01 ) then ierr = 1 write ( *, 1000) return end if call enfft ( nmsub, nfft, 2, n, lyfft, nfft2, head, err02 ) nf = nfft2 / 2 call eisge(nmsub, llyfft, lyfft, nfft2, 9, head, err03, llyfft) call eisge(nmsub, llper, lper, nf, 9, head, err04, llper) call eisge(nmsub, llfreq, lfreq, nf, 9, head, err05, llfreq) if (err02 .or. err03 .or. err04 .or. err05) then ierr = 1 write ( *, 1000) return end if call pgmmn (yfft, n, nfft2, iextnd, nf, per, lper, yfft, freq, & lfreq, nprt, nmsub) return 1000 format (/' the correct form of the call statement is'// & ' call pgms (yfft, n, nfft, lyfft,'/ & ' + iextnd, nf, per, lper, freq, lfreq, nprt)') end subroutine pgord ( per, npts, yaxis, nprt ) !*****************************************************************************80 ! !! PGORD produces coordinates for the periodogram plot. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & nprt,npts ! ! array arguments real & per(npts),yaxis(npts) ! ! real & fplm integer & i ! ! variable definitions (alphabetically) ! ! real fplm ! the floating point largest magnitude. ! integer i ! an index variable ! integer nprt ! the variable controling printed output, where ! if nprt <= -2, the output consists of a page plot of the ! periodogram on a log-linear scale, ! if nprt == -1, the output consists of a page plot of the ! periodogram in decibels on a linear scale, ! if nprt == 0, the output is suppressed, ! if nprt == 1, the output consists of a vertical plot of the ! periodogram in decibels on a linear scale. ! if nprt >= 2, the output consists of a vertical plot of the ! periodogram on a log-linear scale, ! integer npts ! the number of frequencies for which the spectral estimates ! are estimated. ! real per(npts) ! the array containing the periodogram values. ! real yaxis(npts) ! the y coordinates for the periodogram plots. ! fplm = huge ( fplm ) ! ! the first value should be zero, so no attempt is made to plot it. ! yaxis(1) = fplm do i = 2, npts yaxis(i) = fplm if ( 0.0 < per(i) ) then yaxis(i) = per(i) if (iabs(nprt) == 1) yaxis(i) = 10.0e0*log10(yaxis(i)) end if end do return end subroutine pgout ( yaxis, xaxis, npts, nprt, nmsub ) !*****************************************************************************80 ! !! PGOUT produces the periodogram plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer nprt integer npts ! ! array arguments real & xaxis(npts),yaxis(npts) character & nmsub(6)*1 real & fplm,xmiss,xmn,xmx,ymn,ymx integer & ilog logical & error ! ! local arrays real & ymiss(1) integer & isym(1) ! ! variable definitions (alphabetically) ! ! logical error ! an error flag ! real fplm ! the floating point largest magnitude. ! integer isym(1) ! a dummy array for the page plots. ! character*1 nmsub(6) ! the name of the calling subroutine. ! integer nprt ! the variable controling printed output, where ! if nprt <= -2, the output consists of a page plot of the ! periodogram on a log-linear scale, ! if nprt == -1, the output consists of a page plot of the ! periodogram in decibels on a linear scale, ! if nprt == 0, the output is suppressed, ! if nprt >= 1, the output consists of a vertical plot of the ! periodogram in decibels on a linear scale. ! integer npts ! the number of x, y coordinates to be plotted. ! real xaxis(npts) ! the x coordinates for the page plots. ! real xmiss ! the value used to specify if the periodogram value was ! less than or equal to zero. ! real xmn, xmx ! ... ! real yaxis(npts) ! the y coordinates for the spectral plots. ! real ymiss(1) ! the value used to specify if an periodogram value was ! less than or equal to zero. ! real ymn, ymx ! fplm = huge ( fplm ) xmiss = fplm ymiss(1) = fplm ! ! set output width. ! call versp(.true.) if (iabs(nprt) == 1) then write ( *, 1010) else write ( *, 1000) end if if (abs(nprt) == 1) then ilog = 0 else ilog = 1 end if ! ! Plot vertical plots ! if (nprt >= 1) then call vplmt(yaxis, ymiss, npts, 1, npts, 0.0e0, 0.0e0, ymn, ymx, & error, nmsub, .true., 1) if (.not.error) & call vpmn ( yaxis(2), ymiss, npts-1, 1, npts, 1, 0, isym, 1, 0, & ymn, ymx, 0.5e0/real(npts-1), 0.5e0 / real ( npts-1 ), & .true., ilog, -1, 0) else ! ! Plot page plots ! call pplmt(yaxis, ymiss, xaxis, xmiss, npts, 1, npts, & 0.0e0, 0.0e0, ymn, ymx, 0.0e0, 0.5e0, xmn, xmx, & error, nmsub, .true.) if (.not.error) then call ppmn (yaxis, ymiss, xaxis, xmiss, npts, 1, npts, 0, & isym, 1, 0, -1, ymn, ymx, xmn, xmx, .true., ilog) write ( *, 1030) end if end if return 1000 format (' sample periodogram') 1010 format (' sample periodogram (in decibels)') 1030 format ('+freq'/ & ' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, '6.6667', 4x, & '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, '2.5', 7x, & '2.2222', 4x, '2.') end subroutine pline ( imin, imax, isymbl, line ) !*****************************************************************************80 ! !! PLINE defines one line of a plot string for the vertical plot routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer imax ! the largest location in the plot string being defined. ! integer imin ! the smallest location in the plot string being defined. ! character*1 isymbl ! the plotting symbol being used. ! character*1 line(103) ! the vector used for the plot string. ! implicit none integer & imax,imin character & isymbl*1 ! ! array arguments character & line(103)*1 line(imin:imax) = isymbl return end subroutine pltchk ( ym, ymmiss, x, xmiss, n, m, iym, multi, & ilog, ylb, yub, xlb, xub, nmsub, miss, xcheck ) !*****************************************************************************80 ! !! PLTCHK checks for errors for the multiple plot routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xlb,xmiss,xub,ylb,yub integer & ilog,iym,m,n logical & miss,multi,xcheck ! ! array arguments real & x(*),ym(*),ymmiss(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & nv logical & err01,err02,err03,err04,err05,err06,err07,err08,err09,head ! ! local arrays integer & ilogxy(2) character & liym(8)*1,lm(8)*1,ln(8)*1,lone(8)*1,lx(8)*1,lxlb(8)*1, & lxub(8)*1,ly(8)*1,lylb(8)*1,lym(8)*1,lyub(8)*1 ! ! external subroutines external eisge,eragt,eragtm,ersgt,ervgt,ervgtm,prtcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01, err02, err03, err04, err05, err06, err07, err08, ! 1 err09 ! values indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the common variable used as an error flag ! if = 0 then no erorrs ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ilogxy(2) ! ... ! integer iym ! actual row dimension of ym declared in users main program ! character*1 liym(8), lm(8), ln(8), lone(8), lx(8), lxlb(8), ! * lxub(8), ly(8), lylb(8), lym(8), lyub(8) ! the array(s) containing the name(s) of the input parameters(s) ! checked for errors. ! integer m ! the number of vectors in ym ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! an indicator variable used to designate whether the calling ! routine has an m prefix (true) or not (false). ! integer n ! the length of the vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nv ! the number of violations found in the x and y axis arrays. ! real x(n) ! vector of observations for x coordinates ! logical xcheck ! indicator variable used to designate whether x-axis values ! are to be checked (xcheck = .true.) or not (xcheck = .false.) ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! multivariate observations for the y (vertical) coordinates. ! real ymmiss(m) ! the missing value code for each column of ym. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & liym(1), liym(2), liym(3), liym(4), liym(5), liym(6) & / 'i', 'y', 'm', ' ', ' ', ' '/ data liym(7), liym(8) & / ' ', ' '/ data & lm(1), lm(2), lm(3), lm(4), lm(5), lm(6) & / 'm', ' ', ' ', ' ', ' ', ' '/ data lm(7), lm(8) & / ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6) & / 'n', ' ', ' ', ' ', ' ', ' '/ data ln(7), ln(8) & / ' ', ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), & lone(7), lone(8)/'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ data & lx(1), lx(2), lx(3), lx(4), lx(5), lx(6) & / 'x', ' ', ' ', ' ', ' ', ' '/ data lx(7), lx(8) & / ' ', ' '/ data & lxlb(1), lxlb(2), lxlb(3), lxlb(4), lxlb(5), lxlb(6) & / 'x', 'l', 'b', ' ', ' ', ' '/ data lxlb(7), lxlb(8) & / ' ', ' '/ data & lxub(1), lxub(2), lxub(3), lxub(4), lxub(5), lxub(6) & / 'x', 'u', 'b', ' ', ' ', ' '/ data lxub(7), lxub(8) & / ' ', ' '/ data & ly(1), ly(2), ly(3), ly(4), ly(5), ly(6) & / 'y', ' ', ' ', ' ', ' ', ' '/ data ly(7), ly(8) & / ' ', ' '/ data & lylb(1), lylb(2), lylb(3), lylb(4), lylb(5), lylb(6) & / 'y', 'l', 'b', ' ', ' ', ' '/ data lylb(7), lylb(8) & / ' ', ' '/ data & lym(1), lym(2), lym(3), lym(4), lym(5), lym(6) & / 'y', 'm', ' ', ' ', ' ', ' '/ data lym(7), lym(8) & / ' ', ' '/ data & lyub(1), lyub(2), lyub(3), lyub(4), lyub(5), lyub(6) & / 'y', 'u', 'b', ' ', ' ', ' '/ data lyub(7), lyub(8) & / ' ', ' '/ ierr = 0 head = .true. ! ! number of points must be at least 1 ! call eisge(nmsub, ln, n, 1, 2, head, err01, lone) ! ! there must be at least 1 column of vectors ! call eisge(nmsub, lm, m, 1, 2, head, err02, lone) ! ! the actual length of ym must equal or exceed the number of ! observations ! err03 = .true. if (.not.err01) & call eisge(nmsub, liym, iym, n, 3, head, err03, ln) ! ! if this is a log plot check for non-positive values in data ! if (err01 .or. err02 .or. err03) ierr = 1 if (ilog <= 0) return err04 = .false. err05 = .false. err06 = .false. err07 = .false. err08 = .false. err09 = .false. call prtcnt (max(0,ilog),2,ilogxy) if ((ilogxy(1) /= 0) .and. xcheck) then if (.not.err01) then ! ! if x axis is log scale, check for negative x axis values ! if (miss) then call ervgtm(nmsub, lx, x, xmiss, n, 0.0e0, 0, head, 1, & nv, err04, lx) else call ervgt(nmsub, lx, x, n, 0.0e0, 0, head, 1, nv, err04, & lx) end if end if if (xlb iend) ipoint = iend return end subroutine pltsym ( iptsym, i, j, isym, n, ipoint, line, icount ) !*****************************************************************************80 ! !! PLTSYM supplies the plot symbol for the plot line. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an indexing variable. ! integer icount(103) ! the number of plot symbols at each location. ! integer ipoint ! the location in the plot string of the value being plotted. ! integer iptsym ! an indicator variable used to designate the type ! of plot. if iptsym = 1, the plot is a symple page ! or vertical plot. if iptsym = 2, the plot is a symbol ! plot. if iptsym = 3, the plot is a multivariate plot. ! integer isym(n) ! vector containing symbol designations for plotting ! integer isymbl ! the index of the plot symbol to be used. ! integer j ! an index variable. ! character*1 line(103) ! the vector used for the plot string. ! integer n ! the number of observations. ! character*1 sym(30), sym1(10) ! the plot symbols. ! implicit none integer & i,ipoint,iptsym,j,n ! ! array arguments integer & icount(103),isym(n) character & line(103)*1 ! ! integer & isymbl ! ! local arrays character & sym(30)*1,sym1(10)*1 data sym( 1)/'+'/,sym( 2)/'.'/,sym( 3)/'*'/,sym( 4)/'-'/, & sym( 5)/'a'/,sym( 6)/'b'/,sym( 7)/'c'/,sym( 8)/'d'/, & sym( 9)/'e'/,sym(10)/'f'/,sym(11)/'g'/,sym(12)/'h'/, & sym(13)/'i'/,sym(14)/'j'/,sym(15)/'k'/,sym(16)/'l'/, & sym(17)/'m'/,sym(18)/'n'/,sym(19)/'o'/,sym(20)/'p'/, & sym(21)/'q'/,sym(22)/'r'/,sym(23)/'s'/,sym(24)/'t'/, & sym(25)/'u'/,sym(26)/'v'/,sym(27)/'w'/,sym(28)/'y'/, & sym(29)/'z'/,sym(30)/'z'/ data sym1(1)/'1'/,sym1(2)/'2'/,sym1(3)/'3'/,sym1(4)/'4'/, & sym1(5)/'5'/,sym1(6)/'6'/,sym1(7)/'7'/,sym1(8)/'8'/, & sym1(9)/'9'/,sym1(10)/'x'/ icount(ipoint) = icount(ipoint) + 1 if ( icount(ipoint) /= 1 ) then isymbl = min(icount(ipoint), 10) line(ipoint) = sym1(isymbl) return end if if ( iptsym == 1 ) then line(ipoint) = sym(1) else if ( iptsym == 2 ) then isymbl = min(29, max(1, isym(i))) line(ipoint) = sym(isymbl) else if ( iptsym == 3 ) then isymbl = min(29, max(1, j+4)) line(ipoint) = sym(isymbl) end if return end subroutine polar ( ampl, phas, n ) !*****************************************************************************80 ! !! POLAR converts complex numbers from Cartesian to polar representation. ! ! Discussion: ! ! This routine converts the pair of series ampl and phas ! from the real and imaginary parts of a series of complex ! numbers to their magnitudes and phases. the conversion is ! done in place. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! ! Parameters: ! ! real ampl(n) ! the array in which the amplitudes are stored. ! integer i ! an index variable. ! integer n ! the number of observations. ! real phas(n) ! the array in which the primary phase estimates are returned. ! real phase ! the phase component of the demodulated series. ! real r ! the amplitude component of the demodulated series. ! implicit none integer & n ! ! array arguments real & ampl(n),phas(n) ! ! real & phase,r integer & i do i = 1, n r = sqrt(ampl(i)*ampl(i) + phas(i)*phas(i)) phase = 0.0e0 if (r /= 0.0e0) phase = atan2(phas(i), ampl(i)) ampl(i) = r phas(i) = phase end do return end subroutine ppc ( ym, x, n, ilog, isize, nout, ylb, yub, xlb, xub ) !*****************************************************************************80 ! !! PPC produces a simple page plot (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xlb,xub,ylb,yub integer & ilog,isize,n,nout ! ! array arguments real & x(*),ym(*) ! ! scalars in common integer & ierr ! ! real & xmiss integer & ischck,iym,lisym,m logical & miss,multi ! ! local arrays real & ymmiss(1) integer & isym(1) character & nmsub(6)*1 ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'p', 'c', ' ', ' ', ' '/ ymmiss(1) = 1.0e0 xmiss = 1.0e0 m = 1 iym = n multi = .false. ischck = 0 miss = .false. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ppc (y, x, n, ilog,'/ & ' + isize, nout, ylb, yub, xlb, xub)') end subroutine ppcnt ( ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym ) !*****************************************************************************80 ! !! PPCNT is the controling routine for user called page plot routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xlb,xmiss,xub,ylb,yub integer & ilog,ischck,isize,iym,lisym,m,n,nout logical & miss,multi ! ! array arguments real & x(*),ym(*),ymmiss(*) integer & isym(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! real & xmn,xmx,ymn,ymx logical & error,xcheck ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical error ! a value indicating whether an error was detectec (true) ! or not (false). ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(lisym) ! vector containing symbols for plotting, not used in some cases ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! logical xcheck ! indicator variable used to designate whether x-axis values ! are to be checked (xcheck = .true.) or not (xcheck = .false.) ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xmn, xmx ! the x-axis lower and upper limits actually used. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! vector of observations for the y (vertical) coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real ymn, ymx ! the y-ayis lower and upper limits actually used. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! xcheck = .true. call pltchk (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, miss, xcheck) if (ierr == 0) then ! ! determine the bounds for the x and y axis and complete error ! checking ! call pplmt (ym, ymmiss, x, xmiss, n, m, iym, ylb, yub, ymn, ymx, & xlb, xub, xmn, xmx, error, nmsub, miss) if (error) then ierr = 1 else ! ! Print plot ! if (isize <= 9) then call versp(.true.) else call versp(.false.) end if call ppmn (ym, ymmiss, x, xmiss, n, m, iym, ischck, isym, & lisym, isize, nout, ymn, ymx, xmn, xmx, miss, ilog) end if end if return end subroutine pp ( ym, x, n ) !*****************************************************************************80 ! !! PP: user callable routine which produces a simple page plot (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n ! ! array arguments real & x(*),ym(*) ! ! scalars in common integer & ierr ! ! real & xlb,xmiss,xub,ylb,yub integer & ilog,ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays real & ymmiss(1) integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'p', ' ', ' ', ' ', ' '/ ymmiss(1) = 1.0e0 xmiss = 1.0e0 m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 0 isize = -1 nout = 0 miss = .false. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call pp (y, x, n)') end function ppfchs ( p, nu ) !*****************************************************************************80 ! !! PPCHFS computes the percentage points of the Chi Square distribution. ! ! Discussion: ! ! This function is a version of datapac subroutine chsppf, with ! modifications to facilitate conversion to double precision ! automatically using the nag, inc., code apt, and to correspond ! to starpac conventions. ! ! This routine computes the percent point ! function value for the chi-squared distribution ! with integer degrees of freedom parameter = nu. ! the chi-squared distribution used ! herein is defined for all non-negative x, ! and its probability density function is given ! in references 2, 3, and 4 below. ! note that the percent point function of a distribution ! is identically the same as the inverse cumulative ! distribution function of the distribution. ! ! Author: ! ! James Filliben, ! Statistical Engineering Laboratory, ! National Bureau of Standards, ! Washington, DC 20234. ! ! Reference: ! ! Formula 6.1.41, ! Milton Abramowitz, Irene Stegun,
! Handbook of Mathematical Functions,
! National Bureau of Standards, 1964,
! LC: QA47.A34,
! ISBN: 0-486-61272-4. ! ! Johnson, Kotz, ! Continuous Univariate Distributions, ! 1970, pages 166-206. ! ! Wilk, Gnanadesikan, Huyett, ! Probability Plots for the Gamma Distribution", ! Technometrics, 1962 !. ! Hastings, Peacock, ! Statistical Distributions, ! A Handbook for Students and Practitioners, ! 1975, pages 46-51. ! ! input arguments--p = the single precision value ! (between 0.0e0 (inclusively) ! and 1.0e0 (exclusively)) ! at which the percent point ! function is to be evaluated. ! --nu = the integer number of degrees ! of freedom. ! nu should be positive. ! output arguments--ppfchs = the single precision percent ! point function value. ! ! restrictions--nu should be a positive integer variable. ! --p should be between 0.0e0 (inclusively) ! and 1.0e0 (exclusively). ! ! accuracy--(on the univac 1108, exec 8 system at nbs) ! compared to the known nu = 2 (exponential) ! results, agreement was had out to 6 significant ! digits for all tested p in the range p = .001 to ! p = .999. for p = .95 and smaller, the agreement ! was even better--7 significant digits. ! (note that the tabulated values given in the wilk, ! gnanadesikan, and huyett reference below, page 20, ! are in error for at least the gamma = 1 case-- ! the worst detected error was agreement to only 3 ! significant digits (in their 8 significant digit table) ! for p = .999.) implicit none integer nu real p real ppfchs real & a,aj,b,c,cut1,cut2,cutoff,den,dx,fp,gamm, & pcalc,sum,term,xdel,xlower,xmax,xmid,xmin,xmin0,xupper, & z,z2,z3,z4,z5 integer & icount,iloop,j,maxit ! ! local arrays real & d(10) data c/0.918938533204672741e0/ data d(3),d(4),d(5) & /+0.793650793650793651e-3, & -0.595238095238095238e-3, & +0.8417508417508417151e-3/ data d(6),d(7),d(8),d(9),d(10) & /-0.191752691752691753e-2, & +0.641025641025641025e-2, & -0.2955065359147712418e-1, & +0.179644372368830573e0, & -0.139243221690590111e1/ d(1) = 1.0e0/12.0e0 d(2) = 1.0e0/360.0e0 if ( p < 0.0E+00 .or. 1.0E+00 <= p ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPFCHS - Fatal error!' write ( *, '(a)' ) ' The first input argument P is outside' write ( *, '(a)' ) ' the allowable (0,1) interval.' write ( *, '(a,g14.6)' ) ' P = ', p ppfchs = 0.0e0 return end if if(nu<1) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPFCHS - Fatal error!' write ( *, '(a)' ) ' The second input argument NU is not positive.' write ( *, '(a,i8)' ) ' NU = ', nu ppfchs = 0.0e0 return end if ! ! Express the chi-squared distribution percent point ! function in terms of the equivalent gamma ! distribution percent point function, ! and then evaluate the latter. ! fp = p gamm = real ( nu ) / 2.0e0 maxit = 10000 ! ! Compute the Gamma function using the algorithm in the ! NBS applied mathematics series reference. ! This Gamma function need be calculated only once. ! It is used in the calculation of the cdf based on ! the tentative value of the ppfchs in the iteration. ! z = gamm den = 1.0e0 do if ( 10.0 <= z ) then exit end if den = den * z z = z + 1.0e0 end do z2 = z*z z3 = z*z2 z4 = z2*z2 z5 = z2*z3 a = (z-0.5e0)*log(z)-z+c b = d(1)/z + d(2)/z3 + d(3)/z5 + d(4)/(z2*z5) + d(5)/(z4*z5) + & d(6)/(z*z5*z5) + d(7)/(z3*z5*z5) + d(8)/(z5*z5*z5) + & d(9)/(z2*z5*z5*z5) ! ! Determine lower and upper limits on the desired 100p percent point. ! iloop = 1 xmin0 = exp((1.0e0/gamm)*(log(fp)+log(gamm)+(a+b)-log(den))) xmin = xmin0 xlower = xmin xmid = xmin xupper = xmin icount = 1 350 continue xmax = real ( icount ) * xmin0 dx = xmax go to 600 360 if(pcalc fp) then xupper = xmid xmid = (xmid+xlower)/2.0e0 else xlower = xmid xmid = (xmid+xupper)/2.0e0 end if xdel = xmid-xlower if(xdel<0.0e0)xdel = -xdel icount = icount+1 if((xdel >= 0.0000000001e0) .and. (icount <= 100)) go to 550 end if ppfchs = 2.0e0*xmid return ! ! this section below is logically separate from the above. ! this section computes a cdf value for any given tentative ! percent point x value as defined in either of the 2 ! iteration loops in the above code. ! ! compute t-sub-q as defined on page 4 of the wilk, gnanadesikan, ! and huyett reference ! 600 continue sum = 1.0e0/gamm term = 1.0e0/gamm cut1 = dx-gamm cut2 = dx*10000000000.0e0 do j=1,maxit aj = real ( j ) term = dx*term/(gamm+aj) sum = sum+term cutoff = cut1+(cut2*term/sum) if (aj > cutoff) go to 750 end do write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'PPFCHS - Fatal error!' write ( *, '(a)' ) ' The iteration did not converge.' write ( *, '(a,i8)' ) ' Iteration limit is MAXIT = ', maxit write ( *, '(a,g14.6)' ) ' P = ', p write ( *, '(a,i8)' ) ' NU = ', nu write ( *, '(a)' ) ' PPFCHS has been set to zero.' ppfchs = 0.0e0 return 750 continue pcalc = exp(gamm*log(dx) + log(sum) + log(den) - dx - a - b) if (iloop == 1) go to 360 go to 560 end function ppff ( p, nu1, nu2 ) !*****************************************************************************80 ! !! PPFF computes the percentage points for the F distribution. ! ! Discussion: ! ! This function is a version of dataplot subroutine fppf, ! with modifications necessary to correspond to starpac conventions. ! ! this subroutine computes the percent point for the f distribution ! with integer degrees of freedom parameters = nu1 and nu2. ! ! this distribution is defined for all non-negative x. ! the probability density function is given in the reference. ! ! Author: ! ! James Filliben, ! Statistical Engineering Laboratory, ! National Bureau of Standards, ! Washington, DC 20234. ! ! input arguments--p = the single precision value ! (between 0.0e0 and 1.0e0) ! at which the percent point ! function is to be evaluated. ! --nu1 = the integer degrees of freedom ! for the numerator of the f ratio. ! nu1 should be positive. ! --nu2 = the integer degrees of freedom ! for the denominator of the f ratio. ! nu2 should be positive. ! output arguments--ppff = the single precision percent point ! function value. ! output--the single precision percent point ! function value ppff for the f distribution ! with degrees of freedom ! parameters = nu1 and nu2. ! ! restrictions--p should be between ! 0.0e0 (inclusively) and 1.0e0 (exclusively). ! --nu1 should be a positive integer variable. ! --nu2 should be a positive integer variable. ! ! Reference: ! ! national bureau of standards applied mathematics ! series 55, 1964, pages 946-947, ! formulae 26.6.4, 26.6.5, 26.6.8, and 26.6.15. ! ! johnson and kotz, ! continuous univariate distributions--2, ! 1970, page 83, formula 20, and page 84, third formula. ! ! paulson, ! an approximate normailization of the analysis of variance distribution, ! annals of mathematical statistics, 1942, ! number 13, pages 233-135. ! ! scheffe, tukey, ! a formula for sample sizes for population tolerance limits, ! 1944, number 15, page 217. ! implicit none real p real ppff integer & nu1,nu2 ! ! real & anu1,anu2,expf,pcalc,sdf,tol,x,xdel,xlow,xmax, & xmid,xmin,xn,xup,zn integer & ibug,icount,maxit ! ! external functions real & cdff,ppfnml external cdff,ppfnml ! ! variable definitions (alphabetically) ! ! real anu1 ! the (real) degrees of freedom in the numerator. ! real anu2 ! the (real) degrees of freedom in the denominator. ! integer nu1 ! the degrees of freedom in the numerator. ! integer nu2 ! the degrees of freedom in the denominator. ! real p ! the value (between 0.0e0 and 1.0e0) at which the percent point ! is to be calculated. ! ppff = 0.0e0 if ( nu1 <= 0 ) then write ( *,1010) write ( *,1040) nu1 ppff = 0.0e0 return end if if (nu2 <= 0) then write ( *,1020) write ( *,1040) nu2 ppff = 0.0e0 return end if if ( p < 0.0e0 .or. p >= 1.0e0) then write ( *,1000) write ( *,1030) p ppff = 0.0e0 return end if ibug = 0.0e0 tol = 0.000001e0 maxit = 100 xmin = 0.0e0 xmax = 10.0e30 xlow = xmin xup = xmax anu1 = real ( nu1 ) anu2 = real ( nu2 ) expf = 0.5e0*((1.0e0/anu2)-(1.0e0/anu1)) sdf = sqrt(0.5e0*((1.0e0/anu2)+(1.0e0/anu1))) zn = ppfnml(p) xn = expf + zn*sdf xmid = exp(2.0e0*xn) if (ibug == 1) write ( *,1050) xmid if (p == 0.0e0) then ppff = xmin return end if icount = 0 70 continue x = xmid pcalc = cdff(x,anu1,anu2) if (pcalc == p) go to 130 if (pcalc > p) go to 100 80 continue xlow = xmid x = xmid*2.0e0 if (x >= xup) go to 90 xmid = x if (ibug == 1) write ( *,1050) xmid pcalc = cdff(x,anu1,anu2) if (pcalc == p) go to 130 if (pcalc p) go to 100 xlow = x 110 continue xmid = (xlow+xup)/2.0e0 if (ibug == 1) write ( *,1050) xmid 120 continue xdel = abs(xmid-xlow) icount = icount + 1 if (xdel maxit) go to 130 go to 70 130 continue ppff = xmid return 1000 format (' ***** fatal error--the first input argument to t', & 'he fppf subroutine is outside the allowable (0,1) interval ', & '*****') 1010 format (' ***** fatal error--the second input argument to t', & 'he fppf subroutine is non-positive *****') 1020 format (' ***** fatal error--the third input argument to t', & 'he fcdf subroutine is non-positive *****') 1030 format (' ***** the value of the argument is ', e15.8, & ' *****') 1040 format (' ***** the value of the argument is ', i8, ' *****') 1050 format (' ', 'xmid = ', e15.7) end function ppfnml ( p ) !*****************************************************************************80 ! !! PPFNML computes the percentage points of the normal distribution. ! ! Discussion: ! ! this subroutine computes the percent point function value for the ! normal (gaussian) distribution with mean = 0 and standard deviation = 1. ! ! this distribution is defined for all x and has the probability density ! function ! ! f(x) = (1/sqrt(2*pi))*exp(-x*x/2). ! ! note that the percent point function of a distribution ! is identically the same as the inverse cumulative ! distribution function of the distribution. ! ! Author: ! ! James Filliben, ! Statistical Engineering Laboratory, ! National Bureau of Standards, ! Washington, DC 20234. ! ! restrictions--p should be between 0.0e0 and 1.0e0, exclusively. ! ! Reference: ! ! odeh, evans, ! Algorithm 70: ! the percentage points of the normal distribution, ! applied statistics, 1974, pages 96-97. ! ! evans, ! algorithms for minimal degree polynomial and rational approximation, ! m. sc. thesis, 1972, ! university of victoria, b. c., canada. ! ! hastings, ! approximations for digital computers, 1955, pages 113, 191, 192. ! ! national bureau of standards applied mathematics ! series 55, 1964, page 933, formula 26.2.23. ! ! filliben, ! simple and robust linear estimation of the location parameter ! of a symmetric distribution ! pHD dissertation, ! princeton university, 1969, pages 21-44, 229-231. ! ! filliben, ! the percent point function, ! unpublished manuscript, 1970, pages 28-31. ! ! johnson and kotz, ! continuous univariate distributions--1, ! 1970, pages 40-111. ! ! the kelley statistical tables, 1948. ! ! owen, ! handbook of statistical tables, ! 1962, pages 3-16. ! ! pearson and hartley, ! biometrika tables for statisticians, ! volume 1, 1954, pages 104-113. ! ! comments--the coding as presented below ! is essentially identical to that ! presented by odeh and evans ! as algortihm 70 of applied statistics. ! the present author has modified the ! original odeh and evans code with only ! minor stylistic changes. ! --as pointed out by odeh and evans ! in applied statistics, ! their algorithm representes a ! substantial improvement over the ! previously employed ! hastings approximation for the ! normal percent point function-- ! the accuracy of approximation ! being improved from 4.5*(10**-4) ! to 1.5*(10**-8). ! implicit none real p real ppfnml ! ! real & aden,anum,p0,p1,p2,p3,p4,q0,q1,q2,q3,q4,r,t ! ! variable definitions (alphabetically) ! ! real p ! the probability at which the percent point is to be evaluated ! real p0, p1, p2, p3, p4 ! various parameters used in the approximations. ! real q0, q1, q2, q3, q4 ! various additional parameters used in the approximations. ! data p0, p1, p2, p3, p4 & /-.322232431088e0, -1.0e0, -.342242088547e0, & -.204231210245e-1,-.453642210148e-4/ data q0, q1, q2, q3, q4 & /.993484626060e-1, .588581570495e0, & .531103462366e0, .103537752850e0, .38560700634e-2/ if (p == 0.5e0) then ppfnml = 0.0e0 return end if r = p if (p > 0.5e0) r = 1.0e0 - r t = sqrt(-2.0e0*log(r)) anum = ((((t*p4+p3)*t+p2)*t+p1)*t+p0) aden = ((((t*q4+q3)*t+q2)*t+q1)*t+q0) ppfnml = t + (anum/aden) if (p<0.5e0) then ppfnml = -ppfnml end if return end function ppft ( p, idf ) !*****************************************************************************80 ! !! PPFT computes the percentage points of the Student's T distribution. ! ! Discussion: ! ! this subroutine computes the percent point function value for the ! student"s t distribution with integer degrees of freedom parameter = idf. ! ! the student"s t distribution used herein is defined for all x, ! and its probability density function is given in the reference. ! ! note that the percent point function of a distribution is identically ! the same as the inverse cumulative distribution function of the ! distribution. ! ! Author: ! ! James Filliben, ! Statistical Engineering Laboratory, ! National Bureau of Standards, ! Washington, DC 20234. ! ! Reference: ! ! Enrico Federghi, ! Extended Tables of the Percentage Points of Student's T-Distribution, ! Journal of the American Statistical Association, ! Volume 54, Number 287, 1959, pages 683-688. ! ! national bureau of standards applied mathmatics ! series 55, 1964, page 949, formula 26.7.5. ! ! johnson and kotz, ! continuous univariate distributions--2, 1970, ! page 102, formula 11. ! ! hastings and peacock, ! statistical distributions--a handbook for students and practitioners, ! 1975, pages 120-123. ! ! restrictions--idf should be a positive integer variable. ! --p should be between 0.0e0 (exclusively) ! and 1.0e0 (exclusively). ! comment--for idf = 1 and idf = 2, the percent point function ! for the t distribution exists in simple closed form ! and so the computed percent points are exact. ! --for other small values of idf (idf between 3 and 6, ! inclusively), the approximation ! of the t percent point by the formula ! given in the reference below is augmented ! by 3 iterations of newton"s method for ! root determination. ! this improves the accuracy--especially for ! values of p near 0 or 1. ! ! implicit none real p real ppft integer & idf real & arg,b21,b31,b32,b33,b34,b41,b42,b43,b44,b45, & b51,b52,b53,b54,b55,b56,c,con,d1,d3,d5,d7,d9,df,pi,ppfn, & s,sqrt2,term1,term2,term3,term4,term5,z integer & ipass,maxit ! ! external functions real & ppfnml external ppfnml ! ! external subroutines external getpi ! ! variable definitions (alphabetically) ! ! real df ! the degrees of freedom. ! integer idf ! the (integer) degrees of freedom. ! real p ! the probability at which the percent point is to be evaluated. ! real pi ! the value of pi. ! real ppfn ! the normal percent point value. ! real sqrt2 ! the square root of two. ! ! define constants used in the approximations ! data b21 /4.0e0/ data b31, b32, b33, b34 /96.0e0, 5.0e0, 16.0e0, 3.0e0/ data b41, b42, b43, b44, b45 & /384.0e0, 3.0e0, 19.0e0, 17.0e0, -15.0e0/ data b51, b52, b53, b54, b55, b56 & /9216.0e0, 79.0e0, 776.0e0, 1482.0e0, & -1920.0e0, -945.0e0/ call getpi(pi) sqrt2 = sqrt(2.0e0) df = real ( idf ) maxit = 5 if (idf >= 3) go to 50 if (idf == 1) go to 30 if (idf == 2) go to 40 ppft = 0.0e0 return ! ! treat the idf = 1 (cauchy) case ! 30 arg = pi*p ppft = -cos(arg)/sin(arg) return ! ! treat the idf = 2 case ! 40 term1 = sqrt2/2.0e0 term2 = 2.0e0*p - 1.0e0 term3 = sqrt(p*(1.0e0-p)) ppft = term1*term2/term3 return ! ! treat the idf greater than or equal to 3 case ! 50 ppfn = ppfnml(p) d1 = ppfn d3 = ppfn**3 d5 = ppfn**5 d7 = ppfn**7 d9 = ppfn**9 term1 = d1 term2 = (1.0e0/b21)*(d3+d1)/df term3 = (1.0e0/b31)*(b32*d5+b33*d3+b34*d1)/(df**2) term4 = (1.0e0/b41)*(b42*d7+b43*d5+b44*d3+b45*d1)/(df**3) term5 = (1.0e0/b51)*(b52*d9+b53*d7+b54*d5+b55*d3+b56*d1)/(df**4) ppft = term1 + term2 + term3 + term4 + term5 if (idf >= 7) return if (idf == 3) go to 60 if (idf == 4) go to 80 if (idf == 5) go to 100 if (idf == 6) go to 120 return ! ! augment the results for the idf = 3 case ! 60 con = pi*(p-0.5e0) arg = ppft/sqrt(df) z = atan(arg) do ipass = 1, maxit s = sin(z) c = cos(z) z = z - (z+s*c-con)/(2.0e0*c*c) end do ppft = sqrt(df)*s/c return ! ! augment the results for the idf = 4 case ! 80 con = 2.0e0*(p-0.5e0) arg = ppft/sqrt(df) z = atan(arg) do ipass=1,maxit s = sin(z) c = cos(z) z = z - ((1.0e0+0.5e0*c*c)*s-con)/(1.5e0*c*c*c) end do ppft = sqrt(df)*s/c return ! ! augment the results for the idf = 5 case ! 100 con = pi*(p-0.5e0) arg = ppft/sqrt(df) z = atan(arg) do ipass=1,maxit s = sin(z) c = cos(z) z = z - (z+(c+(2.0e0/3.0e0)*c*c*c)*s-con)/((8.0e0/3.0e0)*c**4) end do ppft = sqrt(df)*s/c return ! ! augment the results for the idf = 6 case ! 120 con = 2.0e0*(p-0.5e0) arg = ppft/sqrt(df) z = atan(arg) do ipass=1,maxit s = sin(z) c = cos(z) z = z - ((1.0e0+0.5e0*c*c+0.375e0*c**4)*s-con)/ & ((15.0e0/8.0e0)*c**5) end do ppft = sqrt ( df ) * s / c return end subroutine ppl ( ym, x, n, ilog ) !*****************************************************************************80 ! !! PPL produces a simple page plot (log option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ilog,n ! ! array arguments real & x(*),ym(*) ! ! scalars in common integer & ierr real & xlb,xmiss,xub,ylb,yub integer & ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays real & ymmiss(1) integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'p', 'l', ' ', ' ', ' '/ ymmiss(1) = 1.0e0 xmiss = 1.0e0 m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 0 isize = -1 nout = 0 miss = .false. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ppl (y, x, n, ilog)') end subroutine pplmt ( ym, ymmiss, x, xmiss, n, m, iym, ylb, yub, ymn, & ymx, xlb, xub, xmn, xmx, error, nmsub, miss ) !*****************************************************************************80 ! !! PPLMT sets the plot limits for page plots with missing values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real xlb real xmiss real xmn real xmx real xub real ylb real ymn real ymx real yub integer & iym,m,n logical & error,miss ! ! array arguments real & x(n),ym(iym,m),ymmiss(m) character & nmsub(6)*1 ! ! integer & i,ii,j logical & head,setlmt,skprow ! ! external functions logical & mvchk external mvchk ! ! external subroutines external adjlmt,ehdr ! ! variable definitions (alphabetically) ! ! logical error ! a value indicating whether an error was detected (true) ! or not (false). ! logical head ! print heading (head=true) or not (head=false). ! integer i, ii ! indexing variables. ! integer iym ! actual row dimension of ym declared in the users main program ! integer j ! an index variable. ! integer m ! the number of vectors in ym ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! integer n ! the integer number of observations . ! character*1 nmsub(6) ! the characters of the calling routines name. ! logical setlmt ! an indicator variable used to determine if starting values ! for xmn, xmx, ymn, ymx have been found. ! logical skprow ! an indicator variable used to designate whether all ! observations in a given row of ym are unused (true) ! or not (false). ! real x(n) ! the array containing the independent variable. ! real xlb ! the user supplied x-axis lower bound. ! real xmiss ! the user supplied code which is used to determine whether or ! not an observation is missing. ! if x(i) = xmiss, the value is assumed missing, otherwise ! it is not. ! real xmn, xmx ! the x-axis lower and upper limits actually used. ! real xub ! the user supplied x-axis upper bounds. ! real ylb ! the user supplied y-axis lower bound. ! real ym(iym,m) ! the array containing the dependent variable(s). ! real ymmiss(m) ! the user supplied code which is used to determine whether or ! not an observation is missing. ! if ym(i,j) = ymmiss(j), the value is assumed missing, otherwise ! it is not. ! real ymn, ymx ! the y-axis lower and upper limits actually used. ! real yub ! the user supplied y-axis upper bounds. ! error = .false. if ((xlb < xub) .and. (ylb < yub)) then ! ! set limits to user specified values ! xmn = xlb xmx = xub ymn = ylb ymx = yub else ! ! set limits to range of values within any user specified values ! setlmt = .false. ii = 1 xmn = huge ( xmn ) xmx = -huge ( xmx ) ymn = huge ( ymn ) ymx = -huge ( ymx ) ! ! find first value to be plotted ! do i=1,n if (miss .and. mvchk(x(i),xmiss)) then cycle end if if ((xlb= yub) .and. (xlb >= xub)) then write ( *, 1010) else write ( *, 1020) end if write ( *, 1030) else ! ! find limits from remaining values ! do i=ii,n if ( miss .and. mvchk(x(i),xmiss) ) then cycle end if if ((xlb= ymx) call adjlmt(ymn, ymx) end if if (xlb= xmx) call adjlmt(xmn, xmx) end if end if return 1010 format (/ ' no non-missing plot coordinates were found.') 1020 format (/ & ' no non-missing values were found within the user supplied limits.') 1030 format (/ 'the plot has been suppressed.') end subroutine ppmc ( ym, ymmiss, x, xmiss, n, ilog, isize, nout, ylb, & yub, xlb, xub ) !*****************************************************************************80 ! !! PPMC: simple page plot for data with missing observations (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xlb,xmiss,xub,ylb,yub integer & ilog,isize,n,nout ! ! array arguments real & x(*),ym(*),ymmiss(1) ! ! scalars in common integer & ierr ! ! integer & ischck,iym,lisym,m logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'p', 'm', 'c', ' ', ' '/ m = 1 iym = n multi = .false. ischck = 0 miss = .true. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ppmc (y, ymiss, x, xmiss, n, ilog,'/ & ' + isize, nout, ylb, yub, xlb, xub)') end subroutine ppm ( ym, ymmiss, x, xmiss, n ) !*****************************************************************************80 ! !! PPM: simple page plot for data with missing observations (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xmiss integer & n ! ! array arguments real & x(*),ym(*),ymmiss(1) ! ! scalars in common integer & ierr ! ! real & xlb,xub,ylb,yub integer & ilog,ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'p', 'm', ' ', ' ', ' '/ m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 0 isize = -1 nout = 0 miss = .true. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ppm (y, ymiss, x, xmiss, n)') end subroutine ppml ( ym, ymmiss, x, xmiss, n, ilog ) !*****************************************************************************80 ! !! PPML plots data with missing observations (log option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xmiss integer & ilog,n ! ! array arguments real & x(*),ym(*),ymmiss(1) ! ! scalars in common integer & ierr ! ! real & xlb,xub,ylb,yub integer & ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'p', 'p', 'm', 'l', ' ', ' '/ m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 0 isize = -1 nout = 0 miss = .true. lisym = 1 call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ppml (y, ymiss, x, xmiss, n, ilog)') end subroutine ppmn ( ym, ymmiss, x, xmiss, n, m, iym, ischck, isym, & lisym, isize, nout, ymn, ymx, xmn, xmx, miss, ilog ) !*****************************************************************************80 ! !! PPMN is the main routine for page plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! input arguments - (in order of usage) ! ! x the n vector of observations for the x ! coordinates ! y the n by m matrix of observations for the y (vertical) ! coordinates ! the ith column is plotted using the following symbol ! 1 = a 2 = b 3 = c 4 = d ! 5 = e 6 = f 7 = g 8 = h ! 9 = i 10 = j 11 = k 12 = l ! 13 = m 14 = n 15 = o 16 = p ! 17 = q 18 = r 19 = s 20 = t ! 21 = u 22 = v 23 = w 24 = y ! 25 (and above) = z ! the numbers 1 to 9 indicate multiple points on a given ! plot location, where the number indicates how many points ! are represented ! note that x is not used as a plotting symbol except to ! indicate that more than 9 points fell on the same plot ! location ! n the integer number of observations to be plotted (in each ! column) ! m the number of columns in the y array to be plotted versus x ! for the case of a vector y, m must be equal to 1 ! iym the actual integer value of the row dimension of the y array ! when y is a vector (m == 1) iym should be set equal to n ! ischck the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! isym the n vector of integers determining the plotting symbols to ! used for the s series of plots, where ! 1 = + 2 = . 3 = * 4 = - ! 5 = a 6 = b 7 = c 8 = d ! 9 = e 10 = f 11 = g 12 = h ! 13 = i 14 = j 15 = k 16 = l ! 17 = m 18 = n 19 = o 20 = p ! 21 = q 22 = r 23 = s 24 = t ! 25 = u 26 = v 27 = w 28 = y ! 29 (and above) = z ! the numbers 1 to 9 indicate multiple points on a given ! plot location, where the number indicates how many points ! are represented ! note that x is not used as a plotting symbol except to ! indicate that more than 9 points fell on the same plot ! location ! isize the integer code for the plot size, where ! 0 indicates a plot 100 col by 50 rows ! 1 indicates a plot 50 col by 50 rows ! nout the integer value indicating how many of the points which ! fell outside of the graph limits are to be listed ! if xlb == xub and ylb == yub, nout should be set to zero ! xlb the minimum value of x to be plotted(ie, the lower bound for ! the x axis), where if xlb=xub the routine will determine ! this value from the minimum value of the x vector ! xub the maximum value of x to be plotted(ie, the upper bound for ! the x axis), where if xlb=xub the routine will determine ! this value from the maximum value of the x vector ! ylb the minimum value of y to be plotted(ie, the lower bound for ! the y axis), where if ylb=yub the routine will determine ! this value from the minimum value of the y vector ! yub the maximum value of y to be plotted(ie, the upper bound for ! the y axis), where if ylb=yub the routine will determine ! this value from the maximum value of the y vector ! ilog the integer indicator variable used to determine whether ! the y axis scale is to be log or not ! if ilog == 0, the scale is not log ! if ilog /= 0, the scale is log ! ! ! additional variables used - (in alphabetical order) ! ! aline the vector of the current plot line ! alphai the plot axis symbol i ! axisch the y a axis symbol to be used for the current line, ! either i or - ! alphax the plotting symbol x designating more than 9 points fell on ! a single plotting location ! blank the plotting symbol blank ! delx the range of the x axis ! dely the range of the y axis ! hyphen the plot axis symbol - ! ic the count of the number of values falling outside of the ! graph bounds ! icol the column location for the plot line ! iout the minimum of nout or 50, indicating how many of the ! points which fell outside of the graph limits will actually ! be listed ! ipcode the integer code, used in error checking, which determines ! which plot routine has been called ! ipr the unit number of the printer ! itest the indicator variable for whether the x axis labels are ! printed in e or f format ! kss an integer vector used in determining the plot symbol ! needed ! nn the number of y labels to be listed on the left axis, ! (dependent on the graph size) ! numcol the integer value of the number of columns in the graph ! numlab the integer number of x labels to be listed at the bottom ! of the graph (dependent on graph size) ! numrow the integer number of rows in the graph ! sym the vector of plot symbol assignments (see is above) ! sym1 the vector of integer values used to indicate multiple ! points on the same plot location ! temp the array of values to be printed which fall outside the ! graph limits ! xlabel the vector of x axis labels ! xmn the minimum x value to be plotted, computed from data or ! assigned by xlb ! xwidth the value of an individual x axis graph interval ! xmx the maximum x value to be plotted, computed from data or ! assigned by xub ! ylabel the value of the y axis label to be printed ! ylower the lower bound for y values to be plotted on the current ! line ! ymn the minimum y value to be plotted, computed from data or ! assigned by ylb ! yupper the upper bound for y values to be plotted on the current ! line ! ywidth the value of an individual y axis graph interval ! ymx the maximum y value to be plotted, computed from data or ! assigned by yub ! ! implicit none real xmiss real xmn real xmx real ymn real ymx integer & ilog,ischck,isize,iym,lisym,m,n,nout logical & miss ! ! array arguments real & x(n),ym(iym,m),ymmiss(m) integer & isym(lisym) ! ! scalars in common integer & ierr ! ! real & delx,dely,tn,tx,xdmn,xdmx,xwidth,xx,ydmn,ydmx,yl,ylower, & yupper,ywidth,yy integer & i,ic,icol,ik,ilogx,ilogy,iout,irow,it,itest,j,jcol,k, & l,nlablx,nlably,nlu,nn,numcol,numcp2,numrow character & alphai*1,alphax*1,axisch*1,blank*1,hyphen*1,fmt*4, & xlfmt*205,xlfmt2*205 ! ! local arrays real & temp(50,2),xlabel(20),ylabel(20) integer & aline(105),ilogxy(2),isizxy(2),ispace(20),kss(101) character & cline(105)*1,itemp(50)*1,sym(30)*1,sym1(9)*1 ! ! external functions logical & mvchk external mvchk ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer aline(105) ! character*1 alphai, alphax ! character*1 axisch ! character*1 blank ! character*1 cline(105) ! real delx, dely ! character fmt*4 ! the format for the x-axis labels ! character*1 hyphen ! integer i, ic, icol, ierr, ik ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ilogx ! the values of p as specified by ilog. ! integer ilogxy(2) ! the values of p and q as specified by ilog. ! integer ilogy ! the values of q as specified by ilog. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isizxy(2) ! integer ispace(20) ! the spacing for the x-axis labels ! integer isym(lisym) ! integer it ! character*1 itemp(50) ! integer itest ! integer iym ! integer j, jcol ! integer k ! integer kss(101) ! integer l ! integer lisym ! integer m ! logical miss ! integer n ! integer nlablx, nlably, nlu ! integer nn, nout, numcol, numcp2, numrow ! character*1 sym(30), sym1(9) ! real temp(50, 2) ! real tn, tx ! real x(n) ! real xdmn, xdmx ! the x-axis data limits actually used. ! real xlabel(20) ! the x-axis lables. ! character xlfmt*205, xlfmt2*205 ! the formats used to print the x-axis ! real xmiss, xmn, xmx, xwidth, xx ! real ydmn, ydmx ! the y-axis data limits actually used. ! real yl ! real ylabel(20) ! the y-axis lables. ! real ylower ! real ym(iym, m) ! real ymmiss(m) ! real ymn, ymx, yupper, ywidth, yy ! data blank/' '/,hyphen/'-'/,alphai/'i'/,alphax/'x'/ data sym( 1)/'+'/,sym( 2)/'.'/,sym( 3)/'*'/,sym( 4)/'-'/, & sym( 5)/'a'/,sym( 6)/'b'/,sym( 7)/'c'/,sym( 8)/'d'/, & sym( 9)/'e'/,sym(10)/'f'/,sym(11)/'g'/,sym(12)/'h'/, & sym(13)/'i'/,sym(14)/'j'/,sym(15)/'k'/,sym(16)/'l'/, & sym(17)/'m'/,sym(18)/'n'/,sym(19)/'o'/,sym(20)/'p'/, & sym(21)/'q'/,sym(22)/'r'/,sym(23)/'s'/,sym(24)/'t'/, & sym(25)/'u'/,sym(26)/'v'/,sym(27)/'w'/,sym(28)/'y'/, & sym(29)/'z'/,sym(30)/'z'/ data sym1(1)/'1'/,sym1(2)/'2'/,sym1(3)/'3'/,sym1(4)/'4'/, & sym1(5)/'5'/,sym1(6)/'6'/,sym1(7)/'7'/,sym1(8)/'8'/, & sym1(9)/'9'/ ! ! define the number of rows and columns within the plot ! call prtcnt(max(0,isize),2,isizxy) if (isizxy(1) == 0) then numcol=101 else numcol = 51 end if if (isizxy(2) == 0) then numrow = 51 else numrow = 26 end if numcp2 = numcol + 2 nn=(numrow-1)/5 ! ! Adjust for log plots if necessary and find axis labels. ! call prtcnt (max(0,ilog),2,ilogxy) ilogx = ilogxy(1) ilogy = ilogxy(2) call loglmt (ilogy, ymn, ymx, ylabel, numrow, 5, dely, ywidth, & nlably, ydmn, ydmx) call loglmt (ilogx, xmn, xmx, xlabel, numcol, 10, delx, xwidth, & nlablx, xdmn, xdmx) ! ! Test for format for y axis labels. ! itest=0 tx=ymx tn=ymn if ( ilogy /= 0) then tx = 10.0e0**tx tn = 10.0e0**tn end if ! 190 if ((tn >= 1.0e6 .or. tn <= (-1.0e5)) .or. & (abs(tn) > 0.0e0.and.abs(tn)<0.001e0)) itest=1 if ((tx >= 1.0e6 .or. tx <= (-1.0e5)) .or. & (abs(tx) > 0.0e0.and.abs(tx)<0.001e0)) itest=1 ! ! blank out the plot print line cline ! cline(1:105)=blank ! ! write out the top horizontal axis of the plot ! cline(1:numcol)=hyphen cline(1)=alphai if (ilogx == 0) then do icol=11,numcol,10 cline(icol)=alphai end do else do ik = nlablx, 1, -1 icol = int ( ((log10(xlabel(ik))-xmn)/xwidth)+1.5e0 ) cline(icol) = alphai end do end if cline(numcol+1)=hyphen cline(numcol+2)=blank write ( *, 1004) hyphen,(cline(i),i=1,numcol),hyphen cline(1:105)=blank ! ! determine and write out the plot positions one line at a time. ! l=-1 ik=1 do irow=1,numrow l=l+1 if (l > nn) l=1 aline(1:numcol)=0 kss(1:numcol)=0 yupper=ymx+(1.5e0-real ( irow ) )*ywidth ylower=ymx+(0.5e0-real ( irow ) )*ywidth do i = 1, n if (miss .and. mvchk(x(i), xmiss)) then cycle end if if (ilogx == 0) then xx=x(i) else xx=log10(x(i)) end if do j=1,m if (miss .and. mvchk(ym(i,j), ymmiss(j))) then cycle end if if (ilogy == 0) then yy=ym(i,j) else yy=log10(ym(i,j)) end if if (((ylower <= yy).and.(yy= ydmn).and.(yy <= ydmx))) then if ((xx >= xdmn) .and. (xx <= xdmx)) then icol=int ( ((xx-xmn)/xwidth)+1.5e0 ) aline(icol) = aline(icol) + 1 ! ! simple plotting (plt) ! kss(icol)=1 ! ! symbol plots (splt) ! if (ischck == 1) kss(icol) = isym(i) ! ! multiple plots (mplt) ! if (ischck == 2) kss(icol) = j + 4 if (kss(icol) > 30) kss(icol)=30 if (kss(icol)<1) kss(icol)=1 end if end if end do end do do icol=1,numcol if (aline(icol) == 0) then cline(icol)=blank else if (aline(icol) == 1) then k=kss(icol) cline(icol)=sym(k) else if (aline(icol) <= 9) then cline(icol)=sym1(aline(icol)) else cline(icol)=alphax end if end if end if end do cline(numcol+2)=hyphen axisch=hyphen if (ilogy == 0) then yl = ylabel(ik) else yl = log10(ylabel(ik)) end if if ((ylower > yl) .or. (yl >= yupper)) then ! ! print line without label ! cline(numcp2)=alphai write ( *, 1008) alphai, (cline(icol), icol=1,numcp2) else ! ! print line with label ! if (itest == 0) then write ( *,1006) ylabel(ik),axisch, & (cline(icol),icol=1,numcp2) else write ( *,1007) ylabel(ik),axisch, & (cline(icol),icol=1,numcp2) end if ik=ik+1 end if end do ! ! write out the bottom horizontal axis and the x axis labels. ! cline(1:numcol)=hyphen cline(1)=alphai if (ilogx == 0) then nlu = nlablx+1 do icol=numcol,1,-10 cline(icol)=alphai nlu = nlu - 1 ispace(nlu) = 1 end do else jcol = 1 cline(jcol) = alphai nlu = nlablx do ik = nlablx, 1, -1 icol = int ( ((log10(xlabel(ik))-xmn)/xwidth)+1.5 ) cline(icol) = alphai if (icol-jcol >= 10) then ispace(nlu) = icol-jcol-9 nlu = nlu - 1 xlabel(nlu) = xlabel(ik) jcol = icol end if end do end if cline(numcol+1)=hyphen cline(numcol+2)=blank write ( *, 1004) hyphen, (cline(icol), icol = 1, numcp2) ! ! check x-axis labels for format ! fmt = 'f9.4' do i=1,nlablx if (((abs(xlabel(i)) > 0.0e0) .and. (abs(xlabel(i))<0.01e0)) & .or. & ((xlabel(i) >= 1.0e4) .or. (xlabel(i) <= (-1.0e3)))) then fmt = 'e9.4' exit end if end do write(xlfmt2,1000) nlablx-nlu write(xlfmt,xlfmt2) (fmt, ispace(i), i=nlablx,nlu+1,-1), fmt write ( *, xlfmt) (xlabel(i),i=nlablx,nlu,-1) ! ! determine values to be listed if outside of axis limits. ! ic = 0 iout = min(nout,50) if (iout >= 0) then do i = 1, n if (miss .and. mvchk(x(i), xmiss)) then cycle end if if (ilogx == 0) then xx = x(i) else xx = log10(x(i)) end if do j = 1, m if (miss .and. mvchk(ym(i,j), ymmiss(j))) then cycle end if if (ilogy == 0) then yy = ym(i,j) else yy = log10(ym(i,j)) end if if (((ydmn <= yy) .and. (yy <= ydmx)) .and. & ((xdmn <= xx) .and. (xx <= xdmx))) then cycle end if ic=ic+1 if ( ic <= iout ) then temp(ic,1)=x(i) temp(ic,2)=ym(i,j) it=1 if (ischck == 1) it=isym(i) if (ischck == 2) it=j+4 it = max ( it, 1 ) it = min ( it, 30 ) itemp(ic) = sym(it) end if end do end do end if ! ! check for points outside of graph limits and list if requested ! the total number of points to be plotted is n*m ! if (ic == 0) return if (iout < 0) return write ( *, 1010) ic if (iout <= 0) return write ( *, 1016) if (ic <= iout) go to 360 ic=iout write ( *, 1011) iout go to 370 360 write ( *, 1012) 370 write ( *, 1013) (temp(i,1), temp(i,2), itemp(i), i = 1, ic) return 1000 format ('(''(14x'',', i2, '('', '', a4, '','', i2, ''x''),', & ''', '', a4, '')'')') 1004 format (' ',16x, a1, 105a1) 1006 format(4x,f11.4,1x,a1,1x,105a1) 1007 format (' ', e14.7, 1x, a1, 1x, 105a1) 1008 format (' ', 15x, a1, 1x, 105a1) 1010 format(16x,'**note',i4, & 'values fell outside the specified limit s**') 1011 format ('1', 15x, 'the first ', i3, & ' values outside the plot limits are'/ 22x, & ' x y sym') 1012 format ('1', 15x, 'the values outside the plot limits are'/ 22x, & ' x y sym') 1013 format (15x,2e15.8,9x,a1) 1016 format (16x, 'see next page for list') end subroutine prtcnt ( nprt, ndigit, iptout ) !*****************************************************************************80 ! !! PRTCNT sets up the print control parameters. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer iptout(ndigit) ! the variable used to control printed output for each section. ! integer ndigit ! the number of digits in the print control value. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! implicit none integer & ndigit,nprt ! ! array arguments integer & iptout(ndigit) integer & i,ifac1,ifac2 if ( nprt <= -1 ) then iptout(1:ndigit) = 1 iptout (ndigit) = 2 else ifac1 = 10 ** (ndigit) do i = 1, ndigit ifac2 = ifac1/10 iptout(i) = mod(nprt, ifac1) / ifac2 ifac1 = ifac2 end do end if return end subroutine qapply ( nn, n, p, j, r, ierr ) !*****************************************************************************80 ! !! QAPPLY applies orthogonal transformation to the residual R. ! ! Discussion: ! ! This subroutine applies to R the orthogonal transformations ! stored in J by QRFACT. ! ! The vectors U which determine the Householder transformations ! are normalized so that their 2-norm squared is 2. The use of ! these transformations here is in the spirit of Businger and Golub. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Businger, Gene Golub, ! Linear Least Squares Solutions by Householder Transformations, ! Numerische Mathematik, ! Volume 7, pages 269-276, 1965. ! ! Parameters: ! ! Input, integer NN, the row dimension of the matrix J as declared in ! the calling program dimension statement ! ! Input, integer N, the number of rows of J and the size of the R. ! ! Input, integer P, the number of columns of J and the size of SIGMA. ! ! Input, real J(NN,P), an N by P matrix. It contains on its diagonal ! and below its diagonal the column vectors U which determine the ! Householder transformations (identity - U*U'). ! ! Input/output, real R(N). On input, the right hand side vector to ! which the orthogonal transformations will be applied. On output, ! R has been transformed. ! ! Input, integer IERR, if non-zero, indicates that not all the ! transformations were successfully determined and only the first ! abs(IERR) - 1 transformations will be used. ! implicit none integer n integer nn integer p real dotprd integer ierr real j(nn,p) integer k integer l integer nl1 real r(n) real t if ( ierr /= 0 ) then k = abs(ierr) - 1 else k = p end if do l = 1, k nl1 = n - l + 1 t = -dotprd ( nl1, j(l,l), r(l) ) r(l:n) = r(l:n) + t * j(l:n,l) end do return end subroutine qrfact ( nm, m, n, qr, alpha, ipivot, ierr, nopivk, sum ) !*****************************************************************************80 ! !! QRFACT computes the QR decomposition of a matrix. ! ! Discussion: ! ! This subroutine does a QR decomposition on the M x N matrix QR, ! with an optionally modified column pivoting, and returns the ! upper triangular R matrix, as well as the orthogonal vectors ! used in the transformations. ! ! This may be used when solving linear least-squares problems. ! See subroutine QR1 of ROSEPACK. It is called for this purpose ! in the NL2SOL package. ! ! This version of QRFACT tries to eliminate the occurrence of ! underflows during the accumulation of inner products. RKTOL1 ! is chosen below so as to insure that discarded terms have no ! effect on the computed two-norms. ! ! This routine was adapted from Businger and Golub's ALGOL ! routine "SOLVE". ! ! This routine is equivalent to the subroutine QR1 of ROSEPACK ! with RKTOL1 used in place of RKTOL below, with V2NORM used ! to initialize (and sometimes update) the sum array, and ! with calls on DOTPRD in place of some loops. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Businger, Gene Golub, ! Linear Least Squares Solutions by Householder Transformations, ! in Handbook for Automatic Computation, ! Volume II, Linear Algebra, ! edited by James Wilkinson and C Reinsch, ! Springer Verlag, pages 111-118, 1971; ! prepublished in Numerische Mathematik, ! Volume 7, pages 269-276, 1965. ! ! Parameters: ! ! Input, integer NM, the row dimension of the two dimensional ! array parameters as declared in the calling program dimension statement. ! ! Input, integer M, the number of rows in the matrix. ! ! Input, integer N, the number of columns in the matrix. ! ! Input/output, real QR(NM,N), on input, the M by N rectangular matrix ! to be decomposed. On output, contains the non-diagonal elements of ! the R matrix in the strict upper triangle. The vectors U, which ! define the Householder transformations (Identity - U*U'), are in the ! columns of the lower triangle. These vectors U are scaled so that ! the square of their 2-norm is 2.0. ! ! Output, real ALPHA(N), the diagonal elements of R. ! ! Output, integer IPIVOT(N), reflects the column pivoting performed ! on the input matrix to accomplish the decomposition. The J-th ! element of IPIVOT gives the column of the original matrix which was ! pivoted into column J during the decomposition. ! ! Output, integer IERR, error flag. ! 0, for normal return, ! K, if no non-zero pivot could be found for the K-th transformation, ! -K, for an error exit on the K-th transformation. ! If an error exit was taken, the first (K - 1) transformations are correct. ! ! Input, integer NOPIVK, controls pivoting. Columns 1 through NOPIVK ! will remain fixed in position. ! ! Workspace, real SUM(N). ! ! Local Parameters: ! ! Local, real UFETA, the smallest positive floating point number ! such that UFETA and -UFETA can both be represented. ! ! Local, real RKTOL, the square root of the relative precision ! of floating point arithmetic (MACHEP). ! implicit none integer n integer nm real alpha(n) real alphak real beta real dotprd integer i integer ierr integer ipivot(n) integer j integer jbar integer k integer m integer minum integer mk1 integer nopivk real qr(nm,n) real qrkk real qrkmax real, save :: rktol = 0.0E+00 real rktol1 real sigma real sum(n) real sumj real temp real, save :: ufeta = 0.0E+00 real v2norm if ( ufeta <= 0.0E+00 ) then ufeta = tiny ( ufeta ) rktol = sqrt ( 0.999E+00 * epsilon ( rktol ) ) end if ierr = 0 rktol1 = 0.01E+00 * rktol do j = 1, n sum(j) = v2norm ( m, qr(1,j) ) ipivot(j) = j end do minum = min ( m, n ) do k = 1, minum mk1 = m - k + 1 ! ! K-th Householder transformation. ! sigma = 0.0E+00 jbar = 0 ! ! Find largest column sum. ! if ( nopivk < k ) then do j = k, n if ( sigma < sum(j) ) then sigma = sum(j) jbar = j end if end do if ( jbar == 0 ) then ierr = k do i = k, n alpha(i) = 0.0E+00 if ( k < i ) then qr(k:i-1,i) = 0.0E+00 end if end do return end if ! ! Column interchange. ! i = ipivot(k) ipivot(k) = ipivot(jbar) ipivot(jbar) = i sum(jbar) = sum(k) sum(k) = sigma do i = 1, m sigma = qr(i,k) qr(i,k) = qr(i,jbar) qr(i,jbar) = sigma end do end if ! ! Second inner product. ! qrkmax = maxval ( abs ( qr(k:m,k) ) ) if ( qrkmax < ufeta ) then ierr = -k do i = k, n alpha(i) = 0.0E+00 if ( k < i ) then qr(k:i-1,i) = 0.0E+00 end if end do return end if alphak = v2norm ( mk1, qr(k,k) ) / qrkmax sigma = alphak**2 ! ! End second inner product. ! qrkk = qr(k,k) if ( 0.0E+00 <= qrkk ) then alphak = -alphak end if alpha(k) = alphak * qrkmax beta = qrkmax * sqrt ( sigma - ( qrkk * alphak / qrkmax ) ) qr(k,k) = qrkk - alpha(k) qr(k:m,k) = qr(k:m,k) / beta do j = k + 1, n temp = -dotprd ( mk1, qr(k,k), qr(k,j) ) qr(k:m,j) = qr(k:m,j) + temp * qr(k:m,k) if ( k + 1 <= m ) then sumj = sum(j) if ( ufeta <= sumj ) then temp = abs ( qr(k,j) / sumj ) if ( rktol1 <= temp ) then if ( 0.99E+00 <= temp ) then sum(j) = v2norm ( m-k, qr(k+1,j) ) else sum(j) = sumj * sqrt ( 1.0E+00 - temp**2 ) end if end if end if end if end do end do return end function r1mach ( i ) !*****************************************************************************80 ! !! R1MACH returns single precision real machine constants. ! ! Discussion: ! ! Assume that single precision real numbers are stored with a mantissa ! of T digits in base B, with an exponent whose value must lie ! between EMIN and EMAX. Then for values of I between 1 and 5, ! R1MACH will return the following values: ! ! R1MACH(1) = B**(EMIN-1), the smallest positive magnitude. ! R1MACH(2) = B**EMAX*(1-B**(-T)), the largest magnitude. ! R1MACH(3) = B**(-T), the smallest relative spacing. ! R1MACH(4) = B**(1-T), the largest relative spacing. ! R1MACH(5) = log10(B) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Phyllis Fox, Andrew Hall, Norman Schryer, ! Algorithm 528, ! Framework for a Portable Library, ! ACM Transactions on Mathematical Software, ! Volume 4, Number 2, June 1978, page 176-188. ! ! Parameters: ! ! Input, integer I, chooses the parameter to be returned. ! 1 <= I <= 5. ! ! Output, real R1MACH, the value of the chosen parameter. ! implicit none integer i real r1mach if ( i < 1 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i r1mach = 0.0E+00 stop else if ( i == 1 ) then r1mach = 1.1754944E-38 else if ( i == 2 ) then r1mach = 3.4028235E+38 else if ( i == 3 ) then r1mach = 5.9604645E-08 else if ( i == 4 ) then r1mach = 1.1920929E-07 else if ( i == 5 ) then r1mach = 0.3010300E+00 else if ( 5 < i ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'R1MACH - Fatal error!' write ( *, '(a)' ) ' The input argument I is out of bounds.' write ( *, '(a)' ) ' Legal values satisfy 1 <= I <= 5.' write ( *, '(a,i12)' ) ' I = ', i r1mach = 0.0E+00 stop end if return end function r9gmit ( a, x, algap1, sgngam, alx ) !*****************************************************************************80 ! !! R9GMIT computes Tricomi's incomplete gamma function for small X. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real a real ae real aeps real alg2 real algap1 real alx integer k integer m integer ma real r9gmit real sgngam real x real algs,bot,eps,fk,s,sgng2,t,te ! ! external functions real alngam external alngam data eps, bot / 2*0.0 / if (eps == 0.0) eps = 0.25 * epsilon ( eps ) if (bot == 0.0) bot = log( tiny ( bot ) ) if ( x <= 0.0 ) then call xerror ('r9gmit x should be gt 0', 1, 2) end if ma = int ( a + 0.5 ) if (a<0.0) ma = int ( a - 0.5 ) aeps = a - real ( ma ) if ( a < -0.5 ) then ae = aeps else ae = a end if t = 1.0 te = ae s = t do k = 1, 200 fk = real ( k ) te = -x*te/fk t = te/(ae+fk) s = s + t if (abs(t)= (-0.5)) then algs = -algap1 + log(s) else algs = -alngam(1.0+aeps) + log(s) s = 1.0 m = -ma - 1 t = 1.0 do k=1,m t = x*t/(aeps-real ( m+1-k )) s = s + t if (abs(t) bot) r9gmit = sgng2*exp(alg2) if (algs > bot) r9gmit = r9gmit + exp(algs) return end if end if r9gmit = exp ( algs ) return end function r9lgic ( a, x, alx ) !*****************************************************************************80 ! !! R9LGIC compute the log complementary incomplete gamma function. ! ! Discussion: ! ! This routine is suitable for large x and for a <= x. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real a real alx real r9lgic real x ! ! real eps,fk,p,r,s,t,xma,xpa integer k data eps / 0.0 / if (eps == 0.0) eps = 0.25 * epsilon ( eps ) xpa = x + 1.0 - a xma = x - 1.0 - a r = 0.0 p = 1.0 s = p do k = 1, 200 fk = real ( k ) t = fk*(a-fk)*(1.0+r) r = -t/((xma+2.0*fk)*(xpa+2.0*fk)+t) p = r*p s = s + p if (abs(p)= x. ! ! implicit none real a real a1x real algap1 real ax real, save :: eps = 0.0E+00 real fk real hstar integer k real p real r real r9lgit real s real, save :: sqeps = 0.0E+00 real t real x if ( eps == 0.0 ) then eps = 0.25 * epsilon ( eps ) end if if ( sqeps == 0.0 ) then sqeps = sqrt ( epsilon ( sqeps ) ) end if if (x <= 0.0 .or. a= 10.0 so that ! log (gamma(x)) = log(sqrt(2*pi)) + (x-.5)*log(x) - x + r9lgmc(x) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real r9lgmc real x ! ! real xbig,xmax integer nalgm ! ! local arrays real algmcs(6) ! ! external functions real csevl integer inits external csevl,inits ! ! series for algm on the interval 0. to 1.00000d-02 ! with weighted error 3.40e-16 ! log weighted error 15.47 ! significant figures required 14.39 ! decimal places required 15.86 ! data algmcs( 1) / .166638948045186e0 / data algmcs( 2) / -.0000138494817606e0 / data algmcs( 3) / .0000000098108256e0 / data algmcs( 4) / -.0000000000180912e0 / data algmcs( 5) / .0000000000000622e0 / data algmcs( 6) / -.0000000000000003e0 / data nalgm, xbig, xmax / 0, 2*0.0 / if ( nalgm == 0 ) then nalgm = inits ( algmcs, 6, 0.5 * epsilon ( x ) ) xbig = 1.0 / sqrt ( epsilon ( xbig ) ) xmax = exp (min(log(huge ( xmax ) /12.0), -log(12.0* tiny ( xmax ) )) ) end if if (x<10.0) call xerror ('r9lgmc x must be ge 10', 1, 2) if (x >= xmax) then r9lgmc = 0.0 call xerror ('r9lgmc x so big r9lgmc underflows', 2, 1) return end if r9lgmc = 1.0/(12.0*x) if (x v(j)) then x = (abs(randn)-v(j))/ (v(j+1)-v(j)) y = randu(0) s = x + y if (s <= c2) then if (s <= c1) then return else if (y <= c-aa*exp(-p5 * (b-b*x)**2)) then if (exp(-p5*v(j+1)**2)+y*pc/v(j+1) > exp(-p5*randn**2)) then ! ! tail part; 3.855849 is .5*xn**2 ! do s = xn - log(randu(0)) / xn if (3.855849e0+log(randu(0))-xn*s <= -p5*s**2) then exit end if end do randn = sign ( s, randn ) end if return end if end if randn = sign ( b-b*x, randn ) end if return end function randu ( jd ) !*****************************************************************************80 ! !! RANDU returns uniform random numbers. ! ! Discussion: ! ! this routine generates quasi uniform random numbers on the ! interval (0,1]. it can be used with any computer which allows ! integers at least as large as 32767. ! ! ! use ! first time.... ! z = randu(jd) ! here jd is any n o n - z e r o integer. ! this causes initialization of the program ! and the first random number to be returned as z. ! subsequent times... ! z = randu(0) ! causes the next random number to be returned as z. ! ! ! note: users who wish to transport this program from one computer ! to another should read the following information: ! ! machine dependencies... ! mdig = a lower bound on the number of binary digits available ! for representing integers, including the sign bit. ! this value must be at least 16, but may be increased ! in line with remark a below. ! ! remarks... ! a. this program can be used in two ways: ! (1) to obtain repeatable results on different computers, ! set 'mdig' to the smallest of its values on each, or, ! (2) to allow the longest sequence of random numbers to be ! generated without cycling (repeating) set 'mdig' to the ! largest possible value. ! b. the sequence of numbers generated depends on the initial ! input 'jd' as well as the value of 'mdig'. ! if mdig=16 one should find that ! the first evaluation ! z=randu(305) gives z=.027832881... ! the second evaluation ! z=randu(0) gives z=.56102176... ! the third evaluation ! z=randu(0) gives z=.41456343... ! the thousandth evaluation ! z=randu(0) gives z=.19797357... ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Marsaglia, ! Comments on the Perfect Uniform Random Number Generator, ! unpublished notes, wash s. u. ! implicit none integer jd real randu ! ! real & one,zero integer & i,j,j0,j1,jseed,k,k0,k1,m1,m2,mdig ! ! local arrays integer & m(17) ! ! external functions integer & i1mach external i1mach ! ! save statement save i,j,m,m1,m2 ! ! data m(1),m(2),m(3),m(4),m(5),m(6),m(7),m(8),m(9),m(10),m(11), & m(12),m(13),m(14),m(15),m(16),m(17)/30788,23052,2053,19346, & 10646,19427,23975,19049,10949,19693,29746,26748,2796,23890, & 29168,31924,16499/ data m1,m2,i,j/32767,256,5,17/ data zero,one /0.0e0,1.0e0/ if (jd /= 0) then ! ! fill ! mdig = i1mach(8) + 1 ! ! modification so same numbers will be generated on all machines ! with i1mach(8) at least 31 ! mdig = min(mdig,32) ! ! be sure that mdig at least 16. ! if (mdig<16) call xerror('randu--mdig less than 16', 1, 2 ) m1 = 2** (mdig-2) + (2** (mdig-2)-1) m2 = 2** (mdig/2) jseed = min(abs(jd),m1) if (mod(jseed,2) == 0) jseed = jseed - 1 k0 = mod(9069,m2) k1 = 9069/m2 j0 = mod(jseed,m2) j1 = jseed/m2 do i = 1,17 jseed = j0*k0 j1 = mod(jseed/m2+j0*k1+j1*k0,m2/2) j0 = mod(jseed,m2) m(i) = j0 + m2*j1 end do i = 5 j = 17 end if ! ! begin main loop here ! k = m(i) - m(j) if (k<0) k = k + m1 m(j) = k i = i - 1 if (i == 0) i = 17 j = j - 1 if (j == 0) j = 17 randu = real(k)/real(m1) ! ! modification so random numbers in (0,1] rather than [0,1) ! if (randu == zero) randu = one return end subroutine ranko ( n, y, h, r, t ) !*****************************************************************************80 ! !! RANKO puts the rank of N X's in the vector R. ! ! Discussion: ! ! This routine puts rank of n x"s in vector r. vector h is used for storage. ! x,h and r must be dimensioned n or greater. ! stores correction for ties in t = sum(t-1)*t*(t+1). ! n.b. t is 12 times value computed by original omnitab routine. ! t=0 means no ties. ! ! Author: ! ! David Hogben, ! Statistical Engineering Division, ! National Bureau of Standards, ! Boulder, Colorado ! implicit none real & t integer & n ! ! array arguments real & r(n),y(n) integer & h(n) ! ! integer & i,ij,j,k,k2 ! ! external subroutines external srtir,srtri ! ! variable definitions (alphabetically) ! ! integer h(n) ! the indices to the hierarchy of r ! integer i ! index variable ! integer ij ! index variable based on i-j ! integer j ! index variable ! integer k ! index variable ! integer k2 ! index variable ! integer n ! number of observations ! real r(n) ! final vector containing rank ! real t ! 12 times the omnitab correction for ties ! t = sum(t-1)*t*(t+1) ! t = 0 means no ties ! real y(n) ! vector to be ranked ! ! ! move y to r and put i in h ! do i=1,n h(i) = i end do r(1:n) = y(1:n) ! ! sort y in r, carry along i in h to obtain hierarchy in h. ! call srtir(h, n, r) ! ! replace r(i) by i*. ! let k be such that r(i)=r(i-j+1),j=1,k. then i* = i-(k-1)/2. ! k = 1 t = 0 do i=2,n if (r(i) == r(i-1)) then k = k + 1 else do j=1,k ij = i - j r(ij) = real (i-1) - real (k-1)/2.0e0 end do t = t + real ( (k-1)*k*(k+1) ) k = 1 end if end do t = t + real ( (k-1)*k*(k+1) ) do i=1,k k2 = n + 1 - i r(k2) = real ( n ) - real ( k - 1 ) / 2.0e0 end do ! ! sort h carry along r to obtain ranks in r ! call srtri(r, n, h) return end subroutine realtr ( a, b, n, isn ) !*****************************************************************************80 ! !! REALTR computes the forward or inverse Fourier transform of real data. ! ! Discussion: ! ! if isn=1, this subroutine completes the Fourier transform ! of 2*n data values, where the original data values are ! stored alternately in arrays a and b, and are first ! transformed by a complex Fourier transform of dimension n. ! the cosine coefficients are in a(1),a(2),...a(n+1) and ! the sine coefficients are in b(1),b(2),...b(n+1). ! a typical calling sequence is ! call fft(a,b,n,n,n,1) ! call realtr(a,b,n,1) ! the results should be multiplied by 0.5e0/n to give the ! usual scaling of coefficients. ! ifisn-1, the inverse transformation is done, the first step ! in evaluating a real Fourier series. ! a typical calling sequence is ! call realtra(a,b,n,-1) ! call fft(a,b,n,n,n,-1) ! the results should be multiplied by 0.5e0 to give the usual ! scaling, and the time domain results alternate in arrays a ! and b, i.e. a(1),b(1),a(2),b(2),...a(n),b(n). ! the data may alternatively be stored in a single complex ! array a, then the magnitude of isn changed to two to ! give the correct indexing increment and a(2) used to ! pass the initial address for the sequence of imaginary ! values, e.g. ! call fft(a,a(2),n,n,n,2) ! call realtr(a,a(2),n,2) ! in this case, the cosine and sine coefficients alternate in a. ! ! Author: ! ! RC Singleton, ! Stanford Research Institute, ! October 1968. ! ! implicit none integer & isn,n ! ! array arguments real & a(1),b(1) ! ! real & aa,ab,ba,bb,cd,cn,im,re,sd,sn integer & inc,j,k,nh,nk inc = iabs(isn) nk = n*inc + 2 nh = nk/2 sd = 2.0e0*atan(1.0e0)/ real ( n ) cd = 2.0e0*sin(sd)**2 sd = sin(sd+sd) sn = 0.0e0 if ( isn < 0 ) then cn = -1.0E+00 sd = -sd else cn = 1.0e0 a(nk-1) = a(1) b(nk-1) = b(1) end if do j = 1, nh, inc k = nk - j aa = a(j) + a(k) ab = a(j) - a(k) ba = b(j) + b(k) bb = b(j) - b(k) re = cn*ba + sn*ab im = sn*ba - cn*ab b(k) = im - bb b(j) = im + bb a(k) = aa - re a(j) = aa + re aa = cn - (cd*cn+sd*sn) sn = (sd*cn-cd*sn) + sn cn = 0.5e0/(aa**2+sn**2) + 0.5e0 sn = cn*sn cn = cn*aa end do return end subroutine relcom ( n, v, w, reltol, abstol, nfail, ifail ) !*****************************************************************************80 ! !! RELCOM computes the difference between V(I) and W(I) relative to RELTOL. ! ! Discussion: ! ! this subroutine computes the number of times the ! relative difference between v(i) and w(i), i = 1, 2, ..., n, ! is greater than reltol . ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & abstol,reltol integer & n,nfail ! ! array arguments real & v(n),w(n) integer & ifail(n) integer & i ! ! variable definitions (alphabetically) ! ! real abstol ! the absolute tolerance used in the comparison. ! integer ifail(n) ! an indicator variable designating whether or not the comparison ! failed or not, where 0 indicates not failure and 1 indicates ! falure. ! integer n ! the number of observations. ! integer nfail ! the total number of failures. ! real reltol ! the relative tolerance used in the comparison. ! real v(n), w(n) ! the values being compared. ! nfail = 0 do i = 1, n if ((abs(v(i)-w(i)) <= reltol*max(abs(v(i)),abs(w(i)))) .or. & (((v(i) == 0.0e0).or.(w(i) == 0.0e0)).and. & (abs(v(i)-w(i)) <= abstol))) then ifail(i) = 0 else ifail(i) = 1 nfail = nfail + 1 end if end do return end function reldst ( p, d, x, x0 ) !*****************************************************************************80 ! !! RELDST computes the relative difference between two real values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer P, the length of the vectors. ! ! Input, real D(P), a scaling vector. ! ! Input, real X(P), X0(P), two vectors whose relative difference ! is desired. ! ! Output, real RELDST, the relative difference between X and X0. ! implicit none integer p real d(p) real emax integer i real reldst real x(p) real x0(p) real xmax emax = 0.0E+00 xmax = 0.0E+00 do i = 1, p emax = max ( emax, abs ( d(i) * ( x(i) - x0(i) ) ) ) xmax = max ( xmax, d(i) * ( abs ( x(i) ) + abs ( x0(i) ) ) ) end do if ( 0.0E+00 < xmax ) then reldst = emax / xmax else reldst = 0.0E+00 end if return end subroutine repck ( d, nrests, npar, n ) !*****************************************************************************80 ! !! REPCK reformats the data in D for the N by NPAR format used by NLCMP. ! ! Discussion: ! ! this routine modifies d to conform to n by npar format required ! by nlcmp. future revisions to nlcmp should be made to eliminate ! the need for this routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,npar,nrests ! ! array arguments real & d(nrests*npar) integer & i,i1,i2,j i1 = -n i2 = -n do j = 1, npar i1 = i1 + nrests i2 = i2 + n do i = 1, n d(i2+i) = d(i1+i) end do end do return end function rmdcon ( k ) !*****************************************************************************80 ! !! RMDCON returns machine constants. ! ! implicit none integer & k real rmdcon ! ! real & big,eta,machep,one001,pt999 ! ! ! return machine dependent constants used by nl2sol ! ! integer k ! ! the constant returned depends on k... ! ! k = 1... smallest pos. eta such that -eta exists. ! k = 2... square root of 1.001*eta. ! k = 3... unit roundoff = smallest pos. no. machep such ! that 1 + machep > 1 .and. 1 - machep < 1. ! k = 4... square root of 0.999*machep. ! k = 5... square root of 0.999*big (see k = 6). ! k = 6... largest machine no. big such that -big exists. ! ! data one001/1.001e0/, pt999/0.999e0/ big = huge ( big ) eta = tiny ( eta ) machep = epsilon ( machep ) go to (10, 20, 30, 40, 50, 60), k ! 10 rmdcon = eta go to 999 ! 20 rmdcon = sqrt(one001*eta) go to 999 ! 30 rmdcon = machep go to 999 ! 40 rmdcon = sqrt(pt999*machep) go to 999 ! 50 rmdcon = sqrt(pt999*big) go to 999 ! 60 rmdcon = big ! 999 return end subroutine rptmul ( func, ipivot, j, nn, p, rd, x, y, z ) !*****************************************************************************80 ! !! RPTMUL multiplies the R factor times a vector X. ! ! Discussion: ! ! This routine computes one of: ! ! Y = R * P' * X ! Y = P * R' * R * P' * X ! Y = P * R' * X. ! ! where P is a permutation matrix represented by a permutation ! vector, and R is an upper triangular matrix, the R factor of ! a QR factorization. ! ! The strict upper triangle of R is stored in the strict upper triangle ! of the array J, and the diagonal of R is stored in the vector RD. ! ! X and Y may share storage. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer FUNC, determines which product to compute: ! 1, Y = RMAT * PERM' * X. ! 2, Y = PERM * PERM' * RMAT * PERM' * X. ! 3, Y = PERM * PERM' * X. ! ! Input, integer IPIVOT(P), the permutation vector. ! ! Input, real J(NN,P), contains the strict upper triangle of the ! matrix RMAT. ! ! Input, integer NN, the leading dimension of J. ! ! Input, integer P, the length of X and Y, and the order of RMAT. ! ! Input, real RD(P), the diagonal elements of the matrix RMAT. ! ! Input, real X(P), the input vector. ! ! Output, real Y(P), the output vector. ! ! Workspace, real Z(P). ! implicit none integer nn integer p real dotprd integer func integer i integer ipivot(p) real j(nn,p) integer k real rd(p) real x(p) real y(p) real z(p) real zk if ( func <= 2 ) then ! ! Set Z = PERM' * X. ! do i = 1, p k = ipivot(i) z(i) = x(k) end do ! ! Set Y = RMAT * Z. ! y(1) = z(1) * rd(1) do k = 2, p zk = z(k) do i = 1, k-1 y(i) = y(i) + j(i,k) * zk end do y(k) = zk * rd(k) end do if ( func <= 1 ) then return end if else y(1:p) = x(1:p) end if ! ! Set Z = RMAT' * Y. ! z(1) = y(1) * rd(1) do i = 2, p z(i) = y(i) * rd(i) + dotprd ( i-1, j(1,i), y ) end do ! ! Set Y = PERM * Z. ! do i = 1, p k = ipivot(i) y(k) = z(i) end do return end subroutine s88fmt ( n, w, ifmt ) !*****************************************************************************80 ! !! S88FMT writes an integer into a string. ! ! s88fmt replaces ifmt(1), ... , ifmt(n) with ! the characters corresponding to the n least significant ! digits of w. ! ! implicit none integer n,w ! ! array arguments character ifmt(n)*4 ! ! integer idigit,nt,wt ! ! local arrays character digits(10)*4 ! ! data digits( 1) / '0' / data digits( 2) / '1' / data digits( 3) / '2' / data digits( 4) / '3' / data digits( 5) / '4' / data digits( 6) / '5' / data digits( 7) / '6' / data digits( 8) / '7' / data digits( 9) / '8' / data digits(10) / '9' / nt = n wt = w do if ( nt <= 0 ) then exit end if idigit = mod( wt, 10 ) ifmt(nt) = digits(idigit+1) wt = wt / 10 nt = nt - 1 end do return end subroutine sample ( y, n, ns, ys, nys ) !*****************************************************************************80 ! !! SAMPLE creates a new series by sampling every K-th item of the input. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,ns,nys ! ! array arguments real & y(*),ys(*) ! ! scalars in common integer & ierr logical & err01,err02,head ! ! local arrays character & ln(8)*1,lns(8)*1,lone(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,eisii,smply ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01, err02 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! character*1 ln(8), lns(8), lone(8) ! the array containing the name of the variable n and ns. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer ns ! the sampling rate. ! integer nys ! the number of observations in the filtered series ys. ! real y(n) ! the vector containing the observed time series. ! real ys(n) ! the vector in which the sampled series is returned. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'a', 'm', 'p', 'l', 'e'/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lns(1), lns(2), lns(3), lns(4), lns(5), lns(6), lns(7), lns(8) & / 'n', 's', ' ', ' ', ' ', ' ', ' ', ' '/ data & lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), lone(7), & lone(8) & / 'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 3, 1, head, err01, ln) call eisii(nmsub, lns, ns, 1, n, 1, head, err02, lone, ln) if (err01 .or. err02) then ierr = 1 write ( *, 1000) return end if call smply (y, n, ns, ys, nys) return 1000 format (/' the correct form of the call statement is'// & ' call sample (y, n, ns, ys, nys)') end function sasum ( n, x, incx ) !*****************************************************************************80 ! !! SASUM takes the sum of the absolute values of a real vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector to be examined. ! ! Input, integer INCX, the increment between successive entries of X. ! INCX must not be negative. ! ! Output, real SASUM, the sum of the absolute values of X. ! implicit none integer incx integer n real sasum real x(*) sasum = sum ( abs ( x(1:1+(n-1)*incx:incx) ) ) return end subroutine saxpy ( n, sa, x, incx, y, incy ) !*****************************************************************************80 ! !! SAXPY adds a real constant times one vector to another. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real SA, the multiplier. ! ! Input, real X(*), the vector to be scaled and added to Y. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input/output, real Y(*), the vector to which a multiple of X is to ! be added. ! ! Input, integer INCY, the increment between successive entries of Y. ! implicit none integer i integer incx integer incy integer ix integer iy integer n real sa real x(*) real y(*) if ( n <= 0 ) then else if ( sa == 0.0E+00 ) then else if ( incx == 1 .and. incy == 1 ) then y(1:n) = y(1:n) + sa * x(1:n) else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if do i = 1, n y(iy) = y(iy) + sa * x(ix) ix = ix + incx iy = iy + incy end do end if return end subroutine scopy ( n, x, incx, y, incy ) !*****************************************************************************80 ! !! SCOPY copies one real vector into another. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector to be copied into Y. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Output, real Y(*), the copy of X. ! ! Input, integer INCY, the increment between successive elements of Y. ! implicit none integer i integer incx integer incy integer ix integer iy integer n real x(*) real y(*) if ( n <= 0 ) then else if ( incx == 1 .and. incy == 1 ) then y(1:n) = x(1:n) else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if do i = 1, n y(iy) = x(ix) ix = ix + incx iy = iy + incy end do end if return end function sdot ( n, x, incx, y, incy ) !*****************************************************************************80 ! !! SDOT forms the dot product of two real vectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input, real X(*), one of the vectors to be multiplied. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input, real Y(*), one of the vectors to be multiplied. ! ! Input, integer INCY, the increment between successive elements of Y. ! ! Output, real SDOT, the dot product of X and Y. ! implicit none integer i integer incx integer incy integer ix integer iy integer n real sdot real stemp real x(*) real y(*) if ( n <= 0 ) then sdot = 0.0E+00 else if ( incx == 1 .and. incy == 1 ) then sdot = dot_product ( x(1:n), y(1:n) ) else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if stemp = 0.0E+00 do i = 1, n stemp = stemp + x(ix) * y(iy) ix = ix + incx iy = iy + incy end do sdot = stemp end if return end subroutine setesl ( n, ndiv, nfft ) !*****************************************************************************80 ! !! SETESL: smallest suitable value of NFFT for given N and Singleton FFT. ! ! Discussion: ! ! this routine computes the smallest value of nfft which ! equals or exceeds n + 2, such that nfft - 2 is ! 1. divisible by ndiv, ! 2. has no more than 11 prime factors, ! 3. has no prime factor greater than 23, and ! 4. the product of the square free prime factors of ! (nfft-2)/ndiv do not exceed 210 if ndiv = 2, and ! 105 if ndiv = 4. ! the value of nfft thus meet the requirements of ! the extended length of the series required for any routine ! using the singleton fft providing the proper value of ndiv ! is chosen. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,ndiv,nfft ! ! integer & i,npf,nsfp ! ! local arrays integer & ipf(50),ipfexp(50) ! ! external subroutines external factor ! ! variable definitions (alphabetically) ! ! integer i ! an index variable. ! integer ipf(50), ipfexp(50) ! the vectors of prime factors of nfft and their exponents, ! respectively, where the length of these vectors is ! sufficient to accomodate the prime factors of an integer ! up to 2 ** 128 (approximately 10 ** 40). ! integer n ! the number upon which nfft is based. ! integer ndiv ! a required factor of nfft - 2. ! integer nfft ! the returned value which meets the above description. ! integer npf ! the number of prime factors in nfft. ! integer nsfp ! the product of the non square factors. ! nfft = n if (nfft <= 0) return if (mod(nfft, ndiv) /= 0) nfft = nfft + ndiv - mod(nfft, ndiv) nfft = nfft - ndiv do nfft = nfft + ndiv call factor(nfft/ndiv, npf, ipf, ipfexp) if ((npf >= 11) .or. (ipf(npf) > 23)) then cycle end if nsfp = 1 if (ndiv == 4) nsfp = 2 do i = 1, npf if (mod(ipfexp(i), 2) == 1) nsfp = nsfp * ipf(i) end do if (nsfp < 210) then exit end if end do nfft = nfft + 2 return end subroutine setfrq ( freq, nf, nprt, fmin, fmax, h ) !*****************************************************************************80 ! !! SETFRQ computes the frequencies at which the spectrum is to be estimated. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin,h integer & nf,nprt ! ! array arguments real & freq(nf) ! ! real & deltaf integer & i ! ! variable definitions (alphabetically) ! ! real deltaf ! the frequency increment. ! real fmax, fmin ! the maximum and minimum frequencies at which the ! spectrum is to be estimated. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! estimated. ! real h ! the sampling interval. ! integer i ! an indexing variable. ! integer nf ! the number of frequencies for which the spectral estimates ! are to be estimated. ! integer nprt ! a code used to specify the type of plot, where if ! nprt equals 2 the frequency scale is linear, and if ! nprt equals 3 the frequency scale is log. ! ! compute frequency values for linear scale ! if ( nprt /= 3) then freq(1) = fmin if (nf == 1) return deltaf = (fmax - fmin) / (h * real (nf - 1)) do i = 2, nf freq(i) = freq(i-1) + deltaf end do freq(nf) = fmax ! ! compute frequency values for log scale ! else deltaf = (log10(fmax) - log10(fmin)) / (h * real (nf - 1)) freq(1) = fmin if (nf == 1) return do i = 2, nf freq(i) = 10.0e0**(log10(freq(i-1)) + deltaf) end do freq(nf) = fmax end if return end subroutine setiv ( vector, n, value ) !*****************************************************************************80 ! !! SETIV sets the entries of an integer vector to a value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer n ! number of elements to set ! integer value ! value to which the elements are to be set ! integer vector(n) ! vector whose first n elements are to be set. ! implicit none integer & n,value ! ! array arguments integer & vector(n) vector(1:n) = value return end subroutine setlag ( n, lagmax ) !*****************************************************************************80 ! !! SETLAG sets the number of autocorrelations to be computed. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer lagmax integer n ! ! variable definitions (alphabetically) ! ! integer lagmax ! the number of lags at which the autocovariances are to be ! computed. ! integer n ! the integer number of observations in each series ! if (n >= 96) lagmax = min(n / 3, 100) if (33 <= n .and. n <= 95) lagmax = 32 if (n <= 32) lagmax = n - 1 return end subroutine setra ( array, im, m, n, value ) !*****************************************************************************80 ! !! SETRA sets the entries of a real array to a given value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real array(im,m) ! array for which elements will be set ! integer im ! actual first dimension of array in calling program ! integer m ! number of columns to set ! integer n ! number of rows to set ! real value ! value to which the elements are to be set ! implicit none real & value integer & im,m,n ! ! array arguments real & array(im,m) array(1:n,1:m) = value return end subroutine setrow ( nrow, xm, n, m, ixm, nrowu ) !*****************************************************************************80 ! !! SETROW selects the row used by the derivative checking procedure. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ixm ! the first dimension of the independent variable array xm. ! integer m ! the number of independent variables. ! integer n ! the number of observations of data. ! integer nrow, nrowu ! the user-supplied number of the row of the independent ! variable array at which the derivative is to be checked, ! and the number of the row actually used. ! real xm(ixm,m) ! the independent variable matrix. ! implicit none integer & ixm,m,n,nrow,nrowu ! ! array arguments real & xm(ixm,m) ! ! integer & i nrowu = nrow if ((nrowu >= 1) .and. (nrowu <= n)) return ! ! select first row of independent variables which contains no zeros ! if there is one, otherwise first row is used. ! do i = 1, n if ( any ( xm(i,1:m) == 0.0E+00 ) ) then else nrowu = i return end if end do nrowu = 1 return end subroutine setrv ( vector, n, value ) !*****************************************************************************80 ! !! SETRV sets the elements of a real vector to a value. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer n ! number of elements to set ! real value ! value to which the elements are to be set ! real vector(n) ! vector whose first n elements are to be set. ! implicit none integer n real value real vector(n) vector(1:n) = value return end subroutine slflt ( y, n, k, h, yf, nyf ) !*****************************************************************************80 ! !! SLFLT applies a symmetric filter to a series. ! ! Discussion: ! ! this subroutine performs a symmetric filtering operation ! on an input series y, returning the filtered series in yf. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & k,n,nyf ! ! array arguments real & h(*),y(*),yf(*) ! ! scalars in common integer & ierr logical & err01,err02,err03,err04,head ! ! local arrays character & lh(8)*1,lk(8)*1,ln(8)*1,lone(8)*1,nmsub(6)*1 ! ! external subroutines external eisge,eisii,eriodd,erslf,fltsl ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01, err02, err03, err04 ! value(s) indicating whether an error was detected (true) or not ! (false). ! real h(k) ! the array of symmetric linear filter coefficients. ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer k ! the number of filter terms. ! character*1 lh(8), lk(8), ln(8), lone(8) ! the arrays containing the names of the variables k and n. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nyf ! the number of observations in the filtered series yf. ! real y(n) ! the vector containing the observed time series. ! real yf(n) ! the vector in which the filtered series is returned. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'l', 'f', 'l', 't', ' '/ data & lh(1), lh(2), lh(3), lh(4), lh(5), lh(6), lh(7), lh(8) & / 'h', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lk(1), lk(2), lk(3), lk(4), lk(5), lk(6), lk(7), lk(8) & / 'k', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data & lone(1), lone(2), lone(3), lone(4), lone(5), lone(6), lone(7), & lone(8) /'o', 'n', 'e', ' ', ' ', ' ', ' ', ' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 3, 1, head, err01, ln) call eisii(nmsub, lk, k, 1, n, 1, head, err02, lone, ln) call eriodd(nmsub, lk, k, 1, head, err03) if (err01 .or. err02 .or. err03) then ierr = 1 write ( *, 1000) return end if call erslf(nmsub, lh, k, h, head, err04) if ( err04 ) then ierr = 1 write ( *, 1000) return end if call fltsl (y, n, k, h, yf, nyf) return 1000 format (/' the correct form of the call statement is'// & ' call slflt (y, n, k, h, yf, nyf)') end subroutine slupdt ( a, cosmin, p, size, step, u, w, wchmtd, wscale, y ) !*****************************************************************************80 ! !! SLUPDT updates a symmetric matrix A so that A * STEP = Y. ! ! Discussion: ! ! Update the symmetric matrix A so that A * STEP = Y. Only the lower ! triangle of A is stored, by rows. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! implicit none integer p real a((p*(p+1))/2) real cosmin real denmin real dotprd integer i integer j integer k real sdotwm real size real step(p) real t real u(p) real v2norm real w(p) real wchmtd(p) real wscale real y(p) sdotwm = dot_product ( step(1:p), wchmtd(1:p) ) denmin = cosmin * v2norm ( p, step ) * v2norm ( p, wchmtd ) if ( denmin /= 0.0E+00 ) then wscale = min ( 1.0E+00, abs ( sdotwm / denmin ) ) else wscale = 1.0E+00 end if if ( sdotwm /= 0.0E+00 ) then t = wscale / sdotwm else t = 0.0E+00 end if w(1:p) = t * wchmtd(1:p) call slvmul ( p, u, a, step ) t = 0.5E+00 * ( size * dotprd ( p, step, u ) - dotprd ( p, step, y ) ) u(1:p) = t * w(1:p) + y(1:p) - size * u(1:p) ! ! Set A = A + U * W' + W * U'. ! k = 1 do i = 1, p do j = 1, i a(k) = size * a(k) + u(i) * w(j) + w(i) * u(j) k = k + 1 end do end do return end subroutine slvmul ( p, y, s, x ) !*****************************************************************************80 ! !! SLVMUL sets Y = S * X, where S is a P by P symmetric matrix. ! ! Discussion: ! ! This routine sets Y = S * X, where X is a given vector and ! S is a P by P symmetric matrix. The lower triangle of S is ! stored by rows. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer P, the order of S, X and Y. ! ! Output, real Y(P), the product S * X. ! ! Input, real S((P*(P+1))/2), the P by P symmetric matrix. Only the ! lower triangle is stored, by rows. ! ! Input, real X(P), the vector to be multiplied by S. ! implicit none integer p integer i integer j integer k real s((p*(p+1))/2) real x(p) real y(p) ! ! Compute the lower triangle of S times X. ! j = 1 do i = 1, p y(i) = dot_product ( s(j:j+i-1), x(1:i) ) j = j + i end do ! ! Compute the strict upper triangle of S times X. ! j = 1 do i = 2, p j = j + 1 do k = 1, i - 1 y(k) = y(k) + s(j) * x(i) j = j + 1 end do end do return end function smach ( job ) !*****************************************************************************80 ! !! SMACH computes machine parameters for single precision arithmetic. ! ! Discussion: ! ! Assume the computer has ! ! B = base of arithmetic; ! T = number of base B digits; ! L = smallest possible exponent; ! U = largest possible exponent; ! ! then ! ! EPS = B**(1-T) ! TINY = 100.0 * B**(-L+T) ! HUGE = 0.01 * B**(U-T) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for FORTRAN usage, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, pages 308-323, 1979. ! ! Parameters: ! ! Input, integer JOB: ! 1, EPS is desired; ! 2, TINY is desired; ! 3, HUGE is desired. ! ! Output, real SMACH, the requested value. ! implicit none real eps real huge integer job real s real smach real tiny eps = 1.0E+00 do eps = eps / 2.0E+00 s = 1.0E+00 + eps if ( s <= 1.0E+00 ) then exit end if end do eps = 2.0E+00 * eps s = 1.0E+00 do tiny = s s = s / 16.0E+00 if ( s * 1.0E+00 == 0.0E+00 ) then exit end if end do tiny = ( tiny / eps ) * 100.0E+00 huge = 1.0E+00 / tiny if ( job == 1 ) then smach = eps else if ( job == 2 ) then smach = tiny else if ( job == 3 ) then smach = huge else smach = 0.0E+00 end if return end subroutine smply ( y, n, ns, ys, nys ) !*****************************************************************************80 ! !! SMPLY samples every K-th observation from a series. ! ! Discussion: ! ! this subroutine samples every kth observation from the input ! series y, storing the sampled series in ys. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,ns,nys ! ! array arguments real & y(n),ys(n) ! ! integer & i,i1 ! ! variable definitions (alphabetically) ! ! integer n ! the number of observations in the series y. ! integer ns ! the sampling rate. ! integer nys ! the number of observations in the filtered series ys. ! real y(n) ! the vector containing the observed time series. ! real ys(n) ! the vector in which the sampled series is returned. ! nys = 0 do i = 1, n, ns nys = nys + 1 ys(nys) = y(i) end do i1 = nys + 1 ys(i1:n) = 0.0e0 return end function snrm2 ( n, x, incx ) !*****************************************************************************80 ! !! SNRM2 computes the Euclidean norm of a real vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real X(*), the vector whose norm is to be computed. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Output, real SNRM2, the Euclidean norm of X. ! implicit none real absxi integer incx integer ix integer n real norm real scale real snrm2 real ssq real x(*) if ( n < 1 .or. incx < 1 ) then norm = 0.0E+00 else if ( n == 1 ) then norm = abs ( x(1) ) else scale = 0.0E+00 ssq = 1.0E+00 do ix = 1, 1 + ( n - 1 )*incx, incx if ( x(ix) /= 0.0E+00 ) then absxi = abs ( x(ix) ) if ( scale < absxi ) then ssq = 1.0E+00 + ssq * ( scale / absxi )**2 scale = absxi else ssq = ssq + ( absxi / scale )**2 end if end if end do norm = scale * sqrt( ssq ) end if snrm2 = norm return end subroutine spcck ( spc, isort, nf, spcmn, spcmx, nspc, ispcer ) !*****************************************************************************80 ! !! SPCCK analyzes ordinates for the spectal semi-log plots. ! ! Discussion: ! ! this routine analyzes the ordinates for the spectral semi log ! plots produced by the aspc series of routines. y axis values ! (yord) more than 3 powers of ten less than the next larger ! value are considered insignificant and are culled from the ! ordinates. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & spcmn,spcmx integer & ispcer,nf,nspc ! ! array arguments real & spc(nf) integer & isort(nf) ! ! integer & i,k1,k2,log1,log2 ! ! external subroutines external srtir,srtri ! ! variable definitions (alphabetically) ! ! integer i ! an index variable ! integer isort(nf) ! the array in which the order permutation for the sorted ! data is stored. ! integer ispcer ! an indicator variable used to supress the spectral plots ! when fewer than 1 valid spectral values were computed. ! integer k1, k2 ! index variables. ! integer log1, log2 ! the order of the spectral estimates. ! integer nf ! the number of frequencies for which the spectral estimates ! are to be estimated. ! integer nspc ! the number of valid spectral estimates. ! real spc(nf) ! the array containing the spectral estimates. ! real spcmn, spcmx ! the minimum and maximum spectral value to be plotted. ! ! order the spectral estimates from smallest to largest. ! do i = 1, nf isort(i) = i end do call srtir (isort, nf, spc) ! ! determine significant values to be plotted. ! k1 = nf k2 = k1 if ((spc(nf) <= 0.0e0) .or. (nf == 1)) go to 30 log1 = int ( log10(spc(nf)) ) if (spc(nf) < 1.0e0) log1 = log1 - 1 do i = 2, nf k2 = k1 - 1 if (spc(k2) <= 0.0e0) then exit end if log2 = int ( log10(spc(k2)) ) if (spc(k2) < 1.0e0) then log2 = log2 - 1 end if if (log1-log2 >= 3 .and. nf-k2 >= 5) then exit end if log1 = log2 k1 = k2 end do 30 continue spcmn = spc(k1) nspc = nf + 1 - k1 spcmx = spc(nf) call srtri (spc, nf, isort) ispcer = 0 if (nf-k2 <= 0) ispcer = 1 return end subroutine sppc ( ym, x, n, isym, ilog, isize, nout, ylb, yub, & xlb, xub ) !*****************************************************************************80 ! !! SPPC: simple page plot with user control of plot symbols (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xlb,xub,ylb,yub integer & ilog,isize,n,nout ! ! array arguments real & x(*),ym(*) integer & isym(*) ! ! scalars in common integer & ierr ! ! real & xmiss integer & ischck,iym,lisym,m logical & miss,multi ! ! local arrays real & ymmiss(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'p', 'p', 'c', ' ', ' '/ ymmiss(1) = 1.0e0 xmiss = 1.0e0 m = 1 iym = n multi = .false. ischck = 1 miss = .false. lisym = n call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call sppc (y, x, n, isym, ilog,'/ & ' + isize, nout, ylb, yub, xlb, xub)') end subroutine spp ( ym, x, n, isym ) !*****************************************************************************80 ! !! SPP: simple page plot with user control of plot symbols (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n ! ! array arguments real & x(*),ym(*) integer & isym(*) ! ! scalars in common integer & ierr ! ! real & xlb,xmiss,xub,ylb,yub integer & ilog,ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays real & ymmiss(1) character & nmsub(6)*1 ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! the labeled common for communicating error flags to the user ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'p', 'p', ' ', ' ', ' '/ ymmiss(1) = 1.0e0 xmiss = 1.0e0 m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 1 isize = -1 nout = 0 miss = .false. lisym = n call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call spp (y, x, n, isym)') end subroutine sppl ( ym, x, n, isym, ilog ) !*****************************************************************************80 ! !! SPPL: simple page plot with user control of plot symbols (log option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ilog,n ! ! array arguments real & x(*),ym(*) integer & isym(*) ! ! scalars in common integer & ierr ! ! real & xlb,xmiss,xub,ylb,yub integer & ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays real & ymmiss(1) character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'p', 'p', 'l', ' ', ' '/ ymmiss(1) = 1.0e0 xmiss = 1.0e0 m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 1 isize = -1 nout = 0 miss = .false. lisym = n call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if ( ierr /= 0 ) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call sppl (y, x, n, isym, ilog)') end subroutine sppltc ( xaxis, yaxis, isym, npts, xpltmn, xpltmx, bw, & cilow, cimid, ciup, lpcv ) !*****************************************************************************80 ! !! SPPLTC: confidence interval and bandwidth coordinates for spectrum plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & bw,cilow,cimid,ciup,xpltmn,xpltmx integer & lpcv,npts ! ! array arguments real & xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) ! ! variable definitions (alphabetically) ! ! real bw ! the bandwidth. ! real cilow, cimid, ciup ! the y cordnates for the lower mid and upper confidence ! interval points. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lpcv ! the length of the vectors used for the plots. ! integer npts ! the number of coordinates to be plotted. ! real xaxis(lpcv) ! the x axis values for the spectrum plot. ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real yaxis(lpcv) ! the y axis values for the spectrum plots. ! if (xpltmx - xpltmn < bw) then xpltmx = max(xpltmx + (bw - xpltmx + xpltmn) / 2.0e0, 0.5e0) xpltmn = xpltmx - bw end if npts = npts + 1 xaxis(npts) = xpltmx - 0.5e0 * bw yaxis(npts) = ciup isym(npts) = 7 npts = npts + 1 xaxis(npts) = xpltmx - 0.5e0 * bw yaxis(npts) = cimid isym(npts) = 3 npts = npts + 1 xaxis(npts) = xpltmx - 0.5e0 * bw yaxis(npts) = cilow isym(npts) = 13 npts = npts + 1 xaxis(npts) = xpltmx - bw yaxis(npts) = cimid isym(npts) = 6 npts = npts + 1 xaxis(npts) = xpltmx yaxis(npts) = cimid isym(npts) = 27 return end subroutine sppltd ( spcmn, spcmx, alow, aup, ypltmn, ypltmx, & cilow, cimid, ciup, ymax ) !*****************************************************************************80 ! !! SPTLTD sets various y axis limits for decibel spectrum plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & alow,aup,cilow,cimid,ciup,spcmn,spcmx,ymax,ypltmn,ypltmx real & rngmn,ymin ! ! variable definitions (alphabetically) ! ! real alow, aup ! factors used to compute the confidence intervals. ! real cilow, cimid, ciup ! the y coordnates for the lower mid and upper confidence ! interval points. ! real rngmn ! the minimum y axis range for the plot. ! real spcmn, spcmx ! the minimum and maximum spectral value to be plotted. ! real ymax, ymin ! the maximum and minimum actual spectral value ! (in decibels) to be plotted. ! real ypltmn, ypltmx ! the minimum and maximum vaues to be plotted for the y axis. ! ! set coordinates for decibel plots ! ymax = 10.0e0 * log10(spcmx) ymin = 10.0e0 * log10(spcmn) - ymax ypltmx = 0.0e0 rngmn = 20.0e0 * (log10(aup) - log10(alow)) if (abs(ymin) < rngmn) ypltmx = (rngmn + ymin) * 0.5e0 ypltmn = ymin - ypltmx ciup = ypltmx cimid = ciup - 10.0e0 * log10(aup) cilow = cimid + 10.0e0 * log10(alow) return end subroutine sppltl ( spcmn, spcmx, alow, aup, ypltmn, ypltmx, cilow, cimid, & ciup ) !*****************************************************************************80 ! !! SPPLTL sets various y axis limits for decibel spectrum plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & alow,aup,cilow,cimid,ciup,spcmn,spcmx,ypltmn,ypltmx real & rngmn,ymax,ymin ! ! variable definitions (alphabetically) ! ! real alow, aup ! factors used to compute the confidence intervals. ! real cilow, cimid, ciup ! the y cordnates for the lower mid and upper confidence ! interval points. ! real rngmn ! the minimum y axis range for the plot. ! real spcmn, spcmx ! the minimum and maximum spectral value to be plotted. ! real ymax, ymin ! the maximum and minimum actual spectrum value to be plotted. ! real ypltmn, ypltmx ! the minimum and maximum vaues to be plotted for the y axis. ! ! set coordinates for decibel plots ! ymax = log10(spcmx) ymin = log10(spcmn) ypltmx = spcmx ypltmn = spcmn rngmn = 2.0e0 * (log10(aup) - log10(alow)) if (ymax - ymin < rngmn) then ypltmx = 10.0e0 ** (ymax + (rngmn - ymax + ymin) * 0.5e0) ypltmn = 10.0e0 ** (ymin - (rngmn - ymax + ymin) * 0.5e0) end if ciup = ypltmx cimid = ciup / aup cilow = cimid * alow return end subroutine sppmc ( ym, ymmiss, x, xmiss, n, isym, ilog, isize, nout, & ylb, yub, xlb, xub ) !*****************************************************************************80 ! !! SPPMC: page plot with user plot symbols and missing observations (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xlb,xmiss,xub,ylb,yub integer & ilog,isize,n,nout ! ! array arguments real & x(*),ym(*),ymmiss(1) integer & isym(*) ! ! scalars in common integer & ierr ! ! integer & ischck,iym,lisym,m logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'p', 'p', 'm', 'c', ' '/ m = 1 iym = n multi = .false. ischck = 1 miss = .true. lisym = n call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call sppmc (y, ymiss, x, xmiss, n, isym, ilog,'/ & ' + isize, nout, ylb, yub, xlb, xub)') end subroutine sppm ( ym, ymmiss, x, xmiss, n, isym ) !*****************************************************************************80 ! !! SPPM page plot with user plot symbols and missing observations (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xmiss integer & n ! ! array arguments real & x(*),ym(*),ymmiss(1) integer & isym(*) ! ! scalars in common integer & ierr ! ! real & xlb,xub,ylb,yub integer & ilog,ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'p', 'p', 'm', ' ', ' '/ m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 1 isize = -1 nout = 0 miss = .true. lisym = n call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call sppm (y, ymiss, x, xmiss, n, isym)') end subroutine sppml ( ym, ymmiss, x, xmiss, n, isym, ilog ) !*****************************************************************************80 ! !! SPPML: page plot with user plot symbols, missing observations (log option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xmiss integer & ilog,n ! ! array arguments real & x(*),ym(*),ymmiss(1) integer & isym(*) ! ! scalars in common integer & ierr ! ! real & xlb,xub,ylb,yub integer & ischck,isize,iym,lisym,m,nout logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external ppcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbols for plotting. ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nout ! used to indicate how many of the points outside the bounds ! of the plot are to be listed. ! real x(n) ! vector of observations for x coordinates ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real xmiss ! the missing value code for the x-axis. ! real xub ! the upper bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(n,1) ! vector of observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'p', 'p', 'm', 'l', ' '/ m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 0.0e0 xub = 0.0e0 ischck = 1 isize = -1 nout = 0 miss = .true. lisym = n call ppcnt (ym, ymmiss, x, xmiss, n, m, iym, multi, ilog, & ylb, yub, xlb, xub, nmsub, ischck, isym, isize, nout, miss, & lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call sppml (y, ymiss, x, xmiss, n, isym, ilog)') end subroutine srot ( n, x, incx, y, incy, c, s ) !*****************************************************************************80 ! !! SROT applies a real plane rotation. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input/output, real X(*), one of the vectors to be rotated. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input/output, real Y(*), one of the vectors to be rotated. ! ! Input, integer INCY, the increment between successive elements of Y. ! ! Input, real C, S, parameters (presumably the cosine and sine of ! some angle) that define a plane rotation. ! implicit none real c integer i integer incx integer incy integer ix integer iy integer n real s real stemp real x(*) real y(*) if ( n <= 0 ) then else if ( incx == 1 .and. incy == 1 ) then do i = 1, n stemp = c * x(i) + s * y(i) y(i) = c * y(i) - s * x(i) x(i) = stemp end do else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if do i = 1, n stemp = c * x(ix) + s * y(iy) y(iy) = c * y(iy) - s * x(ix) x(ix) = stemp ix = ix + incx iy = iy + incy end do end if return end subroutine srotg ( sa, sb, c, s ) !*****************************************************************************80 ! !! SROTG constructs a real Givens plane rotation. ! ! Discussion: ! ! Given values A and B, this routine computes ! ! SIGMA = sign ( A ) if abs ( A ) > abs ( B ) ! = sign ( B ) if abs ( A ) <= abs ( B ); ! ! R = SIGMA * ( A * A + B * B ); ! ! C = A / R if R is not 0 ! = 1 if R is 0; ! ! S = B / R if R is not 0, ! 0 if R is 0. ! ! The computed numbers then satisfy the equation ! ! ( C S ) ( A ) = ( R ) ! ( -S C ) ( B ) = ( 0 ) ! ! The routine also computes ! ! Z = S if abs ( A ) > abs ( B ), ! = 1 / C if abs ( A ) <= abs ( B ) and C is not 0, ! = 1 if C is 0. ! ! The single value Z encodes C and S, and hence the rotation: ! ! If Z = 1, set C = 0 and S = 1; ! If abs ( Z ) < 1, set C = sqrt ( 1 - Z * Z ) and S = Z; ! if abs ( Z ) > 1, set C = 1/ Z and S = sqrt ( 1 - C * C ); ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input/output, real SA, SB. On input, SA and SB are the values ! A and B. On output, SA is overwritten with R, and SB is ! overwritten with Z. ! ! Output, real C, S, the cosine and sine of the Givens rotation. ! implicit none real c real r real roe real s real sa real sb real scale real z if ( abs ( sb ) < abs ( sa ) ) then roe = sa else roe = sb end if scale = abs ( sa ) + abs ( sb ) if ( scale == 0.0E+00 ) then c = 1.0E+00 s = 0.0E+00 r = 0.0E+00 else r = scale * sqrt ( ( sa / scale )**2 + ( sb / scale )**2 ) r = sign ( 1.0E+00, roe ) * r c = sa / r s = sb / r end if if ( 0.0E+00 < abs ( c ) .and. abs ( c ) <= s ) then z = 1.0E+00 / c else z = s end if sa = r sb = z return end subroutine srtir ( ir, la, a ) !*****************************************************************************80 ! !! SRTIR sorts an integer array IR on a key array A. ! ! Discussion: ! ! sort integer array ir on key array a. ! if the integer array consists of the ! ordered sequence 1, 2, ... la, then ! on completion ir is a permutation ! vector for the sort of a. ! ! Parameters: ! ! a(la) - on input, contains the array to be sorted on ! on output, a contains the sorted array ! la - input variable containing the number of ! elements in the array to be sorted ! ir(la) - if on input, ir contains the integer values ! 1,2,...,la. ! - then on output, ir contains a record of the ! permutations made on the vector a. ! ! implicit none integer & la ! ! array arguments real & a(la) integer & ir(la) real & r,t,tt integer & i,ij,it,itt,j,k,l,m ! ! local arrays integer & il(21),iu(21) m = 1 i = 1 j = la r = .375e0 10 if (i == j) go to 90 if (r > 0.5898437e0) go to 20 r = r + 3.90625e-2 go to 30 20 r = r - .21875e0 30 k = i ! ! select a central element of the array and save it in location t. ! ij = i + int(real(j-i)*r) t = a(ij) it = ir(ij) ! ! if first element of array is greater than t, interchange with t. ! if ( t < a(i) ) then a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) end if l = j ! ! if last element of array is less than t, interchange with t ! if (a(j) >= t) go to 60 a(ij) = a(j) a(j) = t t = a(ij) ir(ij) = ir(j) ir(j) = it it = ir(ij) ! ! if first element of array is greater than t, interchange with t ! if (a(i) <= t) go to 60 a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) go to 60 50 continue tt = a(l) a(l) = a(k) a(k) = tt itt = ir(l) ir(l) = ir(k) ir(k) = itt 60 continue ! ! find an element in the second half of the array which is smaller than t. ! do l = l - 1 if ( a(l) <= t ) then exit end if end do ! ! find an element in the first half of the array which is greater than t. ! 70 continue k = k + 1 if (a(k)= 1) go to 30 if (i == 1) go to 10 i = i - 1 110 continue i = i + 1 if (i == j) go to 90 t = a(i+1) it = ir(i+1) if (a(i) <= t) go to 110 k = i do a(k+1) = a(k) ir(k+1) = ir(k) k = k - 1 if ( a(k) <= t ) then exit end if end do a(k+1) = t ir(k+1) = it go to 110 end subroutine srtirr ( ir, rr, la, a ) !*****************************************************************************80 ! !! SRTIRR sorts arrays A, IR and RR based on values in A. ! ! Discussion: ! ! this routine sorts the length la array a, the length la ! integer array ir, and the length la array rr into ! ascending order, based on the values in a. the array ! a constitutes the sorting key. the other two arrays are ! carried along. ordinarily the array ir contains the ! values 1, ..., la initially, so that the three arrays can ! later be sorted again with ir as the key, in order to ! restore a and rr to their original order. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & la ! ! array arguments real & a(la),rr(la) integer & ir(la) ! ! real & r,rt,rtt,t,tt integer & i,ij,it,itt,j,k,l,m ! ! local arrays integer & il(21),iu(21) ! ! variable definitions (alphabetically) ! ! real a(la) ! input/output parameter. the key array. ! integer ir(la) ! input/output parameter. the integer array carried along ! in the sort. initially it should contain 1, ..., la. ! on exit it contains the permutation vector of the sort. ! sorting on the permutation vector will restore the key ! array a and the array rr to their original orders. ! integer la ! input parameter. the length of the input/output parameters ! a, ir, and rr. ! real rr(la) ! input/output parameter. the array carried along in ! the sort. it might be the set of weights for a. ! m = 1 i = 1 j = la r = .375e0 10 if (i == j) go to 90 if (r > 0.5898437e0) go to 20 r = r + 3.90625e-2 go to 30 20 r = r - .21875e0 30 k = i ! ! select a central element of the array and save it in location t. ! ij = i + int(real(j-i)*r) t = a(ij) it = ir(ij) rt = rr(ij) ! ! if first element of array is greater than t, interchange with t. ! if (a(i) <= t) go to 40 a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) rr(ij) = rr(i) rr(i) = rt rt = rr(ij) 40 l = j ! ! if last element of array is less than t, interchange with t ! if (a(j) >= t) go to 60 a(ij) = a(j) a(j) = t t = a(ij) ir(ij) = ir(j) ir(j) = it it = ir(ij) rr(ij) = rr(j) rr(j) = rt rt = rr(ij) ! ! if first element of array is greater than t, interchange with t ! if (a(i) <= t) go to 60 a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) rr(ij) = rr(i) rr(i) = rt rt = rr(ij) go to 60 50 tt = a(l) a(l) = a(k) a(k) = tt itt = ir(l) ir(l) = ir(k) ir(k) = itt rtt = rr(l) rr(l) = rr(k) rr(k) = rtt ! ! find an element in the second half of the array which is smaller than t. ! 60 l = l - 1 if (a(l) > t) go to 60 ! ! find an element in the first half of the array which is greater than t ! 70 k = k + 1 if (a(k)= 1) go to 30 if (i == 1) go to 10 i = i - 1 110 i = i + 1 if (i == j) go to 90 t = a(i+1) it = ir(i+1) rt = rr(i+1) if (a(i) <= t) go to 110 k = i 120 a(k+1) = a(k) ir(k+1) = ir(k) rr(k+1) = rr(k) k = k - 1 if (t 0.5898437e0) go to 20 r = r + 3.90625e-2 go to 30 20 r = r - .21875e0 30 k = i ! ! select a central element of the ! array and save it in location it ! ij = i + int(real(j-i)*r) t = a(ij) it = ir(ij) ! ! if first element of array is greater ! than it, interchange with it ! if (ir(i) <= it) go to 40 a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) 40 l = j ! ! if last element of array is less than it, interchange with it. ! if (ir(j) >= it) go to 60 a(ij) = a(j) a(j) = t t = a(ij) ir(ij) = ir(j) ir(j) = it it = ir(ij) ! ! if first element of array is greater than it, interchange with it. ! if (ir(i) <= it) go to 60 a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) go to 60 50 tt = a(l) a(l) = a(k) a(k) = tt itt = ir(l) ir(l) = ir(k) ir(k) = itt ! ! find an element in the second half of the array which is smaller than it. ! 60 l = l - 1 if (ir(l) > it) go to 60 ! ! find an element in the first half of the array which is greater than it. ! 70 k = k + 1 if (ir(k)= 1) go to 30 if (i == 1) go to 10 i = i - 1 110 i = i + 1 if (i == j) go to 90 t = a(i+1) it = ir(i+1) if (ir(i) <= it) go to 110 k = i 120 a(k+1) = a(k) ir(k+1) = ir(k) k = k - 1 if (it 0.5898437e0) go to 20 r = r + 3.90625e-2 go to 30 20 r = r - 0.21875e0 30 k = i ! ! select a central element of the array and save it in location it. ! ij = i + int ( real (j-i) * r ) t = a(ij) it = ir(ij) rt = rr(ij) ! ! if first element of array is greater than it, interchange with it. ! if (ir(i) <= it) go to 40 a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) rr(ij) = rr(i) rr(i) = rt rt = rr(ij) 40 l = j ! ! if last element of array is less than it, interchange with it. ! if (ir(j) >= it) go to 60 a(ij) = a(j) a(j) = t t = a(ij) ir(ij) = ir(j) ir(j) = it it = ir(ij) rr(ij) = rr(j) rr(j) = rt rt = rr(ij) ! ! if first element of array is greater than it, interchange with it. ! if (ir(i) <= it) go to 60 a(ij) = a(i) a(i) = t t = a(ij) ir(ij) = ir(i) ir(i) = it it = ir(ij) rr(ij) = rr(i) rr(i) = rt rt = rr(ij) go to 60 50 continue tt = a(l) a(l) = a(k) a(k) = tt itt = ir(l) ir(l) = ir(k) ir(k) = itt rtt = rr(l) rr(l) = rr(k) rr(k) = rtt ! ! find an element in the second half of the array which is smaller than it. ! 60 l = l - 1 if (ir(l) > it) go to 60 ! ! find an element in the first half of the array which is greater than it. ! 70 k = k + 1 if (ir(k)= 1) go to 30 if (i == 1) go to 10 i = i - 1 110 continue i = i + 1 if (i == j) go to 90 t = a(i+1) it = ir(i+1) rt = rr(i+1) if (ir(i) <= it) go to 110 k = i 120 continue a(k+1) = a(k) ir(k+1) = ir(k) rr(k+1) = rr(k) k = k - 1 if (it < ir(k)) go to 120 a(k+1) = t ir(k+1) = it rr(k+1) = rt go to 110 end subroutine sscal ( n, sa, x, incx ) !*****************************************************************************80 ! !! SSCAL scales a real vector by a constant. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vector. ! ! Input, real SA, the multiplier. ! ! Input/output, real X(*), the vector to be scaled. ! ! Input, integer INCX, the increment between successive entries of X. ! implicit none integer i integer incx integer ix integer m integer n real sa real x(*) if ( n <= 0 ) then else if ( incx == 1 ) then m = mod ( n, 5 ) x(1:m) = sa * x(1:m) do i = m+1, n, 5 x(i) = sa * x(i) x(i+1) = sa * x(i+1) x(i+2) = sa * x(i+2) x(i+3) = sa * x(i+3) x(i+4) = sa * x(i+4) end do else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if do i = 1, n x(ix) = sa * x(ix) ix = ix + incx end do end if return end subroutine ssidi ( a, lda, n, kpvt, det, inert, work, job ) !*****************************************************************************80 ! !! SSIDI computes the determinant, inertia, inverse of a real symmetric matrix. ! ! Discussion: ! ! SSIDI uses the factors from SSIFA. ! ! A division by zero may occur if the inverse is requested ! and SSICO has set RCOND == 0.0E+00 or SSIFA has set INFO /= 0. ! ! Variables not requested by JOB are not used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, ! LINPACK User's Guide, ! SIAM, (Society for Industrial and Applied Mathematics), ! 3600 University City Science Center, ! Philadelphia, PA, 19104-2688. ! ISBN 0-89871-172-X ! ! Parameters: ! ! Input/output, real A(LDA,N). On input, the output from SSIFA. ! On output, the upper triangle of the inverse of the original matrix. ! The strict lower triangle is never referenced. ! ! Input, integer LDA, the leading dimension of the array A. ! ! Input, integer N, the order of the matrix. ! ! Input, integer KPVT(N), the pivot vector from SSIFA. ! ! Output, real DET(2), the determinant of the original matrix, ! if requested. ! determinant = DET(1) * 10.0**DET(2) ! with 1.0E+00 <= abs ( DET(1) ) < 10.0E+00 or DET(1) = 0.0. ! ! Output, integer INERT(3), the inertia of the original matrix. ! INERT(1) = number of positive eigenvalues. ! INERT(2) = number of negative eigenvalues. ! INERT(3) = number of zero eigenvalues. ! ! Workspace, real WORK(N). ! ! Input, integer JOB, specifies the tasks. ! JOB has the decimal expansion ABC where ! If C /= 0, the inverse is computed, ! If B /= 0, the determinant is computed, ! If A /= 0, the inertia is computed. ! For example, JOB = 111 gives all three. ! implicit none integer lda integer n real a(lda,n) real ak real akkp1 real akp1 real d real det(2) logical dodet logical doert logical doinv integer inert(3) integer j integer jb integer job integer k integer kpvt(n) integer ks integer kstep real sdot real t real temp real, parameter :: ten = 10.0E+00 real work(n) doinv = mod ( job, 10 ) /= 0 dodet = mod ( job, 100 ) / 10 /= 0 doert = mod ( job, 1000 ) / 100 /= 0 if ( dodet .or. doert ) then if ( doert ) then inert(1:3) = 0 end if if ( dodet ) then det(1) = 1.0E+00 det(2) = 0.0E+00 end if t = 0.0E+00 do k = 1, n d = a(k,k) ! ! 2 by 2 block. ! ! use det (d s) = (d/t * c - t) * t, t = abs ( s ) ! (s c) ! to avoid underflow/overflow troubles. ! ! Take two passes through scaling. Use T for flag. ! if ( kpvt(k) <= 0 ) then if ( t == 0.0E+00 ) then t = abs ( a(k,k+1) ) d = ( d / t ) * a(k+1,k+1) - t else d = t t = 0.0E+00 end if end if if ( doert ) then if ( 0.0E+00 < d ) then inert(1) = inert(1) + 1 else if ( d < 0.0E+00 ) then inert(2) = inert(2) + 1 else if ( d == 0.0E+00 ) then inert(3) = inert(3) + 1 end if end if if ( dodet ) then det(1) = d * det(1) if ( det(1) /= 0.0E+00 ) then do while ( abs ( det(1) ) < 1.0E+00 ) det(1) = ten * det(1) det(2) = det(2) - 1.0E+00 end do do while ( ten <= abs ( det(1) ) ) det(1) = det(1) / ten det(2) = det(2) + 1.0E+00 end do end if end if end do end if ! ! Compute inverse(A). ! if ( doinv ) then k = 1 do while ( k <= n ) if ( 0 <= kpvt(k) ) then ! ! 1 by 1. ! a(k,k) = 1.0E+00 / a(k,k) if ( 2 <= k ) then work(1:k-1) = a(1:k-1,k) do j = 1, k-1 a(j,k) = sdot ( j, a(1,j), 1, work, 1 ) call saxpy ( j-1, work(j), a(1,j), 1, a(1,k), 1 ) end do a(k,k) = a(k,k) + sdot ( k-1, work, 1, a(1,k), 1 ) end if kstep = 1 ! ! 2 by 2. ! else t = abs ( a(k,k+1) ) ak = a(k,k) / t akp1 = a(k+1,k+1) / t akkp1 = a(k,k+1) / t d = t * ( ak * akp1 - 1.0E+00 ) a(k,k) = akp1 / d a(k+1,k+1) = ak / d a(k,k+1) = -akkp1 / d if ( 2 <= k ) then work(1:k-1) = a(1:k-1,k+1) do j = 1, k-1 a(j,k+1) = sdot ( j, a(1,j), 1, work, 1 ) call saxpy ( j-1, work(j), a(1,j), 1, a(1,k+1), 1 ) end do a(k+1,k+1) = a(k+1,k+1) + sdot ( k-1, work, 1, a(1,k+1), 1 ) a(k,k+1) = a(k,k+1) + sdot ( k-1, a(1,k), 1, a(1,k+1), 1 ) work(1:k-1) = a(1:k-1,k) do j = 1, k-1 a(j,k) = sdot ( j, a(1,j), 1, work, 1 ) call saxpy ( j-1, work(j), a(1,j), 1, a(1,k), 1 ) end do a(k,k) = a(k,k) + sdot ( k-1, work, 1, a(1,k), 1 ) end if kstep = 2 end if ! ! Swap. ! ks = abs ( kpvt(k) ) if ( ks /= k ) then call sswap ( ks, a(1,ks), 1, a(1,k), 1 ) do jb = ks, k j = k + ks - jb temp = a(j,k) a(j,k) = a(ks,j) a(ks,j) = temp end do if ( kstep /= 1 ) then temp = a(ks,k+1) a(ks,k+1) = a(k,k+1) a(k,k+1) = temp end if end if k = k + kstep end do end if return end subroutine ssifa ( a, lda, n, kpvt, info ) !*****************************************************************************80 ! !! SSIFA factors a real symmetric matrix. ! ! Discussion: ! ! To solve A*X = B, follow SSIFA by SSISL. ! ! To compute inverse(A)*C, follow SSIFA by SSISL. ! ! To compute determinant(A), follow SSIFA by SSIDI. ! ! To compute inertia(A), follow SSIFA by SSIDI. ! ! To compute inverse(A), follow SSIFA by SSIDI. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch and Pete Stewart, ! LINPACK User's Guide, ! SIAM, (Society for Industrial and Applied Mathematics), ! 3600 University City Science Center, ! Philadelphia, PA, 19104-2688. ! ISBN 0-89871-172-X ! ! Parameters: ! ! Input/output, real A(LDA,N). On input, the symmetric matrix ! to be factored. Only the diagonal and upper triangle are used. ! On output, a block diagonal matrix and the multipliers which ! were used to obtain it. The factorization can be written A = U*D*U' ! where U is a product of permutation and unit upper triangular ! matrices, U' is the transpose of U, and D is block diagonal ! with 1 by 1 and 2 by 2 blocks. ! ! Input, integer LDA, the leading dimension of the array A. ! ! Input, integer N, the order of the matrix. ! ! Output, integer KPVT(N), the pivot indices. ! ! Output, integer INFO, error flag. ! 0, normal value. ! K, if the K-th pivot block is singular. This is not an error ! condition for this subroutine, but it does indicate that SSISL ! or SSIDI may divide by zero if called. ! implicit none integer lda integer n real a(lda,n) real absakk real ak real akm1 real alpha real bk real bkm1 real colmax real denom integer imax integer info integer isamax integer j integer jj integer jmax integer k integer kpvt(n) integer kstep real mulk real mulkm1 real rowmax logical swap real t ! ! ALPHA is used in choosing pivot block size. ! alpha = ( 1.0E+00 + sqrt ( 17.0E+00 ) ) / 8.0E+00 info = 0 ! ! Main loop on K, which goes from N to 1. ! k = n do while ( 0 < k ) if ( k == 1 ) then kpvt(1) = 1 if ( a(1,1) == 0.0E+00 ) then info = 1 end if return end if ! ! This section of code determines the kind of ! elimination to be performed. When it is completed, ! KSTEP will be set to the size of the pivot block, and ! SWAP will be set to .true. if an interchange is required. ! absakk = abs ( a(k,k) ) ! ! Determine the largest off-diagonal element in column K. ! imax = isamax ( k-1, a(1,k), 1 ) colmax = abs ( a(imax,k) ) if ( alpha * colmax <= absakk ) then kstep = 1 swap = .false. ! ! Determine the largest off-diagonal element in row IMAX. ! else rowmax = 0.0E+00 do j = imax+1, k rowmax = max ( rowmax, abs ( a(imax,j) ) ) end do if ( imax /= 1 ) then jmax = isamax ( imax-1, a(1,imax), 1 ) rowmax = max ( rowmax, abs ( a(jmax,imax) ) ) end if if ( alpha * rowmax <= abs ( a(imax,imax) ) ) then kstep = 1 swap = .true. else if ( alpha * colmax * ( colmax / rowmax ) <= absakk ) then kstep = 1 swap = .false. else kstep = 2 swap = ( imax /= k-1 ) end if end if ! ! Column K is zero. ! Set INFO and iterate the loop. ! if ( max ( absakk, colmax ) == 0.0E+00 ) then kpvt(k) = k info = k ! ! 1 x 1 pivot block. ! ! Perform an interchange. ! else if ( kstep /= 2 ) then if ( swap ) then call sswap ( imax, a(1,imax), 1, a(1,k), 1 ) do jj = imax, k j = k + imax - jj t = a(j,k) a(j,k) = a(imax,j) a(imax,j) = t end do end if ! ! Perform the elimination. ! do jj = 1, k-1 j = k - jj mulk = -a(j,k) / a(k,k) t = mulk call saxpy ( j, t, a(1,k), 1, a(1,j), 1 ) a(j,k) = mulk end do ! ! Set the pivot array. ! if ( swap ) then kpvt(k) = imax else kpvt(k) = k end if ! ! 2 x 2 pivot block. ! ! Perform an interchange. ! else if ( swap ) then call sswap ( imax, a(1,imax), 1, a(1,k-1), 1 ) do jj = imax, k-1 j = k-1 + imax - jj t = a(j,k-1) a(j,k-1) = a(imax,j) a(imax,j) = t end do t = a(k-1,k) a(k-1,k) = a(imax,k) a(imax,k) = t end if ! ! Perform the elimination. ! if ( k-2 /= 0 ) then ak = a(k,k) / a(k-1,k) akm1 = a(k-1,k-1) / a(k-1,k) denom = 1.0E+00 - ak * akm1 do jj = 1, k-2 j = k-1 - jj bk = a(j,k) / a(k-1,k) bkm1 = a(j,k-1) / a(k-1,k) mulk = ( akm1 * bk - bkm1 ) / denom mulkm1 = ( ak * bkm1 - bk ) / denom t = mulk call saxpy ( j, t, a(1,k), 1, a(1,j), 1 ) t = mulkm1 call saxpy ( j, t, a(1,k-1), 1, a(1,j), 1 ) a(j,k) = mulk a(j,k-1) = mulkm1 end do end if ! ! Set the pivot array. ! if ( swap ) then kpvt(k) = -imax else kpvt(k) = 1 - k end if kpvt(k-1) = kpvt(k) end if k = k - kstep end do return end subroutine sswap ( n, x, incx, y, incy ) !*****************************************************************************80 ! !! SSWAP interchanges two real vectors. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Jack Dongarra, Cleve Moler, Jim Bunch, Pete Stewart, ! LINPACK User's Guide, ! SIAM, 1979. ! ! Charles Lawson, Richard Hanson, David Kincaid, Fred Krogh, ! Basic Linear Algebra Subprograms for Fortran Usage, ! Algorithm 539, ! ACM Transactions on Mathematical Software, ! Volume 5, Number 3, September 1979, pages 308-323. ! ! Parameters: ! ! Input, integer N, the number of entries in the vectors. ! ! Input/output, real X(*), one of the vectors to swap. ! ! Input, integer INCX, the increment between successive entries of X. ! ! Input/output, real Y(*), one of the vectors to swap. ! ! Input, integer INCY, the increment between successive elements of Y. ! implicit none integer i integer incx integer incy integer ix integer iy integer m integer n real temp real x(*) real y(*) if ( n <= 0 ) then else if ( incx == 1 .and. incy == 1 ) then m = mod ( n, 3 ) do i = 1, m temp = x(i) x(i) = y(i) y(i) = temp end do do i = m+1, n, 3 temp = x(i) x(i) = y(i) y(i) = temp temp = x(i+1) x(i+1) = y(i+1) y(i+1) = temp temp = x(i+2) x(i+2) = y(i+2) y(i+2) = temp end do else if ( 0 <= incx ) then ix = 1 else ix = ( - n + 1 ) * incx + 1 end if if ( 0 <= incy ) then iy = 1 else iy = ( - n + 1 ) * incy + 1 end if do i = 1, n temp = x(ix) x(ix) = y(iy) y(iy) = temp ix = ix + incx iy = iy + incy end do end if return end subroutine stat1 ( y, n, ymed, ymin, ymax, ymidrg, yrange, ncells, & ylb, yub, ydistr ) !*****************************************************************************80 ! !! STAT1 computes statistics for a sorted vector. ! ! Discussion: ! ! this subroutine is based on a modification of the statis ! code used in omnitab, version 5 (6/16/72), writted by ! sally peavy. the original adaptation to starpac was made ! by janet donaldson. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & ylb,ymax,ymed,ymidrg,ymin,yrange,yub integer & n,ncells ! ! array arguments real & y(n),ydistr(ncells) ! ! real & dely,yt integer & i,ic,ic1,l,m,m1 ! ! variable definitions (alphabetically) ! ! real dely ! the width of an interval one tenth the range of the ! data in y. ! integer i ! a loop index. ! integer ic ! previous sign in runs calculation. ! integer ic1 ! count in frequency distribution calculations. ! integer l ! a loop index. ! integer m ! a loop index. ! integer m1 ! when n is even, m1 is m + 1, otherwise it is m. ! integer n ! input parameter. the length of y and wt. ! integer ncells ! the number of cells in the frequency distribution. ! real y(n) ! input parameter. a set of n data points, sorted ! into ascending order. ! real ydistr(ncells) ! output parameter. the numbers of y values with ! positive weights in each of ncells equal length intervals ! that divide the range of y values. ! real ylb ! the lower bound for the frequency distribution. ! if ylb = yub, the minimum observation will be used. ! real ymax ! output parameter. the maximum of the observations y having ! positive weight. ! real ymed ! output parameter. the median of the observations y. ! real ymidrg ! output parameter. the midrange of the observations y. ! real ymin ! output parameter. the minimum of the observations y having ! positive weight. ! real yrange ! the range of the observations y. ! real yt ! the maximum value in each interval in the frequency ! distributions calculations. ! real yub ! the upper bound for the frequency distribution. ! if ylb = yub, the maximum observation will be used. ! ! calculate the median, midrange, range, and extrema. ! m = (n+1)/2 m1 = m if (mod(n,2) == 0) m1 = m1 + 1 ymed = (y(m)+y(m1))/2.0e0 ymidrg = (y(1)+y(n))/2.0e0 yrange = y(n) - y(1) ymin = y(1) ymax = y(n) ! ! compute frequency distribution. ! if (ncells <= 0) return ic1 = 0 if (ncells == 1) then ydistr(ncells) = real ( n - ic1 ) return end if dely = yrange yt = ymin if ( ylb < yub ) then dely = yub - ylb yt = ylb end if dely = dely / real ( ncells ) yt = yt + dely l = 0 do i = 2, ncells ic = 0 do l = l + 1 if ( l > n ) then exit end if if (y(l) > yt) then exit end if ic = ic + 1 ic1 = ic1 + 1 end do ydistr(i-1) = real ( ic ) l = l - 1 yt = yt + dely end do ydistr(ncells) = real ( n - ic1 ) return end subroutine stat1w ( y, wt, n, ymed, ymin, ymax, ymidrg, yrange, & ncells, ylb, yub, ydistr, nnzw ) !*****************************************************************************80 ! !! STAT1W computes statistics for a sorted vector with weights. ! ! Discussion: ! ! this subroutine is based on a modification of the statis ! code used in omnitab, version 5 (6/16/72), writted by ! sally peavy. the original adaptation to starpac was made ! by janet donaldson. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & ylb,ymax,ymed,ymidrg,ymin,yrange,yub integer & n,ncells,nnzw ! ! array arguments real & wt(n),y(n),ydistr(ncells) ! ! real & dely,yt integer & i,ic,ic1,kk,l,m,m1,max,maxy,miny,n2 ! ! variable definitions (alphabetically) ! ! real dely ! the width of an interval one tenth the range of the ! data in y. ! integer i ! a loop index. ! integer ic ! previous sign in runs calculation. ! integer ic1 ! count in frequency distribution calculations. ! integer kk ! a backwards, boulder, colorado loop index. ! integer l ! a loop index. ! integer m ! a loop index. ! integer max ! index of a maximum element. ! integer maxy ! last element of y, the largest one. ! integer miny ! first element of y, the least one. ! integer m1 ! ... ! integer n ! input parameter. the length of y and wt. ! integer ncells ! the number of cells in the frequency distribution. ! integer nnzw ! input parameter. the number of positive elements in wt. ! integer n2 ! (nnzw + 1)/2 ! real wt(n) ! input parameter. the vector of weights for the ! y observations. ! real y(n) ! input parameter. a set of n data points, sorted ! into ascending order. ! real ydistr(ncells) ! output parameter. the numbers of y values with ! positive weights in each of ten equal length intervals. ! that divide the range of y values. ! real ylb ! the lower bound for the frequency distribution. ! if ylb = yub, the minimum observation will be used. ! real ymax ! output parameter. the maximum of the observations y having ! positive weight. ! real ymed ! output parameter. the median of the observations y. ! real ymidrg ! output parameter. the midrange of the observations y. ! real ymin ! output parameter. the minimum of the observations y having ! positive weight. ! real yrange ! output parameter. the range of the observations y. ! real yt ! the maximum value in each interval in the frequency ! distributions calculations. ! real yub ! the upper bound for the frequency distribution. ! if ylb = yub, the maximum observation will be used. ! ! calculate the median. ! n2 = (nnzw+1)/2 m = 1 do i=1,n if ( i > n2 ) then exit end if m = i if ( wt(m) <= 0.0e0 ) then n2 = n2 + 1 end if end do m1 = m if (mod(nnzw,2) /= 0) go to 40 do m1=m,n if (wt(m1) > 0.0e0) go to 40 end do 40 ymed = (y(i)+y(m1))/2.0e0 ! ! calculate the midrange, range, minimum, and maximum. ! max = n - nnzw + 1 do i=1,max miny = i if (wt(miny) > 0.0e0) then exit end if end do do i=1,max kk = n + 1 - i maxy = kk if (wt(maxy) > 0.0e0) then exit end if end do ymidrg = (y(miny)+y(maxy))/2.0e0 yrange = y(maxy) - y(miny) ymin = y(miny) ymax = y(maxy) ! ! compute frequency distribution ! dely = yrange yt = ymin if ( ylb < yub ) then dely = yub - ylb yt = ylb end if dely = dely / real ( ncells ) yt = yt + dely l = 0 ic1 = 0 do i=2,ncells ic = 0 do l = l + 1 if (l > n) then exit end if if (wt(l) <= 0.0e0) then cycle end if if (y(l) > yt) then exit end if ic = ic + 1 ic1 = ic1 + 1 end do ydistr(i-1) = real ( ic ) l = l - 1 yt = yt + dely end do ydistr(ncells) = real ( nnzw - ic1 ) return end subroutine stat2 ( y, n, sts, sumda, sumdi, sumd2, sumd3, sumd4 ) !*****************************************************************************80 ! !! STAT2 computes statistics that do not require sorted data. ! ! Discussion: ! ! this subroutine computes for a vector y the statistics that do ! not require sorting of the vector, that is, those not computed ! by stat1. no weights are used. ! ! this subroutine is based on a modification of the statis ! code used in omnitab, version 5 (6/16/72), written by ! sally peavy. the original adaptation to starpac was ! done by janet donaldson. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & sumd2,sumd3,sumd4,sumda,sumdi integer & n ! ! array arguments real & sts(53),y(n) ! ! scalars in common integer & ierr ! ! real & dif,t,ta,tk1,tk2 integer & i,ic,ici,idruns,iminus,iplus,irun ! ! external functions real & cdff,ppfchs,ppft external cdff,ppfchs,ppft ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real dif ! the sum of the differences between succeeding elements ! in y. ! integer i ! a loop index. ! integer ic ! previous sign in runs calculation. ! integer ici ! current sign in runs calculation. ! integer idruns ! the number of runs. ! integer ierr ! an error flag set in common errchk. ! integer iminus, iplus ! counts of signs of deviations. ! integer irun ! the number of runs up and down. ! integer n ! input parameter. the length of y and wt. ! real sts(53) ! output parameter. the vector of 53 statistics computed. ! row statistic row statistic ! 1 length of vector tests for nonrandomness ! 2 number of nonzero weights 23 number of runs up and down ! measures of location 24 expected number of runs ! 3 unweighted mean 25 s.d. of number of runs ! 4 weighted mean 26 mean sqr. successive diff. ! 5 median 27 mean sqr. succ. diff./var. ! 6 mid-range deviations from wtd mean ! 7 25 p.c. unwtd. trimmed mean 28 number of + signs ! 8 25 p.c. wtd. trimmed mean 29 number of - signs ! measures of dispersion 30 number of runs ! 9 standard deviation (s.d.) 31 expected number of runs ! 10 s.d. of mean 32 s.d. of runs ! 11 range 33 diff./s.d. of runs ! 12 mean variation other statistics ! 13 variance (var.) 34 minimum ! 14 coefficient of variation 35 maximum ! confidence intervals 36 beta 1 ! 15 lower confidence limit, mean 37 beta 2 ! 16 upper confidence limit, mean 38 wtd. sum of values ! 17 lower confidence limit, s.d. 39 wtd. sum of squares ! 18 upper confidence limit, s.d. 40 wtd. sum of sqrd. devs. ! linear trend statistics 41 students t ! 19 slope 42 wtd. sum of abs. values ! 20 s.d. of slope 43 wtd. avg. abs. values ! 21 slope/s.d. of slope = t 44-53 freq. distribution ! 22 prob ( x > abs(obs. t)) ! real sumda ! input parameter. the sum of the absolute values of the ! differences diff. ! real sumdi ! input parameter. the sum of the products of i and the ! ith difference diff. ! real sumd2 ! input parameter. the sum of the squares of the ! differences diff. ! real sumd3 ! input parameter. the sum of the cubes of the ! differences diff. ! real sumd4 ! input parameter. the sum of the hypercubes of the ! differences diff. ! real t ! a residual (y(i) - meany) ! real ta ! a temporary variable in the runs calculation. ! real tk1, tk2 ! chi-squared values. ! real y(n) ! input parameter. a set of n data points, sorted ! into ascending order. ! ! begin storage of statistics. ! sts(1) = real ( n ) sts(2) = sts(1) sts(24) = (2.0e0*sts(1)-1.0e0)/3.0e0 sts(25) = sqrt((16.0e0*sts(1)-29.0e0)/90.0e0) sts(43) = sts(42)/sts(1) ! ! compute residuals and standard deviations. ! ici = 0 iplus = 0 iminus = 0 idruns = 0 ic = 0 do i=1,n t = y(i) - sts(4) if ( t < 0.0e0 ) then iminus = iminus + 1 ici = -1 else iplus = iplus + 1 ici = +1 end if if (ic /= ici) then ic = ici idruns = idruns + 1 end if end do sts(28) = real ( iplus ) sts(29) = real ( iminus ) sts(31) = 1.0e0 + (2.0e0*sts(28)*sts(29)/sts(1)) sts(32) = sqrt((2.0e0*sts(28)*sts(29)* & (2.0e0*sts(28)*sts(29) - & sts(28)-sts(29)))/ & ((sts(28)+sts(29))**2*(sts(1)-1.0e0))) sts(30) = real ( idruns ) sts(33) = 0.0e0 if (sts(32) /= 0.0e0) & sts(33) = (sts(30)-sts(31))/sts(32) sts(13) = sumd2/(sts(1)-1.0e0) sts(9) = sqrt(sts(13)) sts(10) = sts(9)/sqrt(sts(1)) if (sts(4) /= 0.0e0) & sts(14) = 100.0e0*abs(sts(9)/sts(4)) if (sts(4) == 0.0e0) sts(14) = 0.0e0 sts(36) = 0.0e0 if (sumd2 > 0.0e0) & sts(36) = (sumd3/sts(1))**2/((sumd2/sts(1))**3) sts(37) = 0.0e0 if (sumd2 > 0.0e0) & sts(37) = (sumd4/sts(1))/((sumd2/sts(1))**2) sts(40) = sumd2 sts(19) = (12.0e0*sumdi)/(sts(1)*(sts(1)**2-1.0e0)) sts(20) = (1.0e0/(sts(1)-2.0e0)* & (12.0e0*(sumd2/(sts(1)*(sts(1)**2-1.0e0)))- & sts(19)**2)) if (sts(20) <= 0.0e0) sts(20) = 0.0e0 sts(20) = sqrt(sts(20)) if (sts(20) == 0.0e0) sts(21) = 0.0e0 if (sts(20) > 0.0e0) sts(21) = sts(19)/sts(20) sts(22) = 1.0e0 - cdff(sts(21)*sts(21), 1.0e0, sts(1)-2.0e0) ! ! compute number of runs in the data. ! dif = 0.0e0 irun = 1 ta = 0.0e0 do i=1,n if ( i >= n ) then exit end if ta = y(i+1) - y(i) if ( ta /= 0.0e0 ) then exit end if end do do i=1,n if ( i == n ) then cycle end if t = y(i+1) - y(i) dif = dif + t*t if (ta*t < 0.0e0) then ta = t irun = irun + 1 end if end do sts(23) = real ( irun ) sts(26) = dif/(sts(1)-1.0e0) sts(27) = 0.0e0 if (sts(13) /= 0.0e0) & sts(27) = sts(26)/sts(13) sts(41) = 0.0e0 if (sts(9) /= 0.0e0) & sts(41) = (sts(4)*sqrt(sts(1)))/sts(9) sts(12) = sumda/sts(1) t = ppft(0.975e0, n-1) tk1 = ppfchs(0.975e0, n-1) tk2 = ppfchs(0.025e0, n-1) sts(15) = sts(4) - t*sts(10) sts(16) = sts(4) + t*sts(10) sts(17) = sqrt((sts(1)-1.0e0)/tk1)*sts(9) sts(18) = sqrt((sts(1)-1.0e0)/tk2)*sts(9) return end subroutine stat2w ( y, wt, n, nnzw, sts, sumda, sumdi, sumwd2, & sumd2, sumd3, sumd4, sumw ) !*****************************************************************************80 ! !! STAT2W computes statistics on an unsorted, weighted vector. ! ! Discussion: ! ! this subroutine computes for a vector y the statistics that do ! not require sorting of the vector, that is, those not computed ! by stat1w. weights are used in the calculations. ! ! this subroutine is based on a modification of the statis ! code used in omnitab, version 5 (6/16/72), written by ! sally peavy. the original adaptation to starpac was ! done by janet donaldson. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & sumd2,sumd3,sumd4,sumda,sumdi,sumw,sumwd2 integer & n,nnzw ! ! array arguments real & sts(53),wt(n),y(n) ! ! scalars in common integer & ierr ! ! real & dif,t,ta,tk1,tk2 integer & i,ic,ici,icount,idruns,iminus,iplus,irun,j ! ! external functions real & cdff,ppfchs,ppft external cdff,ppfchs,ppft ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real dif ! the sum of the differences between succeeding elements ! in y. ! integer i ! a loop index. ! integer ic ! previous sign in runs calculation. ! integer ici ! current sign in runs calculation. ! integer icount ! used in runs calculations. ! integer idruns ! the number of runs. ! integer ierr ! an error flag set in common errchk. ! integer iminus, iplus ! counts of signs of deviations. ! integer irun ! the number of runs up and down. ! integer j ! a loop index. ! integer n ! input parameter. the length of y and wt. ! integer nnzw ! input parameter. the number of positive elements in wt. ! real sts(53) ! output parameter. the vector of 53 statistics computed. ! row statistic row statistic ! 1 length of vector tests for nonrandomness ! 2 number of nonzero weights 23 number of runs up and down ! measures of location 24 expected number of runs ! 3 unweighted mean 25 s.d. of number of runs ! 4 weighted mean 26 mean sqr. successive diff. ! 5 median 27 mean sqr. succ. diff./var. ! 6 mid-range deviations from wtd mean ! 7 25 p.c. unwtd. trimmed mean 28 number of + signs ! 8 25 p.c. wtd. trimmed mean 29 number of - signs ! measures of dispersion 30 number of runs ! 9 standard deviation (s.d.) 31 expected number of runs ! 10 s.d. of mean 32 s.d. of runs ! 11 range 33 diff./s.d. of runs ! 12 mean variation other statistics ! 13 variance (var.) 34 minimum ! 14 coefficient of variation 35 maximum ! confidence intervals 36 beta 1 ! 15 lower confidence limit, mean 37 beta 2 ! 16 upper confidence limit, mean 38 wtd. sum of values ! 17 lower confidence limit, s.d. 39 wtd. sum of squares ! 18 upper confidence limit, s.d. 40 wtd. sum of sqrd. devs. ! linear trend statistics 41 students t ! 19 slope 42 wtd. sum of abs. values ! 20 s.d. of slope 43 wtd. avg. abs. values ! 21 slope/s.d. of slope = t 44-53 freq. distribution ! 22 prob ( x > abs(obs. t)) ! real sumda ! input parameter. the sum of the absolute values of the ! differences diff. ! real sumdi ! input parameter. the sum of the products of i and the ! ith difference diff. ! real sumd2 ! input parameter. the sum of the squares of the ! differences diff. ! real sumd3 ! input parameter. the sum of the cubes of the ! differences diff. ! real sumd4 ! input parameter. the sum of the hypercubes of the ! differences diff. ! real sumw ! input parameter. the sum of the weights vector wt. ! real sumwd2 ! input parameter. the weighted sum of the squared ! differences diff. ! real t ! a residual (y(i) - meany) ! real ta ! a temporary variable in the runs calculation. ! real tk1, tk2 ! chi-squared values. ! real wt(n) ! input parameter. the vector of weights for the ! y observations. ! real y(n) ! input parameter. a set of n data points, sorted ! into ascending order. ! sts(1) = real ( n ) sts(2) = real ( nnzw ) sts(24) = (2.0e0*sts(2)-1.0e0)/3.0e0 sts(25) = sqrt((16.0e0*sts(2)-29.0e0)/90.0e0) sts(43) = sts(42)/sumw ! ! compute residuals and standard deviations. ! ici = 0 iplus = 0 iminus = 0 idruns = 0 ic = 0 do i=1,n if (wt(i) <= 0.0e0) then cycle end if t = y(i) - sts(4) if ( t < 0.0e0 ) then iminus = iminus + 1 ici = -1 else iplus = iplus + 1 ici = 1 end if if ( ic /= ici ) then ic = ici idruns = idruns + 1 end if end do sts(28) = real ( iplus ) sts(29) = real ( iminus ) sts(31) = 1.0e0 + (2.0e0*sts(28)*sts(29)/sts(2)) sts(32) = & sqrt((2.0e0*sts(28)*sts(29)*(2.0e0*sts(28)*sts(29)- & sts(28)-sts(29)))/ & ((sts(28)+sts(29))**2*(sts(2)-1.0e0))) sts(30) = real ( idruns ) sts(33) = 0.0e0 if (sts(32) /= 0.0e0) & sts(33) = (sts(30)-sts(31))/sts(32) sts(13) = sumwd2/(sts(2)-1.0e0) sts(9) = sqrt(sts(13)) sts(10) = sts(9)/(sqrt(sumw)) if (sts(4) /= 0.0e0) & sts(14) = 100.0e0*abs(sts(9)/sts(4)) if (sts(4) == 0.0e0) sts(14) = 0.0e0 sts(36) = 0.0e0 if (sumd2 /= 0.0e0) & sts(36) = (sumd3/sts(2))**2/((sumd2/sts(2))**3) sts(37) = 0.0e0 if (sumd2 /= 0.0e0) & sts(37) = (sumd4/sts(2))/((sumd2/sts(2))**2) sts(40) = sumwd2 sts(19) = (12.0e0*sumdi)/(sts(2)*(sts(2)**2-1.0e0)) sts(20) = (1.0e0/(sts(2)-2.0e0)* & (12.0e0*(sumd2/(sts(2)*(sts(2)**2-1.0e0)))- & sts(19)**2)) if (sts(20) <= 0.0e0) sts(20) = 0.0e0 sts(20) = sqrt(sts(20)) if (sts(20) == 0.0e0) sts(21) = 0.0e0 if (sts(20) > 0.0e0) sts(21) = sts(19)/sts(20) sts(22) = 1.0e0 - cdff(sts(21)*sts(21), 1.0e0, sts(2)-2.0e0) ! ! compute number of runs in the data. ! dif = 0.0e0 irun = 1 ta = 0.0e0 do i=1,n if (i >= n) then exit end if if ( wt(i) <= 0.0e0 ) then cycle end if j = i 40 continue j = j + 1 if (j >= n) go to 60 if (wt(j) <= 0.0e0) go to 40 ta = y(j) - y(i) if (ta /= 0.0e0) then exit end if end do 60 icount = 0 do i=1,n if (wt(i) <= 0.0e0) then cycle end if icount = icount + 1 if (icount >= nnzw) then cycle end if j = i do j = j + 1 if ( 0.0E+00 < wt(j) ) then exit end if end do t = y(j) - y(i) dif = dif + t*t if ( ta * t < 0.0e0 ) then ta = t irun = irun + 1 end if end do sts(23) = real ( irun ) sts(26) = dif/(sts(2)-1.0e0) sts(27) = 0.0e0 if (sts(13) /= 0.0e0) then sts(27) = sts(26)/sts(13) end if sts(41) = 0.0e0 if (sts(9) /= 0.0e0) & sts(41) = (sts(4)*sqrt(sumw))/sts(9) sts(12) = sumda/sts(2) t = ppft(0.975e0, nnzw-1) tk1 = ppfchs(0.975e0, nnzw-1) tk2 = ppfchs(0.025e0, nnzw-1) sts(15) = sts(4) - t*sts(10) sts(16) = sts(4) + t*sts(10) sts(17) = sqrt((sts(2)-1.0e0)/tk1)*sts(9) sts(18) = sqrt((sts(2)-1.0e0)/tk2)*sts(9) return end subroutine stater ( nmsub, wt, n, ldstak, wts, nnzw, stack, ierr ) !*****************************************************************************80 ! !! STATER does error checking for the STAT family of routines. ! ! Discussion: ! ! this subroutine checks input parameters to the user ! callable members of the stat family of routines ! for errors and reports any that it finds, besides ! returning a flag indicating that errors have been ! found. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ierr,ldstak,n,nnzw logical & stack,wts ! ! array arguments real & wt(*) character & nmsub(6)*1 ! ! integer & ldsmin,nzw logical & head,ier1,ier2,ier3 ! ! local arrays character & llds(8)*1,ln(8)*1,lthree(8)*1,lwt(8)*1 ! ! external subroutines external eisge,ervwt,ldscmp ! ! variable definitions (alphabetically) ! ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! output parameter. a flag indicating whether or ! not an error has been found. 0 = ok, 1 = error. ! logical ier1 ! true if n < 3 ! logical ier2 ! true if ldstak < (n + 13)/2.0e0 ! logical ier3 ! true if some wt < 0.0e0 or nnzw < 3 ! integer ldsmin ! minimum length of framework area in double ! precision elements. ! integer ldstak ! input parameter. the number of locations provided in ! the framework area. ! character*1 llds(8), ln(8), lthree(8), lwt(8) ! the array(s) containing the name(s) fo the varialbe(s) checked ! for errors ! integer n ! input parameter. the number of elements in y and wt. ! character*1 nmsub(6) ! the name of the calling subroutine ! integer nnzw ! output parameter. if wts, then set equal to the ! number of values in wt which are positive. else, ! undefined. ! integer nzw ! the number of zero weights. ! logical stack ! a flag indicating whether this routine uses the stack (true) ! or not (false). ! real wt(n) ! input parameter. the vector of weights corresponding ! to the vector y. ! logical wts ! input parameter. a flag indicating whether or not ! there is really a vector wt (true), or only a dummy parameter ! (false). ! ! initialize name vectors ! data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) / 'l', 'd', 's', 't', 'a', 'k', ' ', ' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), & ln(7), ln(8) / 'n', ' ', ' ', ' ', ' ', ' ', ' ', ' '/ data lthree(1),lthree(2),lthree(3),lthree(4),lthree(5),lthree(6), & lthree(7), lthree(8) / 't', 'h', 'r', 'e', 'e', ' ', ' ', ' '/ data lwt(1), lwt(2), lwt(3), lwt(4), lwt(5), lwt(6), & lwt(7), lwt(8) / 'w', 't', ' ', ' ', ' ', ' ', ' ', ' '/ ! ! initialize error flags ! ier1 = .false. ier2 = .false. ier3 = .false. ierr = 0 head = .true. ! ! Check to see that there are at least three data points. ! call eisge(nmsub, ln, n, 3, 2, head, ier1, lthree) ! ! Check to see that an amount of work area equal ! in length to the requirements of the permutation ! vector will be available. ! if (stack) then call ldscmp(1, 0, n, 0, 0, 0, 's', 0, ldsmin) call eisge(nmsub, llds, ldstak, ldsmin, 9, head, ier2, llds) end if ! ! If there are weights, check that at least three data items have ! nonzero weights. ! nnzw = n if (wts) then call ervwt(nmsub, lwt, wt, n, 3, head, nnzw, nzw, 1, ier3, lthree) end if if (ier1 .or. ier2 .or. ier3) ierr = 1 return end subroutine stat_external ( y, n, ldstak ) !*****************************************************************************80 ! !! stat_external() computes 53 statistics for an unweighted vector. ! ! Discussion: ! ! The original subroutine name "stat()" conflicted with an intrinsic. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ldstak,n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,sumd2,sumd3,sumd4,sumda,sumdi,sumt1 integer & idp,iint,lsort,mid,nall0,nnzw logical & stack,wts ! ! local arrays real & sts(53),wt(1) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external geni,srtir,srtri,stat1,stat2,stater,stkclr,stkset, & sumbs,sumds,sumid,sumot,sumss,sumts ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real alpha ! the percentage to be trimmed off each end of y for the ! trimmed means calculations. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idp ! the code value for double precision for framework. ! integer ierr ! the code indicating whether or not an error has ! been discovered. 0 means no error, not 0 means ! some error exists. ! integer iint ! the code value for integer for framework ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! input parameter. the number of double precision ! elements dimensioned for dstak in the user program. ! integer lsort ! the starting location in istak of the permutation ! vector. ! integer mid ! the index of the (an) element of y closest to zero, when ! y has been sorted. ! integer n ! input parameter. the length of y. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nnzw ! number of nonzero weights. ! logical stack ! a flag indicating whether this routine uses the stack (true) ! or not (false). ! real sts(53) ! the vector of the 53 statistics computed. ! real sumda ! the sum of the absolute differences from the mean. ! real sumdi ! the sum of the products of the indices and the differences. ! real sumd2 ! the sum of the squares of the differences. ! real sumd3 ! the sum of the cubes of the differences. ! real sumd4 ! the sum of the 4th powers of the differences. ! real sumt1 ! the sum of the alpha trimmed array y. ! real wt(1) ! the dummy weights vector. ! logical wts ! a flag indicating whether there are weights (true) ! or not (false). ! real y(n) ! input parameter. the vector of data points on which ! the statistics are computed. y is sorted, but restored ! to its original order afterwards. ! ! initialize name vectors ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 't', 'a', 't', ' ', ' '/ data alpha /0.25e0/ data idp /4/ data iint /2/ data wts /.false./ data stack /.true./ ! ! check for errors in the input parameters ! call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr) ! ! print error message. ! if (ierr /= 0) then write ( *,1000) return end if ! ! set up framework area. ! call stkset (ldstak, idp) nall0 = stkst(1) ! ! set up lsort, the permutation vector. ! lsort = stkget(n,iint) call geni(istak(lsort), n, 1, 1) ! ! sort the vector y. ! call srtir(istak(lsort), n, y) ! ! compute the statistics which use a sorted array. ! call stat1(y, n, sts(5), sts(34), sts(35), sts(6), & sts(11), 10, 0.0e0, 0.0e0, sts(44)) ! ! calculate sums of the sorted array. ! call sumbs(y, n, 1, mid, n) call sumss(y, n, 1, mid, n, sts(38), sts(39), sts(42), & sts(3)) sts(4) = sts(3) call sumts(y, n, alpha, sumt1, sts(7)) sts(8) = sts(7) call sumds(y, n, 1, mid, n, sts(3), sumda, sumd2, sumd3, sumd4) ! ! restore the vector y to its original order. ! call srtri(y, n, istak(lsort)) ! ! compute rest of statistics. ! call sumid(y, n, sts(3), sumdi) call stat2(y, n, sts, sumda, sumdi, sumd2, sumd3, sumd4) call sumot(sts, n, n, wts) ! ! return the vector lsort. ! call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call stat_external (y, n, ldstak)') end subroutine stats ( y, n, ldstak, sts, nprt ) !*****************************************************************************80 ! !! STATS computes 53 different statistics for an unweighted vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ldstak,n,nprt ! ! array arguments real & sts(53),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,sumd2,sumd3,sumd4,sumda,sumdi,sumt1 integer & idp,iint,lsort,mid,nall0,nnzw logical & stack,wts ! ! local arrays real & wt(1) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external geni,srtir,srtri,stat1,stat2,stater,stkclr,stkset, & sumbs,sumds,sumid,sumot,sumss,sumts ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real alpha ! the percentage to trim from each end in the trimmed ! means. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idp ! framework code value for double precision numbers. ! integer ierr ! the code indicating whether or not an error has ! been discovered. 0 means no error, not 0 means ! some error exists. ! integer iint ! the code value for integer for framework. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! input parameter. the number of double precision ! elements dimensioned for dstak in the user program. ! integer lsort ! the starting location in istak of the permutation ! vector. ! integer mid ! in the sorted array y, a point equal to or the point ! closest to, zero. ! integer n ! input parameter. the length of y. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! input parameter. flag to control output. ! 0 means no output. other values mean output. ! integer nnzw ! number of nonzero weights. ! logical stack ! a flag indicating whether this routine uses the stack (true) ! or not (false). ! real sts(53) ! output parameter. the vector of the 53 statistics computed. ! real sumda ! the sum of the absolute values of the differences from ! the mean. ! real sumdi ! the sum of the products of the index and differences. ! real sumd2 ! the sum of the square of the differences. ! real sumd3 ! the sum of the cube of the differences. ! real sumd4 ! the sum of the 4th powers of the differences. ! real sumt1 ! the trimmed unweighted simple sum of elements in y. ! real wt(1) ! the dummy weights vector. ! logical wts ! a flag indicating whether there are weights (true) ! or not (false). ! real y(n) ! input parameter. the vector of data points on which ! the statistics are computed. y is sorted, but restored ! to its original order afterwards. ! ! initialize name vectors ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 't', 'a', 't', 's', ' '/ data alpha /0.25e0/ data idp /4/ data iint /2/ data wts /.false./ data stack /.true./ ! ! check for errors in the input parameters. ! call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr) if (ierr /= 0) then ! ! set up the output unit number. ! write ( *,1000) return end if ! ! set up framework area ! call stkset (ldstak, idp) nall0 = stkst(1) ! ! set up lsort, the permutation vector. ! lsort = stkget(n,iint) call geni(istak(lsort), n, 1, 1) ! ! sort the vector y. ! call srtir(istak(lsort), n, y) ! ! compute the statistics which use a sorted array. ! call stat1(y, n, sts(5), sts(34), sts(35), sts(6), & sts(11), 10, 0.0e0, 0.0e0, sts(44)) ! ! calculate sums of the sorted array. ! call sumbs(y, n, 1, mid, n) call sumss(y, n, 1, mid, n, sts(38), sts(39), sts(42), & sts(3)) sts(4) = sts(3) call sumts(y, n, alpha, sumt1, sts(7)) sts(8) = sts(7) call sumds(y, n, 1, mid, n, sts(3), sumda, sumd2, sumd3, sumd4) ! ! restore the vector y to its original order. ! call srtri(y, n, istak(lsort)) ! ! compute rest of statistics. ! call sumid(y, n, sts(3), sumdi) call stat2(y, n, sts, sumda, sumdi, sumd2, sumd3, sumd4) if (nprt /= 0) call sumot(sts, n, n, wts) ! ! return the vector lsort. ! call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call stats (y, n, ldstak, sts, nprt)') end subroutine statw ( y, wt, n, ldstak ) !*****************************************************************************80 ! !! STATW computes 53 statistics for a weighted vector. ! ! Discussion: ! ! this subroutine computes 53 different statistics for a ! vector y, with weights specified. one page of automatic ! printout is produced. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ldstak,n ! ! array arguments real & wt(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,sum1,sumd2,sumd3,sumd4,sumda,sumdi,sumt1,sumw,sumwd2, & sumwt1 integer & idp,iint,lsort,mid,nall0,nnzw logical & stack,wts ! ! local arrays real & sts(53) integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external geni,srtirr,srtrri,stat1w,stat2w,stater,stkclr, & stkset,sumbs,sumidw,sumot,sumwds,sumwss,sumwts ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real alpha ! the percentage of points to be trimmed from either end of ! y in calculating the trimmed means. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idp ! framework code value for double precision numbers. ! integer ierr ! the code indicating whether or not an error has ! been discovered. 0 means no error, not 0 means ! some error exists. ! integer iint ! the code value for integer for framework. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! input parameter. the number of double precision ! elements dimensioned for dstak in the user program. ! integer lsort ! the starting location in istak of the permutation ! vector. ! integer mid ! the index of a zero element in the sorted y, or of the ! element closest to zero. ! integer n ! input parameter. the length of y. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nnzw ! number of nonzero weights. ! logical stack ! a flag indicating whether this routine uses the stack (true) ! or not (false). ! real sts(53) ! the vector of the 53 statistics computed. ! real sumda ! the sum of the absolute differences from the mean. ! real sumdi ! the sum of the products of the indices and the ! differences. ! real sumd2 ! the sum of the squares of the differences. ! real sumd3 ! the sum of the cubes of the differences. ! real sumd4 ! the sum of the 4th powers of the differences. ! real sumt1 ! the sum of the alpha trimmed array y. ! real sumw ! the sum of the weights vector wt. ! real sumwd2 ! the weighted sum of the squares of the differences. ! real sumwt1 ! the weighted sum of the alpha trimmed array. ! real sum1 ! the unweighted sum of the elements of y. ! real wt(n) ! input parameter. the weights vector. ! logical wts ! a flag indicating whether there are weights (true) ! or not (false). ! real y(n) ! input parameter. the vector of data points on which ! the statistics are computed. y is sorted, but restored ! to its original order afterwards. ! ! initialize name vectors ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 't', 'a', 't', 'w', ' '/ data alpha /0.25e0/ data idp /4/ data iint /2/ data wts /.true./ data stack /.true./ ! ! check for errors in the input parameters. ! call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr) if (ierr /= 0) then ! ! print error message. ! write ( *,1000) return end if ! ! set up framework area. ! call stkset (ldstak, idp) nall0 = stkst(1) ! ! set up lsort, the permutation vector. ! lsort = stkget(n,iint) call geni(istak(lsort), n, 1, 1) ! ! sort the vector y. ! call srtirr(istak(lsort), wt, n, y) ! ! compute the statistics which use a sorted array. ! call stat1w(y, wt, n, sts(5), sts(34), sts(35), sts(6), & sts(11), 10, 0.0e0, 0.0e0, sts(44), nnzw) ! ! computed various sums in the sorted array y. ! call sumbs(y, n, 1, mid, n) call sumwss(y, wt, n, 1, mid, n, nnzw, sum1, sts(38), sts(39), & sts(42), sumw, sts(3), sts(4)) call sumwts(y, wt, n, nnzw, alpha, sumt1, sumwt1, sts(7), & sts(8)) call sumwds(y, wt, n, 1, mid, n, sts(4), sumda, sumwd2, sumd2, & sumd3, sumd4) ! ! restore the vector y to its original order. ! call srtrri(y, wt, n, istak(lsort)) ! ! compute rest of statistics. ! call sumidw(y, wt, n, sts(4), sumdi) call stat2w(y, wt, n, nnzw, sts, sumda, sumdi, sumwd2, sumd2, & sumd3, sumd4, sumw) call sumot(sts, n, nnzw, wts) ! ! return the vector lsort. ! call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call statw (y, wt, n, ldstak)') end subroutine statws ( y, wt, n, ldstak, sts, nprt ) !*****************************************************************************80 ! !! STATWS computes 53 statistics for a weighted vector. ! ! Discussion: ! ! this subroutine computes 53 different statistics for a vector ! y, with weights specified. one page of automatic ! printout is produced. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ldstak,n,nprt ! ! array arguments real & sts(53),wt(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,sum1,sumd2,sumd3,sumd4,sumda,sumdi,sumt1,sumw,sumwd2, & sumwt1 integer & idp,iint,lsort,mid,nall0,nnzw logical & stack,wts ! ! local arrays integer & istak(12) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external geni,srtirr,srtrri,stat1w,stat2w,stater,stkclr, & stkset,sumbs,sumidw,sumot,sumwds,sumwss,sumwts ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real alpha ! the percentage to be trimmed from each end of the ! sorted array y. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer idp ! framework code value for double precision numbers. ! integer ierr ! the code indicating whether or not an error has ! been discovered. 0 means no error, not 0 means ! some error exists. ! integer iint ! the code value for integer for framework. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer ldstak ! input parameter. the number of double precision ! elements dimensioned for dstak in the user program. ! integer lsort ! the starting location in istak of the permutation vector. ! integer mid ! the index of a zero element in the sorted y, or of the ! element closest to zero. ! integer n ! input parameter. the length of y. ! integer nall0 ! the number of allocations outstanding at the time this routine ! was called. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! input parameter. the code indicating whether printout ! is desired. 0 means no printout, not 0 means printout. ! integer nnzw ! number of nonzero weights. ! logical stack ! a flag indicating whether this routine uses the stack (true) ! or not (false). ! real sts(53) ! output parameter. the vector of the 53 statistics computed. ! real sumda ! the sum of the absolute differences from the mean. ! real sumdi ! the sum of the products of the indices and the ! differences. ! real sumd2 ! the sum of the squares of the differences. ! real sumd3 ! the sum of the cubes of the differences. ! real sumd4 ! the sum of the 4th powers of the differences. ! real sumt1 ! the sum of the alpha trimmed array y. ! real sumw ! the sum of the weights vector wt. ! real sumwd2 ! the weighted sum of the squares of the differences. ! real sumwt1 ! the weighted sum of the alpha trimmed array. ! real sum1 ! the sum of the elements of x. a dummy variable. ! real wt(n) ! input parameter. the weights vector. ! logical wts ! a flag indicating whether there are weights (true) ! or not (false). ! real y(n) ! input parameter. the vector of data points on which ! the statistics are computed. y is sorted, but restored ! to its original order afterwards. ! ! initialize name vectors ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 't', 'a', 't', 'w', 's'/ data alpha /0.25e0/ data idp /4/ data iint /2/ data wts /.true./ data stack /.true./ ! ! check for errors in the input parameters. ! call stater(nmsub, wt, n, ldstak, wts, nnzw, stack, ierr) if (ierr /= 0) then write ( *,1000) return end if ! ! set up framework area. ! call stkset (ldstak, idp) nall0 = stkst(1) ! ! set up lsort, the permutation vector. ! lsort = stkget(n,iint) call geni(istak(lsort), n, 1, 1) ! ! sort the vector y carrying along the contents of the vector ! istak(lsort). ! call srtirr(istak(lsort), wt, n, y) ! ! compute the statistics which use a sorted array. ! call stat1w(y, wt, n, sts(5), sts(34), sts(35), sts(6), & sts(11), 10, 0.0e0, 0.0e0, sts(44), nnzw) ! ! computed various sums in the sorted array y. ! call sumbs(y, n, 1, mid, n) call sumwss(y, wt, n, 1, mid, n, nnzw, sum1, sts(38), sts(39), & sts(42), sumw, sts(3), sts(4)) call sumwts(y, wt, n, nnzw, alpha, sumt1, sumwt1, sts(7), & sts(8)) call sumwds(y, wt, n, 1, mid, n, sts(4), sumda, sumwd2, sumd2, & sumd3, sumd4) ! ! restore the vector y to its original order. ! call srtrri(y, wt, n, istak(lsort)) ! ! compute rest of statistics. ! call sumidw(y, wt, n, sts(4), sumdi) call stat2w(y, wt, n, nnzw, sts, sumda, sumdi, sumwd2, sumd2, & sumd3, sumd4, sumw) if (nprt /= 0) call sumot(sts, n, nnzw, wts) ! ! return the vector lsort. ! call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call statws (y, wt, n, ldstak, sts, nprt)') end subroutine stkclr ( nall0 ) !*****************************************************************************80 ! !! STKCLR clears the stack for framework area manipulation routines. ! ! Discussion: ! ! This routine is an addition to the framework area manipulation ! routines. it clears all allocations made since the first nall0. ! it is intended for use during error or final exits from starpac ! routines which make allocations, to release all allocations ! made since the nall0 existing on entry to the starpac routine, ! without knowing how many allocations must be released. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer nall0 ! input parameter. the number of allocations to be preserved ! when all later ones are released. ! integer nalln ! the total number of allocations existing before any are ! released. ! implicit none integer nall0 integer nalln integer stkst nalln = stkst ( 1 ) call stkrel ( nalln - nall0 ) return end function stkget ( nitems, itype ) !*****************************************************************************80 ! !! STKGET allocates space on an integer stack. ! ! Discussion: ! ! This routine allocates space out of the integer array ISTAK, ! in common block CSTAK, for an array of length NITEMS and of type ! determined by ITYPE as follows ! ! 1 - logical ! 2 - integer ! 3 - real ! 4 - double precision ! 5 - complex ! ! on return, the array will occupy ! ! stak(stkget), stak(stkget+1), ..., stak(stkget-nitems+1) ! ! where stak is an array of type itype equivalenced to istak. ! ! (for those wanting to make machine dependent modifications ! to support other types, codes 6, 7, 8, 9, 10, 11 and 12 have ! been reserved for 1/4 logical, 1/2 logical, 1/4 integer, ! 1/2 integer, quad precision, double complex and quad ! complex, respectively.) ! ! the use of the first five words is described below. ! ! istak( 1) - lout, the number of current allocations. ! istak( 2) - lnow, the current active length of the stack. ! istak( 3) - lused, the maximum value of istak(2) achieved. ! istak( 4) - lmax, the maximum length the stack. ! istak( 5) - lbook, the number of words used for bookeeping. ! ! the next five words contain integers describing the amount ! of storage allocated by the fortran system to the various ! data types. the unit of measurement is arbitrary and may ! be words, bytes or bits or whatever is convenient. the ! values currently assumed correspond to an ans fortran ! environment. for some mini-computer systems the values may ! have to be changed (see i0tk00). ! ! istak( 6) - the number of units allocated to logical ! istak( 7) - the number of units allocated to integer ! istak( 8) - the number of units allocated to real ! istak( 9) - the number of units allocated to double precision ! istak(10) - the number of units allocated to complex ! ! this function was adapted from the framework function istkgt ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer i ! the location of a pointer to the end of the previous allocation ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer isize(5) ! the number of words in each of the various data types. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer itype ! the type of array of length nitems to be allocated. ! integer lbook ! the number of words used for bookeeping. ! integer lmax ! the maximum length of the stack. ! integer lnow ! the current active length of the stack. ! integer lout ! the number of current allocations. ! integer lused ! the maximum value of istak(2) achieved. ! integer nitems ! the length of the array of itype to be allocated. ! implicit none double precision dstak(3000) integer i integer ierr integer isize(5) integer istak(12) integer itype integer lbook integer lmax integer lnow integer lout integer lused integer nitems integer stkget common /cstak/dstak common /errchk/ierr ! ! equivalences ! equivalence ( dstak(1), istak(1) ) equivalence ( istak(1), lout ) equivalence ( istak(2), lnow ) equivalence ( istak(3), lused ) equivalence ( istak(4), lmax ) equivalence ( istak(5), lbook ) equivalence ( istak(6), isize(1) ) stkget = ( lnow * isize(2) - 1 ) / isize(itype) + 2 i = ( ( stkget - 1 + nitems ) * isize(itype) - 1 ) / isize(2) + 3 ! ! stack overflow is an unrecoverable error. ! if ( lmax < i ) then ierr = 1 write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'STKGET - Fatal error!' write ( *, '(a)' ) ' Stacksize exceeded.' stop end if ! ! istak(i-1) contains the type for this allocation. ! istak(i ) contains a pointer to the end of the previous allocation. ! istak(i-1) = itype istak(i ) = lnow lout = lout + 1 lnow = i lused = max ( lused, lnow ) return end subroutine stkrel ( number ) !*****************************************************************************80 ! !! STKREL deallocates the last allocations made in the stack. ! ! Discussion: ! ! error states - ! ! 1 - number < 0 ! 2 - lnow, lused, lmax or lbook overwritten ! 3 - attempt to de-allocate non-existent allocation ! 4 - the pointer at istak(lnow) overwritten ! ! this function was adapted from the framework function istkgt ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer lbook ! the number of words used for bookeeping. ! integer lmax ! the maximum length of the stack. ! integer lnow ! the current active length of the stack. ! integer lout ! the number of current allocations. ! integer lused ! the maximum value of istak(2) acheived. ! integer number ! the number of allocations to be freed from the stack. ! implicit none integer ierr integer number ! ! arrays in common double precision dstak(3000) ! ! integer & in,lbook,lmax,lnow,lout,lused ! ! local arrays integer & istak(12) ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (istak(1),lout) equivalence (istak(2),lnow) equivalence (istak(3),lused) equivalence (istak(4),lmax) equivalence (istak(5),lbook) if ( lnow < lbook .or. lnow > lused .or. lused > lmax ) then ierr = 1 write ( *, 1000) return end if in = number do if ( in == 0 ) then exit end if if ( lnow <= lbook ) then ierr = 1 write ( *, 1010) return end if ! ! check to make sure the back pointers are monotone. ! if (istak(lnow)= lnow-1) then ierr = 1 write ( *, 1020) lout return end if lout = lout-1 lnow = istak(lnow) in = in-1 end do return 1000 format (///' ***** error *****'// & ' dstak bookkeeping elements have been overwritten.') 1010 format (///' ***** error *****'// & ' attempt has been made to de-allocate a non-existent', & ' allocation in dstak.') 1020 format (///' ***** error *****'// & ' the pointer for allocation number ', i3, ' has been', & ' overwritten.') end subroutine stkset ( nitems, itype ) !*****************************************************************************80 ! !! STKSET initializes the stack to NITMES of type ITYPE. ! ! Discussion: ! ! this function was adapted from the framework subroutine istkin ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer isize(5) ! the number of words in each of the various data types. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer itype ! the type of array of length nitems to be allocated. ! integer lbook ! the number of words used for bookeeping. ! integer lmax ! the maximum length of the stack. ! integer lnow ! the current active length of the stack. ! integer lout ! the number of current allocations. ! integer lused ! the maximum value of istak(2) acheived. ! integer nitems ! the length of the array of itype to be allocated. implicit none integer itype integer nitems ! ! arrays in common double precision dstak(3000) ! ! integer & lbook,lmax,lnow,lout,lused ! ! local arrays integer & isize(5),istak(12) ! ! common blocks common /cstak/dstak ! ! equivalences ! equivalence (dstak(1),istak(1)) equivalence (istak(1),lout) equivalence (istak(2),lnow) equivalence (istak(3),lused) equivalence (istak(4),lmax) equivalence (istak(5),lbook) equivalence (istak(6),isize(1)) ! ! here to initialize ! ! set data sizes appropriate for a standard conforming ! fortran system using the fortran "storage unit" as the ! measure of size. ! ! logical ! isize(1) = 1 ! ! integer ! isize(2) = 1 ! ! real ! isize(3) = 1 ! ! double precision ! isize(4) = 2 ! ! complex ! isize(5) = 2 lbook = 10 lnow = lbook lused = lbook lmax = max ( ( nitems * isize(itype) ) / isize(2), 12 ) lout = 0 return end function stkst ( nfact ) !*****************************************************************************80 ! !! STKST returns statistics on the state of the stack. ! ! Discussion: ! ! this routine replaces function istkst in the framework ! for use with starpac. returns one of four statistics on the ! state of the cstak stack. ! ! this routine assumes that the stack is initialized. ! it does not check to see if it is. in fact, there ! is no way that it could check. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & nfact integer stkst ! ! arrays in common double precision dstak(3000) ! ! local arrays integer & istak(12),istats(4) ! ! common blocks common /cstak/dstak ! ! equivalences equivalence (dstak(1),istak(1)) equivalence (istak(1),istats(1)) ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer istats(4) ! integer array including the four stack statistics. ! integer nfact ! if ( nfact <= 0 .or. 6 <= nfact ) then write ( *, 1000) nfact stkst = 0 return end if ! ! report true value of a statistic, assuming stack is ! defined. ! stkst = istats(nfact) return 1000 format (///' ***** error *****'// & ' illegal stack statistic', i5, ' requested.') end function stopx ( ) !*********************************************************************** ! !! STOPX is called to stop execution. ! ! Discussion: ! ! This function may serve as the STOPX (asynchronous interruption) ! function for the NL2SOL package at those installations which do not ! wish to implement a dynamic STOPX. ! ! At installations where the NL2SOL system is used ! interactively, this dummy STOPX should be replaced by a ! function that returns TRUE if and only if the interrupt ! (break) key has been pressed since the last call on STOPX. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none logical stopx stopx = .false. return end subroutine stpadj ( xm, n, m, ixm, mdl, par, npar, & nexmpt, stp, nfail, ifail, j, reltol, abstol, stplow, stpmid, & stpup, itemp, fd, fdlast, pv, pvnew ) !*****************************************************************************80 ! !! STPADJ adjusts the selected step sizes to optimal values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & abstol,reltol,stp,stplow,stpmid,stpup integer & ixm,j,m,n,nexmpt,nfail,npar ! ! array arguments real & fd(n),fdlast(n),par(npar),pv(n),pvnew(n),xm(ixm,m) integer & ifail(n),itemp(n) ! ! subroutine arguments external mdl ! ! scalars in common real & q real & factor,stpnew,temp integer & ncount logical & done,first ! ! external subroutines external cmpfd,icopy,relcom,scopy ! ! common blocks common /notopt/ q ! ! variable definitions (alphabetically) ! ! real abstol ! the absolute agreement tolerance. ! logical done ! the variable used to indicate whether the adjustment ! process is complete or not. ! real factor ! a factor used in computing the step size. ! real fd(n) ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter ! real fdlast(n) ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter ! computed with the most recent step size selected. ! logical first ! the variable used to indicate whether this step size ! is being used for the first time or whether it has been ! previously adjusted. ! integer ifail(n) ! an indicator vector used to designate those observations ! for which the step size does not meet the criteria. ! integer itemp(n) ! a temporary vector used for storing past values of itemp. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the parameter being examined. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer npar ! the number of unknown parameters in the model. ! integer ncount ! the number of observations at which the new step size does ! satisfy the criteria. ! integer nexmpt ! the number of observations for which a given step size ! does not have to be satisfactory and the selected step ! size still be considered ok. ! integer nfail ! a vector containing for each observation the number of ! observations for which the step size did not meet the criteria. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real pv(n) ! the predicted value based on the current parameter estimates ! real pvnew(n) ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stpcd. ! real q ! a dummy variable which is used, along with common notopt (no ! optimization), to compute the step size. ! real reltol ! the relative agreement tolerance. ! real stp ! the step size currently being examined for the forward ! difference approximation to the derivative. ! real stplow ! the lower limit on the step size. ! real stpmid ! the midpoint of the acceptable range of the step size. ! real stpnew ! the value of the new step size being tested. ! real stpup ! the upper limit on the step size. ! real temp ! a temporary location in which the current estimate of the jth ! parameter is stored. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! call icopy(n, ifail, 1, itemp, 1) ncount = nfail if ((stplow <= abs(stp)) .and. (abs(stp) <= stpup)) return if (abs(stp) > stpmid) then stpnew = stpup * sign(1.0e0, par(j)) factor = 10.0e0 else stpnew = stplow * sign(1.0e0, par(j)) factor = 0.1e0 end if q = stpnew + par(j) stpnew = q - par(j) done = .false. first = .true. do call scopy(n, fd, 1, fdlast, 1) temp = par(j) par(j) = temp + stpnew call mdl(par, npar, xm, n, m, ixm, pvnew) par(j) = temp call cmpfd(n, stpnew, pvnew, pv, fd) call relcom ( n, fd, fdlast, reltol, abstol, ncount, itemp ) if (ncount <= nexmpt) then done = .true. call icopy(n, itemp, 1, ifail, 1) nfail = ncount if (first) then stp = stpnew else stp = stpnew / factor end if else first = .false. stpnew = stpnew * factor q = stpnew + par(j) stpnew = q - par(j) if ((factor > 1.0e0 .and. abs(stpnew) > abs(stp)) .or. & (factor<1.0e0 .and. abs(stpnew)= 2) .and. (neta <= ndd)) then eta = 10.0e0 ** (-neta) ndgt1 = neta else call etamdl(mdl, par, npar, xm, n, m, ixm, eta, ndgt1, & rstak(partmp), rstak(pvtemp), 0) end if tau = min(eta ** (0.25e0), 0.01e0) exm = exmpt if ((exm<0.0e0) .or. (exm > 1.0e0)) exm = 0.10e0 nexmpt = int ( exm * real ( n ) ) if (exm /= 0.0e0) then nexmpt = max(nexmpt, 1) end if ! ! compute predicted values of the model using the input parameter ! estimates ! call mdl(par, npar, xm, n, m, ixm, rstak(pv)) mxfail = 0 nfailj = nfail do j = 1, npar if (istak(ifixd-1+j) == 0) then if (scale(1) <= 0.0e0) then if (par(j) == 0.0e0) then scl = 1.0e0 else scl = abs(par(j)) end if else scl = scale(j) end if call stpmn ( j, xm, n, m, ixm, mdl, par, npar, nexmpt, & eta, tau, scl, stp(j), istak(nfailj), istak(ifailj), & rstak(cd), istak(itemp), rstak(fd), rstak(fdlast), & rstak(fdsave), rstak(pv), rstak(pvmcd), rstak(pvnew), & rstak(pvpcd), rstak(pvstp), rstak(pvtemp) ) ! ! compute the maximum number of failures for any parameter ! mxfail = max(istak(nfailj), mxfail) else stp(j) = 0.0 end if ! ! print results if they are desired ! if ((nprt /= 0) .or. (mxfail > nexmpt)) & call stpout(head, n, exm, nexmpt, ndgt1, j, par, npar, & stp, istak(nfail), istak(ifailj), scale, lscale, hdr, & page, wide, isubhd, nprt, prtfxd, istak(ifixd)) nfailj = nfailj + 1 end do hlfrpt = .false. if ((nprt /= 0) .or. (mxfail > nexmpt)) hlfrpt = .true. if (mxfail > nexmpt) ierr = 2 call stkclr(nall0) return end subroutine stpdrv ( nmsub, xm, n, m, ixm, mdl, par, npar, ldstak, & stp, neta, exmpt, scale, lscale, nprt ) !*****************************************************************************80 ! !! STPDRV is the driver for selecting forward difference step sizes. ! ! Discussion: ! ! this is the driver routine for selecting step sizes ! to be used in computing forward difference quotient estimates ! of the numerical derivatives. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & exmpt integer & ixm,ldstak,lscale,m,n,neta,npar,nprt ! ! array arguments real & par(*),scale(*),stp(*),xm(*) character & nmsub(6)*1 ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & isubhd,lifixd logical & hlfrpt,page,prtfxd,wide ! ! local arrays integer & ifixed(1) ! ! external subroutines external stkset,stpcnt,stper,stphdr ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real exmpt ! the proportion of observations for which the computed ! numerical derivatives wrt a given parameter are excepted ! from meeting the derivative acceptance criteria. ! logical hlfrpt ! the variable which indicates whether the step size selection ! routine has already printed part of the initial summary (true) ! or not (false). ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ifixed(1) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixed(i) /= 0, then par(i) will be optimized. if ! ifixed(i) == 0, then par(i) will be held fixed. ! integer isubhd ! an indicator value specifying subheadings to be printed. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lifixd ! the length of the vector ifixed. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer neta ! the number of accurate digits in the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of unknown parameters in the model. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! real scale(lscale) ! the typical size of the unknown parameters. ! real stp(npar) ! the selected step sizes. ! external stphdr ! the name of the routine which produces the heading ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! real xm(ixm,m) ! the independent variable array ! call stper(nmsub, n, m, ixm, npar, ldstak, scale, lscale) if (ierr /= 0) return call stkset(ldstak, 4) page = .false. wide = .true. isubhd = 0 prtfxd = .false. ifixed(1) = -1 lifixd = 1 ! ! pass control of step size selection to subroutine stpcnt ! call stpcnt(xm, n, m, ixm, mdl, par, npar, stp, exmpt, neta, & scale, lscale, nprt, stphdr, page, wide, isubhd, hlfrpt, & prtfxd, ifixed, lifixd) return end subroutine stper ( nmsub, n, m, ixm, npar, ldstak, scale, lscale ) !*****************************************************************************80 ! !! STPER does error checking for the stepsize selection routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,ldstak,lscale,m,n,npar ! ! array arguments real & scale(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i,ldsmin,nv logical & head ! ! local arrays logical & error(10) character & lixm(8)*1,llds(8)*1,lm(8)*1,ln(8)*1,lnpar(8)*1, & lone(8)*1,lscl(8)*1,lzero(8)*1 ! ! external subroutines external eisge,ervgt,ldscmp ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical error(10) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldsmin ! the minimum length allowed for the array dstak. ! integer ldstak ! the length of the array dstak. ! character*1 lixm(8), llds(8), lm(8), ln(8), lnpar(8), lone(8), ! + lscl(8), lzero(8) ! the array(s) containing the name(s) of input parameter(s) ! checked for errors. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of unknown parameters in the model. ! integer nv ! the number of violations found. ! real scale(lscale) ! the typical size of the unknown parameters. ! ! set up name arrays ! data lixm(1), lixm(2), lixm(3), lixm(4), lixm(5), lixm(6), & lixm(7), lixm(8) /'i','x','m',' ',' ',' ',' ',' '/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data lm(1), lm(2), lm(3), lm(4), lm(5), lm(6), lm(7), lm(8) /'m', & ' ',' ',' ',' ',' ',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lnpar(1), lnpar(2), lnpar(3), lnpar(4), lnpar(5), & lnpar(6), lnpar(7), lnpar(8) /'n','p','a','r',' ',' ',' ', & ' '/ data lone(1), lone(2), lone(3), lone(4), lone(5), & lone(6), lone(7), lone(8) /' ',' ','o','n','e',' ',' ', & ' '/ data lscl(1), lscl(2), lscl(3), lscl(4), lscl(5), & lscl(6), lscl(7), lscl(8) /'s','c','a','l','e',' ',' ', & ' '/ data lzero(1), lzero(2), lzero(3), lzero(4), lzero(5), & lzero(6), lzero(7), lzero(8) /'z','e','r','o',' ',' ',' ',' '/ error(1:10) = .false. ierr = 0 head = .true. call eisge(nmsub, ln, n, 1, 2, head, error(1), lone) call eisge(nmsub, lm, m, 1, 2, head, error(2), lone) call eisge(nmsub, lixm, ixm, n, 3, head, error(3), ln) call eisge(nmsub, lnpar, npar, 1, 2, head, error(4), lone) call ldscmp(14, 0, 2*(n+npar), 0, 0, 0, 's', 9*n + max(n,npar), & ldsmin) if ((.not.error(1)) .and. (.not.error(4))) & call eisge(nmsub, llds, ldstak, ldsmin, 9, head, error(5), & llds) call ervgt(nmsub, lscl, scale, lscale, 0.0e0, 0, head, 6, nv, & error(9), lzero) do i=1,10 if (error(i)) then ierr = 1 end if end do return end subroutine stphdr ( page, wide, isubhd ) !*****************************************************************************80 ! !! STPHDR prints page headings for the stepsize selection routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & isubhd logical & page,wide ! ! external subroutines external versp ! ! variable definitions (alphabetically) ! ! integer isubhd ! an indicator value specifying subheadings to be printed. ! logical page ! the variable used to indicate whether a given section of ! the output is to begin on a new page (true) or not (false). ! logical wide ! the variable used to indicate whether the heading should ! full width (true) or not (false). ! if (page) write ( *, 1020) call versp(wide) if (page) write ( *,1000) if (.not.page) write ( *,1010) page = .true. if (isubhd == 0) return write ( *, 1030) return 1000 format ('+derivative step size selection continued') 1010 format ('+', 34('*')/ ' * derivative step size selection *'/ & 1x, 34('*')) 1020 format ('1') 1030 format (//' summary of initial conditions'/ 1x, 30('-')) end subroutine stpls1 ( n, m, ixm, par, npar, neta, exmpt, scale, nprt ) !*****************************************************************************80 ! !! STPLS1 sets a test problem for the step size selection family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real exmpt ! the proportion of observations for which the computed ! numerical derivatives wrt a given parameter are exempted ! from meeting the derivative acceptance criteria. ! integer ixm ! the first dimension of the independent variable array. ! integer m ! the number of independent variables. ! integer n ! the number of observations. ! integer neta ! the number of reliable digits in the model. ! integer npar ! the number of unknown parameters in the model. ! integer nprt ! the parameter used to indicate how much printed output is ! to be provided. ! real par(10) ! the array in which the current estimates of the unknown ! parameters are stored. ! real scale(10) ! a value to indicate use of the default values of ! the typical size of the unknown parameters. ! implicit none real & exmpt integer & ixm,m,n,neta,npar,nprt ! ! array arguments real & par(10),scale(10) par(1) = 0.0e0 par(2) = 3.125e0 par(3) = 1.0e0 par(4) = 2.0e0 n = 101 m = 1 ixm = 200 npar = 4 scale(1:10) = 1.0e0 neta = 0 exmpt = 0.0e0 nprt = 1 return end subroutine stpls2 ( npar, stp ) !*****************************************************************************80 ! !! STPLS2 sets a test problem for the step size selection family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer npar ! the number of unknown parameters in the model. ! real stp(npar) ! the step size array. ! implicit none integer & npar ! ! array arguments real & stp(npar) ! ! scalars in common integer & ierr ! ! common blocks common /errchk/ierr stp(1:npar) = -1.0e0 ierr = -1 return end subroutine stplsc ( xm, n, m, ixm, mdl, par, npar, ldstak, stp, & neta, exmpt, scale, nprt ) !*****************************************************************************80 ! !! STPLSC selects step sizes for forward difference estimates of derivatives. ! ! Discussion: ! ! this is the user callable subroutine for selecting step sizes ! to be used in computing forward difference quotient estimates ! of the numerical derivatives for the nonlinear least squares ! routines (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & exmpt integer & ixm,ldstak,m,n,neta,npar,nprt ! ! array arguments real & par(*),scale(*),stp(*),xm(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! integer & lscale ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external stpdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real exmpt ! the proportion of observations for which the computed ! numerical derivatives wrt a given parameter are exempted ! from meeting the derivative acceptance criteria. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer neta ! the number of accurate digits in the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters in the model. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! real par(npar) ! the array in which the current estimates of the ! parameters are stored. ! real scale(npar) ! the typical size of the parameters. ! real stp(npar) ! the selected step sizes. ! real xm(ixm,m) ! the independent variable array ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 's','t','p','l','s','c'/ ! ! set length of vector scale. ! lscale = npar ! ! pass control to step size selection driver ! call stpdrv(nmsub, xm, n, m, ixm, mdl, par, npar, ldstak, stp, & neta, exmpt, scale, lscale, nprt) if (ierr /= 1) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call stplsc (xm, n, m, ixm, nlsmdl, par, npar, ldstak,', & ' stp,'/ & ' + neta, exmpt, scale, nprt)') end subroutine stpls ( xm, n, m, ixm, mdl, par, npar, ldstak, stp ) !*****************************************************************************80 ! !! STPLS selects step sizes for estimating derivatives in NLS routines. ! ! Discussion: ! ! this is the user callable subroutine for selecting step sizes ! to be used in computing forward difference quotient estimates ! of the numerical derivatives for the nonlinear least squares ! routines (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ixm,ldstak,m,n,npar ! ! array arguments real & par(*),stp(*),xm(*) ! ! subroutine arguments external mdl ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & exmpt integer & lscale,neta,nprt ! ! local arrays real & scale(1) character & nmsub(6)*1 ! ! external subroutines external stpdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! variable definitions (alphabetically) ! ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real exmpt ! the proportion of observations for which the computed ! numerical derivatives wrt a given parameter are excepted ! from meeting the derivative acceptance criteria. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors were detected. ! integer ixm ! the first dimension of the independent variable array xm. ! integer ldstak ! the length of the array dstak. ! integer lscale ! the length of vector scale. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer neta ! the number of accurate digits in the model. ! character*1 nmsub(6) ! the name of the subroutine calling the error checking ! subroutines. ! integer npar ! the number of parameters in the model. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! real par(npar) ! the array in which the current estimates of the ! parameters are stored. ! real scale(1) ! a dummy vector used to designate use of the default values of ! the typical size of the parameters. ! real stp(npar) ! the selected step sizes. ! real xm(ixm,m) ! the independent variable array ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 's','t','p','l','s',' '/ exmpt = 0.1e0 neta = 0 scale(1) = 0.0e0 lscale = 1 nprt = 1 ! ! pass control to step size selection driver ! call stpdrv(nmsub, xm, n, m, ixm, mdl, par, npar, ldstak, stp, & neta, exmpt, scale, lscale, nprt) if (ierr == 1 ) then write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call stpls (xm, n, m, ixm, nlsmdl, par, npar, ldstak,', & ' stp)') end subroutine stpmn ( j, xm, n, m, ixm, mdl, par, npar, & nexmpt, eta, reltol, scale, stp, nfail, ifail, cd, & itemp, fd, fdlast, fdsave, pv, pvmcd, pvnew, pvpcd, pvstp, pvtemp ) !*****************************************************************************80 ! !! STPMN: main routine for numerical derivative step size selection. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! real abstol ! the absolute agreement tolerance. ! real cd(n) ! the central difference quotient approximation to the ! derivative of the model with respect to the jth parameter. ! real curve ! a measure of the curvature of the model. ! real eta ! the relative noise in the model ! real eta3 ! the cube root of eta. ! real fd(n) ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter ! real fdlast(n) ! the forward difference quotient approximation to the ! derivative of the model with respect to the jth parameter ! computed with the most recent step size selected. ! real fdsave(n) ! a vector used to save the best of the ! the forward difference quotient approximations to the ! derivative of the model with respect to the jth parameter ! real fplrs ! the floating point largest relative spacing. ! integer i ! an index variable. ! integer ifail(n) ! the vector of indicator variables designating whether ! the step size selected was satisfactory for a given ! observation and parameter. ! integer itemp(n) ! a temporary storage vector. ! integer ixm ! the first dimension of the independent variable array. ! integer j ! the index of the parameter being examined. ! integer m ! the number of independent variables. ! external mdl ! the name of the user supplied subroutine which computes the ! predicted values based on the current parameter estimates. ! integer n ! the number of observations. ! integer npar ! the number of unknown parameters in the model. ! integer nexmpt ! the number of observations for which a given step size ! does not have to be satisfactory and the selected step ! size still be considered ok. ! integer nfail ! the vector containing the counts for each parameter ! of the number of observations the selected step size was ! not satisfactory. ! real par(npar) ! the array in which the current estimates of the unknown ! parameters are stored. ! real parmx ! the maximum of the current parameter estimate and the ! typical value of that parameter ! real pv(n) ! the predicted value based on the current parameter estimates ! real pvmcd(n) ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)-stpcd. ! real pvmean ! the mean of a function of the predicted values. ! real pvnew(n) ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stpnew. ! real pvpcd(n) ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stpcd. ! real pvstp(n) ! the predicted value based on the current parameter estimates ! for all but the jth parameter value, which is par(j)+stp. ! real pvtemp(n) ! a temporary storage vector for predicted values. ! real pvtyp ! the typical size of the predicted values of the model. ! real q ! a dummy variable which is used, along with common notopt (no ! optimization), to compute the step size. ! real scale ! the typical size of the jth parameter. ! real stp ! the step size currently being examined for the forward ! difference approximation to the derivative. ! real stpcd ! the step size used for the central difference quotient. ! real stplow ! the lower limit on the step size. ! real stpmid ! the midpoint of the acceptable range of the step size. ! real stpup ! the upper limit on the step size. ! real reltol ! the relative agreement tolerance. ! real tauabs ! the absolute agreement tolerance. ! real temp ! a temporary location in which the current estimate of the jth ! parameter is stored. ! real third ! the value one third. ! real xm(ixm,m) ! the array in which one row of the independent variable array ! is stored. ! implicit none integer ixm integer m integer n integer npar real cd(n) real eta real fd(n) real fdlast(n) real fdsave(n) integer ifail(n) integer itemp(n) integer j external mdl integer nexmpt integer nfail real par(npar) real pv(n) real pvmcd(n) real pvnew(n) real pvpcd(n) real pvstp(n) real pvtemp(n) real q real reltol real scale real stp real xm(ixm,m) real & abstol,curve,eta3,fplrs,parmx,pvmean,pvtyp,stpcd,stplow, & stpmid,stpup,tauabs,temp,third integer & i ! ! external subroutines external cmpfd,gmean,relcom,stpadj,stpsel ! ! common blocks common /notopt/ q fplrs = epsilon ( fplrs ) third = 1.0e0 / 3.0e0 eta3 = eta ** third parmx = max ( abs ( par(j) ), abs ( scale ) ) if ( parmx == 0.0e0 ) then parmx = 1.0e0 end if stpcd = ( ( 3.0e0 ** third ) * eta3 * parmx * sign ( 1.0e0, par(j) ) ) q = stpcd + par(j) stpcd = q - par(j) temp = par(j) par(j) = temp + stpcd call mdl ( par, npar, xm, n, m, ixm, pvpcd ) par(j) = temp - stpcd call mdl ( par, npar, xm, n, m, ixm, pvmcd ) par(j) = temp ! ! Estimate curvature by second derivative of model with respect to PAR(J). ! do i = 1, n pvtemp(i) = abs( ( pvpcd(i) + pvmcd(i) ) - 2.0 * pv(i) ) if ( pvtemp(i) == 0.0e0 ) then if ( pv(i) == 0.0e0 ) then pvtemp(i) = fplrs else pvtemp(i) = fplrs * abs ( pv(i) ) end if end if end do ! ! Compute the geometric mean ! call gmean ( pvtemp, n, pvmean ) curve = abs(pvmean / stpcd / stpcd) ! ! compute a typical value of the model ! do i = 1, n pvtemp(i) = abs(pvpcd(i) + pv(i) + pvmcd(i)) if (pvtemp(i) == 0.0e0) then if (pv(i) == 0.0e0) then pvtemp(i) = fplrs else pvtemp(i) = fplrs*abs(pv(i)) end if end if end do call gmean(pvtemp, n, pvmean) pvtyp = abs(pvmean / 3.0e0) ! ! set values representative of the range the step size ! can be expected to take ! stpup = (eta3) * parmx stplow = (eta3) * stpup stpmid = sqrt(stplow) * sqrt(stpup) ! ! Select an optimum starting step size. ! if ( curve == 0.0e0 ) then stp = parmx * sign(1.0e0, par(j)) else stp = (2.0e0 * sqrt(eta) * sqrt(pvtyp) / sqrt(curve)) * & sign(1.0e0,par(j)) end if if ( abs(stp) > parmx ) then stp = parmx * sign(1.0e0,par(j)) end if q = stp + par(j) stp = q - par(j) if ( stp == 0.0e0 ) then stp = fplrs * par(j) if ( stp == 0.0e0 ) then stp = fplrs end if do q = stp + par(j) stp = q - par(j) if ( stp /= 0.0 ) then exit end if stp = 2.0e0 * stp end do end if ! ! Compute the absolute tolerances. ! abstol = 10.0e0 * eta * pvtyp tauabs = 2.0e0 * sqrt ( eta ) * sqrt ( pvtyp ) if ( curve /= 0.0e0 ) then tauabs = tauabs * sqrt(curve) end if temp = par(j) par(j) = temp + stp call mdl ( par, npar, xm, n, m, ixm, pvstp ) par(j) = temp ! ! Compute the forward and central difference quotient estimate ! of the derivative. ! call cmpfd ( n, stp, pvstp, pv, fd ) call cmpfd ( n, 2.0e0 * stpcd, pvpcd, pvmcd, cd ) ! ! Compute the number of observations for which the forward difference ! does not agree with the central difference within the tolerance specified. ! call relcom ( n, fd, cd, reltol, abstol, nfail, ifail ) ! ! If the forward difference approximation does not agree within ! tolerance for more than NEXMPT observation, select new ! value of the step size, else adjust the step size and return. ! if ( nfail > nexmpt ) then ! ! Select new value of the step size. ! call stpsel ( xm, n, m, ixm, mdl, par, npar, & nexmpt, stp, nfail, ifail, j, eta3, reltol, abstol, & tauabs, stplow, & stpmid, stpup, itemp, fd, fdlast, fdsave, pv, pvnew ) else ! ! Adjust the current step size value. ! call stpadj ( xm, n, m, ixm, mdl, par, npar, & nexmpt, stp, nfail, ifail, j, reltol, abstol, stplow, & stpmid, stpup, itemp, fd, fdlast, pv, pvnew ) end if ! ! Convert selected absolute step size to relative step size. ! stp = abs ( stp ) / parmx return end subroutine stpout ( head, n, exm, nexmpt, neta, j, par, npar, stp, & nfail, ifail, scale, lscale, hdr, page, wide, isubhd, nprt, & prtfxd, ifixd ) !*****************************************************************************80 ! !! STPOUT prints results for the step size selection routines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! variable definitions (alphabetically) ! ! character*1 blank ! the character blank. ! character*1 c ! the character flag indicating high curvature. ! real exm ! the proportion of observations actually used for which the ! computed numerical derivatives wrt a given parameter are ! exempted from meeting the derivative acceptance criteria. ! character*1 f ! the character flag indicating number of observations ! failing selection criteria exceeded exempted number. ! character*1 fixed(3) ! the characters used to label the parameters fixed or not. ! external hdr ! the name of the routine which produces the heading ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer i ! an index variable. ! integer ifail(n) ! the array of indicator variables designating whether ! the step size selected was satisfactory for a given ! observation and parameter. ! integer index(25) ! the row numbers of observations for which the step size ! selected failed. ! integer ifixd(npar) ! the indicator values used to designate whether the ! parameters are to be optimized or are to be held fixed. if ! ifixd(i) /= 0, then par(i) will be optimized. if ! ifixd(i) == 0, then par(i) will be held fixed. ! integer j ! the index of the parameter being examined. ! integer k ! an index variable. ! integer lscale ! the length of vector scale. ! integer n ! the number of observations. ! integer npar ! the number of parameters in the model. ! integer neta ! the number of reliable digits in the model. ! integer nexmpt ! the number of observations for which a given step size ! does not have to be satisfactory and the selected step ! size still be considered ok. ! integer nfail(npar) ! the number of observations for which the selected step ! size does not meet the criteria. ! integer nflabs ! the absolute value of nfail. ! integer nk ! an index variable. ! integer nperl ! the number of observations to be printed per line. ! integer nprt ! the indicator variable used to specify whether or not ! printed output is to be provided, where if the value of ! nprt is zero, no printed output is given. ! logical page ! the variable used to indicate whether or not the output ! is to begin on a new page. ! real par(npar) ! the array in which the current estimates of the ! parameters are stored. ! character*1 plus ! the character plus. ! logical prtfxd ! the indicator value used to designate whether the ! output is to include information on whether the ! parameter is fixed (true) or not (false). ! logical sameln ! an indicator value to designate whether the line is to be ! printed on the same line as the previous line printed (true) ! or not (false). ! real scale(lscale) ! the typical size of the parameters. ! real stp(npar) ! the selected step size. ! logical wide ! the variable used to indicate whether the heading should ! be full width (true) or not (false). ! implicit none integer lscale integer n integer npar real exm character fixed(3) external hdr logical head integer ifail(n) integer ifixd(n) integer isubhd integer j integer neta integer nexmpt integer nfail(npar) integer nprt logical page real par(npar) logical prtfxd real scale(lscale) real stp(npar) logical wide integer & i,k,nflabs,nk,nperl logical & sameln character & blank*1,c*1,f*1,plus*1 ! ! local arrays integer & index(25) data blank /' '/, plus /'+'/ fixed(1:3) = ' ' ! ! Print heading ! if ( head ) then head = .false. call hdr ( page, wide, isubhd ) if (prtfxd) then write ( *,1000) else write ( *,1010) end if ! ! Print information otherwise suppressed by print control ! do i=1,j-1 if (prtfxd) call fixprt(ifixd(i), fixed) if (ifixd(i) == 0) then f = ' ' c = ' ' nflabs = iabs(nfail(i)) if (nflabs > nexmpt) f = '+' if (nfail(i)<0) c = '+' if (scale(1) > 0.0e0) then write ( *,1020) i, (fixed(k),k=1,3), par(i), & scale(i), stp(i), nflabs, f, c else write ( *,1040) i, (fixed(k),k=1,3), par(i), & stp(i), nflabs, f, c end if if (nflabs > nexmpt) then write ( *,1030) end if else write ( *,1045) i, (fixed(k),k=1,3), par(i) end if end do end if ! ! print information for current parameter ! i = j if ( prtfxd ) then call fixprt(ifixd(i), fixed) end if if (ifixd(i) == 0) then f = ' ' c = ' ' nflabs = iabs(nfail(i)) if (nflabs > nexmpt) f = '+' if (nfail(i)<0) c = '+' if (scale(1) > 0.0e0) then write ( *,1020) i, (fixed(k),k=1,3), par(i), & scale(i), & stp(i), nflabs, f, c else write ( *,1040) i, (fixed(k),k=1,3), par(i), & stp(i), nflabs, f, c end if if (nflabs >= 1) then if ((nprt == 0) .and. (nflabs <= nexmpt)) then write ( *,1030) else ! ! print row numbers ! nperl = 7 sameln = .true. nk = 0 do i=1,n if (ifail(i) == 0) then cycle end if nk = nk + 1 index(nk) = i if (nk stpmid) factor = 0.1e0 stpnew = stp * factor stp1 = stpnew stp2 = stpnew q = stpnew + par(j) stpnew = q - par(j) first = .true. forwrd = .true. succes = .false. fail = .false. nfail = n + 1 ! ! repeat following until (succes) or (fail) ! do call scopy(n, fd, 1, fdlast, 1) temp = par(j) par(j) = temp + stpnew call mdl(par, npar, xm, n, m, ixm, pvnew) par(j) = temp call cmpfd(n, stpnew, pvnew, pv, fd) call relcom ( n, fd, fdlast, reltol, abstol, ncount, itemp ) if (ncount <= nexmpt) then succes = .true. nfail = ncount call icopy(n, itemp, 1, ifail, 1) if (abs(abs(stpnew) - stpmid) > abs(abs(stpnew/factor) - stpmid)) then stp = stpnew / factor else stp = stpnew end if else if (ncount 1.0e0 .and. abs(stpnew) > stpup) .or. & (factor<1.0e0 .and. abs(stpnew) x(mid)) curlo = mid if (0.0e0 == x(mid)) then exit end if end do return end subroutine sumds ( x, n, lo, mid, hi, xmeanw, sumda, sumd2, sumd3, sumd4 ) !*****************************************************************************80 ! !! SUMDS sums unweighted powers of differences from the mean of a sorted vector. ! ! Discussion: ! ! This routine calculates unweighted sums of powers of ! differences from the weighted mean for a sorted ! vector in which the midth element is the element ! closest to zero. used by the stat family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & sumd2,sumd3,sumd4,sumda,xmeanw integer & hi,lo,mid,n ! ! array arguments real & x(n) real & diff integer & curhi,curlo,i,irev ! ! variable definitions (alphabetically) ! ! integer curhi ! the upper bound of the current interval. ! integer curlo ! the lower bound of the current interval. ! real diff ! the differences between x(i) and xmeanw. ! integer hi ! input parameter. the upper bound of the initial ! interval. ! integer i ! a loop parameter. ! integer irev ! a variable which runs in the same interval as i, but ! in the reverse order. ! integer lo ! input parameter. the lower bound of the initial ! interval. ! integer mid ! input parameter. the index of the element in x closest to ! zero in value. the point out from which the summing is ! done. ! integer n ! input parameter. the length of the array x. ! real sumda ! output parameter. the sum of the absolute values of the ! differences diff. ! real sumd2 ! output parameter. the sum of the squares of the ! differences diff. ! real sumd3 ! output parameter. the sum of the cubes of the ! differences diff. ! real sumd4 ! output parameter. the sum of the hypercubes of the ! differences diff. ! real x(n) ! input parameter. the data array x in which the sums are taken. ! real xmeanw ! input parameter. the weighted mean of x. ! ! initialize summation variables. ! diff = x(mid) - xmeanw sumda = abs(diff) sumd2 = diff*diff sumd3 = diff*diff*diff sumd4 = diff*diff*diff*diff curlo = mid - 1 curhi = mid + 1 ! ! sum outwards from the value nearest zero. that is, sum from ! the least in magnitude to the greatest. ! do if (curhi > hi .or. curlo abs(obs. t)) ! logical wts ! input parameter. a flag to indicate whether or not there are ! weights. ! ! ! print heading ! call versp(.true.) ! ! print numbers of observations, raw and nonzero weighted. ! if (.not.wts) write ( *,1000) if (wts) write ( *,1010) if ( nnzw == n ) then write ( *,1020) nnzw else write ( *,1030) nnzw, n write ( *,1040) end if ! ! print frequency distributions ! do i=1,10 itemp(i) = int ( sts(i+43) ) end do write ( *,1050) (itemp(i),i=1,10) ! ! print measures of location and dispersion ! write ( *,1060) if (sts(4) /= 0.0e0) then write ( *,1070) (sts(i+2),sts(i+8),i=1,6) else write ( *,1080) (sts(i+2),sts(i+8),i=1,5), sts(8) end if ! ! print confidence intervals ! write ( *,1090) sts(15:18) ! ! print linear trend and other statistics, and print heading for ! tests for nonrandomness ! write ( *,1100) & (sts(i),sts(i+15),i=19,22), sts(38:41) itemp(1) = int ( sts(23) ) itemp(2) = int ( sts(28) ) itemp(3) = int ( sts(29) ) itemp(4) = int ( sts(30) ) ! ! print tests for nonrandomness ! write ( *,1110) itemp(1), sts(42), sts(24), sts(43), & (sts(i),i=25,27), (itemp(i),i=2,4), sts(31:33) ! ! print footnote ! write ( *,1120) return 1000 format('+statistical analysis') 1010 format('+weighted statistical analysis') 1020 format(//5x, 'n = ', i5) 1030 format(//5x, 'n = ', i5, ' (no. of non-zero wts) length', & ' =', i5) 1040 format(/5x, 'all computations are based on observations wi', & 'th non-zero weights') 1050 format(//5x, 'frequency distribution (1-6)', 7x, 10i6) 1060 format(//5x, 'measures of location (2-2)', 34x, 'measures o', & 'f dispersion (2-6)') 1070 format(/10x, 'unweighted mean =', 1pe15.7, 20x, & 'wtd standard deviation =', e15.7/10x, 'weighted mean ', & ' =', e15.7, 20x, 'weighted s.d. of mean =', & e15.7/10x, 'median =', e15.7, 20x, 'range ', & ' =', e15.7/10x, 'mid-range ', & ' =', e15.7, 20x, 'mean deviation =', e15.7/10x, & '25 pct unwtd trimmed mean=', e15.7, 20x, 'variance ', & ' =', e15.7/10x, '25 pct wtd trimmed mean =', & e15.7, 20x, 'coef. of. var. (percent) =', e15.7) 1080 format(/10x, 'unweighted mean =', 1pe15.7, 20x, & 'wtd standard deviation =', e15.7/10x, 'weighted mean ', & ' =', e15.7, 20x, 'weighted s.d. of mean =', & e15.7/10x, 'median =', e15.7, 20x, 'range ', & ' =', e15.7/10x, 'mid-range ', & ' =', e15.7, 20x, 'mean deviation =', e15.7/10x, & '25 pct unwtd trimmed mean=', e15.7, 20x, 'variance ', & ' =', e15.7/10x, '25 pct wtd trimmed mean =', & e15.7, 20x, 'coefficient of variation =', ' undefined'/ & 98x, '(mean is zero)') 1090 format(///20x, 'a two-sided 95 pct confidence interval for mea', & 'n is', 1pe14.7, ' to ', e14.7, ' (2-2)'/20x, 'a two-sided 9', & '5 pct confidence interval for s.d. is', e14.7, ' to ', & e14.7, ' (2-7)') 1100 format(///5x, 'linear trend statistics (5-1) ', 30x, 'other ', & 'statistics'//10x, 'slope', 20x, '=', 1pe15.7, 20x, 'minimum', & 18x, '=', e15.7/10x, 's.d. of slope', 12x, '=', e15.7, 20x, & 'maximum', 18x, '=', e15.7/10x, 'slope/s.d. of slope = t =', & e15.7, 20x, 'beta one', 17x, '=', e15.7/10x, 'prob exceeding', & ' abs value of obs t =', 0pf6.3, 20x, 'beta two', 17x, '=', & 1pe15.7/71x, 'wtd sum of values', 8x, '=', e15.7/71x, 'wtd sum', & ' of squares', 7x, '=', e15.7/5x, 'tests for non-randomness', & 42x, 'wtd sum of dev squared', ' =', e15.7/71x, 'students ', & 't', 15x, '=', e15.7) 1110 format(10x, 'hno. of runs up and down =', i5, 30x, 'wtd sum a', & 'bsolute values =', 1pe15.7/ & 10x, 'expected no. of runs =', & 0pf7.1, 28x, 'wtd ave absolute values =', 1pe15.7/ & 10x, 's.d. of no. of runs =', 0pf8.2/ & 10x, 'mean sq successive diff =', 1x, 1pe16.7/ & 10x, 'mean sq succ diff/var =', 0pf9.3/// & 10x, 'deviations from wtd mean'// & 15x, 'no. of + signs =', i5/ & 15x, 'no. of - signs =', i5/ & 15x, 'no. of runs =', i5/ & 15x, 'expected no. of runs=', f7.1/ & 15x, 's.d. of runs', 8x, '=', f8.2/ & 15x, 'diff./s.d. of runs =', f9.3) 1120 format(///' note - items in parentheses refer to page number', & ' in nbs handbook 91 (natrella, 1966)') end subroutine sumss ( x, n, lo, mid, hi, sum1, sum2, suma, xmean ) !*****************************************************************************80 ! !! SUMSS calculates the sum of powers and mean for a sorted vector. ! ! Discussion: ! ! a routine to calculate sums of powers and the mean ! for a sorted vector in which the midth element is ! the element closest to zero. used by the stat ! family. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & sum1,sum2,suma,xmean integer & hi,lo,mid,n ! ! array arguments real & x(n) integer & curhi,curlo,i,irev ! ! variable definitions (alphabetically) ! ! integer curhi ! the upper bound of the current interval. ! integer curlo ! the lower bound of the current interval. ! integer hi ! input parameter. the upper bound of the initial ! interval. ! integer i ! loop parameter. ! integer irev ! a variable which runs in the same interval as i, but ! in the reverse order. ! integer lo ! input parameter. the lower bound of the initial interval. ! integer mid ! input parameter. the index of the element in x closest to ! zero in value. the point out from which the summing is ! done. ! integer n ! input parameter. the length of the array x. ! real suma ! output parameter. the sum of the absolute values of the ! elements of x. ! real sum1 ! output parameter. the sum of the elements of x. ! real sum2 ! output parameter. the sum of the squares of the ! elements of x. ! real x(n) ! input parameter. the data array x over which the sums are ! taken. ! real xmean ! output parameter. the unweighted mean of x. ! sum1 = x(mid) sum2 = x(mid)*x(mid) suma = abs(x(mid)) curlo = mid - 1 curhi = mid + 1 ! ! sum outwards from the value nearest zero. that is, sum from ! the least in magnitude to the greatest. ! do if (curhi > hi .or. curlo ithi .or. curlo hi .or. curlo hi .or. curlo ithi .or. curlo= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'v', 'p', 'c', ' ', ' '/ m = 1 iym = n multi = .false. ischck = 1 miss = .false. lisym = n call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call svpc (y, n, ns, isym, ilog,'/ & ' + isize, irlin, ibar, ylb, yub, xlb, xinc)') end subroutine svp ( ym, n, ns, isym ) !*****************************************************************************80 ! !! SVP: vertical plot with user plot symbols (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,ns ! ! array arguments real & ym(*) integer & isym(*) ! ! scalars in common integer & ierr real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'v', 'p', ' ', ' ', ' '/ m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 1 isize = -1 miss = .false. lisym = n irlin = -1 ibar = 0 call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call svp (y, n, ns, isym)') end subroutine svpl ( ym, n, ns, isym, ilog ) !*****************************************************************************80 ! !! SVPL produces a vertical log plot with user control of the plot symbol. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ilog,n,ns ! ! array arguments real & ym(*) integer & isym(*) ! ! scalars in common integer & ierr real & xinc,xlb,ylb,yub integer & ibar,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'v', 'p', 'l', ' ', ' '/ m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 1 isize = -1 miss = .false. lisym = n irlin = -1 ibar = 0 call vpcnt (ym, ym, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call svpl (y, n, ns, isym, ilog)') end subroutine svpmc ( ym, ymmiss, n, ns, isym, ilog, isize, & irlin, ibar, ylb, yub, xlb, xinc ) !*****************************************************************************80 ! !! SVPMC: vertical plot with missing data and user plot symbols (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,isize,n,ns ! ! array arguments real & ym(*),ymmiss(*) integer & isym(*) ! ! scalars in common integer & ierr integer ischck,iym,lisym,m logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'v', 'p', 'm', 'c', ' '/ m = 1 iym = n multi = .false. ischck = 1 miss = .true. lisym = n call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call svpmc (y, ymiss, n, ns, isym, ilog,'/ & ' + isize, irlin, ibar, ylb, yub, xlb, xinc)') end subroutine svpm ( ym, ymmiss, n, ns, isym ) !*****************************************************************************80 ! !! SVPM: vertical plot with missing data and user plot symbols (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,ns ! ! array arguments real & ym(*),ymmiss(*) integer & isym(*) ! ! scalars in common integer & ierr real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'v', 'p', 'm', ' ', ' '/ m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 1 isize = -1 miss = .true. lisym = n irlin = -1 ibar = 0 call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call svpm (y, ymiss, n, ns, isym)') end subroutine svpml ( ym, ymmiss, n, ns, isym, ilog ) !*****************************************************************************80 ! !! SVPML: vertical plot with missing data, user plot symbols (log plot option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ilog,n,ns ! ! array arguments real & ym(*),ymmiss(*) integer & isym(*) ! ! scalars in common integer & ierr real & xinc,xlb,ylb,yub integer & ibar,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(n) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 's', 'v', 'p', 'm', 'l', ' '/ m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 1 isize = -1 miss = .true. lisym = n irlin = -1 ibar = 0 call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call svpml (y, ymiss, n, ns, isym, ilog)') end subroutine taper ( y, n, taperp, yt ) !*****************************************************************************80 ! !! TAPER applies a split-cosine-bell taper to a centered observed series. ! ! Discussion: ! ! this is the user routine for applying a split-cosine-bell ! taper to the (centered) observed series y, returning the tapered ! series in yt. this routine is adapted from bloomfields ! routine taper. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Peter Bloomfield, ! Fourier Analysis of Time Series - An Introduction, ! Wiley, New York, 1976. ! implicit none real & taperp integer & n ! ! array arguments real & y(*),yt(*) ! ! scalars in common integer & ierr real & pi,weight integer & i,j,m logical & err01,head ! ! local arrays character & ln(8)*1,nmsub(6)*1 ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err01 ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a variable used to indicare whether a heading is needed for ! error messages (true) or not (false). ! integer i ! an indexing variable. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list. ! if ierr == 0, no errors were detected. ! if ierr == 1, errors have been detected. ! integer j ! an indexing variable. ! character*1 ln(8) ! the array(s) containing the name(s) of the parameter(s) checked ! for errors. ! integer m ! the number of points at each end of the series to be ! tapered. ! integer n ! the number of observations in the series y. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! real pi ! the value of pi. ! real taperp ! the total percentage of the data to be tapered. ! real weight ! the ith taper weight. ! real y(n) ! the vector containing the observed time series. ! real yt(n) ! the vector in which the tapered series is returned. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 't', 'a', 'p', 'e', 'r', ' '/ data & ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) & /'n',' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. call eisge(nmsub, ln, n, 17, 1, head, err01, ln) if ( err01 ) then ierr = 1 write ( *, 1000) return end if call center (y, n, yt) if ((taperp <= 0.0e0) .or. (taperp > 1.0e0)) return call getpi(pi) m = int ( taperp * real ( n ) + 0.5e0 ) / 2 do i = 1, m weight = 0.5e0 - 0.5e0 * cos(pi * (real ( i ) -0.5e0) / real ( m ) ) yt(i) = weight * yt(i) j = n + 1 - i yt(j) = weight * yt(j) end do return 1000 format (/' the correct form of the call statement is'// & ' call taper (y, n, taperp, yt)') end subroutine timestamp ( ) !*****************************************************************************80 ! !! TIMESTAMP prints the current YMDHMS date as a time stamp. ! ! Example: ! ! 31 May 2001 9:45:54.872 AM ! ! Licensing: ! ! This code is distributed under the GNU LGPL license. ! ! Modified: ! ! 18 May 2013 ! ! Author: ! ! John Burkardt ! implicit none character ( len = 8 ) ampm integer ( kind = 4 ) d integer ( kind = 4 ) h integer ( kind = 4 ) m integer ( kind = 4 ) mm character ( len = 9 ), parameter, dimension(12) :: month = (/ & 'January ', 'February ', 'March ', 'April ', & 'May ', 'June ', 'July ', 'August ', & 'September', 'October ', 'November ', 'December ' /) integer ( kind = 4 ) n integer ( kind = 4 ) s integer ( kind = 4 ) values(8) integer ( kind = 4 ) y call date_and_time ( values = values ) y = values(1) m = values(2) d = values(3) h = values(5) n = values(6) s = values(7) mm = values(8) if ( h < 12 ) then ampm = 'AM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Noon' else ampm = 'PM' end if else h = h - 12 if ( h < 12 ) then ampm = 'PM' else if ( h == 12 ) then if ( n == 0 .and. s == 0 ) then ampm = 'Midnight' else ampm = 'AM' end if end if end if write ( *, '(i2.2,1x,a,1x,i4,2x,i2,a1,i2.2,a1,i2.2,a1,i3.3,1x,a)' ) & d, trim ( month(m) ), y, h, ':', n, ':', s, '.', mm, trim ( ampm ) return end subroutine uas ( y, n ) !*****************************************************************************80 ! !! UAS is the user callable routine for autoregressive spectrum estimation. ! ! Discussion: ! ! This is the short call version. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! real & alpha,delta,fmax,fmin,var,ymean integer & iar,lacov,lag,lagmax,laic,ldsmin,ldstak,lpcv,lphi, & lspc,lwork,nf,nprt ! ! local arrays real & acov(101),aic(101),freq(101),ftest(2,100),phi(100),spca(101), & spcf(101),work(101),xaxis(207),yaxis(207) integer & isort(101),isym(207) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external acvf,parzen,setlag,uasdv,uaser ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real acov(101) ! the autocovariance computed from the lag product pairs. ! real aic(101) ! the array contaning akiakes criteria for each order. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequency for which the ! spectrum estimates are to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! estimated. ! real ftest(2, 100) ! the array in which the f ratio and probability are stored. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected ! integer isort(101) ! an array used for sorting. ! integer isym(207) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the covariance arrays. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the array aic. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lphi ! the length of the vector phi. ! integer lspc ! the length of the spectrum arrays. ! integer lwork ! the length of the vector work. ! integer n ! the integer number of observations in the series. ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the type of window to be used. ! real phi(100) ! the array of autoregressive coefficients for the ! selected order. ! real spca(101) ! the aray containing the autoregressive spectrum estimates. ! real spcf(101) ! the array containing the Fourier spectrum estimates. ! real var ! the one step prediction variance for the selected model. ! real work(101) ! a real work area used for the lag windows and for ! computing the autoregressive coefficients. ! real xaxis(207) ! the x axis values for the spectrum plot. ! real y(n) ! the array containing the observed time series. ! real yaxis(207) ! the y axis values for the spectrum plot. ! real ymean ! the mean of the observed time series ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'u', 'a', 's', ' ', ' ', ' '/ option(1) = .false. option(2) = .false. option(3) = .false. option(4) = .false. lag = 0 iar = 0 nf = 101 fmin = 0.0e0 fmax = 0.5e0 nprt = -1 ldstak = 0 ldsmin = 0 ! ! set the maximum number of lags to be used. ! call setlag(n, lagmax) ! ! call error checking routine ! call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, & nf, ldstak, ldsmin, n, n, option) if (ierr /= 0) then ierr = 1 write ( *, 1000) return end if lpcv = 207 lspc = 101 lphi = 100 laic = 101 lacov = 101 lwork = 101 alpha = .95e0 delta = 1.0e0 ! ! compute autocovariances ! call acvf ( y, n, ymean, acov, lagmax, lacov ) ! ! call the main driver for autoregressive spectrum routines. ! call uasdv ( acov, spca, spcf, lspc, iar, phi, nf, fmin, fmax, freq, & n, lagmax, ftest, aic, work, lacov, lwork, delta, isort, & isym, xaxis, yaxis, lpcv, alpha, lag, laic, lphi, nprt, var, & parzen, nmsub ) return 1000 format (/' the correct form of the call statement is'// & ' call uas (y, n)') end subroutine uascft ( acov, lagmax, lacov, iar, phi, n, var ) !*****************************************************************************80 ! !! UASCFT computes autoregressive coefficients using Durbin's method. ! ! Discussion: ! ! this routine computes the autoregressive model coefficients ! for an order iar model using durbins recursive method. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the array of autocovariance estimates. ! integer iar ! the order of the autoregressive process chosen. ! integer l ! an index variable. ! integer lacov ! the length of the array acov. ! integer lagmax ! the maximum lag value to be used. ! integer n ! the number of observations in the series. ! real phi(iar) ! the array of autoregressive coefficients for the ! selected order. ! real rss, var ! implicit none integer iar integer lacov real acov(lacov) integer l integer lagmax integer n real phi(iar) real rss real var phi(1) = acov(2) / acov(1) rss = acov(1) * real ( n ) * (1.0e0 - phi(1)*phi(1)) do l = 2, iar call arcoef(acov(2), phi, rss, l, lagmax, acov(1)) end do var = rss / real ( n - iar - 1 ) return end subroutine uasdv ( acov, spca, spcf, lspc, iar, phi, nf, fmin, fmax, & freq, n, lagmax, ftest, aic, work, lacov, lwork, delta, isort, & isym, xaxis, yaxis, lpcv, alpha, lag, laic, lphi, nprt, var, & window, nmsub ) !*****************************************************************************80 ! !! UASDV is the driver for computing the autoregressive and Fourier spectrums. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance computed from the lag product pairs. ! real aic(laic) ! the array containing the akaikes criteria for each order(?). ! logical aicprt ! an indicator variable used to determine if the akiake ! information criteria and chi squared statistics should ! be printed. ! real alow ! a factor used to compute the lower confidence limits. ! real alpha ! the desired confidence level. ! real aup ! a factor used to compute the upper confidence limits. ! real bw ! the bandwidth. ! real delta ! the sampling interval. ! real df ! the effective degrees of freedom. ! real fmax, fmin ! the maximum and minimum frequency for which the ! spectrum estimates are to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! estimated. ! real ftest(2,lagmax) ! the array in which the f ratio and probability are stored. ! the order of the autoregressive process chosen. ! integer isort(nf) ! an array used for sorting. ! integer lspc ! the actual first dimension for the spectrum arrays. ! integer ispcer ! an error flag used for the spectrum plots. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the covariance arrays. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmax ! the maximum lag value to be used. ! integer lags(1) ! the lag window truncation point returned from ufslag. ! integer laic ! the length of the array aic. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lphi ! the length of the vector phi. ! integer lwork ! the actual length of the work array. ! integer n ! the integer number of observations in the series ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! integer nlppa(1) ! a dummy array ! character*1 nmsub(6) ! the name of the calling subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer npts ! the number of x, y coordinates to be plotted. ! integer nspca, nspcf ! the number of valid spectrum estimates for the autoregressive ! and Fourier spectrums, respectively. ! integer nw ! the number of lag window truncation points selcted. ! real phi(lphi) ! the array of autoregressive coefficients for the ! selected order. ! real spca(lspc) ! the aray containing the autoregressive spectrum estimates. ! real spcamn, spcamx ! the minimum and maximum autoregressive spectrum value to be ! plotted. ! real spcf(lspc) ! the array containing the Fourier spectrum estimates. ! real spcfmn, spcfmx ! the minimum and maximum Fourier spectrum value to be plotted. ! real var ! the one step prediction variance. ! external window ! the type of window to be used. ! real work(lwork) ! the work array. ! real xaxis(lpcv) ! the x axis values for the spectrum plot. ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real yaxis(lpcv) ! the y axis values for the spectrum plot. ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! implicit none real alpha real delta real fmax real fmin integer iar integer lacov integer lag integer lagmax integer laic integer lpcv integer lphi integer lspc integer lwork integer n integer nf integer nprt real var ! ! array arguments real & acov(lacov),aic(laic),freq(nf),ftest(2,lagmax),phi(lphi), & spca(lspc),spcf(lspc),work(lwork),xaxis(lpcv),yaxis(lpcv) integer & isort(nf),isym(lpcv) character & nmsub(6)*1 ! ! subroutine arguments external window ! ! real & alow,aup,bw,df,spcamn,spcamx,spcfmn,spcfmx,xpltmn,xpltmx, & ypltmn,ypltmx integer & ispcer,npts,nspca,nspcf,nw logical & aicprt ! ! local arrays integer & lags(1),nlppa(1) ! ! external subroutines external aos,setfrq,spcck,uascft,uasest,uasord,uasout,ufslag,ufsmn nw = 1 ! ! Set the lag window truncation point to be used for the ! Fourier spectrum estimates. ! if ( lag <= 0 ) then call ufslag ( acov, lagmax, lags, n, nw, nw, lacov ) lag = lags(1)/2 end if ! ! Set frequencies for the spectrum. ! call setfrq ( freq, nf, 1, fmin, fmax, delta ) ! ! Compute the Fourier spectrum estimates ! call ufsmn ( acov, nlppa, lag, df, nf, freq, alpha, bw, spcf, & alow, aup, lacov, lspc, window, work, lwork, n, delta, & .false., 1 ) aicprt = .false. ! ! User has chosen order. ! Compute coefficients and variance using durbins recursive method. ! if ( iar < 0 ) then call uascft ( acov, lagmax, lacov, iabs(iar), phi, n, var ) ! ! Select model order and compute coefficients and variance. ! else if ( iar == 0 ) then aicprt = .true. call aos ( n, lagmax, acov, work, iar, var, phi, & work, aic, ftest, lacov, laic ) end if ! ! Compute the autoregressive spectrum estimates. ! call uasest ( iabs(iar), var, phi, nf, freq, delta, spca, lphi, & lspc ) if ( nprt == 0 ) then return end if ! ! Set plotting vectors. ! xpltmn = fmin xpltmx = fmax ypltmn = 0.0e0 ypltmx = 0.0e0 call spcck ( spcf, isort, nf, spcfmn, spcfmx, nspcf, ispcer ) if ( ispcer == 0 ) then call spcck ( spca, isort, nf, spcamn, spcamx, nspca, ispcer ) if ( ispcer == 0 ) then call uasord ( spcf, spca, spcfmn, spcfmx, spcamn, spcamx, freq, nf, & xaxis, yaxis, isym, npts, lspc, lpcv, nspcf, nspca, bw, alow, & aup, xpltmn, xpltmx, ypltmn, ypltmx, nprt ) end if end if ! ! print results ! call uasout ( xaxis, yaxis, isym, npts, bw, int(df+0.5e0), lag, & iabs(iar), phi, ispcer, lpcv, xpltmn, xpltmx, ypltmn, ypltmx, & ftest, aic, laic, var, nprt, lagmax, aicprt, n, nmsub ) return end subroutine uaser ( nmsub, n, acov, iar, phi, lagmax, lag, lacov, & nf, ldstak, ldsmin, lyfft, nfft, option ) !*****************************************************************************80 ! !! UASER: error checks for time series Fourier univariate spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance function. ! logical err(20) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lag ! the lag window truncation point used for a specific window. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! character*1 lacv(8), lacv1p(8), ! * liar(8), llacov(8), llag(8), llgmx(8), llgmxm(8), ! * llgmxp(8), llgmx1(8), llds(8), ln(8), lnf(8), lnm1(8), ! * llyfft(8), lphi(8), l1(8) ! the array(s) containing the name(s) of the argument(s) ! checked for errors. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in the series. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the array containing the name of the user called subroutine. ! integer nv ! the number of violations found when checking vector lags. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! real phi(iar) ! the array of autoregressive coefficients for the ! selected order. ! implicit none integer & iar,lacov,lag,lagmax,ldsmin,ldstak,lyfft,n,nf,nfft ! ! array arguments real & acov(*),phi(*) logical & option(4) character & nmsub(6)*1 ! ! scalars in common integer & ierr integer & i,nv logical & head ! ! local arrays logical & err(20) character & l1(8),lacv(8),liar(8), & llacov(8),llag(8),llds(8),llgmx(8),llgmx1(8), & llgmxm(8),llgmxp(8),llyfft(8),ln(8),lnf(8), & lnm1(8),lphi(8) ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data lacv(1), lacv(2), lacv(3), lacv(4), lacv(5), lacv(6), & lacv(7), lacv(8) /'a','c','o','v',' ',' ',' ',' '/ data liar(1), liar(2), liar(3), liar(4), liar(5), & liar(6), liar(7), liar(8) /'i','a','r',' ',' ',' ',' ', & ' '/ data llacov(1), llacov(2), llacov(3), llacov(4), llacov(5), & llacov(6), llacov(7), llacov(8) /'l','a','c','o','v',' ',' ', & ' '/ data llag(1), llag(2), llag(3), llag(4), llag(5), llag(6), & llag(7), llag(8) /'l','a','g',' ',' ',' ',' ',' '/ data llgmx(1), llgmx(2), llgmx(3), llgmx(4), llgmx(5), & llgmx(6), llgmx(7), llgmx(8) /'l','a','g','m','a','x',' ', & ' '/ data llgmxm(1), llgmxm(2), llgmxm(3), llgmxm(4), llgmxm(5), & llgmxm(6), llgmxm(7), llgmxm(8) /'-','l','a','g','m','a','x', & ' '/ data llgmxp(1), llgmxp(2), llgmxp(3), llgmxp(4), llgmxp(5), & llgmxp(6), llgmxp(7), llgmxp(8) /'+','l','a','g','m','a','x', & ' '/ data llgmx1(1), llgmx1(2), llgmx1(3), llgmx1(4), llgmx1(5), & llgmx1(6), llgmx1(7), llgmx1(8) /'l','a','g','m','a','x','+', & '1'/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), lnf(6), lnf(7), & lnf(8) /'n','f',' ',' ',' ',' ',' ',' '/ data lnm1(1), lnm1(2), lnm1(3), lnm1(4), lnm1(5), lnm1(6), & lnm1(7), lnm1(8) /'n','-','1',' ',' ',' ',' ',' '/ data llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) /'l','y','f','f','t',' ',' ', & ' '/ data lphi(1), lphi(2), lphi(3), lphi(4), lphi(5), lphi(6), & lphi(7), lphi(8) /'p','h','i',' ',' ',' ',' ',' '/ data l1(1), l1(2), l1(3), l1(4), l1(5), l1(6), l1(7), l1(8) /'1', & ' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. err(1:20) = .false. call eisge(nmsub, ln, n, 17, 1, head, err(1), ln) if ( option(3) ) then call ervii(nmsub, lacv, acov, lagmax+1, -abs(acov(1)), & abs(acov(1)), 0, head, 4, nv, err(15) ) call eisii(nmsub, llgmx, lagmax, 1, n-1, 1, head, err(2), & l1, lnm1) if (option(2)) then call eisge(nmsub, llacov, lacov, lagmax+1, 8, head, err(3), & llgmx1) else call eisge(nmsub, llacov, lacov, lagmax+1, 7, head, err(3), & llgmx1) end if end if if (option(1) .and. (.not.err(1))) & call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err(4), & llyfft) if (option(1) .and. (.not.option(4))) & call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(5), llds) if ( .not. option(4) ) then do i = 1, 15 if (err(i)) then ierr = 1 return end if end do return end if call eisii(nmsub, liar, iar, -iabs(lagmax), iabs(lagmax), 1, head, & err(6), llgmxm, llgmxp) call ervii ( nmsub, lphi, phi, iar, -1.0e0, 1.0e0, 0, head, 1, nv, & err(7) ) if (.not.option(3)) then call eisii(nmsub, llgmx, lagmax, 1, n-1, 1, head, err(2), & l1, lnm1) end if call eisii(nmsub, llag, lag, -iabs(lagmax), iabs(lagmax), 1, head, & err(8), llgmxm, llgmxp) call eisge(nmsub, lnf, nf, 1, 1, head, err(9), lnf) if (err(1) .or. err(2) .or. err(9)) then ierr = 1 return end if call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(14), llds) do i = 1, 15 if (err(i)) then ierr = 1 return end if end do return end subroutine uasest ( iar, var, phi, nf, freq, delta, spca, lphi, ispc ) !*****************************************************************************80 ! !! UASET calculates the autoregressive spectrum. ! ! Discussion: ! ! This routine is modeled after subroutine UASEC by Dick Jones. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta,var integer & iar,ispc,lphi,nf ! ! array arguments real & freq(nf),phi(lphi),spca(ispc) ! ! real & arg,ei,er,exi,exr,exrtmp,pi,ti,tr integer & i,j ! ! variable definitions (alphabetically) ! ! real arg ! the argument for the sine and cosine functions used in ! calculations of the spectrum. ! real delta ! the sampling interval. ! real ei, er, exi, exr, exrtmp ! 'complex' variables used in the computations. ! real freq(nf) ! the array containing the frequencies at which the spectrum ! is to be computed. ! integer i ! an index variable. ! integer iar ! the order of the autoregressive process chosen. ! integer ispc ! the length of the array spca. ! integer j ! an index variable. ! integer lphi ! the length of the array phi. ! integer nf ! the number of frequencies at which the spectrum is to be ! estimated. ! real phi(lphi) ! the array of autoregressive coefficients for the ! selected order. ! real pi ! the value of pi. ! real spca(ispc) ! the array in which the autoregressive spectrum is stored. ! real ti, tr ! a variable used in the computations. ! real var ! the one step prediction variance for the selected order (iar). ! call getpi(pi) do j=1,nf spca(j) = delta * var if (iar >= 1) then if (delta == 1.0e0) then if (freq(j) == 0.0e0) then er = 1.0e0 ei = 0.0e0 else if (freq(j) == 0.25e0) then er = 0.0e0 ei = 1.0e0 else if (freq(j) == 0.5e0) then er = -1.0e0 ei = 0.0e0 else arg = 2.0e0 * pi * delta * freq(j) er = cos(arg) ei = sin(arg) end if else arg = 2.0e0 * pi * delta * freq(j) er = cos(arg) ei = sin(arg) end if exr = 1.0e0 exi = 0.0e0 tr = 1.0e0 ti = 0.0e0 do i=1,iar exrtmp = exr*er - exi*ei exi = exr*ei + exi*er exr = exrtmp tr = tr - phi(i) * exr ti = ti - phi(i) * exi end do spca(j) = spca(j)/(tr*tr + ti*ti) end if end do return end subroutine uasf ( yfft, n, lyfft, ldstak ) !*****************************************************************************80 ! !! UASF is the user callable routine for autoregressive spectrum estimation. ! ! Discussion: ! ! This routine uses the fast Fourier transform. This is the version with ! a short calling sequence. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ldstak,lyfft,n ! ! array arguments real & yfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,fmax,fmin,var,ymean integer & iar,ifp,lacov,lag,lagmax,laic,ldsmin,lpcv,lphi,lspc, & lwork,nall0,nf,nfft,nprt,work ! ! local arrays real & acov(101),aic(101),freq(101),ftest(2,100),phi(100),rstak(12), & spca(101),spcf(101),xaxis(207),yaxis(207) integer & isort(101),istak(12),isym(207) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acvff,ldscmp,parzen,setesl,setlag,stkclr,stkset, & uasdv,uaser ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) equivalence (isym(1),isort(1)) ! ! variable definitions (alphabetically) ! ! real acov(101) ! the autocovariance computed from the lag product pairs. ! real aic(101) ! the array contaning akiakes criteria for each order. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency for which the ! spectrum estimates are to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! estimated. ! real ftest(2, 100) ! the array in which the f ratio and probability are stored. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer isort(101) ! an array used for sorting. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer lspc ! the length of the spectrum arrays. ! integer isym(207) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the covariance arrays. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the array aic. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lphi ! the length of the vector phi. ! integer lwork ! the length of the work array. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of allocations outstanding at the time that ! this routine was called. ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the type of window to be used. ! real phi(100) ! the array of autoregressive coefficients for the ! selected order. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spca(101) ! the aray containing the autoregressive spectrum estimates. ! real spcf(101) ! the array containing the Fourier spectrum estimates. ! real var ! the one step prediction variance. ! integer work ! the starting location in rstak for ! the work vector. ! real xaxis(207) ! the x axis values for the spectrum plot. ! real yaxis(207) ! the y axis values for the spectrum plot. ! real yfft(lyfft) ! the array containing the observed time series. ! real ymean ! the mean of the observed time series ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'u', 'a', 's', 'f', ' ', ' '/ ifp = 3 option(1) = .true. option(2) = .false. option(3) = .false. option(4) = .false. lag = 0 iar = 0 nf = 101 fmin = 0.0e0 fmax = 0.5e0 nprt = -1 ! ! set the maximum number of lags to be used. ! call setlag(n, lagmax) ! ! set length of extended series ! call setesl(n+lagmax, 4, nfft) call ldscmp(1, 0, 0, 0, 0, 0, 's', nfft, ldsmin) call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, & nf, ldstak, ldsmin, lyfft, nfft, option) if (ierr /= 0) then ierr = 1 write ( *, 1000) return end if ! ! set the size of the work area ! call stkset(ldstak, 4) ! ! save number of outstanding stack allocations. ! nall0 = stkst(1) lpcv = 207 lspc = 101 lphi = 100 laic = 101 lacov = 101 lwork = nfft alpha = 0.95e0 delta = 1.0e0 ! ! subdivide the work area ! work = stkget(lwork, ifp) ! ! compute autocovariances ! call acvff (yfft, n, nfft, ymean, acov, lagmax, lacov, lyfft, & rstak(work), lwork) ! ! call the main driver for autoregressive spectrum routines. ! call uasdv(acov, spca, spcf, lspc, iar, phi, nf, fmin, fmax, freq, & n, lagmax, ftest, aic, rstak(work), lacov, lwork, delta, isort, & isym, xaxis, yaxis, lpcv, alpha, lag, laic, lphi, nprt, var, & parzen, nmsub) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call uasf (yfft, n, lyfft, ldstak)') end subroutine uasfs ( yfft, n, lyfft, ldstak, iar, phi, lagmax, lag, & nf, fmin, fmax, nprt, spca, spcf, freq ) !*****************************************************************************80 ! !! UASFS: interface, autoregressive spectrum estimation using FFT (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin integer & iar,lag,lagmax,ldstak,lyfft,n,nf,nprt ! ! array arguments real & freq(*),phi(*),spca(*),spcf(*),yfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,fmn,fmx,var,ymean integer & acov,aic,ftest,ia,ifp,io,isort,isym,lacov,laic, & ldsmin,lpcv,lphi,lspc,lwork,nall0,nfft,work,xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external acvff,amean,ldscmp,parzen,setesl,stkclr,stkset, & uasdv,uaser,uasvar ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! integer acov ! the starting location in rstak for the array of ! the autocovariance array. ! integer aic ! the starting location in the stack for ! the array containing the aic. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency for which the ! spectrum estimates are to be computed. ! real fmn, fmx ! the maximum and minimum frequency actually used. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! estimated. ! integer ftest ! the starting location in the stack for ! the array in which the f ratio and probability are stored. ! integer ia ! a variable used to determine the amount of storage required, ! based on whether or not the model order is to be selected or ! has been provided. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output requested. ! integer isort ! the starting location in istak for ! an array used for sorting. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in istak for ! the array containing the code for the plot symbols. ! integer lacov ! the length of the covariance arrays. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the array aic. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lphi ! the length of the vector phi. ! integer lspc ! the length of the spectrum arrays. ! integer lwork ! the actual length of the work array. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in the series ! integer nall0 ! the number of stack allocations outstanding when this routine ! was called. ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the type of window to be used. ! real phi(lagmax) ! the array of autoregressive coefficients for the ! selected order. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spca(nf) ! the aray containing the autoregressive spectrum estimates. ! real spcf(nf) ! the array containing the Fourier spectrum estimates. ! real var ! the one step prediction variance. ! integer work ! the starting location in the stack for ! the work array. ! integer xaxis ! the starting location in rstak for ! the x axis values for the spectrum plot. ! integer yaxis ! the starting location in rstak for ! the y axis values for the spectrum plot. ! real yfft(lyfft) ! the array containing the observed time series. ! real ymean ! the mean of the observed time series ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'u', 'a', 's', 'f', 's', ' '/ ifp = 3 option(1) = .true. option(2) = .false. option(3) = .false. option(4) = .true. ! ! set extended series length ! call setesl(n+lagmax, 4, nfft) io = 1 if (nprt == 0) io = 0 ia = 1 if (iar /= 0) ia = 0 call ldscmp(7, 0, io*(2*nf+5), 0, 0, 0, 's', & lagmax+1+nfft+ia*(3*lagmax+1)+io*(4*nf+10), ldsmin) call uaser(nmsub, n, yfft, iar, phi, lagmax, lag, lacov, & nf, ldstak, ldsmin, lyfft, nfft, option) 5 if (ierr /= 0) then ierr = 1 write ( *, 1000) return end if ! ! set size of work area. ! call stkset (ldstak, 4) ! ! save number of outstanding stack allocations. ! nall0 = stkst(1) lspc = nf lpcv = 2*nf + 5 lphi = lagmax lacov = lagmax + 1 lwork = nfft fmn = max(fmin, 0.0e0) fmx = min(fmax, 0.5e0) if (fmn >= fmx) then fmn = 0.0e0 fmx = 0.5e0 end if alpha = 0.95e0 delta = 1.0e0 if (iar >= 1) then ! ! user has chosen order and supplied coefficients. ! compute residual variance. ! call amean(yfft, n, ymean) call uasvar (yfft, ymean, n, iar, phi, var) end if ! ! compute autocovariances ! acov = stkget(lacov, ifp) work = stkget(lwork, ifp) call acvff (yfft, n, nfft, ymean, rstak(acov), lagmax, lagmax+1, & lyfft, rstak(work), nfft) ! ! set up additional stack work area, if needed. ! if (iar == 0) then laic = lagmax+1 aic = stkget(laic, ifp) ftest = stkget(2*lagmax, ifp) else laic = lwork aic = work ftest = work end if if (nprt /= 0) then xaxis = stkget(lpcv, ifp) yaxis = stkget(lpcv, ifp) isym = stkget(lpcv, 2) isort = isym else xaxis = work yaxis = work isym = work isort = work end if if (ierr == 1) go to 5 ! ! call the main driver for autoregressive spectrum routines. ! call uasdv(rstak(acov), spca, spcf, lspc, iar, phi, nf, fmn, & fmx, freq, n, lagmax, rstak(ftest), rstak(aic), rstak(work), & lacov, lwork, delta, istak(isort), istak(isym), rstak(xaxis), & rstak(yaxis), lpcv, alpha, lag, laic, lphi, nprt, var, parzen, & nmsub) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call uasfs (yfft, n, lyfft, ldstak,'/ & ' + iar, phi, lagmax, lag, nf, fmin, fmax, nprt'/ & ' + spca, spcf, freq)') end subroutine uasord ( spcf, spca, spcfmn, spcfmx, spcamn, spcamx, & freq, nf, xaxis, yaxis, isym, npts, ispc, lpcv, nspcf, nspca, & bw, alow, aup, xpltmn, xpltmx, ypltmn, ypltmx, nprt ) !*****************************************************************************80 ! !! UASORD produces coordinates for the spectrum plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & alow,aup,bw,spcamn,spcamx,spcfmn,spcfmx,xpltmn,xpltmx,ypltmn, & ypltmx integer & ispc,lpcv,nf,nprt,npts,nspca,nspcf ! ! array arguments real & freq(nf),spca(ispc),spcf(ispc),xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) real & cilow,cimid,ciup,ymax integer & i,ispca,ispcf ! ! external subroutines external sppltc,sppltd,sppltl ! ! variable definitions (alphabetically) ! ! real alow ! the factor used to compute the lower confidence limits. ! real aup ! the factor used to compute the upper confidence limits. ! real bw ! the bandwidth. ! real cilow, cimid, ciup ! the y axis values for the lower, mid and upper confidence ! interval points. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! estimated. ! integer i ! an index variable ! integer ispc ! the length of the spectrum arrays. ! integer ispca, ispcf ! the index for the Fourier and autoregressive estimates, ! respectively. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lpcv ! the length of the plot coordinate vectors. ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer npts ! the number of x, y coordinates to be plotted. ! integer nspca, nspcf ! the number of valid spectrum estimates for the autoregressive ! and Fourier spectrums, respectively. ! real spca(ispc) ! the aray containing the autoregressive spectrum estimates. ! real spcamn, spcamx ! the minimum and maximum autoregressive spectrum value to be ! plotted. ! real spcf(ispc) ! the array containing the Fourier spectrum estimates. ! real spcfmn, spcfmx ! the minimum and maximum Fourier spectrum value to be plotted. ! real xaxis(lpcv) ! the x axis values for the spectrum plot. ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real yaxis(lpcv) ! the y axis values for the spectrum plot. ! real ymax ! the maximum actual spectrum value (in decibels) to be plotted. ! real ypltmn, ypltmx ! the minimum and mayimum values to be plotted for the x axis. ! ispcf = 0 ispca = nspcf if ( nprt < 1 ) then ! ! set various y axis values for decibel plots ! call sppltd (min(spcfmn, spcamn), max(spcfmx, spcamx), & alow, aup, ypltmn, ypltmx, cilow, cimid, ciup, ymax) ! ! set coordinates for decibel plots ! do i = 1, nf if ( spcfmn <= spcf(i) ) then ispcf = ispcf + 1 xaxis(ispcf) = freq(i) yaxis(ispcf) = 10.0e0 * log10(spcf(i)) - ymax isym(ispcf) = 1 end if if ( spcamn <= spca(i) ) then ispca = ispca + 1 xaxis(ispca) = freq(i) yaxis(ispca) = 10.0e0 * log10(spca(i)) - ymax isym(ispca) = 2 end if end do else ! ! set various y axis values for log plots ! call sppltl (min(spcfmn, spcamn), max(spcfmx, spcamx), & alow, aup, ypltmn, ypltmx, cilow, cimid, ciup) ! ! set coordinates for log plots ! do i = 1, nf if ( spcfmn <= spcf(i) ) then ispcf = ispcf + 1 xaxis(ispcf) = freq(i) yaxis(ispcf) = spcf(i) isym(ispcf) = 1 end if if ( spcamn <= spca(i) ) then ispca = ispca + 1 xaxis(ispca) = freq(i) yaxis(ispca) = spca(i) isym(ispca) = 2 end if end do end if npts = nspca + nspcf ! ! set coordinates for bandwidth and confidence interval. ! call sppltc (xaxis, yaxis, isym, npts, xpltmn, xpltmx, bw, cilow, & cimid, ciup, lpcv) return end subroutine uasout ( xaxis, yaxis, isym, npts, bw, idf, lag, & iar, phi, ispcer, lpcv, xpltmn, xpltmx, ypltmn, ypltmx, & ftest, aic, laic, var, nprt, lagmax, aicprt, n, nmsub ) !*****************************************************************************80 ! !! UASOUT produces the spectrum plots for the autoregressive spectrum estimates. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real aic(laic) ! the array contaning akiakes criteria for each order. ! logical aicprt ! an indicator variable used to determine if the akiake ! information criteria and chi squared statistics should ! be printed. ! real bw ! the bandwidth. ! logical error ! an error flag ! real ftest(2,lagmax) ! the array in which the f ratio and probability are stored. ! integer iar ! the order of the autoregressive process chosen. ! integer idf ! the effective degrees of freedom. ! integer ispcer ! a variable used to designate an error in the spectral ! estimates. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lag ! the lag window truncation point used for the Fourier spectrum. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the array aic. ! integer lpcv ! the length of the plot coordinate vectors. ! integer n ! the number of observations in the series. ! character*1 nmsub(6) ! the name of the calling subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer npts ! the number of x, y coordinates to be plotted. ! real phi(lagmax) ! the array of autoregressive coefficients for the selected ! order. ! real prho(1) ! a dummy variable. ! real var ! the one step prediction variance for order iar. ! real xaxis(lpcv) ! the x axis values for the spectral plot. ! real xmn, xmx ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real yaxis(lpcv) ! the y axis values for the spectral plot. ! real ymn, ymx ! * ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! implicit none real bw real var real xpltmn real xpltmx real ypltmn real ypltmx integer & iar,idf,ispcer,lag,lagmax,laic,lpcv,n,nprt,npts logical & aicprt ! ! array arguments real & aic(laic),ftest(2,lagmax),phi(lagmax),xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) character & nmsub(6)*1 real & xmn,xmx,ymn,ymx integer & ilog logical & error ! ! local arrays real & prho(1) ! ! print autoregressive model order selection statistics ! if ( aicprt ) then call versp ( .true. ) write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'Autoregressive Order Selection Statistics:' write ( *, '(a)' ) ' ' call aoslst ( prho, aic, ftest, lagmax, laic, iar, phi, var, & .false., n ) write ( *, * )' ' end if call versp ( .true. ) write ( *, '(a)' ) ' ' write ( *, '(a,i8)' ) 'Fourier spectrum (+) (lag wind. trunc. pt.=', lag write ( *, '(a,f6.4)' ) 'BW =', bw write ( *, '(a,i8)' ) 'IDF =', idf write ( *, '(a,i8,a)' ) 'and order ', iar, ' autoregressive spectrum (.)' if ( ispcer /= 0 ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'The plot has been supressed because fewer than' write ( *, '(a)' ) 'four valid (positive) spectral estimates could be ' write ( *, '(a)' ) 'computed.' return end if if ( nprt <= 0 ) then ilog = 0 else ilog = 1 end if call pplmt ( yaxis, yaxis, xaxis, xaxis(1), npts, 1, lpcv, ypltmn, & ypltmx, ymn, ymx, xpltmn, xpltmx, xmn, xmx, error, nmsub, & .false.) if (.not.error) then call ppmn ( yaxis, yaxis, xaxis, xaxis(1), npts, 1, lpcv, 1, isym, & lpcv, 0, -1, ymn, ymx, xmn, xmx, .false., ilog ) end if if ( xpltmn /= 0.0e0 .or. xpltmx /= 0.5e0 ) then return end if write ( *, '(a)' ) '+freq' write ( *, '(a)' ) & ' period inf 20. 10. 6.6667 5.' // & ' 4. 3.3333 2.8571 2.5 2.2222 2.' return end subroutine uass ( y, n, iar, phi, lagmax, lag, nf, fmin, fmax, & nprt, spca, spcf, freq, ldstak ) !*****************************************************************************80 ! !! UASS: user interface for autoregressive spectrum estimation (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer acov ! the starting location in rstak for the array of ! the autocovariance array. ! integer aic ! the starting location in the stack for ! the array containing the aic. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency for which the ! spectrum estimates are to be computed. ! real fmn, fmx ! the maximum and minimum frequency actually used. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! estimated. ! integer ftest ! the starting location in the stack for ! the array in which the f ratio and probability are stored. ! integer ia ! a variable used to determine the amount of storage required, ! based on whether or not the model order is to be selected or ! has been provided. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output requested. ! integer isort ! the starting location in istak for ! an array used for sorting. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in istak for ! the array containing the code for the plot symbols. ! integer lacov ! the length of the covariance arrays. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the array aic. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lphi ! the length of the vector phi. ! integer lspc ! the length of the spectrum arrays. ! integer lwork ! the length of the work array. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of stack allocations outstanding when this routine ! was called. ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the type of window to be used. ! real phi(lagmax) ! the array of autoregressive coefficients for the ! selected order. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spca(nf) ! the array containing the autoregressive spectrum estimates. ! real spcf(nf) ! the array containing the Fourier spectrum estimates. ! real var ! the one step prediction variance. ! integer work ! the starting location in the stack for ! the work array. ! integer xaxis ! the starting location in rstak for ! the x axis values for the spectrum plot. ! real y(n) ! the array containing the observed time series. ! integer yaxis ! the starting location in rstak for ! the y axis values for the spectrum plot. ! real ymean ! the mean of the observed time series ! implicit none integer acov integer aic real alpha double precision dstak(3000) real delta real fmax real fmin real fmn real fmx real freq(*) integer ftest integer ia integer iar integer ierr integer ifp integer io integer isort integer istak(12) integer isym integer lacov integer lag integer lagmax integer laic integer ldsmin integer ldstak integer lpcv integer lphi integer lspc integer lwork integer n integer nall0 integer nf character nmsub(6) integer nprt logical option(4) external parzen real phi(*) real rstak(12) real spca(*) real spcf(*) integer, external :: stkget integer, external :: stkst real var integer work integer xaxis real y(*) integer yaxis real ymean common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'u', 'a', 's', 's', ' ', ' '/ ifp = 3 option(1) = .false. option(2) = .false. option(3) = .false. option(4) = .true. if ( nprt == 0 ) then io = 0 else io = 1 end if if ( iar /= 0 ) then ia = 0 else ia = 1 end if call ldscmp ( 7, 0, io*(2*nf+5), 0, 0, 0, 's', & 2*lagmax+2+ia*(3*lagmax+1)+io*(4*nf+10), ldsmin ) call uaser ( nmsub, n, y, iar, phi, lagmax, lag, lacov, & nf, ldstak, ldsmin, n, n, option ) if ( ierr /= 0 ) then ierr = 1 write ( *, '(a)' ) write ( *, '(a)' ) 'UASS - Fatal error!' write ( *, '(a)' ) ' Nonzero error return from UASER.' return end if ! ! Set size of work area. ! call stkset ( ldstak, 4 ) ! ! Save number of outstanding stack allocations. ! nall0 = stkst(1) lspc = nf lpcv = 2*nf + 5 lphi = lagmax lacov = lagmax + 1 lwork = lagmax+1 fmn = max ( fmin, 0.0e0 ) fmx = min ( fmax, 0.5e0 ) if ( fmn >= fmx ) then fmn = 0.0e0 fmx = 0.5e0 end if alpha = 0.95e0 delta = 1.0e0 ! ! Compute autocovariances. ! acov = stkget ( lacov, ifp ) call acvf ( y, n, ymean, rstak(acov), lagmax, lacov ) ! ! user has chosen order and supplied coefficients. ! compute residual variance. ! if ( iar >= 1 ) then call uasvar ( y, ymean, n, iar, phi, var ) end if ! ! Set up additional stack work area, if needed. ! work = stkget ( lwork, ifp ) if ( iar == 0 ) then laic = lagmax+1 aic = stkget(laic, ifp) ftest = stkget(2*lagmax, ifp) else laic = lwork aic = work ftest = work end if if ( nprt == 0 ) then xaxis = work yaxis = work isym = work isort = work else xaxis = stkget ( lpcv, ifp ) yaxis = stkget ( lpcv, ifp ) isym = stkget ( lpcv, 2 ) isort = isym end if if ( ierr == 1 ) then ierr = 1 write ( *, 1000) return end if ! ! Call the main driver for autoregressive spectrum routines. ! call uasdv ( rstak(acov), spca, spcf, lspc, iar, phi, nf, fmn, & fmx, freq, n, lagmax, rstak(ftest), rstak(aic), rstak(work), & lacov, lwork, delta, istak(isort), istak(isym), rstak(xaxis), & rstak(yaxis), lpcv, alpha, lag, laic, lphi, nprt, var, parzen, & nmsub ) call stkclr ( nall0 ) return 1000 format (/' the correct form of the call statement is'// & ' call uass (y, n,'/ & ' + iar, phi, lagmax, lag, nf, fmin, fmax, nprt,'/ & ' + spca, spcf, freq, ldstak)') end subroutine uasvar ( y, ymean, n, iar, phi, var ) !*****************************************************************************80 ! !! UASVAR computes the variance for a given series and autoregressive model. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer i ! an index variable. ! integer iar ! the order of the autoregressive process chosen. ! integer iar1 ! the value iar + 1. ! integer j, k ! index values. ! integer n ! the integer number of observations in each series ! real phi(iar) ! the array of autoregressive coefficients for the ! selected order. ! real res ! * ! real rss ! the one step prediction residual sum of squares. ! real var ! the one step prediction variance. ! real y(n) ! the array containing the observed time series. ! real ymean ! the mean of the observed time series ! implicit none integer iar integer n integer i integer j real phi(iar) real res real rss real var real y(n) real ymean rss = 0.0e0 do i = iar + 1, n res = y(i) - ymean do j = 1, iar res = res - phi(j) * ( y(i-j) - ymean ) end do rss = rss + res * res end do var = rss / real ( n - ( iar + 1 ) ) return end subroutine uasv ( acov, lagmax, n ) !*****************************************************************************80 ! !! UASV is the user routine for autoregressive spectrum estimation. ! ! Discussion: ! ! This is the user callable routine for autoregressive ! spectrum estimation when the acvf have previously been ! computed and stored (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer lagmax integer n external parzen ! ! array arguments real & acov(*) ! ! scalars in common integer & ierr real & alpha,delta,fmax,fmin,var integer & iar,lacov,lag,laic,ldsmin,ldstak,lpcv,lphi,lspc, & lwork,nf,nprt ! ! local arrays real & aic(101),freq(101),ftest(2,100),phi(100),spca(101),spcf(101), & work(101),xaxis(207),yaxis(207) integer & isort(101),isym(207) logical & option(4) character & nmsub(6)*1 ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real acov(lagmax+1) ! the autocovariance computed from the lag product pairs. ! real aic(101) ! the array contaning akiakes criteria for each order. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequency for which the ! spectrum estimates are to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! estimated. ! real ftest(2, 100) ! the array containing the f ratio and f test. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected ! integer isort(101) ! an array used for sorting. ! integer isym(207) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the covariance arrays. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the array aic. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lphi ! the length of the vector phi. ! integer lspc ! the length of the spectrum arrays. ! integer lwork ! the length of the work array. ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the type of window to be used. ! real phi(100) ! the array of autoregressive coefficients for the ! selected order. ! real spca(101) ! the aray containing the autoregressive spectrum estimates. ! real spcf(101) ! the array containing the Fourier spectrum estimates. ! real var ! the one step prediction variance. ! real work(101) ! a work area used for the lag windows and for ! computing the autoregressive coefficients. ! real xaxis(207) ! the x axis values for the spectrum plot. ! real yaxis(207) ! the y axis values for the spectrum plot. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'u', 'a', 's', 'v', ' ', ' '/ option(1) = .false. option(2) = .false. option(3) = .true. option(4) = .false. lag = 0 iar = 0 nf = 101 fmin = 0.0e0 fmax = 0.5e0 nprt = -1 lacov = lagmax+1 ldstak = 0 ldsmin = 0 call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, & nf, ldstak, ldsmin, n, n, option) if (ierr /= 0) then ierr = 1 write ( *, 1000) return end if lpcv = 207 laic = 101 lspc = 101 lphi = 100 lwork = 101 alpha = 0.95e0 delta = 1.0e0 ! ! call the main driver for autoregressive spectrum routines. ! call uasdv(acov, spca, spcf, lspc, iar, phi, nf, fmin, fmax, freq, & n, lagmax, ftest, aic, work, lacov, lwork, delta, isort, & isym, xaxis, yaxis, lpcv, alpha, lag, laic, lphi, nprt, var, & parzen, nmsub) return 1000 format (/' the correct form of the call statement is'// & ' call uasv (acov, lagmax, n)') end subroutine uasvs ( acov, lagmax, y, n, iar, phi, lag, nf, & fmin, fmax, nprt, spca, spcf, freq, ldstak ) !*****************************************************************************80 ! !! UASVS is a user routine for autoregressive spectrum estimation. ! ! Discussion: ! ! this is the user callable routine for autoregressive ! spectrum estimation when the acvf have previously been ! computed and stored (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin integer & iar,lag,lagmax,ldstak,n,nf,nprt ! ! array arguments real & acov(*),freq(*),phi(*),spca(*),spcf(*),y(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,fmn,fmx,var,ymean integer & aic,ftest,ia,ifp,io,isort,isym,lacov,laic,ldsmin, & lpcv,lphi,lspc,lwork,nall0,work,xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external amean,ldscmp,parzen,stkclr,stkset,uasdv,uaser, & uasvar ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real acov(lagmax+1) ! the array of autocovariance estimates. ! integer aic ! the starting location in the stack for ! the array containing the aic. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency for which the ! spectrum estimates are to be computed. ! real fmn, fmx ! the maximum and minimum frequency actually used. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! estimated. ! integer ftest ! the starting location in the stack for ! the array in which the f ratio and probability are stored. ! integer ia ! a variable used to determine the amount of storage required, ! based on whether or not the model order is to be selected or ! has been provided. ! integer iar ! the order of the autoregressive process chosen. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr /= 0, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required, ! based on printed output requested. ! integer isort ! the starting location in istak for ! an array used for sorting. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in istak for ! the array containing the code for the plot symbols. ! integer lacov ! the length of the covariance arrays. ! integer lag ! the lag window truncation point used for a specific window. ! integer lagmax ! the maximum lag value to be used. ! integer laic ! the length of the array aic. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lpcv ! the length of the plot coordinate vectors. ! integer lphi ! the length of the vector phi. ! integer lspc ! the length of the spectrum arrays. ! integer lwork ! the actual length of the work array. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of stack allocations outstanding when this routine ! was called. ! integer nf ! the number of frequencies for which the spectrum estimates ! are to be estimated. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the type of window to be used. ! real phi(lagmax) ! the array of autoregressive coefficients for the ! selected order. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spca(nf) ! the aray containing the autoregressive spectrum estimates. ! real spcf(nf) ! the array containing the Fourier spectrum estimates. ! real var ! the one step prediction variance. ! integer work ! the starting location in the stack for ! the work array. ! integer xaxis ! the starting location in rstak for ! the x axis values for the spectrum plot. ! real y(n) ! the array containing the observed time series. ! integer yaxis ! the starting location in rstak for ! the y axis values for the spectrum plot. ! real ymean ! the mean of the observed time series ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / 'u', 'a', 's', 'v', 's', ' '/ ifp = 3 option(1) = .false. option(2) = .false. option(3) = .true. option(4) = .true. lacov = lagmax+1 io = 1 if (nprt == 0) io = 0 ia = 1 if (iar /= 0) ia = 0 call ldscmp(6, 0, io*(2*nf+5), 0, 0, 0, 's', & lagmax + 1 + ia*(3*lagmax+1) + io*(4*nf+10), ldsmin) call uaser(nmsub, n, acov, iar, phi, lagmax, lag, lacov, & nf, ldstak, ldsmin, n, n, option) if (ierr /= 0) then ierr = 1 write ( *, 1000) return end if ! ! set size of work area. ! call stkset (ldstak, 4) ! ! save number of outstanding stack allocations. ! nall0 = stkst(1) lspc = nf lpcv = 2*nf + 5 lphi = lagmax lwork = lagmax+1 fmn = max(fmin, 0.0e0) fmx = min(fmax, 0.5e0) if (fmn >= fmx) then fmn = 0.0e0 fmx = 0.5e0 end if alpha = 0.95e0 delta = 1.0e0 if (iar >= 1) then ! ! user has chosen order and supplied coefficients. ! compute residual variance. ! call amean (y, n, ymean) call uasvar (y, ymean, n, iar, phi, var) end if ! ! set up additional stack work area, if needed. ! work = stkget(lwork,ifp) if (iar == 0) then laic = lagmax+1 aic = stkget(laic, ifp) ftest = stkget(2*lagmax, ifp) else laic = lwork aic = work ftest = work end if if (nprt == 0) then xaxis = work yaxis = work isym = work isort = work else xaxis = stkget(lpcv, ifp) yaxis = stkget(lpcv, ifp) isym = stkget(lpcv, 2) isort = isym end if if (ierr /= 0) then ierr = 1 write ( *, 1000) return end if ! ! call the main driver for autoregressive spectrum routines. ! call uasdv(acov, spca, spcf, lspc, iar, phi, nf, fmn, & fmx, freq, n, lagmax, rstak(ftest), rstak(aic), rstak(work), & lacov, lwork, delta, istak(isort), istak(isym), rstak(xaxis), & rstak(yaxis), lpcv, alpha, lag, laic, lphi, nprt, var, parzen, & nmsub) call stkclr(nall0) return 1000 format (/' the correct form of the call statement is'// & ' call uasvs (acov, lagmax, y, n,'/ & ' + iar, phi, lag, nf, fmin, fmax, nprt,'/ & ' + spca, spcf, freq, ldstak)') end subroutine ufparm ( ) !*****************************************************************************80 ! !! UFPARM is a dummy version of the optional user function for NL2SOL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none return end subroutine ufsdrv ( y, ly, ymiss, acov, nlppa, spcf, ispcf, nf, & fmin, fmax, freq, n, nw, lagmax, lags, work, lacov, lwork, & delta, isort, isym, xaxis, yaxis, lpcv, alpha, nprt, window, & nmsub, ldsmin, ldstak, option, lnlppa, nfft ) !*****************************************************************************80 ! !! UFSDRV is the controlling routine for time series Fourier spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lacov) ! the autocovariance. ! real alow ! a factor used to compute the lower confidence limits. ! real alpha ! the desired confidence level. ! real aup ! a factor used to compute the upper confidence limits. ! real bw ! the bandwidth. ! real delta ! the sampling interval. ! real df ! the effective degrees of freedom. ! real fmax, fmin ! the maximum and minimum frequences at which the ! spectrum is to be computed. ! real fmn, fmx ! the maximum and minimum frequences actually used. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index variable ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ilog ! a code used to specify the type of plot, where if ! ilog = 0 the plot is linear/linear, if ! ilog = 1 the plot is log/linear, if ! ilog = 2 the plot is linear/log, and if ! ilog = 3 the plot is log/log. ! integer isort(nf) ! the vector used for sorting. ! integer ispcer ! an error flag used for the spectrum plots. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the vector acov. ! integer lag ! the lag windwo truncation point used for a specific window. ! integer laglst ! the last lag before missing data caused an acvf ! to be unable to be computed. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector work. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in each series ! logical newpg ! the logical variable used to determine if output ! will begin on a new page (true) or not (false). ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! integer nfused ! the number of frequencies actually used. ! integer nlppa(lnlppa) ! the array containing the number of lag product pairs. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer npts ! the number of x, y coordinates to be plotted. ! integer nspc ! the number of valid (positive) spectrum values. ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! integer nwused ! the number of different bandwidths actually used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! real spcf(ispcf,nw) ! the arrays in which the spectrum is stored. ! real spcfmn, spcfmx ! the minimum and maximum spectrum value to be plotted. ! logical univar ! the logical variable used to determine if the output ! is for univariate (true) or bivariate (false) spectra. ! external window ! the subroutine used to compute the window. ! real work(lwork) ! the vector of lag windows. ! real xaxis(lpcv) ! the x axis values for the spectrum plot. ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real y(ly) ! the array containing the observed time series. ! real yaxis(lpcv) ! the y axis values for the spectrum plots. ! real ymean ! the mean of the observed time series ! real ymiss ! the user supplied code which is used to determine whether or ! not an observation in the series is missing. if y(i) = ymiss, ! the value is assumed missing, otherwise it is not. ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! implicit none real & alpha,delta,fmax,fmin,ymiss integer & ispcf,lacov,lagmax,ldsmin,ldstak,lnlppa,lpcv,lwork,ly,n, & nf,nfft,nprt,nw ! ! array arguments real & acov(*),freq(*),spcf(*),work(lwork),xaxis(*),y(*),yaxis(lpcv) integer & isort(*),isym(*),lags(*),nlppa(*) logical & option(4) character & nmsub(6)*1 ! ! subroutine arguments external window ! ! scalars in common integer & ierr real & alow,aup,bw,df,fmn,fmx,spcfmn,spcfmx,xpltmn,xpltmx,ymean, & ypltmn,ypltmx integer & i,ilog,ispcer,lag,laglst,nfused,npts,nspc,nwused logical & newpg,univar ! ! external functions integer & lstlag external lstlag ! ! common blocks common /errchk/ierr nfused = nf if (option(4)) then fmn = max(fmin, 0.0e0) fmx = min(fmax, 0.5e0) if (fmn >= fmx) then fmn = 0.0e0 fmx = 0.5e0 end if else ! ! set various values for short forms of call statement ! nprt = -1 fmn = 0.0e0 fmx = 0.5e0 end if call ufser(nmsub, n, lagmax, lacov, nfused, ispcf, nw, lags, & ldstak, ldsmin, ly, nfft, option) if (ierr == 1) return alpha = 0.95e0 delta = 1.0e0 ! ! compute covariances ! laglst = lagmax if (option(1)) then call acvff(y, n, nfft, ymean, acov, lagmax, lacov, & ly, work, nfft) else if (.not.option(3)) then if (option(2)) then call acvfm(y, ymiss, n, ymean, acov, lagmax, laglst, & nlppa, lacov) else call acvf(y, n, ymean, acov, lagmax, lacov) end if end if end if if (option(2) .and. option(3)) laglst = lstlag(nlppa,lagmax,lacov) if (laglst < 1 ) then ierr = 2 return end if ! ! compute the vector of lag window truncation points, ordered ! smallest to largest. ! nwused = nw if (.not.option(4)) call ufslag(acov, laglst, lags, n, nw, & nwused, lacov) ! ! begin computing Fourier spectrum for series ! univar = .true. if (nprt >= 1) then ilog = 1 else ilog = 0 end if xpltmn = fmn xpltmx = fmx ! ! set frequencies for the spectrum. ! call setfrq(freq, nfused, 2, fmn, fmx, delta) ! ! compute and plot spectrum values. ! newpg = .false. do i=1,nwused lag = lags(i) ispcer = 0 if ( laglst < lag ) then ispcer = 2 df = 0.0e0 else call ufsmn(acov, nlppa, lag, df, nfused, freq, alpha, bw, & spcf(1+(i-1)*ispcf), alow, aup, lacov, ispcf, & window, work, lag, n, delta, option(2), lnlppa) if (nprt == 0) then cycle end if ispcer = 0 call spcck(spcf(1+(i-1)*ispcf), isort, nfused, & spcfmn, spcfmx, nspc, ispcer) if ( ispcer == 0 ) then call ufspcv(spcf(1+(i-1)*ispcf), spcfmn, spcfmx, & freq, nfused, xaxis, yaxis, isym, npts, ispcf, & nfused+5, nspc, bw, alow, aup, & xpltmn, xpltmx, ypltmn, ypltmx, nprt) end if end if call ufsout(xaxis, yaxis, isym, npts, bw, nint(df), lag, & laglst, newpg, ispcer, nfused+5, xpltmn, xpltmx, ypltmn, & ypltmx, ilog, yaxis, xaxis, npts, univar, nmsub) newpg = .true. end do return end subroutine ufser ( nmsub, n, lagmax, lacov, nf, ispcf, nw, & lags, ldstak, ldsmin, lyfft, nfft, option ) !*****************************************************************************80 ! !! UFSET checks errors for time series Fourier univariate spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ispcf,lacov,lagmax,ldsmin,ldstak,lyfft,n,nf,nfft,nw ! ! array arguments integer & lags(*) logical & option(4) character & nmsub(6)*1 ! ! scalars in common integer & ierr ! ! integer & i,nv logical & head ! ! local arrays logical & err(15) character & l1(8)*1,lispcf(8)*1,llacov(8)*1,llagmx(8)*1,llags(8)*1, & llds(8)*1,llgmx1(8)*1,llyfft(8)*1,ln(8)*1,lnf(8)*1, & lnm1(8)*1,lnw(8)*1 ! ! external subroutines external eisge,eisii,eivii ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! logical err(15) ! value(s) indicating whether an error was detected (true) or not ! (false). ! logical head ! a flag indicating whether the heading should be printed ! (true) or not (false). if a heading is printed, the value ! of head will be changed to false. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to specify the lag window truncation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! character*1 lispcf(8), llacov(8), llagmx(8), ! * llags(8), llgmx1(8), llds(8), ln(8), lnf(8), lnm1(8), ! * lnw(8), llyfft(8), l1(8) ! the array(s) containing the name(s) of the argument(s) ! checked for errors. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in the series. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! character*1 nmsub(6) ! the array containing the name of the user called subroutine. ! integer nv ! the number of violations found when checking vector lags. ! integer nw ! the argument used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! ! set up name arrays ! data lispcf(1), lispcf(2), lispcf(3), lispcf(4), lispcf(5), & lispcf(6), lispcf(7), lispcf(8) /'i','s','p','c','f',' ',' ', & ' '/ data llacov(1), llacov(2), llacov(3), llacov(4), llacov(5), & llacov(6), llacov(7), llacov(8) /'l','a','c','o','v',' ',' ', & ' '/ data llagmx(1), llagmx(2), llagmx(3), llagmx(4), llagmx(5), & llagmx(6), llagmx(7), llagmx(8) /'l','a','g','m','a','x',' ', & ' '/ data llags(1), llags(2), llags(3), llags(4), llags(5), llags(6), & llags(7), llags(8) /'l','a','g','s',' ',' ',' ',' '/ data llgmx1(1), llgmx1(2), llgmx1(3), llgmx1(4), llgmx1(5), & llgmx1(6), llgmx1(7), llgmx1(8) /'l','a','g','m','a','x','+', & '1'/ data llds(1), llds(2), llds(3), llds(4), llds(5), llds(6), & llds(7), llds(8) /'l','d','s','t','a','k',' ',' '/ data ln(1), ln(2), ln(3), ln(4), ln(5), ln(6), ln(7), ln(8) /'n', & ' ',' ',' ',' ',' ',' ',' '/ data lnf(1), lnf(2), lnf(3), lnf(4), lnf(5), lnf(6), lnf(7), & lnf(8) /'n','f',' ',' ',' ',' ',' ',' '/ data lnm1(1), lnm1(2), lnm1(3), lnm1(4), lnm1(5), lnm1(6), & lnm1(7), lnm1(8) /'n','-','1',' ',' ',' ',' ',' '/ data lnw(1), lnw(2), lnw(3), lnw(4), lnw(5), lnw(6), lnw(7), & lnw(8) /'n','w',' ',' ',' ',' ',' ',' '/ data llyfft(1), llyfft(2), llyfft(3), llyfft(4), llyfft(5), & llyfft(6), llyfft(7), llyfft(8) /'l','y','f','f','t',' ',' ', & ' '/ data l1(1), l1(2), l1(3), l1(4), l1(5), l1(6), l1(7), l1(8) /'1', & ' ',' ',' ',' ',' ',' ',' '/ ierr = 0 head = .true. err(1:15) = .false. call eisge(nmsub, ln, n, 17, 1, head, err(1), ln) if (option(4)) then call eisge(nmsub, lnf, nf, 1, 1, head, err(6), lnf) if (.not.err(6)) & call eisge(nmsub, lispcf, ispcf, nf, 3, head, err(7), lnf) call eisge(nmsub, lnw, nw, 1, 1, head, err(8), lnw) end if if (.not.err(1)) then if (option(3)) then call eisii(nmsub, llagmx, lagmax, 1, n-1, 1, head, err(2), & l1, lnm1) if (.not.err(2)) then if (option(2)) then call eisge(nmsub, llacov, lacov, lagmax+1, 8, head, & err(3), llgmx1) else call eisge(nmsub, llacov, lacov, lagmax+1, 7, head, & err(3), llgmx1) end if end if end if if (.not.err(2)) then if (option(1)) & call eisge(nmsub, llyfft, lyfft, nfft, 9, head, err(4), & llyfft) if (.not.err(8)) then if (option(4)) then if (option(3)) then call eivii(nmsub, llags, lags, nw, 1, lagmax, 0, head, 3, & nv, err(9), l1, llagmx) else call eivii(nmsub, llags, lags, nw, 1, n-1, 0, head, 3, nv, & err(9), l1, lnm1) end if end if if ((.not.err(6)) .and. (.not.err(9))) & call eisge(nmsub, llds, ldstak, ldsmin, 9, head, err(14), & llds) end if end if end if do i=1,15 if (err(i)) ierr = 1 end do return end subroutine ufsest ( acov, w, lag, spcf, ispcf, lacov, lw, nf, freq, & delta ) !*****************************************************************************80 ! !! UFSEST computes the spectra and the confidence limits. ! ! Discussion: ! ! this routine computes the spectrum, spcf, and ! their lower and upper confidence limits, spclcl and spcucl, ! respectively. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & delta integer & ispcf,lacov,lag,lw,nf ! ! array arguments real & acov(lacov),freq(nf),spcf(ispcf),w(lw) ! ! real & c,pi,v0,v1,v2 integer & i,k,kk ! ! external subroutines external getpi ! ! ! variable definitions (alphabetically) ! ! real acov(lacov) ! the autocovariances of the series. ! real c ! a value used to compute the spectrum values. ! real delta ! the sampling interval. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index variable ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer k, kk ! indexing variables. ! integer lacov ! the length of vector acov. ! integer lag ! the lag window truccation point. ! integer lw ! the length of the vector w. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! real pi ! the value of pi. ! real spcf(ispcf) ! the arrays in which the spectrum is stored. ! real v0, v1, v2 ! constants used for computing the spectrum values. ! real w(lw) ! the vector of lag windows. ! call getpi(pi) ! ! compute the spectrum and its confidence limits. ! do i=1,nf c = cos(2.0e0*pi*freq(i)) v0 = 0.0e0 v1 = 0.0e0 do k=1,lag kk = lag + 1 - k v2 = 2.0e0*c*v1 - v0 + w(kk+1)*acov(kk+1) v0 = v1 v1 = v2 end do spcf(i) = delta*(acov(1)*w(1)+2.0e0*(v1*c-v0)) if (spcf(i)<0.0e0) spcf(i) = 0.0e0 end do return end subroutine ufs ( y, n ) !*****************************************************************************80 ! !! UFS: user routine for time series Fourier spectrum analysis (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr real & alpha,delta,fmax,fmin,ymiss integer & ispcf,lacov,lagmax,ldsmin,ldstak,lnlppa,lpcv,lwork, & ly,nf,nprt,nw ! ! local arrays real & acov(101),freq(101),spcf(101,4),work(101),xaxis(106), & yaxis(106) integer & isort(101),isym(106),lags(4),nlppa(1) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external parzen,setlag,ufsdrv ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real acov(101) ! the autocovariance at lag zero (biased variance). ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequences at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer isort(101) ! an array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer isym(106) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(1) ! a dummy array when the series does not contain missing values. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real spcf(101,4) ! the arrays in which the spectrum is stored. ! real work(101) ! the vector of lag windows. ! real xaxis(106) ! the x axis values for the spectrum plot. ! real y(n) ! the array containing the observed time series. ! real yaxis(106) ! the y axis values for the spectrum plot. ! real ymiss ! a dummy variable when the series do not contain missing values ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s',' ',' ',' '/ option(4) = .false. option(3) = .false. option(2) = .false. option(1) = .false. ldstak = 0 ldsmin = 0 ispcf = 101 lacov = 101 lnlppa = 1 ly = n lpcv = 106 lwork = 101 nf = 101 ymiss = 1.0e0 ! ! set maximum lag value to be used. ! and number of lag window truncation points to use. ! call setlag(n, lagmax) nw = 4 ! ! call the controlling routine for Fourier spectrum routines ! for series with missing data. ! call ufsdrv(y, ly, ymiss, acov, nlppa, spcf, ispcf, nf, fmin, & fmax, freq, n, nw, lagmax, lags, work, lacov, lwork, delta, & isort, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, nmsub, & ldsmin, ldstak, option, lnlppa, ly) if ( ierr /= 0 ) then write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ufs (y, n)') end subroutine ufsf ( yfft, n, lyfft, ldstak ) !*****************************************************************************80 ! !! UFSF: user routine for Fourier spectrum analysis using fft (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(101) ! the autocovariance at lag zero (biased variance). ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequences at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp = 3 indicates ! real and ifp=4 indicates double precision. ! integer isort(101) ! an array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer isym(106) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer lyfft ! the length of the vector yfft. ! integer n ! the integer number of observations in each series ! integer nall0 ! the number of allocations outstanding at the time that ! this routine was called. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nfft ! the number of observations in the extended series. ! integer nlppa(1) ! a dummy array when the series does not contain missing values. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spcf(101,4) ! the arrays in which the spectrum is stored. ! integer work ! the starting location in the work area for array work. ! real xaxis(106) ! the x axis values for the spectrum plot. ! real yfft(lyfft) ! the array containing the observed time series. ! real yaxis(106) ! the y axis values for the spectrum plot. ! real ymiss ! a dummy variable when the series do not contain missing values ! implicit none integer & ldstak,lyfft,n ! ! array arguments real & yfft(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & alpha,delta,fmax,fmin,ymiss integer & ifp,ispcf,lacov,lagmax,ldsmin,lnlppa,lpcv,lwork, & nf,nfft,nprt,nw,work ! ! local arrays real & acov(101),freq(101),rstak(12),spcf(101,4),xaxis(106), & yaxis(106) integer & isort(101),isym(106),lags(4),nlppa(1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external ldscmp,parzen,setesl,setlag,stkset,ufsdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','f',' ',' '/ option(4) = .false. option(3) = .false. option(2) = .false. option(1) = .true. ! ! set maximum lag value to be used. ! set extended series length. ! set number of lag window truncation points to use. ! call setlag(n, lagmax) call setesl(n+lagmax, 4, nfft) nw = 4 ispcf = 101 lacov = 101 lnlppa = 1 lpcv = 106 lwork = nfft nf = 101 ymiss = 1.0e0 ! ! compute minimum allowable stack length ! call ldscmp ( 1, 0, 0, 0, 0, 0, 's', nfft, ldsmin ) ! ! set size of work area. ! set the number of outstanding allocations. ! set the stack allocation type. ! call stkset ( ldstak, 4 ) ifp = 3 ! ! set starting locations in the work area for various arrays. ! if ((ldsmin <= ldstak) .and. (ldsmin >= 7)) then work = stkget(lwork,ifp) else work = 1 end if ! ! call the controlling routine for Fourier spectrum routines ! for series with missing data. ! call ufsdrv(yfft, lyfft, ymiss, acov, nlppa, spcf, ispcf, nf, & fmin, fmax, freq, n, nw, lagmax, lags, rstak(work), lacov, & lwork, delta, isort, isym, xaxis, yaxis, lpcv, alpha, nprt, & parzen, nmsub, ldsmin, ldstak, option, lnlppa, nfft) if (ierr /= 0) then write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ufsf (yfft, n, lyfft, ldstak)') end subroutine ufsfs ( yfft, n, lyfft, ldstak, nw, lags, nf, fmin, fmax, & nprt, spcf, ispcf, freq ) !*****************************************************************************80 ! !! UFSFS: user routine for Fourier spectrum analysis using the fft (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real fmax real fmin external parzen integer & ispcf,ldstak,lyfft,n,nf,nprt,nw ! ! array arguments real & freq(*),spcf(*),yfft(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,ymiss integer & acov,ifp,io,isort,isym,lacov,lagmax,ldsmin,lnlppa, & lpcv,lwork,nall0,nfft,work,xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12),nlppa(1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! integer acov ! the starting location in rstak for the acvf vector. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the spectrum ! is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index variable ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required ! based on printed output requested. ! integer isort ! the starting location for the array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for array isym. ! integer lacov ! the length of vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to specify the lag window truncation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer lyfft ! the length of the vector y. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of allocations outstanding at the time that ! this routine was called. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(1) ! a dummy array for series without missing values. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spcf(ispcf,nw) ! the arrays in which the spectrum is stored ! for each lag window. ! integer work ! the starting location in the work area for array work. ! integer xaxis ! the starting location in the work area for array xaxis. ! real yfft(lyfft) ! the array containing the observed time series. ! integer yaxis ! the starting location in the work area for array yaxis. ! real ymiss ! the missing value code for the series. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','f','s',' '/ option(4) = .true. option(3) = .false. option(2) = .false. option(1) = .true. ! ! set maximum lag value to be used. ! if ( nw <= 0 ) then lagmax = n - 1 else lagmax = maxval ( lags(1:nw) ) end if lacov = lagmax + 1 lnlppa = 1 ! ! set extended series length ! call setesl(n+lagmax, 4, nfft) ! ! compute minimum allowable stack length ! io = 1 if (nprt == 0) io = 0 call ldscmp(5, 0, io*(nf+5), 0, 0, 0, 's', & lagmax+1+nfft+io*(2*nf+10), ldsmin) lpcv = nf + 5 lwork = nfft ! ! set size of work area. ! set the number of outstanding allocations. ! set the stack allocation type. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays. ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then acov = 1 work = 1 xaxis = 1 yaxis = 1 isym = 1 isort = 1 else acov = stkget(lacov,ifp) work = stkget(lwork,ifp) if (nprt /= 0) then xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) isym = stkget(lpcv,2) isort = isym else xaxis = work yaxis = work isym = work isort = isym end if end if ! ! call the controlling routine for Fourier spectrum routines ! call ufsdrv(yfft, lyfft, ymiss, rstak(acov), nlppa, spcf, ispcf, & nf, fmin, fmax, freq, n, nw, lagmax, lags, rstak(work), lacov, & lwork, delta, istak(isort), istak(isym), rstak(xaxis), & rstak(yaxis), lpcv, alpha, nprt, parzen, nmsub, ldsmin, ldstak, & option, lnlppa, nfft) call stkclr(nall0) if (ierr /= 0) then write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call ufsfs (yfft, n, lyfft, ldstak,'/ & ' + nw, lags, nf, fmin, fmax, nprt,'/ & ' + spcf, ispcf, freq)') end subroutine ufslag ( acov, lagmax, lags, n, nw, nwused, lacov ) !*****************************************************************************80 ! !! UFSLAG computes the lag window truncation points for spectrum analysis. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & lacov,lagmax,n,nw,nwused ! ! array arguments real & acov(lacov) integer & lags(nw) real & acovmx,p95lim integer & i,j,k,lag,nwm1 ! ! variable definitions (alphabetically) ! ! real acov(lacov) ! the array in which the autocovariances are stored ! real acovmx ! the maximum autocovariance value. ! integer i ! an index variable ! integer j, k ! index variables. ! integer lacov ! the length of vector acov. ! integer lag, lagmax ! the indexing variable indicating the lag value of the ! autocovariance being computed and the maximum lag to be used, ! respectively. ! integer lags(nw) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer n ! the integer number of observations in each series ! integer nw ! the number of different bandwidths requested. ! integer nwm1, nwused ! the number of different bandwidths minus 1, and the ! actual number of bandwidths actually used. ! real p95lim ! the 95 percent confident limit for white noise. ! lags(nw) = lagmax if (lags(nw) <= 32) go to 30 ! ! compute 95 percent confidence limits on autocovariances, ! assuming white noise. ! p95lim = 1.96e0 * acov(1) / sqrt(real(n)) ! ! check for first acvf exceeding 95 percent limit on white noise ! do i = 1, lagmax lag = lagmax + 1 - i if (abs(acov(lag + 1)) >= p95lim) go to 30 lags(nw) = lags(nw) - 1 end do ! ! if no acvf exceeds white noise limits, check for largest acvf. ! lags(nw) = 1 acovmx = abs(acov(2)) do lag = 1, lagmax if ( acovmx < abs(acov(lag + 1)) ) then lags(nw) = lag acovmx = abs(acov(lag + 1)) end if end do ! ! compute lag window truncation points ! 30 continue lags(nw) = int ( real ( lags(nw) ) * 3.0e0 / 2.0e0 ) if (lags(nw) < 32) lags(nw) = 32 if (lags(nw) > lagmax) lags(nw) = lagmax nwused = nw if (nw == 1) return nwm1 = nw - 1 do i = 1, nwm1 k = nw - i lags(k) = lags(k + 1) / 2 end do ! ! check whether all nw lag window truncation points can be used. ! nwused = nw if (lags(1) >= 4) return ! ! reconsturct -lags- vector if not all truncation points are ! to be used ! do i = 2, nw nwused = nwused - 1 if (lags(i) >= 4) then exit end if end do do i = 1, nwused j = nw - nwused + i lags(i) = lags(j) end do return end subroutine ufsm ( y, ymiss, n ) !*****************************************************************************80 ! !! UFSM: user routine, Fourier spectrum analysis with missing data (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & ymiss integer & n ! ! array arguments real & y(*) ! ! scalars in common integer & ierr ! ! real & alpha,delta,fmax,fmin integer & ispcf,lacov,lagmax,ldsmin,ldstak,lnlppa,lpcv,lwork, & ly,nf,nprt,nw ! ! local arrays real & acov(101),freq(101),spcf(101,4),work(101),xaxis(106), & yaxis(106) integer & isort(101),isym(106),lags(4),nlppa(101) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external ecvf,parzen,setlag,ufsdrv ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real acov(101) ! the autocovariance at lag zero (biased variance). ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequences at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer isort(101) ! an array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer isym(106) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(101) ! the array containing the number of lag product pairs. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real spcf(101,4) ! the arrays in which the spectrum is stored. ! real work(101) ! the vector of lag windows. ! real xaxis(106) ! the x axis values for the spectrum plot. ! real y(n) ! the array containing the observed time series. ! real yaxis(106) ! the y axis values for the spectrum plot. ! real ymiss ! the user supplied code which is used to determine whether or ! not an observation in the series is missing. if y(i) = ymiss, ! the value is assumed missing, otherwise it is not. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','m',' ',' '/ ! ! set up ! option(4) = .false. option(3) = .false. option(2) = .true. option(1) = .false. ldstak = 0 ldsmin = 0 ispcf = 101 lacov = 101 lnlppa = 101 ly = n lpcv = 106 lwork = 101 nf = 101 ! ! set maximum lag value to be used. ! and number of lag window truncation points to use. ! call setlag(n, lagmax) nw = 4 ! ! call the controlling routine for Fourier spectrum routines ! for series with missing data. ! call ufsdrv(y, ly, ymiss, acov, nlppa, spcf, ispcf, nf, fmin, & fmax, freq, n, nw, lagmax, lags, work, lacov, lwork, delta, & isort, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, nmsub, & ldsmin, ldstak, option, lnlppa, ly) ! ! check for errors ! if (ierr == 0) return if (ierr == 2) call ecvf(nmsub) ierr = 1 write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call ufsm (y, ymiss, n)') end subroutine ufsmn ( acov, nlppa, lag, df, nf, freq, alpha, bw, spcf, & alow, aup, lacov, ispcf, window, w, lw, n, delta, miss, lnlppa ) !*****************************************************************************80 ! !! UFSMN computes autocorrelations and partial autocorrelations of time series. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & alow,alpha,aup,bw,delta,df integer & ispcf,lacov,lag,lnlppa,lw,n,nf logical & miss ! ! array arguments real & acov(lacov),freq(nf),spcf(ispcf),w(lw) integer & nlppa(lnlppa) ! ! subroutine arguments external window ! ! external functions real & ppfchs external ppfchs ! ! external subroutines external dfbw,dfbwm,ufsest ! ! variable definitions (alphabetically) ! ! real acov(lacov) ! the autocovariances of the series. ! real alow ! a factor used to compute the lower confidence limits. ! real alpha ! the desired confidence level. ! real aup ! a factor used to compute the upper confidence limits. ! real bw ! the bandwidth. ! real delta ! the sampling interval. ! real df ! the effective degrees of freedom. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer lacov ! the length of vector acov. ! integer lag ! the variable indicating the lag value being examined. ! integer lnlppa ! the length of the vector nlppa. ! integer lw ! the length of the vector w. ! logical miss ! an indicator variable which designates whether there are ! missing values (true) or not (false) ! integer n ! the number of observations in the time series. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(lnlppa) ! the numbers of lagged product pairs in each acvf value. ! real spcf(ispcf) ! the array in which the spectrum is stored. ! real w(lw) ! the vector of lag windows. ! external window ! the name of the window computing subroutine. ! ! compute the window, effective degrees of freedom and ! bandwidth based on the window. ! call window(lag, w, lw) if (.not.miss) call dfbw(n, lag, w, lw, df, bw) if (miss) call dfbwm(n, lag, w, lw, nlppa, nlppa, lnlppa, df, bw) ! ! compute the spectrum ! call ufsest(acov, w, lag, spcf, ispcf, lacov, lw, nf, freq, delta) ! ! compute -alpha- percent point function value for ! spectrum window being used. ! alow = df/ppfchs(0.5e0+alpha/2.0e0,nint(df)) aup = df/ppfchs(0.5e0-alpha/2.0e0,nint(df)) return end subroutine ufsms ( y, ymiss, n, nw, lags, nf, fmin, fmax, nprt, & spcf, ispcf, freq, ldstak ) !*****************************************************************************80 ! !! UFSMS: time series Fourier spectrum analysis with missing data (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real fmax real fmin external parzen real ymiss integer & ispcf,ldstak,n,nf,nprt,nw ! ! array arguments real & freq(*),spcf(*),y(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & alpha,delta integer & acov,ifp,io,isort,isym,lacov,lagmax,ldsmin,lnlppa, & lpcv,lwork,ly,nall0,nlppa,work,xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! integer acov ! the starting location in rstak for the acvf vector. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the spectrum ! is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index variable ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required ! based on printed output requested. ! integer isort ! the starting location for the array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for array isym. ! integer lacov ! the length of vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to specify the lag window truncation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of allocations outstanding at the time that ! this routine was called. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa ! the starting location in istak for the array containing ! the numbers of lagged product pairs used for each acvf. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spcf(ispcf,nw) ! the arrays in which the spectrum is stored ! for each lag window. ! integer work ! the starting location in the work area for array window. ! integer xaxis ! the starting location in the work area for array xaxis. ! real y(n) ! the array containing the observed time series. ! integer yaxis ! the starting location in the work area for array yaxis. ! real ymiss ! the missing value code for the series. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','m','s',' '/ option(4) = .true. option(3) = .false. option(2) = .true. option(1) = .false. ! ! set maximum lag value to be used. ! if ( nw <= 0 ) then lagmax = n - 1 else lagmax = maxval ( lags(1:nw) ) end if lacov = lagmax + 1 lnlppa = lagmax + 1 ! ! compute minimum allowable stack length ! io = 1 if (nprt == 0) io = 0 call ldscmp(6, 0, lagmax+1+io*(nf+5), 0, 0, 0, 's', & 2*lagmax+2+io*(2*nf+10), ldsmin) ly = n lnlppa = lacov lpcv = nf + 5 lwork = lagmax+1 ! ! set size of work area. ! set the number of outstanding allocations. ! set the stack allocation type. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! Set starting locations in the work area for various arrays. ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then nlppa = 1 acov = 1 work = 1 xaxis = 1 yaxis = 1 isym = 1 isort = 1 else nlppa = stkget(lacov,2) acov = stkget(lacov,ifp) work = stkget(lwork,ifp) if (nprt /= 0) then xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) isym = stkget(lpcv,2) isort = isym else xaxis = work yaxis = work isym = work isort = isym end if end if ! ! Call the controlling routine for Fourier spectrum routines ! for series with missing data. ! call ufsdrv ( y, ly, ymiss, rstak(acov), istak(nlppa), spcf, ispcf, & nf, fmin, fmax, freq, n, nw, lagmax, lags, rstak(work), lacov, & lwork, delta, istak(isort), istak(isym), rstak(xaxis), & rstak(yaxis), lpcv, alpha, nprt, parzen, nmsub, ldsmin, ldstak, & option, lnlppa, ly) call stkclr ( nall0 ) ! ! check for errors ! if (ierr == 0) return if (ierr == 2) then call ecvf(nmsub) end if ierr = 1 write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call ufsms (y, ymiss, n,'/ & ' + nw, lags, nf, fmin, fmax, nprt,'/ & ' + spcf, ispcf, freq, ldstak)') end subroutine ufsmv ( acov, nlppa, lagmax, n ) !*****************************************************************************80 ! !! UFSMV: Fourier spectrum analysis, missing data, user ACVF values (short). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real acov(lagmax+1) ! the autocovariance at lag zero (biased variance). ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequences at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer isort(101) ! an array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer isym(106) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(lagmax+1) ! the array containing the number of lag product pairs. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real spcf(101,4) ! the arrays in which the spectrum is stored. ! real work(101) ! the vector of lag windows. ! real xaxis(106) ! the x axis values for the spectrum plot. ! real y(1) ! a dummy array. ! real yaxis(106) ! the y axis values for the spectrum plot. ! real ymiss ! a dummy variable. ! implicit none real acov(*) integer ierr integer lagmax integer n integer nlppa(*) external parzen real & alpha,delta,fmax,fmin,ymiss integer & ispcf,lacov,ldsmin,ldstak,lnlppa,lpcv,lwork,ly,nf, & nprt,nw ! ! local arrays real & freq(101),spcf(101,4),work(101),xaxis(106),y(1),yaxis(106) integer & isort(101),isym(106),lags(4) logical & option(4) character & nmsub(6)*1 ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','m','v',' '/ option(4) = .false. option(3) = .true. option(2) = .true. option(1) = .false. ldstak = 0 ldsmin = 0 ymiss = 1.0e0 lacov = lagmax+1 ispcf = 101 ly = 1 lnlppa = lacov lpcv = 106 lwork = 101 nf = 101 ! ! set number of lag window truncation points ! nw = 4 ! ! call the controlling routine for Fourier spectrum routines ! for series with missing data. ! call ufsdrv ( y, ly, ymiss, acov, nlppa, spcf, ispcf, nf, fmin, & fmax, freq, n, nw, lagmax, lags, work, lacov, lwork, delta, & isort, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, nmsub, & ldsmin, ldstak, option, lnlppa, ly ) ! ! check for errors ! if (ierr == 0) return if (ierr == 2) call ecvf(nmsub) ierr = 1 write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call ufsmv (acov, nlppa, lagmax, n)') end subroutine ufsmvs ( acov, nlppa, lagmax, n, nw, lags, nf, & fmin, fmax, nprt, spcf, ispcf, freq, ldstak ) !*****************************************************************************80 ! !! UFSMVS: time series Fourier spectrum analysis with missing data (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin integer & ispcf,lagmax,ldstak,n,nf,nprt,nw ! ! array arguments real & acov(*),freq(*),spcf(*) integer & lags(*),nlppa(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! ! real & alpha,delta,ymiss integer & ifp,io,isort,isym,lacov,ldsmin,lnlppa,lpcv,lwork,ly, & nall0,work,xaxis,yaxis ! ! local arrays real & rstak(12),y(1) integer & istak(12) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external ecvf,ldscmp,parzen,stkclr,stkset,ufsdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real acov(lagmax+1) ! the autocovariances of the series. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the spectrum ! is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required ! based on printed output requested. ! integer isort ! the starting location for the array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for array isym. ! integer lacov ! the length of the acvf vectors. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to specify the lag window truncation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of allocations outstanding at the time that ! this routine was called. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(lagmax+1) ! the array containing the number of lag product pairs. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spcf(ispcf,nw) ! the arrays in which the spectrum is stored ! for each lag window. ! integer work ! the starting location in rstak for ! the work vector. ! integer xaxis ! the starting location in the work area for array xaxis. ! real y(1) ! a dummy array. ! integer yaxis ! the starting location in the work area for array yaxis. ! real ymiss ! a dummy variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','m','v','s'/ option(4) = .true. option(3) = .true. option(2) = .true. option(1) = .false. ! ! compute minimum allowable stack length ! io = 1 if (nprt == 0) io = 0 call ldscmp(4, 0, io*(nf+5), 0, 0, 0, 's', & lagmax+1+io*(2*nf+10), ldsmin) ymiss = 1.0e0 lacov = lagmax+1 ly = 1 lnlppa = lacov lpcv = nf + 5 lwork = lagmax+1 ! ! set size of work area. ! set the number of outstanding allocations. ! set the stack allocation type. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays. ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then work = 1 xaxis = 1 yaxis = 1 isym = 1 isort = 1 else work = stkget(lwork,ifp) if (nprt /= 0) then xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) isym = stkget(lpcv,2) isort = isym else xaxis = work yaxis = work isym = work isort = isym end if end if ! ! call the controlling routine for Fourier spectrum routines ! for series with missing data. ! call ufsdrv(y, ly, ymiss, acov, nlppa, spcf, ispcf, nf, fmin, & fmax, freq, n, nw, lagmax, lags, rstak(work), lacov, lwork, & delta, istak(isort), istak(isym), rstak(xaxis), rstak(yaxis), & lpcv, alpha, nprt, parzen, nmsub, ldsmin, ldstak, option, & lnlppa, ly) call stkclr(nall0) ! ! check for errors ! if (ierr == 0) return if (ierr == 2) call ecvf(nmsub) ierr = 1 write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call ufsmvs (acov, nlppa, lagmax, n,'/ & ' + nw, lags, nf, fmin, fmax, nprt,'/ & ' + spcf, ispcf, freq, ldstak)') end subroutine ufsout ( xaxis, yaxis, isym, npts, bw, idf, lag, laglst, & newpg, ispcer, lpcv, xpltmn, xpltmx, ypltmn, ypltmx, ilog, & phas, freq, nf, univar, nmsub ) !*****************************************************************************80 ! !! UFSOUT produces the Fourier bivariate spectrum output. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & bw,xpltmn,xpltmx,ypltmn,ypltmx integer & idf,ilog,ispcer,lag,laglst,lpcv,nf,npts logical & newpg,univar ! ! array arguments real & freq(nf),phas(nf),xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) character & nmsub(6)*1 ! ! scalars in common integer & ierr real & pi,xmn,xmx,ymn,ymx integer & i logical & error ! ! external subroutines external getpi,pplmt,ppmn,versp ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real bw ! the bandwidth. ! logical error ! an error flag ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer idf ! the effective degrees of freedom. ! integer ierr ! the error flag. ! integer ilog ! a code used to specify the type of plot, where if ! ilog = 0 the plot is linear/linear, if ! ilog = 1 the plot is log/linear, if ! ilog = 2 the plot is linear/log, and if ! ilog = 3 the plot is log/log. ! integer ispcer ! a variable used to designate an error in the spectrum ! values. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lag ! the lag window truncation point. ! integer laglst ! the last lag before missing data caused the acvf of either ! series 1 or 2 not to be computed. ! integer lpcv ! the length of the vectors used for plotting. ! logical newpg ! the logical variable used to determine if output ! will begin on a new page (true) or not (false). ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! character*1 nmsub(6) ! the name of the calling subroutine. ! integer npts ! the number of coordinates to be plotted. ! real phas(nf) ! the phase component of the bivariate spectra. ! real pi ! the value of pi. ! logical univar ! the logical variable used to determine if the output ! is for univariate (true) or bivariate (false) spectra. ! real xaxis(lpcv) ! the x axis values for the spectrum plot. ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real yaxis(lpcv) ! the y axis values for the spectrum plot. ! real ypltmn, ypltmx ! the minimum and maximum values to be plotted for the y axis. ! ! set logical unit number for output and set output width. ! call getpi(pi) if (newpg) write ( *,1010) if ( 2 <= ispcer ) then call versp(.true.) write ( *,1060) laglst, lag return end if call versp(.true.) if (.not.univar) write ( *,1070) if (univar) write ( *,1080) write ( *,1020) lag, bw, idf if ( ispcer /= 0 ) then write ( *,1050) else ! ! print plots ! ! plot squared coherency component of spectrum ! call pplmt(yaxis, yaxis, xaxis, xaxis(1), npts, 1, lpcv, ypltmn, & ypltmx, ymn, ymx, xpltmn, xpltmx, xmn, xmx, error, nmsub, & .false.) if (.not.error) & call ppmn(yaxis, yaxis, xaxis, xaxis(1), npts, 1, lpcv, 1, isym, & lpcv, 0, -1, ymn, ymx, xmn, xmx, .false., ilog) if (xpltmn == 0.0e0 .and. xpltmx == 0.5e0) write ( *, 1030) end if if (univar) return do i=1,nf xaxis(i) = freq(i) xaxis(nf+i) = freq(i) yaxis(i) = phas(i) if (phas(i) > 0.0e0) then yaxis(nf+i) = phas(i) - 2*pi else if (phas(i)<0.0e0) then yaxis(nf+i) = phas(i) + 2*pi else yaxis(nf+i) = 0.0e0 end if end do ! ! plot smoothed phase component of spectrum ! write ( *,1010) call versp(.true.) write ( *,1000) write ( *,1020) lag, bw, idf call pplmt(yaxis, yaxis, xaxis, xaxis(1), 2*nf, 1, 2*nf, -2*pi, 2*pi, & ymn, ymx, xpltmn, xpltmx, xmn, xmx, error, nmsub, .false.) if (error) then ierr = 1 else call ppmn(yaxis, yaxis, xaxis, xaxis(1), & 2*nf, 1, 2*nf, 0, isym, lpcv, & 0, -1, ymn, ymx, xmn, xmx, .false., ilog) if (xpltmn == 0.0e0 .and. xpltmx == 0.5e0) write ( *, 1030) end if return 1000 format (' -- smoothed Fourier spectrum (phase component) --') 1010 format ('1') 1020 format (' (parzen window with lag wind. trunc. pt.=', i5, 1x, & '/ bw=', f6.4, 1x, '/ edf=', i6, ')') 1030 format ('+freq'/' period', 9x, 'inf', 7x, '20.', 7x, '10.', 8x, & '6.6667', 4x, '5.', 8x, '4.', 8x, '3.3333', 4x, '2.8571', 4x, & '2.5', 7x, '2.2222', 4x, '2.') 1050 format (//' the plot has been supressed because no'/ & ' positive spectrum values were computed.') 1060 format (//' the largest lag window truncation point which can'/ & ' be used is ', i5, '.'/' the spectrum for the requested la', & 'g window', ' point of ', i5, ','/' therefore, cannot be co', & 'mputed.') 1070 format (' -- smoothed Fourier spectrum (squared coherency', & ' component) (+), 95 pct. confidence limits (.)', & ' and 95 pct. significance level (-) --') 1080 format (' -- smoothed Fourier spectrum --') end subroutine ufspcv ( spcf, spcmn, spcmx, freq, nf, xaxis, yaxis, & isym, npts, ispcf, lpcv, nspc, bw, alow, aup, xpltmn, xpltmx, & ypltmn, ypltmx, nprt ) !*****************************************************************************80 ! !! UFSPCV produces coordinates for the spectrum plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & alow,aup,bw,spcmn,spcmx,xpltmn,xpltmx,ypltmn,ypltmx integer & ispcf,lpcv,nf,nprt,npts,nspc ! ! array arguments real & freq(nf),spcf(ispcf),xaxis(lpcv),yaxis(lpcv) integer & isym(lpcv) real & cilow,cimid,ciup,ymax integer & i,ispcfw ! ! variable definitions (alphabetically) ! ! real alow, aup ! factors used to compute the confidence intervals. ! real bw ! the bandwidth. ! real cilow, cimid, ciup ! the y axis values for the lower mid and upper confidence ! interval points. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index variable ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer ispcfw ! an index variable. ! integer isym(lpcv) ! the array containing the code for the plot symbols. ! integer lpcv ! the length of the vectors used for plotting. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer npts ! the number of coordinates to be plotted. ! integer nspc ! the number of valid spectrum values. ! real spcf(ispcf) ! the arrays in which the spectrum is stored ! for each lag window. ! real spcmn, spcmx ! the minimum and maximum spectrum value to be plotted. ! real xaxis(lpcv) ! the x axis values for the spectrum plot. ! real xpltmn, xpltmx ! the minimum and maximum values to be plotted for the x axis. ! real yaxis(lpcv) ! the y axis values for the spectrum plots. ! real ymax ! the maximum actual spectrum value (in decibels) to be plotted. ! real ypltmn, ypltmx ! the minimum and maximum vaues to be plotted for the y axis. ! ispcfw = 0 if ( nprt < 1 ) then ! ! set various y axis values for decibel plots ! call sppltd (spcmn, spcmx, alow, aup, ypltmn, ypltmx, & cilow, cimid, ciup, ymax) ! ! set coordinates for decibel plots ! do i = 1, nf if ( spcmn <= spcf(i) ) then ispcfw = ispcfw + 1 xaxis(ispcfw) = freq(i) yaxis(ispcfw) = 10.0e0 * log10(spcf(i)) - ymax isym(ispcfw) = 1 end if end do else ! ! set various y axis values for log plots ! call sppltl (spcmn, spcmx, alow, aup, ypltmn, ypltmx, & cilow, cimid, ciup) ! ! set coordinates for log plots ! do i = 1, nf if ( spcmn <= spcf(i) ) then ispcfw = ispcfw + 1 xaxis(ispcfw) = freq(i) yaxis(ispcfw) = spcf(i) isym(ispcfw) = 1 end if end do end if npts = nspc ! ! set coordinates for bandwidth and confidence interval. ! call sppltc (xaxis, yaxis, isym, npts, xpltmn, xpltmx, bw, cilow, & cimid, ciup, lpcv) return end subroutine ufss ( y, n, nw, lags, nf, fmin, fmax, nprt, & spcf, ispcf, freq, ldstak ) !*****************************************************************************80 ! !! UFSS: time series Fourier spectrum analysis (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin integer & ispcf,ldstak,n,nf,nprt,nw ! ! array arguments real & freq(*),spcf(*),y(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) ! real & alpha,delta,ymiss integer & acov,ifp,io,isort,isym,lacov,lagmax,ldsmin,lnlppa, & lpcv,lwork,ly,nall0,work,xaxis,yaxis ! ! local arrays real & rstak(12) integer & istak(12),nlppa(1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external ldscmp,parzen,stkclr,stkset,ufsdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! integer acov ! the starting location in rstak for the acvf vector. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the spectrum ! is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer i ! an index variable ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required ! based on printed output requested. ! integer isort ! the starting location for the array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for array isym. ! integer lacov ! the length of vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to specify the lag window truncation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of allocations outstanding at the time that ! this routine was called. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(1) ! a dummy array for series without missing values. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spcf(ispcf,nw) ! the arrays in which the spectrum is stored ! for each lag window. ! integer work ! the starting location in the work area for array window. ! integer xaxis ! the starting location in the work area for array xaxis. ! real y(n) ! the array containing the observed time series. ! integer yaxis ! the starting location in the work area for array yaxis. ! real ymiss ! the missing value code for the series. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','s',' ',' '/ option(4) = .true. option(3) = .false. option(2) = .false. option(1) = .false. ! ! set maximum lag value to be used. ! if ( nw <= 0 ) then lagmax = n - 1 else lagmax = maxval ( lags(1:nw) ) end if lacov = lagmax + 1 lnlppa = 1 ! ! compute minimum allowable stack length ! io = 1 if (nprt == 0) io = 0 call ldscmp(5, 0, io*(nf+5), 0, 0, 0, 's', & 2*lagmax+2+io*(2*nf+10), ldsmin) ly = n lpcv = nf + 5 lwork = lagmax+1 ! ! set size of work area. ! set the number of outstanding allocations. ! set the stack allocation type. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! set starting locations in the work area for various arrays. ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then acov = 1 work = 1 xaxis = 1 yaxis = 1 isym = 1 isort = 1 else acov = stkget(lacov,ifp) work = stkget(lwork,ifp) if (nprt /= 0) then xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) isym = stkget(lpcv,2) isort = isym else xaxis = work yaxis = work isym = work isort = isym end if end if ! ! call the controlling routine for Fourier spectrum routines ! call ufsdrv(y, ly, ymiss, rstak(acov), nlppa, spcf, ispcf, & nf, fmin, fmax, freq, n, nw, lagmax, lags, rstak(work), lacov, & lwork, delta, istak(isort), istak(isym), rstak(xaxis), & rstak(yaxis), lpcv, alpha, nprt, parzen, nmsub, ldsmin, ldstak, & option, lnlppa, ly) call stkclr(nall0) if (ierr == 0) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call ufss (y, n,'/ & ' + nw, lags, nf, fmin, fmax, nprt,'/ & ' + spcf, ispcf, freq, ldstak)') end subroutine ufsv ( acov, lagmax, n ) !*****************************************************************************80 ! !! UFSV: Fourier spectrum analysis, user supplied ACVF values (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & lagmax,n ! ! array arguments real & acov(*) ! ! scalars in common integer & ierr ! ! real & alpha,delta,fmax,fmin,ymiss integer & ispcf,lacov,ldsmin,ldstak,lnlppa,lpcv,lwork,ly,nf, & nprt,nw ! ! local arrays real & freq(101),spcf(101,4),work(101),xaxis(106),y(1),yaxis(106) integer & isort(101),isym(106),lags(4),nlppa(1) logical & option(4) character & nmsub(6)*1 ! ! external subroutines external parzen,ufsdrv ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! real acov(lagmax+1) ! the autocovariance at lag zero (biased variance). ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! real fmax, fmin ! the maximum and minimum frequences at which the ! spectrum is to be computed. ! real freq(101) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! integer isort(101) ! an array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer isym(106) ! the array containing the code for the plot symbols. ! integer lacov ! the length of the vector acov. ! integer lagmax ! the maximum lag value to be used. ! integer lags(4) ! the array used to store the lag window truccation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in each series ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(1) ! a dummy array for series without missing values. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real spcf(101,4) ! the arrays in which the spectrum is stored. ! real work(101) ! the vector of lag windows. ! real xaxis(106) ! the x axis values for the spectrum plot. ! real y(1) ! a dummy array. ! real yaxis(106) ! the y axis values for the spectrum plot. ! real ymiss ! a dummy variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','v',' ',' '/ option(4) = .false. option(3) = .true. option(2) = .false. option(1) = .false. ldstak = 0 ldsmin = 0 ymiss = 1.0e0 lacov = lagmax+1 ispcf = 101 ly = 1 lnlppa = 1 lpcv = 106 lwork = 101 nf = 101 ! ! set number of lag window truncation points ! nw = 4 ! ! call the controlling routine for Fourier spectrum routines ! call ufsdrv(y, ly, ymiss, acov, nlppa, spcf, ispcf, nf, fmin, & fmax, freq, n, nw, lagmax, lags, work, lacov, lwork, delta, & isort, isym, xaxis, yaxis, lpcv, alpha, nprt, parzen, nmsub, & ldsmin, ldstak, option, lnlppa, ly) if (ierr == 0) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call ufsv (acov, lagmax, n)') end subroutine ufsvs ( acov, lagmax, n, nw, lags, nf, & fmin, fmax, nprt, spcf, ispcf, freq, ldstak ) !*****************************************************************************80 ! !! UFSVS: Fourier spectrum analysis and user supplied acvf values (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & fmax,fmin integer & ispcf,lagmax,ldstak,n,nf,nprt,nw ! ! array arguments real & acov(*),freq(*),spcf(*) integer & lags(*) ! ! scalars in common integer & ierr ! ! arrays in common double precision dstak(3000) real & alpha,delta,ymiss integer & ifp,io,isort,isym,lacov,ldsmin,lnlppa,lpcv,lwork,ly, & nall0,work,xaxis,yaxis ! ! local arrays real & rstak(12),y(1) integer & istak(12),nlppa(1) logical & option(4) character & nmsub(6)*1 ! ! external functions integer & stkget,stkst external stkget,stkst ! ! external subroutines external ldscmp,parzen,stkclr,stkset,ufsdrv ! ! common blocks common /cstak/dstak common /errchk/ierr ! ! equivalences equivalence (dstak(1),rstak(1)) equivalence (dstak(1),istak(1)) ! ! variable definitions (alphabetically) ! ! real acov(lagmax+1) ! the autocovariances of the series. ! real alpha ! the desired confidence level. ! real delta ! the sampling interval. ! double precision dstak(3000) ! the double precision version of the /cstak/ work area. ! real fmax, fmin ! the maximum and minimum frequency at which the spectrum ! is to be computed. ! real freq(nf) ! the vector of frequencies at which the spectrum is to be ! computed. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if err01, no errors were detected ! if ierr == 1, errors have been detected ! integer ifp ! an indicator for stack allocation type, where ifp=3 indicates ! real and ifp=4 indicates double precision. ! integer io ! a variable used to determine the amount of storage required ! based on printed output requested. ! integer isort ! the starting location for the array used for sorting. ! integer ispcf ! the actual first dimension of the spectrum arrays. ! integer istak(12) ! the integer version of the /cstak/ work area. ! integer isym ! the starting location in the work area for array isym. ! integer lacov ! the length of the acvf vectors. ! integer lagmax ! the maximum lag value to be used. ! integer lags(nw) ! the array used to specify the lag window truncation ! points used for each set of spectrum values. ! integer ldsmin ! the minimum length allowed for dstak. ! integer ldstak ! the length of the vector dstak in common cstak. ! integer lnlppa ! the length of the vector nlppa. ! integer lpcv ! the length of the vectors used for plotting. ! integer lwork ! the length of the vector w. ! integer ly ! the length of the vector y. ! integer n ! the integer number of observations in the series. ! integer nall0 ! the number of allocations outstanding at the time that ! this routine was called. ! integer nf ! the number of frequencies at which the spectrum is ! to be computed. ! integer nlppa(1) ! a dummy array for series without missing values. ! character*1 nmsub(6) ! the array containing the name of this subroutine. ! integer nprt ! a code used to specify the type of plot, where if ! nprt < 0 the plot is decibels/linear ! nprt = 0 the plot is suppressed ! nprt > 0 the plot is log/linear ! integer nw ! the variable used to determine the number of different ! bandwidths to be used. ! logical option(4) ! an indicator array used to designate whether any of the ! four possible options (f, m, v, or s) have been used (true) ! or not (false). ! external parzen ! the subroutine used to compute the window. ! real rstak(12) ! the real version of the /cstak/ work area. ! real spcf(ispcf,nw) ! the arrays in which the spectrum is stored ! for each lag window. ! integer work ! the starting location in rstak for ! the work vector. ! integer xaxis ! the starting location in the work area for array xaxis. ! real y(1) ! a dummy array. ! integer yaxis ! the starting location in the work area for array yaxis. ! real ymiss ! a dummy variable. ! ! set up name arrays ! data nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) / & 'u','f','s','v','s',' '/ option(4) = .true. option(3) = .true. option(2) = .false. option(1) = .false. lacov = lagmax + 1 ! ! Compute minimum allowable stack length ! io = 1 if (nprt == 0) io = 0 call ldscmp(4, 0, io*(nf+5), 0, 0, 0, 's', & lagmax+1+io*(2*nf+10), ldsmin) ymiss = 1.0e0 ly = 1 lnlppa = 1 lpcv = nf + 5 lwork = lagmax+1 ! ! Set size of work area. ! Set the number of outstanding allocations. ! Set the stack allocation type. ! call stkset(ldstak, 4) nall0 = stkst(1) ifp = 3 ! ! Set starting locations in the work area for various arrays. ! if ((ldsmin > ldstak) .or. (ldsmin <= 6)) then work = 1 xaxis = 1 yaxis = 1 isym = 1 isort = 1 else work = stkget(lwork,ifp) if (nprt /= 0) then xaxis = stkget(lpcv,ifp) yaxis = stkget(lpcv,ifp) isym = stkget(lpcv,2) isort = isym else xaxis = work yaxis = work isym = work isort = isym end if end if ! ! Call the controlling routine for Fourier spectrum routines ! call ufsdrv(y, ly, ymiss, acov, nlppa, spcf, ispcf, nf, fmin, & fmax, freq, n, nw, lagmax, lags, rstak(work), lacov, lwork, & delta, istak(isort), istak(isym), rstak(xaxis), rstak(yaxis), & lpcv, alpha, nprt, parzen, nmsub, ldsmin, ldstak, option, & lnlppa, ly) call stkclr(nall0) if (ierr == 0) return write ( *,1000) return 1000 format (/' the correct form of the call statement is'// & ' call ufsvs (acov, lagmax, n,'/ & ' + nw, lags, nf, fmin, fmax, nprt,'/ & ' + spcf, ispcf, freq, ldstak)') end function v2norm ( p, x ) !*********************************************************************** ! !! V2NORM computes the L2 norm of a vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer P, the length of the vector. ! ! Input, real X(P), the vector. ! ! Output, real V2NORM, the Euclidean norm of the vector. ! ! Local Parameters: ! ! SQTETA is (slightly larger than) the square root of the ! smallest positive floating point number on the machine. ! The tests involving SQTETA are done to prevent underflows. ! implicit none integer p integer i integer j real r real scale real, save :: sqteta = 0.0E+00 real t real v2norm real x(p) real xi if ( p <= 0 ) then v2norm = 0.0E+00 return end if i = 0 do j = 1, p if ( x(j) /= 0.0E+00 ) then i = j exit end if end do if ( i == 0 ) then v2norm = 0.0E+00 return end if scale = abs ( x(i) ) t = 1.0E+00 if ( sqteta == 0.0E+00 ) then sqteta = sqrt ( 1.001E+00 * tiny ( sqteta ) ) end if j = i + 1 do i = j, p xi = abs ( x(i) ) if ( xi <= scale ) then r = xi / scale if ( sqteta < r ) then t = t + r * r end if else r = scale / xi if ( sqteta < r ) then t = 1.0E+00 + t * r * r else t = 1.0E+00 end if scale = xi end if end do v2norm = scale * sqrt ( t ) return end subroutine vcopy ( p, y, x ) !*********************************************************************** ! !! VCOPY copies a vector. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, integer P, the length of the vector. ! ! Output, real Y(P), the copy of the input vector. ! ! Input, real X(P), the vector to be copied. ! implicit none integer p real x(p) real y(p) y(1:p) = x(1:p) return end subroutine vcvotf ( npar, vcv, lvcv, est, lmask, mask, ivcvpt ) !*****************************************************************************80 ! !! VCVOTF prints the variance-covariance matrix. ! ! Discussion: ! ! this subroutine prints the variance covariance matrix ! stored row wise when it is to be labelled on the basis of a mask. ! if est is true, the covariances are listed above the ! diagonal, the variances on the diagonal, and the correlation ! coefficients below the diagonal. ! if est is false, the standard deviations are listed on the ! diagonal, and the correlation coefficients are below the ! diagonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ivcvpt,lmask,lvcv,npar logical & est ! ! array arguments real & vcv(lvcv) integer & mask(lmask) ! ! integer & code,i,ii,mode ! ! variable definitions (alphabetically) ! ! integer code ! if 1 -single printed, x only (y is dummy arg) ! 2 -double printed line, both x and y ! logical est ! an indicator used to designate whether the vcv to be printed ! is of the estimated parameters (true) or not (false). ! integer i ! an index variable. ! integer ii ! the index of the (i,i)th element of the vcv matrix ! integer ivcvpt ! an indicator value used to designate which form of the ! variance covariance matrix (vcv) is being printed, where ! ivcvpt = 1 indicates the vcv was computed as ! inverse(transpose(jacobian)*jacobian) ! ivcvpt = 2 indicates the vcv was computed as ! inverse(hessian) ! ivcvpt = 3 indicates the vcv was computed as ! inverse(hessian)*transpose(jacobian)*jacobian ! *inverse(hessian) ! integer lmask ! the length of mask. ! integer lvcv ! the length of array vcv. ! integer mask(lmask) ! mask vector for vcv. the index of the ith element of ! mask equal to zero is the label in the output of vcv ! of the ith row and ith column. ! integer mode ! if 0, lower triangular part printed ! 1, lower triangular part is printed with ! square roots of the diagonal ! 2, lower triangle printed as correlation matrix ! with square roots on the diagonal ! 3, full matrix printed ! 4, full matrix printed with correlation matrix ! printed below the diagonal ! integer npar ! the number of unknown parameters in the model. ! real vcv(lvcv) ! the variance covariance matrix. ! code = 1 ! ! determine whether to issue negative variance warning ! mode = 0 do i = 1, npar ii = i*(i-1)/2 + i if ( vcv(ii) <= 0.0 ) then if ( est ) then write ( *,1050) if (ivcvpt == 1) write ( *,1060) if (ivcvpt == 2) write ( *,1070) if (ivcvpt == 3) write ( *,1080) else write ( *,1000) end if write ( *,1010) call matprf(vcv, vcv, npar, mode, code, lvcv, mask, lmask) return end if end do ! ! print heading for correlation routines ! if ( .not. est ) then write ( *,1040) write ( *,1030) mode = 2 ! ! print heading for estimation routines ! else write ( *,1050) if (ivcvpt == 1) write ( *,1060) if (ivcvpt == 2) write ( *,1070) if (ivcvpt == 3) write ( *,1080) write ( *,1020) mode = 4 end if call matprf(vcv, vcv, npar, mode, code, lvcv, mask, lmask) return 1000 format (///' covariance matrix') 1010 format (/' nonpositive variances encountered.'/& 'correlation coefficients cannot be computed.') 1020 format (4x, '- covariances are above the diagonal'/4x, '- varia', & 'nces are on the diagonal'/4x, '- correlation coefficients ', & 'are below the diagonal') 1030 format (4x, '- standard deviations are on the diagonal'/4x, & '- correlation coefficients are below the diagonal') 1040 format (/' correlation matrix') 1050 format (///' variance-covariance and correlation matrices', & ' of the estimated (unfixed) parameters'/ 1x, 82('-')) 1060 format (/ & 4x, '- approximation based on assumption that residuals are', & ' small') 1070 format ( & /4x, '- approximation based on asymptotic maximum likelihood theory') 1080 format (/4x, & '- approximation based on assumption that conditions necessary'/ & 5x, ' for asymptotic maximum likelihood theory', & ' might be violated') end subroutine vcvout ( np, vcv, ivcv, est ) !*****************************************************************************80 ! !! VCVOUT prints the variance-covariance matrix. ! ! Discussion: ! ! this subroutine prints the variance covariance matrix. ! if est is true, the covariances are listed above the ! diagonal, the variances on the diagonal, and the correlation ! coefficients below the diagonal. ! if est is false, the standard deviations are listed on the ! diagonal, and the correlation coefficients are below the ! diagonal. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ivcv,np logical & est ! ! array arguments real & vcv(ivcv,np) real & den,svcvii,svcvjj integer & i,j,k,mode ! ! external subroutines external matprt ! ! variable definitions (alphabetically) ! ! real den ! denominator of (i, j) correlation coefficient ! logical est ! an indicator used to designate whether the vcv to be printed ! is of the estimated parameters (true) or not (false). ! integer i ! an index variable. ! integer ivcv ! the exact first dimension of the matrix vcv. ! integer j ! the index of the parameter being examined. ! integer k ! an index variable. ! integer mode ! if mode is 1, print full matrix. ! if mode is 2, print lower triangle with square roots of ! of the diagonal. ! integer np ! the number of unknown parameters in the model. ! real svcvii, svcvjj ! square roots of vcv(i, i) and vcv(j, j) ! real vcv(ivcv,np) ! the variance covariance matrix. ! ! ! determine whether to issue negative variance warning ! mode = 2 do i=1,np if ( vcv(i,i) <= 0.0 ) then write ( *,1000) if (est) write ( *,1050) write ( *,1010) mode = 0 go to 70 end if end do if (est) go to 20 ! ! print heading for correlation routines ! write ( *,1040) write ( *,1030) mode = 2 go to 30 20 continue ! ! print heading for estimation routines ! write ( *,1050) write ( *,1020) mode = 1 30 continue ! ! compute the correlation coefficients and store in the bottom half ! of the variance covariance matrix ! do j=2,np k = j - 1 svcvjj = 0.0e0 if (vcv(j,j) > 0.0e0) svcvjj = sqrt(vcv(j,j)) do i=1,k svcvii = 0.0e0 if (vcv(i,i) > 0.0e0) svcvii = sqrt(vcv(i,i)) den = svcvii*svcvjj if (den <= 0.0e0) vcv(j,i) = 0.0e0 if (den > 0.0e0) vcv(j,i) = vcv(j,i)/den end do end do 70 continue call matprt(vcv, vcv, np, mode, 1, ivcv) ! ! restore the vcv matrix ! if (np == 1) return do j=2,np k = j - 1 vcv(j,1:k) = vcv(1:k,j) end do return 1000 format (/' covariance matrix') 1010 format (/' nonpositive variances encountered.'/& 'correlation coefficients cannot be computed.') 1020 format (4x, '- covariances are above the diagonal'/4x, '- varia', & 'nces are on the diagonal'/4x, '- correlation coefficients ', & 'are below the diagonal') 1030 format (4x, '- standard deviations are on the diagonal'/4x, & '- correlation coefficients are below the diagonal') 1040 format (/' correlation matrix') 1050 format (/' variance-covariance and correlation matrices', & ' of the estimated parameters'/ 1x, 72('-')/) end subroutine versp ( wide ) !*****************************************************************************80 ! !! VERSP prints the version number. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none logical & wide ! ! variable definitions (alphabetically) ! ! logical wide ! the maximum number of columns the printed output can use. ! if (wide) then write ( *, 1000) else write ( *, 1010) end if return 1000 format (105x, 'starpac 2.08s (03/15/90)') 1010 format (54x, 'starpac 2.08s (03/15/90)') end subroutine vp ( ym, n, ns ) !*****************************************************************************80 ! !! VP is the user callable routine which produces a vertical plot (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & n,ns ! ! array arguments real & ym(*) ! ! scalars in common integer & ierr real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays real & ymmiss(1) integer & isym(1) character & nmsub(6)*1 ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / ' ', 'v', 'p', ' ', ' ', ' '/ ymmiss(1) = 1.0e0 m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 0 isize = -1 miss = .false. lisym = 1 irlin = -1 ibar = 0 call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call vp (y, n, ns)') end subroutine vpc ( ym, n, ns, ilog, isize, irlin, ibar, ylb, yub, xlb, xinc ) !*****************************************************************************80 ! !! VPC is the user callable routine which produces a vertical plot (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,isize,n,ns ! ! array arguments real & ym(*) ! ! scalars in common integer & ierr integer ischck,iym,lisym,m logical & miss,multi ! ! local arrays real & ymmiss(1) integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / ' ', 'v', 'p', 'c', ' ', ' '/ ymmiss(1) = 1.0e0 m = 1 iym = n multi = .false. ischck = 0 miss = .false. lisym = 1 call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym ) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call vpc (y, n, ns, ilog,'/ & ' + isize, irlin, ibar, ylb, yub, xlb, xinc)') end subroutine vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym ) !*****************************************************************************80 ! !! VPCNT is the controlling routine for user-called vertical plots ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! logical error ! a value indicating whether an error was detectec (true) ! or not (false). ! integer ibar ! the indicator used to designate whether the plot is to be a ! bar graph (ibar >= 1) or not (ibar <= 0). ! integer ierr ! the common variable used to indicate errors, ! if =0, then no errors ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator used to designate whether the plot will have ! the location of zero plotted as a reference line (irlin == 0), ! the location of the mean plotted as a reference line (irlin >= ! or no reference line (irlin<0). ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(lisym) ! vector containing symbols for plotting, not used in some cases ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns, nsampl ! the sampling frequency. ! logical xcheck ! indicator variable used to designate whether x-axis values ! are to be checked (xcheck = .true.) or not (xcheck = .false.) ! real xinc ! the increment for the x-axis. ! real xlb ! the lower bound for the x-axis. (xlb=xub indicates limits are ! to be determined from the range of the data.) ! real ylb ! the lower bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! real ym(iym,m) ! multivariate observations for the y coordinates ! real ymmiss(m) ! the missing value code for the y-axis. ! real ymn, ymx ! the y-ayis lower and upper limits actually used. ! real yub ! the upper bound for the y-axis. (ylb=yub indicates limits are ! to be determined from the range of the data.) ! implicit none integer ibar integer ilog integer irlin integer ischck integer isize integer iym integer lisym integer m integer n integer ns real xinc real xlb real ylb real yub logical & miss,multi ! ! array arguments real & ym(*),ymmiss(*) integer & isym(*) character & nmsub(6)*1 ! ! scalars in common integer & ierr real & ymn,ymx integer & nsampl logical & error,xcheck ! ! common blocks common /errchk/ierr xcheck = .false. call pltchk ( ym, ymmiss, ym, ymmiss(1), n, m, iym, multi, & ilog, ylb, yub, xlb, xinc, nmsub, miss, xcheck ) if ( ierr == 0 ) then ! ! Determine the bounds for the axis and complete error checking ! nsampl = max(1, ns) call vplmt ( ym, ymmiss, n, m, iym, ylb, yub, ymn, ymx, & error, nmsub, miss, nsampl ) if ( error ) then ierr = 1 else ! ! Print plot ! if ( mod ( max ( 0, isize ), 10 ) == 0 ) then call versp ( .true. ) else call versp ( .false. ) end if call vpmn ( ym, ymmiss, n, m, iym, nsampl, ischck, isym, lisym, & isize, ymn, ymx, xlb, xinc, miss, ilog, irlin, ibar ) end if end if return end subroutine vphead ( nsampl, irlin, ibar, ywidth, ymn, ymx, & isize, ilog, line, numcol, ilogy, ydmn, ydmx ) !*****************************************************************************80 ! !! VPHEAD prints the heading for the vertical plot output. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! real dely ! the scale interval of the plot. ! integer i ! an indexing variable. ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ilogy ! the value of q (see ilog) ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer nsampl ! the sampling frequency, ! where if nsampl <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real ydmn, ydmx ! the y-axis data limits actually used. ! real ylabel(20) ! the y-axis lables. ! character ylfmt*205, ylfmt2*205 ! the formats used to print the x-axis ! real ymn, ymx ! the graph axis lower and upper limits actually used. ! implicit none real ydmn,ydmx,ymn,ymx,ywidth integer & ibar,ilog,ilogy,irlin,isize,nsampl,numcol integer ndigit integer nprt ! ! array arguments character & line(103)*1 real & dely integer & i,icol,ik,jcol,nlably,nlu character & fmt*4,ylfmt*205,ylfmt2*205 ! ! local arrays real & ylabel(20) integer & ispace(20) integer iptout(1) ! ! check plot sequence. ! if (nsampl == 2) then write ( *, 1003) else if (nsampl == 3) then write ( *, 1004) else if (nsampl >= 4) then write ( *, 1005) nsampl end if ! ! print headings for y ! if (ibar == 0) then if (irlin >= 1) then write ( *, 1006) else if (irlin == 0) then write ( *, 1007) end if end if ! ! find size of plot to be created ! if (mod(max(0,isize),10) == 0) then numcol=101 else numcol = 51 end if ! ! adjust for log plots if necessary and find axis labels ! nprt = mod ( max ( 0, ilog ), 10 ) ndigit = 1 iptout(1) = ilogy call prtcnt ( nprt, ndigit, iptout ) ilogy = iptout(1) call loglmt (ilogy, ymn, ymx, ylabel, numcol, 10, dely, ywidth, & nlably, ydmn, ydmx) ! ! write out the horizontal axis and the axis labels. ! line(1:numcol)='-' line(1)='i' if (ilogy == 0) then nlu = nlably+1 do icol=numcol,1,-10 line(icol)='i' nlu = nlu - 1 ispace(nlu) = 1 end do else jcol = 1 line(jcol) = 'i' nlu = nlably do ik = nlably,1,-1 icol = int ( ((log10(ylabel(ik))-ymn)/ywidth)+1.5e0 ) line(icol) = 'i' if (icol-jcol >= 10) then ispace(nlu) = icol-jcol-9 nlu = nlu - 1 ylabel(nlu) = ylabel(ik) jcol = icol end if end do end if line(numcol+1)='-' line(numcol+2)=' ' ! ! check x-axis labels for format ! fmt = 'f9.4' do i=1,nlably if (((abs(ylabel(i)) > 0.0e0).and. & (abs(ylabel(i))<0.01e0)) .or. & ((ylabel(i) >= 1.0e4).or.(ylabel(i) <= (-1.0e3)))) then fmt = 'e9.3' exit end if end do write(ylfmt2,1000) nlably-nlu write(ylfmt,ylfmt2) (fmt, ispace(i), i=nlably,nlu+1,-1), fmt write ( *, ylfmt) (ylabel(i),i=nlably,nlu,-1) write ( *, 1001) '-', (line(icol), icol=1,numcol+2) return 1000 format ('(''(11x'',', i2, '('', '', a4, '','', i2, ''x''),', & ''', '', a4, '')'')') 1001 format (' ',13x, a1, 105a1) 1003 format('0note that every other point has been plotted') 1004 format('0note that every third point has been plotted') 1005 format('0note that every ', i2, 'th point has been plotted') 1006 format(/' location of mean is given by plot character m') 1007 format(/' location of zero is given by plot character 0') end subroutine vpl ( ym, n, ns, ilog ) !*****************************************************************************80 ! !! VPL is the user callable routine which produces a vertical log plot. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer & ilog,n,ns ! ! array arguments real & ym(*) ! ! scalars in common integer & ierr real & xinc,xlb,ylb,yub integer & ibar,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays real & ymmiss(1) integer & isym(1) character & nmsub(6)*1 ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / ' ', 'v', 'p', 'l', ' ', ' '/ ymmiss(1) = 1.0e0 m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 0 isize = -1 miss = .false. lisym = 1 irlin = -1 ibar = 0 call vpcnt (ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call vpl (y, n, ns, ilog)') end subroutine vplmt ( ym, ymmiss, n, m, iym, ylb, yub, ymn, & ymx, error, nmsub, miss, nsampl ) !*****************************************************************************80 ! !! VPLMT sets the plot limits for vertical plots ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & ylb,ymn,ymx,yub integer & iym,m,n,nsampl logical & error,miss ! ! array arguments real & ym(iym,m),ymmiss(m) character & nmsub(6)*1 ! ! integer & i,ii,j logical & head,setlmt ! ! external functions logical & mvchk external mvchk ! ! variable definitions (alphabetically) ! ! logical error ! a value indicating whether an error was detected (true) ! or not (false). ! logical head ! print heading (head=true) or not (head=false). ! integer i, ii ! indexing variables. ! integer iym ! actual row dimension of ym declared in the users main program ! integer j ! an index variable. ! integer m ! the number of vectors in ym ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! integer n ! the integer number of observations . ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer nsampl ! * ! logical setlmt ! an indicator variable used to determine if starting values ! for xlb, xinc, ymn, ymx have been found. ! real ylb ! the user supplied y-axis lower bound. ! real ym(iym,m) ! the array containing the dependent variable(s). ! real ymmiss(m) ! the user supplied code which is used to determine whether or ! not an observation is missing. ! if ym(i,j) = ymmiss(j), the value is assumed missing, otherwise ! it is not. ! real ymn, ymx ! the y-axis lower and upper limits actually used. ! real yub ! the user supplied y-axis upper bounds. ! error = .false. ! ! Set limits to user specified values ! if (ylb= yub) then write ( *, 1010) else write ( *, 1020) end if write ( *, 1030) ! ! find limits from remaining values ! else if (ii <= n) then do i=ii,n,nsampl do j=1,m if (miss .and. mvchk(ym(i,j),ymmiss(j))) then cycle end if if ((ylb= ymx) then call adjlmt(ymn, ymx) end if end if return 1010 format (/ & ' no non-missing plot coordinates were found.') 1020 format (/ & ' no non-missing values were found within', & ' the user supplied limits.') 1030 format (/ ' the plot has been suppressed.') end subroutine vpm ( ym, ymmiss, n, ns ) !*****************************************************************************80 ! !! VPM produces a vertical plot with missing data (short call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! implicit none integer & n,ns ! ! array arguments real & ym(*),ymmiss(1) ! ! scalars in common integer & ierr real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / ' ', 'v', 'p', 'm', ' ', ' '/ m = 1 iym = n multi = .false. ilog = -1 ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 0 isize = -1 miss = .true. lisym = 1 irlin = -1 ibar = 0 call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym ) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call vpm (y, ymiss, n, ns)') end subroutine vpmc ( ym, ymmiss, n, ns, ilog, isize, & irlin, ibar, ylb, yub, xlb, xinc ) !*****************************************************************************80 ! !! VPMC produces a vertical plot with missing data (long call). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none real & xinc,xlb,ylb,yub integer & ibar,ilog,irlin,isize,n,ns ! ! array arguments real & ym(*),ymmiss(1) ! ! scalars in common integer & ierr ! ! integer ischck,iym,lisym,m logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / ' ', 'v', 'p', 'm', 'c', ' '/ m = 1 iym = n multi = .false. ischck = 0 miss = .true. lisym = 1 call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym ) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call vpmc (y, ymiss, n, ns, ilog,'/ & ' + isize, irlin, ibar, ylb, yub, xlb, xinc)') end subroutine vpml ( ym, ymmiss, n, ns, ilog ) !*****************************************************************************80 ! !! VPML produces a vertical plot with missing data (log plot option). ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! implicit none integer ilog integer n integer ns ! ! array arguments real & ym(*),ymmiss(1) ! ! scalars in common integer & ierr ! ! real & xinc,xlb,ylb,yub integer & ibar,irlin,ischck,isize,iym,lisym,m logical & miss,multi ! ! local arrays integer & isym(1) character & nmsub(6)*1 ! ! external subroutines external vpcnt ! ! common blocks common /errchk/ierr ! ! variable definitions (alphabetically) ! ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! integer ierr ! a common variable used as a flag to indicate whether ! or not there are any errors, if =0 then no errors. ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(1) ! vector containing symbol designations for plotting ! integer iym ! the first dimension of array ym. ! integer lisym ! the length of array isym. ! integer m ! number of y vectors ! logical miss ! indicator variable used to designate whether missing values ! may be present (miss = .true.) or not (miss = .false.) ! logical multi ! indicator variable used to designate whether multiple y values ! are to be plotted (multi = .true.) or not (multi = .false.) ! integer n ! length of vectors ! character*1 nmsub(6) ! the characters of the calling routines name. ! integer ns ! the sampling frequency, ! where if ns <= 1, every point is plotted, ! = 2, every other point is plotted, ! = 3, every third point is plotted, etc. ! real xinc, xlb ! increment and lower bounds for x-axis. ! real ylb ! lower bound for y-axis. ! real ym(n,1) ! multivariate observations for the y coordinates ! real ymmiss(1) ! the missing value code for the y-axis. ! real yub ! upper bound for y-axis. ! ! set up name arrays ! data & nmsub(1), nmsub(2), nmsub(3), nmsub(4), nmsub(5), nmsub(6) & / ' ', 'v', 'p', 'm', 'l', ' '/ m = 1 iym = n multi = .false. ylb = 0.0e0 yub = 0.0e0 xlb = 1.0e0 xinc = 1.0e0 ischck = 0 isize = -1 miss = .true. lisym = 1 irlin = -1 ibar = 0 call vpcnt ( ym, ymmiss, n, m, iym, multi, ilog, ylb, yub, & xlb, xinc, ns, irlin, ibar, nmsub, ischck, isym, isize, & miss, lisym ) if (ierr /= 0) then ierr = 1 write ( *,1000) end if return 1000 format (/' the correct form of the call statement is'// & ' call vpml (y, ymiss, n, ns, ilog)') end subroutine vpmn ( ym, ymmiss, n, m, iym, nsampl, ischck, isym, & lisym, isize, ymn, ymx, xlb, xinc, miss, ilog, irlin, ibar ) !*****************************************************************************80 ! !! VPMN produces vertical plots. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! character fmt*72 ! the format for the x-axis labels ! integer i ! an indexing variable. ! integer ibar ! the variable used to determine if single points (ibar == 0) ! or bars (ibar /= 0) are to be plotted. ! character*1 iblank ! the plot symbol blank. ! integer icount(103) ! the number of plot symbols at each location. ! integer iend ! the number of locations in the plot string. ! integer ierr ! the integer value returned by this routine designating ! whether any errors were detected in the parameter list ! if ierr == 0, no errors were detected ! if ierr == 1, errors have been detected ! logical ifmiss ! the indicator variable used to determine whether the ! input series has missing data (true) or not (false). ! integer ilog ! the two digit integer, pq, used to select axis scale, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is linear. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is log. ! integer ilogy ! the value of q (see ilog). ! character*1 im ! the plot symbol m. ! integer imax ! the largest location in the plot string being defined. ! integer imin ! the smallest location in the plot string being defined. ! character*1 ipltch ! the plot character used for a given line of the plot. ! integer ipoint ! the location in the plot string of the value being plotted. ! integer iptsym ! an indicator variable used to designate the type ! of plot. if ischck = 1, the plot is a symple page ! or vertical plot. if ischck = 2, the plot is a symbol ! plot. if ischck = 3, the plot is a multivariate plot. ! character*1 irefch ! the plot symbol used to identify the plot reference line. ! integer irefpt ! the location in the plot string for the value zero, or ! series mean, which ever was requested. ! integer irlin ! the indicator variable used to designate whether zero or the ! series mean is to be plotted as a reference line, or whether ! no reference line is to be plotted. ! if irlin <= -1, no reference line is plotted. ! if irlin == 0, zero is plotted as the reference line. ! if irlin >= 1, the series mean is plotted. ! integer ischck ! the integer value indicating how the plotting symbols ! will be designated, where ! 0 indicates the plotting symbols have not been designated in ! the n vector isym and only the symbol + is to be used ! 1 indicates the plotting symbols have been designated in the ! n vector isym ! 2 indicates that m series are being plotted. ! symbol i+4 will be used for column i of ym. ! integer isize ! the two digit integer, pq, used to select axis size, where ! p designates the x-axis and q designates the y-axis. ! if p == 0 (q == 0), then the x-axis (y-axis) is the maximum. ! if p /= 0 (q /= 0), then the x-axis (y-axis) is half the maximu ! integer isym(lisym) ! vector containing symbol designations for plotting ! integer iym ! the exact value of the first dimension of the matrix ym. ! character*1 i0 ! the plot symbol -0-. ! integer j ! an index variable. ! character*1 line(103) ! the vector used for the plot string. ! integer m ! the number of columns of data in ym. ! integer n ! the integer number of observations . ! integer nsampl ! the sampling frequency actually used. ! integer nused ! the number of active observations. ! real refpt ! the value zero, or the mean of the series, which ever is ! requested, used as a plot reference line. ! real xinc ! the variable used to specify the increment for xlabel. ! real xlabel ! the value used for the labels on the right side of the plot. ! real xlb ! the starting value for labels on the right side of the graph. ! real ydmn, ydmx ! the y-axis data limits actually used. ! real ym(iym,m) ! the vector containing the observed time series ! real ymmiss(m) ! the user supplied code which is used to determine whether or ! not an observation in the series is missing. if ym(i) = ymmiss ! the value is assumed missing, otherwise it is not. ! real ymn, ymx ! the graph axis lower and upper limits actually used. ! real ywidth ! the scale interval of the plot. ! real yy ! the value of ym actually being plotted ! implicit none integer ibar integer ilog integer irlin logical miss real xinc real xlb real ymn real ymx integer & ischck,isize,iym,lisym,m,n,nsampl ! ! array arguments real & ym(iym,m),ymmiss(m) integer & isym(lisym) ! ! scalars in common integer & ierr real & refpt,xlabel,ydmn,ydmx,ywidth,yy integer & i,iend,ilogy,imax,imin,ipoint,iptsym,irefpt,j,numcol, & nused logical & ifmiss character & i0*1,iblank*1,im*1,ipltch*1,irefch*1,fmt*72 ! ! local arrays integer & icount(103) character & line(103)*1 ! ! external functions logical & mvchk external mvchk ! ! common blocks common /errchk/ierr data iblank/' '/, im/'m'/, i0/'0'/ ! ! print plot headings ! call vphead ( nsampl, irlin, ibar, ywidth, ymn, ymx, isize, ilog, & line, numcol, ilogy, ydmn, ydmx ) iend = numcol + 2 ! ! Compute reference point of graph, if required. ! if ( 0 <= irlin ) then ! ! reference point is zero ! if ( irlin == 0 ) then refpt = 0.0e0 irefch = i0 ! ! reference point is mean ! else if ( miss ) then call ameanm ( ym, ymmiss(1), n, nused, refpt ) else call amean ( ym, n, refpt ) end if if (ilogy /= 0) refpt = log10(refpt) irefch = im end if ! ! Compute location of refpt in plot string ! call pltplx ( refpt, ymn, ywidth, irefpt, iend ) else irefpt = 1 end if ! ! Begin plotting ! iptsym = ischck + 1 xlabel = xlb do i = 1, n, nsampl call pline ( 1, iend, iblank, line ) call setiv ( icount, iend, 0 ) ifmiss = .false. ipoint = 1 do j = 1, m if ( miss ) then ifmiss = (ifmiss .or. (mvchk(ym(i,j),ymmiss(j)))) if (.not.(mvchk(ym(i,j),ymmiss(j)))) then if (ilogy == 0) then yy = ym(i,j) else yy = log10(ym(i,j)) end if if ((yy >= ydmn) .and. (yy <= ydmx)) then call pltplx(yy, ymn, ywidth, ipoint, iend) call pltsym(iptsym, i, j, isym, n, ipoint, line, icount) ipltch = line(ipoint) else ipoint = irefpt ipltch = iblank end if end if else if (ilogy == 0) then yy = ym(i,j) else yy = log10(ym(i,j)) end if if ((yy >= ydmn) .and. (yy <= ydmx)) then call pltplx(yy, ymn, ywidth, ipoint, iend) call pltsym(iptsym, i, j, isym, n, ipoint, line, icount) ipltch = line(ipoint) else ipoint = irefpt ipltch = iblank end if end if end do if ((ibar >= 1) .and. (.not.ifmiss)) then imin = min(ipoint,irefpt) imax = max(ipoint,irefpt) call pline(imin, imax, ipltch, line) else if (irlin >= 0) then line(irefpt) = irefch end if if ( ifmiss ) then write ( fmt, 1001 ) numcol write ( *,fmt) xlabel, (line(j), j=1,iend) else write(fmt,1000) numcol, 'g12.5' if (m == 1) then write ( *,fmt) xlabel, (line(j),j=1,iend), ym(i,1) else write ( *,fmt) xlabel, (line(j),j=1,iend) end if end if xlabel = xlabel + xinc * real ( nsampl ) end do return 1000 format( '(g12.5,1x,a1,''i'',', i3, 'a1,''i'',a1,',a, ')' ) 1001 format( '(g12.5,1x,a1,''i'',', i3, 'a1,''i'',a1, ''Missing'' )' ) end subroutine xerabt ( messg, nmessg ) !*****************************************************************************80 ! !! XERABT aborts program execution and prints an error message. ! ! Discussion: ! ! This routine is called to abort execution of a running program, ! indicated by the occurrence of a fatal error. ! ! The error message associated with the fatal condition is provided ! in the calling sequence. ! ! This routine is used when the error message handlers XERROR and ! XERRWV are employed. The similar routine XERHLT is to be used ! when the more modern error message handler XERMSG is used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be processed. ! ! Input, integer NMESSG, the actual number of characters in MESSG. ! If NMESSG is 0, no message is being supplied. ! implicit none character ( len = * ) messg integer nmessg write ( *, '(a)' ) ' ' write ( *, '(a)' ) 'XERABT - Termination after fatal error!' if ( 0 < len ( messg ) ) then write ( *, '(a)' ) ' ' write ( *, '(a)' ) ' Associated error message:' write ( *, '(a)' ) '"' // trim ( messg ) // '"' end if stop end subroutine xerbla ( subrou, nerr ) !*****************************************************************************80 ! !! XERBLA is an error handler for the Level 2 and Level 3 BLAS routines. ! ! Discussion: ! ! This routine is called by Level 2 and 3 BLAS routines if an input ! parameter is invalid. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Parameters: ! ! Input, character ( len = * ) SUBROU, the name of the routine which ! called XERBLA. The name will not be more than 6 characters. ! ! Input, integer NERR, the error number, which here is used to ! indicate the position of the invalid parameter in the ! parameter-list of the calling routine. ! implicit none integer level character ( len = 6 ) librar character ( len = 60 ) message integer nerr character ( len = * ) subrou librar = 'SLATEC' write ( message, '(a,a,a,i2,a)' ) 'On entry to ', trim ( subrou ), & ', parameter number ', nerr, ' had an illegal value.' level = 1 call xermsg ( librar, subrou, message, nerr, level ) return end subroutine xerclr ( ) !*****************************************************************************80 ! !! XERCLR resets the current error number to zero. ! ! Discussion: ! ! This routine simply resets the current error number to zero. ! ! This may be necessary to do in order to determine that ! a certain error has occurred again since the last time ! NUMXER was referenced. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! None ! implicit none integer j4save integer junk logical set integer value integer which which = 1 value = 0 set = .true. junk = j4save ( which, value, set ) if ( junk == 1952 ) then write ( *, '(a)' ) 'This is a dummy message!' end if return end subroutine xercnt ( librar, subrou, messg, nerr, level, kontrl ) !*****************************************************************************80 ! !! XERCNT allows user control over the handling of errors. ! ! Description: ! ! This routine allows user control over handling of individual errors. ! ! This routine is to be used when the error message routine XERMSG ! is employed. The similar routine XERCTL is to be used for the ! older error message routines XERROR and XERRWV. ! ! Just after each message is recorded, but before it is ! processed any further (i.e., before it is printed or ! a decision to abort is made), a call is made to XERCNT. ! ! If the user has replaced this default, dummy version of XERCNT ! with a customized routine, it can then be used to override the ! value of KONTROL used in processing this message by redefining its value. ! ! KONTRL may be set to any value from -2 to 2. ! ! The meanings for KONTRL are the same as in XSETF, except ! that the value of KONTRL changes only for this message. ! ! If KONTRL is set to a value outside the range from -2 to 2, ! it will be moved back into that range. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) LIBRAR, the library or software package ! from which the error message is coming. ! ! Input, character ( len = * ) SUBROU, the subroutine or function within ! the library, from which the error message is coming. ! ! Input, character ( len = * ) MESSG, the error message. ! ! Input, integer NERR, the error number. ! ! Input, integer LEVEL, the error severity level. ! * 2, this is an unconditionally fatal error. ! * 1, this is a recoverable error. It is normally non-fatal, unless ! KONTRL has been reset by XSETF. ! * 0, this is a warning message only. ! *-1, this is a warning message which is to be printed at most once, ! regardless of how many times this call is executed. ! ! Input/output, integer KONTRL. This routine receives the current ! value of KONTRL, and may reset it. The change is effective only ! for the current error message. This allows the user to suppress ! or force printing of certain messages, for instance. ! implicit none integer kontrl integer level character ( len = * ) librar character ( len = * ) messg integer nerr character ( len = * ) subrou return end subroutine xerctl ( messg, nmessg, nerr, level, kontrl ) !*****************************************************************************80 ! !! XERCTL allows user control over handling of individual errors. ! ! Discussion: ! ! This routine gives the user control over handling of individual errors. ! ! This routine is to be used when the error message routines XERROR ! and XERRWV are used. The similar routine XERCNT is to be used for ! the newer error message routine XERMSG. ! ! This routine is called just after each message has been recorded, ! but before it is processed any further; that is, before the ! message is printed or a decision to abort is made. ! ! If the user wishes to influence the behavior of the error package ! with respect to certain errors, then this dummy version of the ! routine should be replaced by a routine that carries out the ! actions the user desires. ! ! In particular, the user can override the value of KONTRL used ! in processing this message by redefining its value. ! ! KONTRL may be set to any value from -2 to 2. ! The meanings for KONTRL are the same as in XSETF, except ! that the value of KONTRL changes only for this message. ! ! If KONTRL is set to a value outside the range from -2 to 2, ! it will be moved back into that range. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the error message. ! ! Input, integer NMESSG, same as in the call to XERROR or XERRWV. ! ! Input, integer NERR, same as in the call to XERROR or XERRWV. ! ! Input, integer LEVEL, same as in the call to XERROR or XERRWV. ! ! Input/output, integer KONTRL. On input, the current value of the control ! flag as set by a call to XSETF. On output, the new value of kontrl. ! If KONTRL is not defined, it will remain at its original value. ! This changed value affects only the current occurrence of the current ! message. ! implicit none integer kontrl integer level character ( len = * ) messg integer nerr integer nmessg return end subroutine xerdmp ( ) !*****************************************************************************80 ! !! XERDMP prints the error tables and then clears them. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! None ! implicit none integer count integer level character ( len = 1 ) messg integer nerr integer nmessg messg = ' ' nmessg = 0 nerr = 0 level = 0 count = 0 call xersav ( messg, nmessg, nerr, level, count ) return end subroutine xerhlt ( messg ) !*****************************************************************************80 ! !! XERHLT aborts program execution. ! ! Discussion: ! ! This routine aborts the execution of the program. ! ! The error message causing the abort is given in the calling ! sequence. ! ! This routine is used when the error message handler XERMSG is ! employed. The similar routine XERABT is to be used when the ! older error message handlers XERROR and XERRWV are used. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the error message associated ! with the halt in execution. ! implicit none character ( len = * ) messg stop end subroutine xermax ( maxmes ) !*****************************************************************************80 ! !! XERMAX sets the maximum number of times any error message is to be printed. ! ! Discussion: ! ! This routine sets the maximum number of times any error message ! is to be printed. That is, a non-fatal message associated with ! a particular numbered error should not be be printed more than ! MAXMES times. ! ! Most error messages won't be printed at all if the error printout ! suppression mode has been set. That is the case if the variable ! KONTRL has been set to zero. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer MAXMES, the maximum number of times any one message ! is to be printed. ! implicit none integer j4save integer junk integer maxmes logical set integer value integer which which = 4 value = maxmes set = .true. junk = j4save ( which, value, set ) if ( junk == 1952 ) then write ( *, '(a)' ) 'This is a dummy message!' end if return end subroutine xermsg ( librar, subrou, messg, nerr, level ) !*****************************************************************************80 ! !! XERMSG processes error messages. ! ! Description: ! ! This routine processes a diagnostic message in a manner determined by the ! value of LEVEL and the current value of the library error control ! flag, KONTRL. ! ! See subroutine XSETF for details on KONTRL. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) LIBRAR, the name of the library from which the ! error message was generated. ! ! Input, character ( len = * ) SUBROU, the name of the subroutine or function ! from which the error message was generated. ! ! Input, character ( len = * ) MESSG, the text of the error or warning ! message. In the example below, the message is a character constant that ! contains a generic message. ! ! call xermsg ('SLATEC', 'MMPY', ! 'The order of the matrix exceeds the row dimension', 3, 1) ! ! It is possible (and is sometimes desirable) to generate a ! specific message--e.g., one that contains actual numeric ! values. Specific numeric values can be converted into ! character strings using formatted WRITE statements into ! character variables. This is called standard Fortran ! internal file I/O and is exemplified in the first three ! lines of the following example. You can also catenate ! substrings of characters to construct the error message. ! Here is an example showing the use of both writing to ! an internal file and catenating character strings. ! ! character ( len = 5 ) charn, charl ! write (charn,'(i5)') n ! write (charl,'(i5)') lda ! call xermsg ('SLATEC', 'MMPY', 'The order'//charn// ! ' of the matrix exceeds its row dimension of'// charl, 3, 1) ! ! There are two subtleties worth mentioning. One is that ! the // for character catenation is used to construct the ! error message so that no single character constant is ! continued to the next line. This avoids confusion as to ! whether there are trailing blanks at the end of the line. ! The second is that by catenating the parts of the message ! as an actual argument rather than encoding the entire ! message into one large character variable, we avoid ! having to know how long the message will be in order to ! declare an adequate length for that large character ! variable. XERMSG calls XERPRN to print the message using ! multiple lines if necessary. If the message is very long, ! XERPRN will break it into pieces of 72 characters (as ! requested by XERMSG) for printing on multiple lines. ! Also, XERMSG asks XERPRN to prefix each line with ' * ' ! so that the total line length could be 76 characters. ! Note also that XERPRN scans the error message backwards ! to ignore trailing blanks. Another feature is that ! the substring '$$' is treated as a new line sentinel ! by XERPRN. If you want to construct a multiline ! message without having to count out multiples of 72 ! characters, just use '$$' as a separator. '$$' ! obviously must occur within 72 characters of the ! start of each line to have its intended effect since ! XERPRN is asked to wrap around at 72 characters in ! addition to looking for '$$'. ! ! Input, integer NERR, the error number, chosen by the library routine's ! author. It must be in the range -99 to 999 (three printable digits). ! Each distinct error should have its own error number. These error ! numbers should be described in the machine readable documentation ! for the routine. The error numbers need be unique only within each ! routine, so it is reasonable for each routine to start enumerating ! errors from 1 and proceeding to the next integer. ! ! Input, integer LEVEL, a value in the range 0 to 2 that indicates the ! level (severity) of the error. Their meanings are ! * -1: A warning message. This is used if it is not clear ! that there really is an error, but the user's attention ! may be needed. An attempt is made to only print this ! message once. ! * 0: A warning message. This is used if it is not clear ! that there really is an error, but the user's attention ! may be needed. ! * 1: A recoverable error. This is used even if the error is ! so serious that the routine cannot return any useful ! answer. If the user has told the error package to ! return after recoverable errors, then XERMSG will ! return to the Library routine which can then return to ! the user's routine. The user may also permit the error ! package to terminate the program upon encountering a ! recoverable error. ! ! * 2: A fatal error. XERMSG will not return to its caller ! after it receives a fatal error. This level should ! hardly ever be used; it is much better to allow the ! user a chance to recover. An example of one of the few ! cases in which it is permissible to declare a level 2 ! error is a reverse communication Library routine that ! is likely to be called repeatedly until it integrates ! across some interval. If there is a serious error in ! the input such that another step cannot be taken and ! the Library routine is called again without the input ! error having been corrected by the caller, the Library ! routine will probably be called forever with improper ! input. In this case, it is reasonable to declare the ! error to be fatal. ! implicit none integer i integer j4save integer kdummy integer kount integer lerr integer level character ( len = 20 ) lfirst character ( len = * ) librar integer lkntrl integer llevel integer ltemp integer maxmes character ( len = * ) messg integer mkntrl integer nerr logical set logical skip character ( len = * ) subrou character ( len = 72 ) temp integer value integer which character ( len = 8 ) xlibr character ( len = 8 ) xsubr which = 2 value = 0 set = .false. lkntrl = j4save ( which, value, set ) which = 4 value = 0 set = .false. maxmes = j4save ( which, value, set ) ! ! LKNTRL is a local copy of the control flag KONTRL. ! ! MAXMES is the maximum number of times any particular message ! should be printed. ! ! We print a fatal error message and terminate for an error in ! calling XERMSG. The error number should be positive, ! and LEVEL should be between 0 and 2. ! if ( nerr .lt. -9999999 .or. & 99999999 .lt. nerr .or. & nerr .eq. 0 .or. & level .lt. -1 .or. & 2 .lt. level ) then call xerprn ( ' ***', -1, & 'Fatal error in...$$ ' // & 'XERMSG -- Invalid error number or level$$ ' // & 'Job abort due to fatal error.', 72 ) call xersve ( ' ', ' ', ' ', 0, 0, 0, kdummy ) call xerhlt ( ' ***XERMSG -- Invalid input' ) return end if ! ! Record the message. ! which = 1 value = nerr set = .true. i = j4save ( which, value, set ) call xersve ( librar, subrou, messg, 1, nerr, level, kount ) ! ! Handle print-once warning messages. ! if ( level .eq. -1 .and. 1 .lt. kount ) then return end if ! ! Allow temporary user override of the control flag. ! xlibr = librar xsubr = subrou lfirst = messg lerr = nerr llevel = level call xercnt ( xlibr, xsubr, lfirst, lerr, llevel, lkntrl ) lkntrl = max ( -2, min ( 2, lkntrl ) ) mkntrl = abs ( lkntrl ) ! ! Skip printing if the control flag value as reset in xercnt is ! zero and the error is not fatal. ! skip = .false. if ( level .lt. 2 .and. lkntrl .eq. 0 ) then skip = .true. end if if ( level .eq. 0 .and. maxmes .lt. kount ) then skip = .true. end if if ( level .eq. 1 .and. maxmes .lt. kount .and. mkntrl .eq. 1 ) then skip = .true. end if if ( level .eq. 2 .and. max ( 1, maxmes ) .lt. kount ) then skip = .true. end if if ( .not. skip ) then ! ! Announce the names of the library and subroutine by building a ! message in character variable TEMP (not exceeding 66 characters) ! and sending it out via XERPRN. Print only if control flag ! is not zero. ! if ( lkntrl .ne. 0 ) then temp(1:21) = 'Message from routine ' i = min ( len ( subrou ), 16 ) temp(22:21+i) = subrou(1:i) temp(22+i:33+i) = ' in library ' ltemp = 33 + i i = min ( len ( librar ), 16) temp(ltemp+1:ltemp+i) = librar (1:i) temp(ltemp+i+1:ltemp+i+1) = '.' ltemp = ltemp + i + 1 call xerprn ( ' ***', -1, temp(1:ltemp), 72 ) end if ! ! If LKNTRL is positive, print an introductory line before ! printing the message. The introductory line tells the choice ! from each of the following three options. ! ! 1. Level of the message ! ! 'Informative message' ! 'Potentially recoverable error' ! 'Fatal error' ! ! 2. Whether control flag will allow program to continue ! ! 'Prog continues' ! 'Prog aborted' ! ! 3. Whether or not a traceback was requested. (The traceback ! may not be implemented at some sites, so this only tells ! what was requested, not what was delivered.) ! ! 'Traceback requested' ! 'Traceback not requested' ! ! Notice that the line including four prefix characters will not ! exceed 74 characters. ! We skip the next block if the introductory line is not needed. ! if ( 0 .lt. lkntrl ) then ! ! The first part of the message tells about the level. ! if ( level .le. 0 ) then temp(1:20) = 'Informative message,' ltemp = 20 else if ( level .eq. 1 ) then temp(1:30) = 'Potentially recoverable error,' ltemp = 30 else temp(1:12) = 'Fatal error,' ltemp = 12 end if ! ! Then whether the program will continue. ! if ( ( mkntrl .eq. 2 .and. 1 .le. level ) .or. & ( mkntrl .eq. 1 .and. level .eq. 2 ) ) then temp(ltemp+1:ltemp+14) = ' Prog aborted,' ltemp = ltemp + 14 else temp(ltemp+1:ltemp+16) = ' Prog continues,' ltemp = ltemp + 16 end if ! ! Finally tell whether there should be a traceback. ! if ( 0 .lt. lkntrl ) then temp(ltemp+1:ltemp+20) = ' Traceback requested' ltemp = ltemp + 20 else temp(ltemp+1:ltemp+24) = ' Traceback not requested' ltemp = ltemp + 24 end if call xerprn ( ' ***', -1, temp(1:ltemp), 72 ) end if ! ! Now send out the message. ! call xerprn ( ' * ', -1, messg, 72 ) ! ! IF LKNTRL is positive, write the error number and request a ! traceback. ! if ( 0 .lt. lkntrl ) then write ( temp, '(a,i8)' ) ' Error number = ', nerr call xerprn ( ' * ', -1, temp, 72 ) call fdump ( ) end if ! ! IF LKNTRL is not zero, print a blank line and an end of message. ! if ( lkntrl .ne. 0 ) then call xerprn ( ' * ', -1, ' ', 72 ) call xerprn ( ' ***', -1, 'End of message', 72 ) call xerprn ( ' ', 0, ' ', 72 ) end if ! ! If the error is not fatal or the error is recoverable and the ! control flag is set for recovery, then return. ! end if if ( level .le. 0 .or. & ( level .eq. 1 .and. mkntrl .le. 1 ) ) then return end if ! ! The program will be stopped due to an unrecovered error or a ! fatal error. Print the reason for the abort and the error ! summary if the control flag and the maximum error count permit. ! if ( 0 .lt. lkntrl .and. kount .lt. max ( 1, maxmes ) ) then if ( level .eq. 1 ) then call xerprn ( ' ***', -1, 'Job abort due to unrecovered error.', 72 ) else call xerprn ( ' ***', -1, 'Job abort due to fatal error.', 72 ) end if call xersve ( ' ', ' ', ' ', -1, 0, 0, kdummy ) call xerhlt ( ' ' ) else call xerhlt ( messg ) end if return end subroutine xerprn ( prefix, npref, messg, nwrap ) !*****************************************************************************80 ! !! XERPRN prints error messages processed by XERMSG. ! ! Description: ! ! Discussion: ! ! This routine is used by the error handling routine XERMSG. A related ! routine, XERPRT, is used by the older error handling routines ! XERROR and XERRWV. ! ! This routine sends one or more lines to each of the (up to five) ! logical units to which error messages are to be sent. This routine ! is called several times by XERMSG, sometimes with a single line to ! print and sometimes with a (potentially very long) message that may ! wrap around into multiple lines. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) PREFIX, a string to be put at the beginning of ! each line before the body of the message. No more than 16 characters ! of PREFIX will be used. ! ! Input, integer NPREF, the number of characters to use from PREFIX. ! If it is negative, the intrinsic function LEN is used to determine ! its length. If it is zero, PREFIX is not used. If it exceeds 16 or if ! LEN(PREFIX) exceeds 16, only the first 16 characters will be ! used. If NPREF is positive and the length of PREFIX is less ! than NPREF, a copy of PREFIX extended with blanks to length ! NPREF will be used. ! ! Input, character ( len = * ) MESSG, the error message. If it is a long ! message, it will be broken into pieces for printing on multiple lines. ! Each line will start with the appropriate prefix and be followed by a piece ! of the message. NWRAP is the number of characters per piece; that is, ! after each NWRAP characters, we break and start a new line. In addition, ! the characters '$$' embedded in MESSG are a sentinel for a new line. ! The counting of characters up to NWRAP starts over for each new line. ! The value of NWRAP typically used by XERMSG is 72 since many ! older error messages in the SLATEC Library are laid out to rely on ! wrap-around every 72 characters. ! ! Input, integer NWRAP, the maximum size piece into which to break MESSG ! for printing on multiple lines. An embedded '$$' ends a line, and the ! count restarts at the following character. If a line break does not occur ! on a blank (it would split a word) that word is moved to the next line. ! Values of NWRAP less than 16 will be treated as 16. Values of NWRAP ! greater than 132 will be treated as 132. The actual line length will ! be NPREF + NWRAP after NPREF has been adjusted to fall between 0 and 16 ! and NWRAP has been adjusted to fall between 16 and 132. ! implicit none character ( len = 148 ) cbuff integer i integer i1mach integer idelta integer iu(5) integer lenmsg integer lpiece integer lpref integer lwrap character ( len = * ) messg integer n character ( len = 2 ), parameter :: newlin = '$$' integer nextc integer npref integer nunit integer nwrap character ( len = * ) prefix call xgetua ( iu, nunit ) ! ! A zero value for a logical unit number means to use the standard ! error message unit instead. I1MACH(4) retrieves the standard ! error message unit. ! n = i1mach(4) do i = 1, nunit if ( iu(i) == 0 ) then iu(i) = n end if end do ! ! LPREF is the length of the prefix. The prefix is placed at the ! beginning of CBUFF, the character buffer, and kept there during ! the rest of this routine. ! if ( npref < 0 ) then lpref = len ( prefix ) else lpref = npref end if lpref = min ( 16, lpref ) if ( lpref /= 0 ) then cbuff(1:lpref) = prefix end if ! ! LWRAP is the maximum number of characters we want to take at one ! time from MESSG to print on one line. ! lwrap = max ( 16, min ( 132, nwrap ) ) ! ! Set LENMSG to the length of MESSG, ignore any trailing blanks. ! lenmsg = len ( messg ) n = lenmsg do i = 1, n if ( messg(lenmsg:lenmsg) /= ' ' ) then exit end if lenmsg = lenmsg - 1 end do ! ! If the message is all blanks, then print one blank line. ! if ( lenmsg == 0 ) then cbuff(lpref+1:lpref+1) = ' ' do i = 1, nunit write ( iu(i), '(a)' ) cbuff(1:lpref+1) end do return end if ! ! Set NEXTC to the position in MESSG where the next substring ! starts. From this position we scan for the new line sentinel. ! When NEXTC exceeds LENMSG, there is no more to print. ! We loop back to label 50 until all pieces have been printed. ! ! We look for the next occurrence of the new line sentinel. The ! INDEX intrinsic function returns zero if there is no occurrence ! or if the length of the first argument is less than the length ! of the second argument. ! ! There are several cases which should be checked for in the ! following order. We are attempting to set LPIECE to the number ! of characters that should be taken from MESSG starting at ! position NEXTC. ! ! * LPIECE == 0 ! The new line sentinel does not occur in the remainder of the ! character string. LPIECE should be set to LWRAP or LENMSG+1-NEXTC, ! whichever is less. ! ! * LPIECE == 1 ! The new line sentinel starts at MESSG(NEXTC:NEXTC). LPIECE is effectively ! zero, and we print nothing to avoid producing unnecessary blank lines. ! This takes care of the situation where the library routine has a message of ! exactly 72 characters followed by a new line sentinel followed by more ! characters. NEXTC should be incremented by 2. ! ! * LWRAP + 1 < LPIECE ! Reduce LPIECE to LWRAP. ! ! * Otherwise ! This last case means 2 <= LPIECE <= LWRAP+1. Reset LPIECE = LPIECE-1. ! Note that this properly handles the end case where LPIECE = LWRAP+1. ! That is, the sentinel falls exactly at the end of a line. ! nextc = 1 do lpiece = index ( messg(nextc:lenmsg), newlin ) ! ! There was no new line sentinel found. ! if ( lpiece == 0 ) then idelta = 0 lpiece = min ( lwrap, lenmsg + 1 - nextc ) if ( lpiece < lenmsg + 1 - nextc ) then do i = lpiece+1, 2, -1 if ( messg(nextc+i-1:nextc+i-1) == ' ' ) then lpiece = i - 1 idelta = 1 exit end if end do end if cbuff(lpref+1:lpref+lpiece) = messg(nextc:nextc+lpiece-1) nextc = nextc + lpiece + idelta ! ! We have a new line sentinel at MESSG(NEXTC:NEXTC+1). ! Don't print a blank line. ! else if ( lpiece == 1 ) then nextc = nextc + 2 cycle ! ! LPIECE should be set down to LWRAP. ! else if ( lwrap + 1 < lpiece ) then idelta = 0 lpiece = lwrap do i = lpiece + 1, 2, -1 if ( messg(nextc+i-1:nextc+i-1) == ' ' ) then lpiece = i - 1 idelta = 1 exit end if end do cbuff(lpref+1:lpref+lpiece) = messg(nextc:nextc+lpiece-1) nextc = nextc + lpiece + idelta ! ! If we arrive here, it means 2 <= LPIECE <= LWRAP+1. ! We should decrement LPIECE by one. ! else lpiece = lpiece - 1 cbuff(lpref+1:lpref+lpiece) = messg(nextc:nextc+lpiece-1) nextc = nextc + lpiece + 2 end if ! ! Print. ! do i = 1, nunit write ( iu(i), '(a)' ) cbuff(1:lpref+lpiece) end do if ( lenmsg < nextc ) then exit end if end do return end subroutine xerprt ( messg, nmessg ) !*****************************************************************************80 ! !! XERPRT prints a message on each file indicated by xgetua. ! ! Discussion: ! ! This routine is used by the error handling routines XERROR and XERRWV. ! A related routine, XERPRN, is used by the more modern error handling ! routines XERMSG. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be printed. ! ! Input, integer NMESSG, the actual number of characters in MESSG. ! implicit none integer ichar integer iunit integer kunit integer last integer lun(5) character ( len = * ) messg integer messg_len integer nmessg integer nunit ! ! Obtain unit numbers and write line to each unit. ! call xgetua ( lun, nunit ) messg_len = len ( messg ) do kunit = 1, nunit iunit = lun(kunit) do ichar = 1, messg_len, 72 last = min ( ichar + 71, messg_len ) if ( iunit == 0 ) then write ( *, '(a)' ) messg(ichar:last) else write ( iunit, '(a)' ) messg(ichar:last) end if end do end do return end subroutine xerror ( messg, nerr, level ) !*****************************************************************************80 ! !! XERROR processes a diagnostic error message. ! ! Discussion: ! ! This routine processes a diagnostic message, in a manner determined ! by the value of LEVEL and the current value of the library error ! control flag KONTRL. ! ! See XSETF for details about KONTRL. ! ! Example: ! ! call xerror ( 'SMOOTH -- NUM was zero.', 1, 2 ) ! ! call xerror ( 'INTEG -- less than full accuracy achieved.', 2, 1 ) ! ! call xerror ( & ! 'ROOTER -- actual zero of f found before interval fully collapsed.', ! 3, 0 ) ! ! call xerror ( 'EXP -- underflows being set to zero.', 1, -1 ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be processed. ! ! Input, integer NERR, the error number associated with this message. ! NERR must not be zero. ! ! Input, integer LEVEL, the error category. ! * 2, this is an unconditionally fatal error. ! * 1, this is a recoverable error. It is normally non-fatal, unless ! KONTRL has been reset by XSETF. ! * 0, this is a warning message only. ! *-1, this is a warning message which is to be printed at most once, ! regardless of how many times this call is executed. ! implicit none integer i1 integer i2 integer level character ( len = * ) messg integer nerr integer ni integer nmessg integer nr real ( kind = 8 ) r1 real ( kind = 8 ) r2 nmessg = len ( messg ) ni = 0 i1 = 0 i2 = 0 nr = 0 r1 = 0.0D+00 r2 = 0.0D+00 call xerrwv ( messg, nmessg, nerr, level, ni, i1, i2, nr, r1, r2 ) return end subroutine xerrwv ( messg, nmessg, nerr, level, ni, i1, i2, nr, r1, r2 ) !*****************************************************************************80 ! !! XERRWV processes an error message that includes numeric information. ! ! Discussion: ! ! This routine processes a diagnostic message, in a manner determined ! by the value of LEVEL and the current value of the library error ! control flag KONTRL. ! ! See XSETF for details about KONTRL. ! ! In addition, up to two integer values and two real values may be ! printed along with the message. ! ! Example: ! ! call xerrwv ( 'SMOOTH -- NUM (=I1) was zero.', 29, 1, 2, 1, num, ! 0, 0, 0.0, 0.0 ) ! ! call xerrwv ( & ! 'QUADXY -- Requested error (R1) less than minimum(R2).', & ! 54, 77, 1, 0, 0, 0, 2, errreq, errmin ) ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, the message to be processed. ! ! Input, integer NMESSG, the number of characters in MESSG. ! ! Input, integer NERR, the error number associated with this message. ! NERR must not be zero. ! ! Input, integer LEVEL, the error category. ! * 2, this is an unconditionally fatal error. ! * 1, this is a recoverable error. It is normally non-fatal, unless ! KONTRL has been reset by XSETF. ! * 0, this is a warning message only. ! *-1, this is a warning message which is to be printed at most once, ! regardless of how many times this call is executed. ! ! Input, integer NI, the number of integer values to be printed. (0 to 2) ! ! Input, integer I1, I2, the first and second integer values. ! ! Input, integer NR, the number of real values to be printed. (0 to 2) ! ! Input, real ( kind = 8 ) R1, R2, the first and second real values. ! implicit none character ( len = 37 ) form integer i integer i1 integer i1mach integer i2 integer ifatal integer isizei integer isizef integer iunit integer j4save integer junk integer kdummy integer kount integer kunit integer lerr integer level integer lkntrl integer llevel integer lmessg integer lun(5) integer maxmes character ( len = * ) messg integer mkntrl integer nerr integer ni integer nmessg integer nr integer nunit real ( kind = 8 ) r1 real ( kind = 8 ) r2 logical set integer value integer which ! ! Get flags ! which = 2 value = 0 set = .false. lkntrl = j4save ( which, value, set ) which = 4 value = 0 set = .false. maxmes = j4save ( which, value, set ) ! ! Check for valid input ! if ( nmessg <= 0 .or. & nerr == 0 .or. & level < -1 .or. & 2 < level ) then if ( 0 < lkntrl ) then call xerprt ( 'Fatal error in...', 17 ) end if call xerprt( 'XERROR -- Invalid input', 23 ) if ( 0 < lkntrl ) then call xerprt ( 'Job abort due to fatal error.', 29 ) end if if ( 0 < lkntrl ) then call xersav ( ' ', 0, 0, 0, kdummy ) end if call xerabt ( 'XERROR -- invalid input', 23 ) return end if ! ! Record the message. ! which = 1 value = nerr set = .true. junk = j4save ( which, value, set ) if ( junk == 1952 ) then write ( *, '(a)' ) 'This is a dummy message!' end if call xersav ( messg, nmessg, nerr, level, kount ) ! ! Let the user override. ! lmessg = nmessg lerr = nerr llevel = level call xerctl ( messg, lmessg, lerr, llevel, lkntrl ) ! ! Reset to original values. ! lmessg = nmessg lerr = nerr llevel = level lkntrl = max ( -2, min ( 2, lkntrl ) ) mkntrl = abs ( lkntrl ) ! ! Decide whether to print message ! if ( llevel < 2 .and. lkntrl == 0 ) then go to 100 end if if ( ( llevel == -1 .and. min ( 1, maxmes ) < kount ) .or. & ( llevel == 0 .and. maxmes < kount ) .or. & ( llevel == 1 .and. maxmes < kount .and. mkntrl == 1 ) .or. & ( llevel == 2 .and. max ( 1, maxmes ) < kount ) ) then go to 100 end if if ( 0 < lkntrl ) then call xerprt ( ' ', 1 ) if ( llevel == -1 ) then call xerprt & ( 'Warning message...this message will only be printed once.',57) else if ( llevel == 0 ) then call xerprt ( 'Warning in...', 13 ) else if ( llevel == 1 ) then call xerprt ( 'Recoverable error in...', 23 ) else if ( llevel == 2 ) then call xerprt ( 'Fatal error in...', 17 ) end if end if ! ! Message. ! call xerprt ( messg, lmessg ) call xgetua(lun,nunit) isizei = 1 + int ( log10 ( real ( i1mach(9), kind = 8 ) ) ) isizef = 1 + int ( log10 ( real ( i1mach(10), kind = 8 )**i1mach(14) ) ) do kunit = 1, nunit iunit = lun(kunit) do i = 1, min ( ni, 2 ) write (form,21) i,isizei 21 format ('(11x,21hin above message, i',i1,'=,i',i2,') ') if ( iunit == 0 ) then if ( i == 1 ) write (*,form) i1 if ( i == 2 ) write (*,form) i2 else if ( i == 1 ) write (iunit,form) i1 if ( i == 2 ) write (iunit,form) i2 end if end do do i = 1, min ( nr, 2 ) write (form,23) i,isizef+10,isizef 23 format ('(11x,21hin above message, r',i1,'=,e',i2,'.',i2,')') if ( iunit == 0 ) then if ( i == 1 ) write (*,form) r1 if ( i == 2 ) write (*,form) r2 else if ( i == 1 ) write (iunit,form) r1 if ( i == 2 ) write (iunit,form) r2 end if end do ! ! Print the error number. ! if ( 0 < lkntrl ) then if ( iunit == 0 ) then write ( *, '(a,i10)' ) ' Error number = ', lerr else write ( iunit, '(a,i10)' ) ' Error number = ', lerr end if end if end do ! ! Traceback ! if ( 0 < lkntrl ) then call fdump ( ) end if 100 continue if ( llevel == 2 .or. ( llevel == 1 .and. mkntrl ==2 ) ) then ifatal = 1 else ifatal = 0 end if ! ! Quit here if message is not fatal. ! if ( ifatal <= 0 ) then return end if ! ! Print reason for abort and error summary. ! if ( 0 < lkntrl .and. kount <= max ( 1, maxmes ) ) then if ( llevel == 1 ) then call xerprt ( 'Job abort due to unrecovered error.', 35 ) end if if ( llevel == 2 ) then call xerprt ( 'Job abort due to fatal error.', 29 ) end if call xersav ( ' ', -1, 0, 0, kdummy ) end if ! ! Abort ! if ( llevel == 2 .and. max ( 1, maxmes ) < kount ) then lmessg = 0 end if call xerabt ( messg, lmessg ) return end subroutine xersav ( messg, nmessg, nerr, level, count ) !*****************************************************************************80 ! !! XERSAV records that an error occurred. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character ( len = * ) MESSG, as in XERROR. ! ! Input, integer NMESSG, as in XERROR, except that, when NMESSG = 0, ! the tables will be dumped and cleared; and when NMESSG < 0, ! the tables will be dumped, but not cleared. ! ! Input, integer NERR, the error number. NERR should not be 0. ! ! Input, integer LEVEL, the error severity level. ! * 2, this is an unconditionally fatal error. ! * 1, this is a recoverable error. It is normally non-fatal, unless ! KONTRL has been reset by XSETF. ! * 0, this is a warning message only. ! *-1, this is a warning message which is to be printed at most once, ! regardless of how many times this call is executed. ! ! Output, integer COUNT, the number of times this message has ! been seen, or zero if the table has overflowed and does not contain ! this message specifically. ! When NMESSG = 0, COUNT will not be altered. ! implicit none integer count integer i integer i1mach integer ii integer iunit integer, save, dimension ( 10 ) :: kount = (/ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) integer, save :: kountx = 0 integer kunit integer level integer, save, dimension ( 10 ) :: levtab = (/ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) integer lun(5) character ( len = 20 ) mes character ( len = * ) messg character ( len = 20 ), save, dimension ( 10 ) :: mestab integer nerr integer, save, dimension ( 10 ) :: nertab = (/ & 0, 0, 0, 0, 0, 0, 0, 0, 0, 0 /) integer nmessg integer nunit ! ! Dump the table ! if ( nmessg <= 0 ) then if ( kount(1) == 0 ) then return end if ! ! Print to each unit ! call xgetua ( lun, nunit ) do kunit = 1, nunit iunit = lun(kunit) if ( iunit == 0 ) then iunit = i1mach(4) end if ! ! Print table header ! write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) & ' Error message summary' write ( iunit, '(a)' ) & 'Message start NERR Level Count' ! ! Print body of table. ! do i = 1, 10 if ( kount(i) == 0 ) then exit end if write ( iunit, '(a20,3i10)' ) & mestab(i), nertab(i), levtab(i), kount(i) end do ! ! Print number of other errors. ! if ( kountx /= 0 ) then write ( iunit, '(a)' ) ' ' write ( iunit, '(a,i10)' ) & 'Other errors not individually tabulated = ', kountx end if write ( iunit, '(a)' ) ' ' end do if ( nmessg < 0 ) then return end if ! ! Clear the error tables. ! kount(1:10) = 0 kountx = 0 ! ! Process a message. ! ! Search for this message, or else an empty slot for this message, ! or else determine that the error table is full. ! else mes(1:20) = messg(1:20) do i = 1, 10 ii = i ! ! An empty slot was found for the new message. ! if ( kount(i) == 0 ) then mestab(ii) = mes nertab(ii) = nerr levtab(ii) = level kount(ii) = 1 count = 1 return end if ! ! Message found in table. ! if ( mes == mestab(i) .and. & nerr == nertab(i) .and. & level == levtab(i) ) then kount(ii) = kount(ii) + 1 count = kount(ii) return end if end do ! ! The table is full. ! kountx = kountx + 1 count = 1 end if return end subroutine xersve ( librar, subrou, messg, kflag, nerr, level, icount ) !*****************************************************************************80 ! !! XERSVE records that an error has occurred. ! ! Discussion: ! ! This routine is used by the error handling routines associated ! with XERMSG. It is a revised version of the routine XERSAV, which ! was used with the older pair of error handling routines XERROR ! and XERRWV. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, character (len = * ) LIBRAR, the name of the library or software ! package from which the error message comes. ! ! Input, character (len = * ) SUBROU, the name of the subroutine or function ! from which the error message comes. ! ! Input, character (len = * ) MESSG, the error message. ! ! Input, integer KFLAG, indicates the action to be performed. ! 0 < KFLAG, the message in MESSG is saved. ! KFLAG=0 the tables will be dumped and cleared. ! KFLAG < 0, the tables will be dumped and not cleared. ! ! Input, integer NERR, the error number. ! ! Input, integer LEVEL, the error severity. ! ! Output, integer ICOUNT, the number of times this message has been seen, ! or zero if the table has overflowed and does not contain this message ! specifically. When KFLAG=0, ICOUNT will not be altered from its ! input value. ! implicit none integer, parameter :: lentab = 10 integer i integer i1mach integer icount integer iunit integer kflag integer, save, dimension ( lentab ) :: kount integer, save :: kountx = 0 integer kunit integer level integer, save, dimension ( lentab ) :: levtab character ( len = 8 ) lib character (len = * ) librar character ( len = 8 ), save, dimension ( lentab ) :: libtab integer lun(5) character ( len = 20 ) mes character (len = * ) messg character ( len = 20 ), save, dimension ( lentab ) :: mestab integer nerr integer, save, dimension ( lentab ) :: nertab integer, save :: nmsg = 0 integer nunit character ( len = 8 ) sub character (len = * ) subrou character ( len = 8 ), save, dimension ( lentab ) :: subtab if ( kflag <= 0 ) then ! ! Dump the table. ! if ( nmsg == 0 ) then return end if ! ! Print to each unit. ! call xgetua ( lun, nunit ) do kunit = 1, nunit iunit = lun(kunit) if ( iunit == 0 ) then iunit = i1mach(4) end if ! ! Print the table header. ! write ( iunit, '(a)' ) ' ' write ( iunit, '(a)' ) ' Error message summary' write ( iunit, '(a,a)' ) & 'Library Subroutine Message start NERR', & ' Level Count' ! ! Print body of table. ! do i = 1, nmsg write ( iunit, '(a,3x,a,3x,a,3i10)' ) & libtab(i), subtab(i), mestab(i), nertab(i), levtab(i), kount(i) end do ! ! Print the number of other errors. ! if ( kountx /= 0 ) then write ( iunit, '(a)' ) ' ' write ( iunit, '(a,i10)' ) & 'Other errors not individually tabulated = ', kountx end if write ( iunit, '(1x)' ) end do ! ! Clear the error tables. ! if ( kflag == 0 ) then nmsg = 0 kountx = 0 end if else ! ! Process a message. ! ! Search for this message, or else an empty slot for this message, ! or else determine that the error table is full. ! lib = librar sub = subrou mes = messg do i = 1, nmsg if ( & lib == libtab(i) .and. & sub == subtab(i) .and. & mes == mestab(i) .and. & nerr == nertab(i) .and. & level == levtab(i) ) then kount(i) = kount(i) + 1 icount = kount(i) return end if end do ! ! Empty slot found for new message. ! if ( nmsg < lentab ) then nmsg = nmsg + 1 libtab(i) = lib subtab(i) = sub mestab(i) = mes nertab(i) = nerr levtab(i) = level kount(i) = 1 icount = 1 ! ! Table is full. ! else kountx = kountx + 1 icount = 0 end if end if return end subroutine xgetf ( kontrl ) !*****************************************************************************80 ! !! XGETF returns current value of error control flag. ! ! Discussion: ! ! This routine returns the current value of KONTRL, the error ! control flag. ! ! The amount of output printed for a given error is determined ! by LEVEL, the level of severity, and KONTRL, which controls ! how much output the user wants to see. ! ! The following table shows how each message is treated, ! depending on the values of KONTRL and LEVEL. ! ! If KONTRL is zero or negative, no information other than the ! message itself (including numeric values, if any) will be ! printed. If KONTRL is positive, introductory messages, ! trace-backs, and so on, will be printed in addition to the message. ! ! KONTRL 0 -1/+1 -2/+2 ! LEVEL ! 2 fatal fatal fatal ! 1 not printed printed fatal ! 0 not printed printed printed ! -1 not printed printed once printed once ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, integer KONTRL, the current value of the error control flag. ! implicit none integer j4save integer kontrl logical set integer value integer which which = 2 value = 0 set = .false. kontrl = j4save ( which, value, set ) return end subroutine xgetua ( iunit, nunit ) !*****************************************************************************80 ! !! XGETUA returns the unit numbers to which error messages are being sent. ! ! Discussion: ! ! These unit numbers may have been set by a call to XSETUN, ! or a call to XSETUA, or may be default values. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, integer IUNIT(5), an array into which the routine will ! store the values of the NUNIT units to which the error messages ! are being sent. The value of NUNIT is never more than 5, so ! using an array of dimension 5 will be sufficient. ! ! Output, integer NUNIT, the number of units to which the ! error messages are being sent. NUNIT will be in the ! range from 1 to 5. ! implicit none integer i integer iunit(5) integer j4save integer nunit logical set integer value integer which which = 5 value = 0 set = .false. nunit = j4save ( which, value, set) if ( nunit < 1 ) then return end if which = 3 value = 0 set = .false. iunit(1) = j4save ( which, value, set ) do i = 2, nunit which = i + 4 value = 0 set = .false. iunit(i) = j4save ( which, value, set ) end do return end subroutine xgetun ( iunit ) !*****************************************************************************80 ! !! XGETUN returns the (first) output file to which messages are being sent. ! ! Discussion: ! ! This routine returns the unit number associated with the first or ! main file to which error messages are being sent. ! ! To find out if more than one file is being used for error output, ! one must use the XGETUA routine. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Output, integer IUNIT, the logical unit number of the first unit ! to which error messages are being sent. ! implicit none integer iunit integer j4save logical set integer value integer which which = 3 value = 0 set = .false. iunit = j4save ( which, value, set ) return end subroutine xsetf ( kontrl ) !*****************************************************************************80 ! !! XSETF sets the error control flag. ! ! Discussion: ! ! This routine sets the error control flag value to KONTRL. ! ! The following table shows how each message is treated, ! depending on the values of KONTRL and LEVEL. See XERROR ! for description of LEVEL. ! ! If KONTRL is zero or negative, no information other than the ! message itself (including numeric values, if any) will be ! printed. If KONTRL is positive, introductory messages, ! trace-backs, and so on, will be printed in addition to the message. ! ! KONTRL 0 -1/+1 -2/+2 ! LEVEL ! 2 fatal fatal fatal ! 1 not printed printed fatal ! 0 not printed printed printed ! -1 not printed printed once printed once ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer KONTRL, the desired value of the error control flag. ! implicit none integer j4save integer junk integer kontrl integer level integer nerr logical set integer value integer which character ( len = 8 ) xern1 if ( kontrl < -2 .or. 2 < kontrl ) then write ( xern1, '(i8)' ) kontrl nerr = 1 level = 2 call xermsg ( 'XERROR', 'XSETF', & 'Invalid value of KONTRL = ' // xern1, nerr, level ) return end if which = 2 value = kontrl set = .true. junk = j4save ( which, value, set ) if ( junk == 1952 ) then write ( *, '(a)' ) 'This is a dummy message!' end if return end subroutine xsetua ( iunita, nunit ) !*****************************************************************************80 ! !! XSETUA sets up to 5 unit numbers to which messages are to be sent. ! ! Discussion: ! ! This routine may be called to declare a list of up to five ! logical units, each of which is to receive a copy of ! each error message processed by this package. ! ! The existence of multiple error output units makes it possible for ! the user to ensure simultaneous printing of each error message to, ! say, a main output file, an interactive terminal, and other files ! such as graphics communication files. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer IUNIT(NUNIT), unit numbers to which the error messages ! should be printed. Normally these numbers should all be different ! but duplicates are not prohibited. ! ! Input, integer NUNIT, the number of unit numbers provided in IUNIT. ! 1 <= N <= 5. ! implicit none integer nunit integer i integer iunita(nunit) integer j4save integer junk integer level integer nerr logical set integer value integer which character ( len = 8 ) xern1 if ( nunit < 1 .or. 5 < nunit ) then write ( xern1, '(i8)' ) nunit nerr = 1 level = 2 call xermsg ( 'XERROR', 'XSETUA', & 'Invalid number of units, NUNIT = ' // xern1, nerr, level ) return end if ! ! Set the main error output unit. ! which = 3 value = iunita(1) set = .true. junk = j4save ( which, value, set ) if ( junk == 1952 ) then write ( *, '(a)' ) 'This is a dummy message!' end if ! ! If 1 < NUNIT, set auxilliary output units. ! do i = 2, nunit which = i + 4 value = iunita(i) set = .true. junk = j4save ( which, value, set ) end do which = 5 value = nunit set = .true. junk = j4save ( which, value, set ) return end subroutine xsetun ( iunit ) !*****************************************************************************80 ! !! XSETUN sets the output file to which error messages are to be sent. ! ! Discussion: ! ! This routine sets the unit number associated with the main error ! output file. If auxilliary error output units were defined, ! this routine suppresses them, as well. ! ! Note that this error package initializes this unit number to the standard ! output file, a reasonable choice. ! ! Common choices for the unit number to be associated with the main ! error output file might be 1, 6 or 9. FORTRAN generally requires ! that such unit numbers be between 1 and 99. Depending on the ! compiler, units -1 or 0 might also be legal choices. It may ! be the case that some unit numbers cannot be chosen, because ! they are reserved by the compiler for other purposes. In ! particular, some compilers reserve unit 5 for input. ! ! Copies of the error output may also be sent to up to four auxilliary ! units, which can be defined by calling XSETUA. ! ! Licensing: ! ! This code is distributed under the MIT license. ! ! Modified: ! ! 22 October 2024 ! ! Author: ! ! Original Fortran77 version by Janet Donaldson. ! This version by John Burkardt. ! ! Reference: ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Technical Report SAND82-0800, ! Sandia National Laboratories, 1982. ! ! Ron Jones, David Kahaner, ! XERROR, The SLATEC Error Handling Package, ! Software: Practice and Experience, ! Volume 13, Number 3, 1983, pages 251-257. ! ! David Kahaner, Cleve Moler, Steven Nash, ! Numerical Methods and Software, ! Prentice Hall, 1989, ! ISBN: 0-13-627258-4, ! LC: TA345.K34. ! ! Parameters: ! ! Input, integer IUNIT, the logical unit number to which error ! messages are to be sent. ! implicit none integer iunit integer j4save integer junk integer nunit logical set integer value integer which ! ! Set the main error output unit. ! which = 3 value = iunit set = .true. junk = j4save ( which, value, set ) if ( junk == 1952 ) then write ( *, '(a)' ) 'This is a dummy message!' end if ! ! Suppress all the other error output units. ! nunit = 1 which = 5 value = nunit set = .true. junk = j4save ( which, value, set ) return end