! G13DKF Example Program Text ! Mark 23 Release. NAG Copyright 2011. MODULE g13dkfe_mod ! G13DKF Example Program Module: ! Parameters and User-defined Routines ! .. Use Statements .. USE nag_library, ONLY : nag_wp ! .. Implicit None Statement .. IMPLICIT NONE ! .. Parameters .. INTEGER, PARAMETER :: iset = 1, nin = 5, nout = 6 CONTAINS SUBROUTINE fprint(k,nm,lmax,predz,sefz,ldsefz,nout) ! .. Implicit None Statement .. IMPLICIT NONE ! .. Scalar Arguments .. INTEGER, INTENT (IN) :: k, ldsefz, lmax, nm, nout ! .. Array Arguments .. REAL (KIND=nag_wp), INTENT (IN) :: predz(ldsefz,lmax), & sefz(ldsefz,lmax) ! .. Local Scalars .. INTEGER :: i, i2, j, l, l2, loop ! .. Intrinsic Functions .. INTRINSIC min, mod ! .. Executable Statements .. WRITE (nout,*) WRITE (nout,*) ' FORECAST SUMMARY TABLE' WRITE (nout,*) ' ----------------------' WRITE (nout,*) WRITE (nout,99999) ' Forecast origin is set at t = ', nm WRITE (nout,*) loop = lmax/5 IF (mod(lmax,5)/=0) loop = loop + 1 DO j = 1, loop i2 = (j-1)*5 l2 = min(i2+5,lmax) WRITE (nout,99998) 'Lead Time ', (i,i=i2+1,l2) WRITE (nout,*) i = 1 WRITE (nout,99997) 'Series ', i, ' : Forecast ', & (predz(1,l),l=i2+1,l2) WRITE (nout,99996) ' : Standard Error ', (sefz(1,l),l=i2+1,l2) DO i = 2, k WRITE (nout,99997) 'Series ', i, ' : Forecast ', & (predz(i,l),l=i2+1,l2) WRITE (nout,99996) ' : Standard Error ', (sefz(i,l),l=i2+1,l2) END DO WRITE (nout,*) END DO RETURN 99999 FORMAT (1X,A,I4) 99998 FORMAT (1X,A,12X,5I10) 99997 FORMAT (1X,A,I2,A,5F10.2) 99996 FORMAT (10X,A,4(F7.2,3X),F7.2) END SUBROUTINE fprint END MODULE g13dkfe_mod PROGRAM g13dkfe ! G13DKF Example Main Program ! .. Use Statements .. USE nag_library, ONLY : g13ddf, g13djf, g13dkf, g13dlf, nag_wp, x04abf USE g13dkfe_mod, ONLY : fprint, iset, nin, nout ! .. Implicit None Statement .. IMPLICIT NONE ! .. Local Scalars .. REAL (KIND=nag_wp) :: cgetol, rlogl INTEGER :: d, i, ifail, ip, iprint, iq, & ishow, k, kmax, ldcm, liwork, & lmax, lpar, lref, lwork, m, & maxcal, mlast, n, nadv, nd, & niter, r, tddelta, tdv LOGICAL :: exact, meanl CHARACTER (1) :: mean ! .. Local Arrays .. REAL (KIND=nag_wp), ALLOCATABLE :: cm(:,:), delta(:,:), g(:), & par(:), predz(:,:), qq(:,:), & ref(:), sefz(:,:), v(:,:), & w(:,:), work(:), workl(:), z(:,:) INTEGER, ALLOCATABLE :: id(:), iwork(:) LOGICAL, ALLOCATABLE :: parhld(:) CHARACTER (1), ALLOCATABLE :: tr(:) ! .. Intrinsic Functions .. INTRINSIC max, maxval ! .. Executable Statements .. WRITE (nout,*) 'G13DKF Example Program Results' WRITE (nout,*) ! Skip heading in data file READ (nin,*) ! Read in the problem size READ (nin,*) k, n ALLOCATE (id(k)) ! Read in differencing READ (nin,*) id(1:k) d = maxval(id(1:k)) tddelta = max(d,1) nd = n - d kmax = k ALLOCATE (z(kmax,n),tr(k),delta(kmax,tddelta),w(kmax,nd),workl(k*n)) ! Read in series and the transformation flag READ (nin,*) (z(i,1:n),i=1,k) READ (nin,*) tr(1:k) ! If required, read in delta IF (d>0) THEN READ (nin,*) (delta(i,1:id(i)),i=1,k) END IF ! Difference and / or transform series ifail = 0 CALL g13dlf(k,n,z,kmax,tr,id,delta,w,nd,workl,ifail) ! Read in information on the VARMA READ (nin,*) ip, iq, mean, lmax ! Calculate number of parameters for the VARMA lpar = (ip+iq)*k*k IF (mean=='M' .OR. mean=='m') THEN lpar = lpar + k meanl = .TRUE. ELSE meanl = .FALSE. END IF ! Read in control parameters READ (nin,*) iprint, cgetol, maxcal, ishow ! Read in exact likelihood flag READ (nin,*) exact ldcm = lpar tdv = nd ALLOCATE (par(lpar),parhld(lpar),qq(kmax,k),v(kmax,tdv),g(lpar), & cm(ldcm,lpar)) ! Read in initial parameter estimates and free parameter flags READ (nin,*) par(1:lpar) READ (nin,*) parhld(1:lpar) ! Read in initial values for covariance matrix Q READ (nin,*) (qq(i,1:i),i=1,k) ! Set the advisory channel to NOUT for monitoring information IF (iprint>=0 .OR. ishow/=0) THEN nadv = nout CALL x04abf(iset,nadv) END IF ! Fit a VARMA model ifail = -1 CALL g13ddf(k,nd,ip,iq,meanl,par,lpar,qq,kmax,w,parhld,exact,iprint, & cgetol,maxcal,ishow,niter,rlogl,v,g,cm,ldcm,ifail) IF (ifail/=0) THEN IF (ifail<4) THEN GO TO 20 END IF END IF lref = (lmax-1)*k*k + 2*k*lmax + k r = max(ip,iq) lwork = max(k*r*(k*r+2),(ip+d+2)*k**2+(n+lmax)*k) liwork = k*max(ip,iq) ALLOCATE (predz(kmax,lmax),sefz(kmax,lmax),ref(lref),work(lwork), & iwork(liwork)) ! Forecast from VARMA ifail = 0 CALL g13djf(k,n,z,kmax,tr,id,delta,ip,iq,mean,par,lpar,qq,v,lmax,predz, & sefz,ref,lref,work,lwork,iwork,liwork,ifail) ! Display results CALL fprint(k,n,lmax,predz,sefz,kmax,nout) ! Update forecasts mlast = 0 D_LP: DO READ (nin,*,IOSTAT=ifail) m IF (ifail/=0) THEN EXIT D_LP END IF READ (nin,*,IOSTAT=ifail) (z(1:k,i),i=1,m) IF (ifail/=0) THEN EXIT D_LP END IF ! Reallocate V if required IF (tdv