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

NAG FL Interface Introduction
Example description
    Program g05xcfe

!     G05XCF Example Program Text

!     Mark 30.0 Release. NAG Copyright 2024.

!     .. Use Statements ..
      Use nag_library, Only: g05xaf, g05xbf, g05xcf, g05xdf, g05xef, nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nout = 6
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: t0, tend
      Integer                          :: a, bgord, d, ifail, ldb, ldc, ldz,   &
                                          nmove, npaths, ntimes, rcord
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: bb(:,:), bd(:,:), c(:,:), diff(:),   &
                                          intime(:), rcommb(:), rcommd(:),     &
                                          start(:), term(:), times(:),         &
                                          zb(:,:), zd(:,:)
      Integer, Allocatable             :: move(:)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: size
!     .. Executable Statements ..
!     Get information required to set up the bridge
      Call get_bridge_init_data(bgord,t0,tend,ntimes,intime,nmove,move)

!     Make the bridge construction bgord
      Allocate (times(ntimes))
      ifail = 0
      Call g05xef(bgord,t0,tend,ntimes,intime,nmove,move,times,ifail)

!     Initialize the Brownian bridge generator
      Allocate (rcommb(12*(ntimes+1)),rcommd(12*(ntimes+1)))
      ifail = 0
      Call g05xaf(t0,tend,times,ntimes,rcommb,ifail)
      ifail = 0
      Call g05xcf(t0,tend,times,ntimes,rcommd,ifail)

!     Get additional information required by the bridge generator
      Call get_bridge_gen_data(npaths,rcord,d,start,a,term,c)
      Allocate (diff(d))
      diff(:) = term(:) - start(:)

      Call allocate_arrays(rcord,npaths,d,a,ntimes,zb,bb,zd,bd)

!     Generate the Z values
      Call get_z(rcord,npaths,d*(ntimes+1-a),zb)
      zd(:,:) = zb(:,:)

!     Leading dimensions for the various input arrays
      ldz = size(zb,1)
      ldc = size(c,1)
      ldb = size(bb,1)

!     Call the Brownian bridge generator routine
      ifail = 0
      Call g05xbf(npaths,rcord,d,start,a,term,zb,ldz,c,ldc,bb,ldb,rcommb,      &
        ifail)
      ifail = 0
      Call g05xdf(npaths,rcord,d,a,diff,zd,ldz,c,ldc,bd,ldb,rcommd,ifail)

!     Display the results
      Call display_results(rcord,t0,tend,ntimes,intime,d,start,bb,bd)

    Contains
      Subroutine get_bridge_init_data(bgord,t0,tend,ntimes,intime,nmove,move)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: t0, tend
        Integer, Intent (Out)          :: bgord, nmove, ntimes
!       .. Array Arguments ..
        Real (Kind=nag_wp), Allocatable, Intent (Out) :: intime(:)
        Integer, Allocatable, Intent (Out) :: move(:)
!       .. Local Scalars ..
        Integer                        :: i
!       .. Intrinsic Procedures ..
        Intrinsic                      :: real
!       .. Executable Statements ..
!       Set the basic parameters for a Wiener process
        ntimes = 10
        t0 = 0.0_nag_wp
        Allocate (intime(ntimes))

!       We want to generate the Wiener process at these time points
        Do i = 1, ntimes
          intime(i) = t0 + real(i,kind=nag_wp)
        End Do
        tend = t0 + real(ntimes+1,kind=nag_wp)

        nmove = 0
        Allocate (move(nmove))
        bgord = 3
      End Subroutine get_bridge_init_data

      Subroutine get_bridge_gen_data(npaths,rcord,d,start,a,term,c)

!       .. Use Statements ..
        Use nag_library, Only: dpotrf
!       .. Scalar Arguments ..
        Integer, Intent (Out)          :: a, d, npaths, rcord
