Program g03acfe

!     G03ACF Example Program Text

!     Mark 30.1 Release. NAG Copyright 2024.

!     .. Use Statements ..
      Use nag_library, Only: g03acf, nag_wp, x04caf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nin = 5, nout = 6
!     .. Local Scalars ..
      Real (Kind=nag_wp)               :: tol
      Integer                          :: i, ifail, irankx, iwk, ldcvm, ldcvx, &
                                          lde, ldx, lwt, m, n, ncv, ng, nx
      Character (1)                    :: weight
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: cvm(:,:), cvx(:,:), e(:,:), wk(:),   &
                                          wt(:), x(:,:)
      Integer, Allocatable             :: ing(:), isx(:), nig(:)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: max, min
!     .. Executable Statements ..
      Write (nout,*) 'G03ACF Example Program Results'
      Write (nout,*)

!     Skip heading in data file
      Read (nin,*)

!     Read in the problem size
      Read (nin,*) n, m, nx, ng, weight

      Select Case (weight)
      Case ('W','w','V','v')
        lwt = n
      Case Default
        lwt = 0
      End Select
      ldx = n
      ldcvm = ng
      lde = min(nx,ng-1)
      ldcvx = nx
      If (nx>=ng-1) Then
        iwk = n*nx + max(5*(nx-1)+(nx+1)*nx,n) + 1
      Else
        iwk = n*nx + max(5*(nx-1)+(ng-1)*nx,n) + 1
      End If
      Allocate (x(ldx,m),isx(m),ing(n),wt(lwt),nig(ng),cvm(ldcvm,nx),e(lde,6), &
        cvx(ldcvx,nx),wk(iwk))

!     Read in data
      If (lwt>0) Then
        Read (nin,*)(x(i,1:m),wt(i),ing(i),i=1,n)
      Else
        Read (nin,*)(x(i,1:m),ing(i),i=1,n)
      End If

!     Read in variable inclusion flags
      Read (nin,*) isx(1:m)

!     Use default tolerance
      tol = 0.0E0_nag_wp

!     Perform canonical variate analysis
      ifail = 0
      Call g03acf(weight,n,m,x,ldx,isx,nx,ing,ng,wt,nig,cvm,ldcvm,e,lde,ncv,   &
        cvx,ldcvx,tol,irankx,wk,iwk,ifail)

!     Display results
      Write (nout,99999) 'Rank of X = ', irankx
      Write (nout,*)
      Write (nout,*)                                                           &
        'Canonical    Eigenvalues Percentage     CHISQ      DF     SIG'
      Write (nout,*) 'Correlations              Variation'
      Write (nout,99998)(e(i,1:6),i=1,ncv)
      Write (nout,*)
      Flush (nout)
      ifail = 0
      Call x04caf('General',' ',nx,ncv,cvx,ldcvx,                              &
        'Canonical Coefficients for X',ifail)
      Write (nout,*)
      Flush (nout)
      ifail = 0
      Call x04caf('General',' ',ng,ncv,cvm,ldcvm,'Canonical variate means',    &
        ifail)

99999 Format (1X,A,I0)
99998 Format (1X,2F12.4,F11.4,F10.4,F8.1,F8.4)
    End Program g03acfe