NAG Library Manual, Mark 30.1
Interfaces:  FL   CL   CPP   AD 

NAG FL Interface Introduction
Example description
!   G13DKF Example Program Text
!   Mark 30.1 Release. NAG Copyright 2024.

    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
!     .. Accessibility Statements ..
      Private
      Public                           :: fprint
!     .. Parameters ..
      Integer, Parameter, Public       :: iset = 1, nin = 5, nout = 6
    Contains
      Subroutine fprint(k,nm,lmax,predz,sefz,ldsefz,nout)

!       .. 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 Procedures ..
        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) Then
          loop = loop + 1
        End If
        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 g13dkfe_mod, Only: fprint, iset, nin, nout
      Use nag_library, Only: g13ddf, g13djf, g13dkf, g13dlf, nag_wp, x04abf
!     .. 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 Procedures ..
      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 100
        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<m) Then
          Deallocate (v)
          Allocate (v(kmax,m))
        End If

!       Reallocate WORK if required
        If (lwork<k*m) Then
          Deallocate (work)
          Allocate (work(lwork))
        End If

!       Update forecast
        ifail = 0
        Call g13dkf(k,lmax,m,mlast,z,kmax,ref,lref,v,predz,sefz,work,ifail)

        Call fprint(k,n+mlast,lmax,predz,sefz,kmax,nout)
      End Do d_lp

100   Continue

    End Program g13dkfe