!       .. Array Arguments ..
        Real (Kind=nag_wp), Allocatable, Intent (Out) :: c(:,:), start(:),     &
                                          term(:)
!       .. Local Scalars ..
        Integer                        :: info
!       .. Executable Statements ..
!       Set the basic parameters for a free Wiener process
        npaths = 2
        rcord = 2
        d = 2
        a = 0

        Allocate (start(d),term(d),c(d,d))

        start(1:d) = (/0.0_nag_wp,2.0_nag_wp/)
        term(1:d) = (/1.0_nag_wp,0.0_nag_wp/)

!       We want the following covariance matrix
        c(:,1) = (/6.0_nag_wp,-1.0_nag_wp/)
        c(:,2) = (/-1.0_nag_wp,5.0_nag_wp/)

!       G05XBF works with the Cholesky factorization of the covariance matrix
!       C so perform the decomposition
        Call dpotrf('Lower',d,c,d,info)
        If (info/=0) Then
          Write (nout,*)                                                       &
            'Specified covariance matrix is not positive definite: info=',     &
            info
          Stop
        End If
      End Subroutine get_bridge_gen_data

      Subroutine allocate_arrays(rcord,npaths,d,a,ntimes,zb,bb,zd,bd)

!       .. Scalar Arguments ..
        Integer, Intent (In)           :: a, d, npaths, ntimes, rcord
!       .. Array Arguments ..
        Real (Kind=nag_wp), Allocatable, Intent (Out) :: bb(:,:), bd(:,:),     &
                                          zb(:,:), zd(:,:)
!       .. Local Scalars ..
        Integer                        :: idim
!       .. Executable Statements ..
        idim = d*(ntimes+1-a)

        If (rcord==1) Then
          Allocate (zb(idim,npaths),zd(idim,npaths))
          Allocate (bb(d*(ntimes+1),npaths),bd(d*(ntimes+1),npaths))
        Else
          Allocate (zb(npaths,idim),zd(npaths,idim))
          Allocate (bb(npaths,d*(ntimes+1)),bd(npaths,d*(ntimes+1)))
        End If

      End Subroutine allocate_arrays

      Subroutine get_z(rcord,npaths,idim,z)

!       .. Use Statements ..
        Use nag_library, Only: g05skf
!       .. Scalar Arguments ..
        Integer, Intent (In)           :: idim, npaths, rcord
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (Out) :: z(npaths*idim)
!       .. Local Scalars ..
        Integer                        :: ifail
!       .. Local Arrays ..
        Real (Kind=nag_wp), Allocatable :: ztmp(:,:), ztmp2(:,:)
        Integer                        :: seed(1)
        Integer, Allocatable           :: state(:)
!       .. Intrinsic Procedures ..
        Intrinsic                      :: reshape, transpose
!       .. Executable Statements ..
!       We now need to generate the input pseudorandom points
!       First initialize the base pseudorandom number generator
        seed(1) = 1023401
        Call initialize_prng(6,0,seed,size(seed),state)

!       Generate the pseudorandom points from N(0,1)
        ifail = 0
        Call g05skf(idim*npaths,0.0_nag_wp,1.0_nag_wp,state,z,ifail)
        If (rcord==1) Then
          Allocate (ztmp(npaths,idim),ztmp2(idim,npaths))
          ztmp(1:npaths,1:idim) = reshape(z,(/npaths,idim/))
          ztmp2(1:idim,1:npaths) = transpose(ztmp)
          z(1:npaths*idim) = reshape(ztmp2,(/npaths*idim/))
        End If
      End Subroutine get_z

      Subroutine initialize_prng(genid,subid,seed,lseed,state)

!       .. Use Statements ..
        Use nag_library, Only: g05kff
!       .. Scalar Arguments ..
        Integer, Intent (In)           :: genid, lseed, subid
!       .. Array Arguments ..
        Integer, Intent (In)           :: seed(lseed)
        Integer, Allocatable, Intent (Out) :: state(:)
!       .. Local Scalars ..
        Integer                        :: ifail, lstate
!       .. Executable Statements ..
!       Initial call to initializer to get size of STATE array
        lstate = 0
        Allocate (state(lstate))
        ifail = 0
        Call g05kff(genid,subid,seed,lseed,state,lstate,ifail)

!       Reallocate STATE
        Deallocate (state)
        Allocate (state(lstate))

!       Initialize the generator to a repeatable sequence
        ifail = 0
        Call g05kff(genid,subid,seed,lseed,state,lstate,ifail)
      End Subroutine initialize_prng

      Subroutine display_results(rcord,t0,tend,ntimes,intime,d,start,bb,bd)

!       .. Scalar Arguments ..
        Real (Kind=nag_wp), Intent (In) :: t0, tend
        Integer, Intent (In)           :: d, ntimes, rcord
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (In) :: bb(:,:), bd(:,:), intime(:),        &
                                          start(:)
!       .. Local Scalars ..
        Integer                        :: i, n
!       .. Local Arrays ..
        Real (Kind=nag_wp), Allocatable :: cum(:), unscaled(:)
!       .. Executable Statements ..
        Allocate (cum(d),unscaled(d))
        Write (nout,*) 'G05XCF Example Program Results'
        Write (nout,*)

        Do n = 1, npaths
          Write (nout,99999) 'Weiner Path ', n, ', ', ntimes + 1,              &
            ' time steps, ', d, ' dimensions'
          Write (nout,'(A)')                                                   &
            '      Output of G05XBF    Output of G05XDF      Sum of G05XDF'

          cum(:) = start(:)
          If (rcord==1) Then
            unscaled(:) = bd(1:d,n)*(intime(1)-t0)
            cum(:) = cum(:) + unscaled(:)
            Write (nout,99998) 1, bb(1:d,n), bd(1:d,n), cum(1:d)
          Else
            unscaled(:) = bd(n,1:d)*(intime(1)-t0)
            cum(:) = cum(:) + unscaled(:)
            Write (nout,99998) 1, bb(n,1:d), bd(n,1:d), cum(1:d)
          End If
          Do i = 2, ntimes
            If (rcord==1) Then
              unscaled(:) = bd(1+(i-1)*d:i*d,n)*(intime(i)-intime(i-1))
              cum(:) = cum(:) + unscaled(:)
              Write (nout,99998) i, bb(1+(i-1)*d:i*d,n), bd(1+(i-1)*d:i*d,n),  &
                cum(1:d)
            Else
              unscaled(:) = bd(n,1+(i-1)*d:i*d)*(intime(i)-intime(i-1))
              cum(:) = cum(:) + unscaled(:)
              Write (nout,99998) i, bb(n,1+(i-1)*d:i*d), bd(n,1+(i-1)*d:i*d),  &
                cum(1:d)
            End If
          End Do
          i = ntimes + 1
          If (rcord==1) Then
            unscaled(:) = bd(1+(i-1)*d:i*d,n)*(tend-intime(i-1))
            cum(:) = cum(:) + unscaled(:)
            Write (nout,99998) i, bb(1+(i-1)*d:i*d,n), bd(1+(i-1)*d:i*d,n),    &
              cum(1:d)
          Else
            unscaled(:) = bd(n,1+(i-1)*d:i*d)*(tend-intime(i-1))
            cum(:) = cum(:) + unscaled(:)
            Write (nout,99998) i, bb(n,1+(i-1)*d:i*d), bd(n,1+(i-1)*d:i*d),    &
              cum(1:d)
          End If

          Write (nout,*)
        End Do

99999   Format (1X,A,I0,A,I0,A,I0,A)
99998   Format (1X,I2,1X,2(1X,F8.4),2X,2(1X,F8.4),2X,2(1X,F8.4))
      End Subroutine display_results
    End Program g05xcfe