Program g03ccfe

!     G03CCF Example Program Text

!     Mark 30.1 Release. NAG Copyright 2024.

!     .. Use Statements ..
      Use nag_library, Only: g03caf, g03ccf, nag_wp, x04caf
!     .. Implicit None Statement ..
      Implicit None
!     .. Parameters ..
      Integer, Parameter               :: nin = 5, nout = 6
!     .. Local Scalars ..
      Integer                          :: i, ifail, ldfl, ldfs, ldr, ldx,      &
                                          liwk, lres, lwk, lwt, m, n, nfac,    &
                                          nvar, tdr
      Character (80)                   :: fmt
      Character (1)                    :: matrix, method, rotate, weight
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: com(:), e(:), fl(:,:), fs(:,:),      &
                                          psi(:), r(:,:), res(:), wk(:),       &
                                          wt(:), x(:,:)
      Real (Kind=nag_wp)               :: stat(4)
      Integer                          :: iop(5)
      Integer, Allocatable             :: isx(:), iwk(:)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: count, max
!     .. Executable Statements ..
      Write (nout,*) 'G03CCF Example Program Results'
      Write (nout,*)
      Flush (nout)

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

!     Read in the problem size
      Read (nin,*) matrix, weight, n, m, nfac

      If (matrix=='C' .Or. matrix=='c') Then
        lwt = 0
        ldx = m
      Else
        If (weight=='W' .Or. weight=='w') Then
          lwt = n
        Else
          lwt = 0
        End If
        ldx = n
      End If
      Allocate (x(ldx,m),isx(m),wt(lwt))

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

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

!     Calculate NVAR
      nvar = count(isx(1:m)==1)

!     Do not apply a rotation
      rotate = 'U'
      tdr = 1
      ldr = 1

      lres = nvar*(nvar-1)/2
      liwk = 4*nvar + 2
      lwk = 5*nvar*nvar + 33*nvar - 4/2
      If (matrix/='C' .And. matrix/='c') Then
        lwk = max(lwk,n*nvar+7*nvar+nvar*(nvar-1)/2)
      End If
      lwk = max(lwk,nvar)
      ldfs = nvar
      ldfl = nvar
      Allocate (e(nvar),com(nvar),psi(nvar),res(lres),fl(ldfl,nfac),wk(lwk),   &
        iwk(liwk),fs(ldfs,nfac),r(ldr,tdr))

!     Read in options
      Read (nin,*) iop(1:5)

!     Fit factor analysis model
      ifail = -1
      Call g03caf(matrix,weight,n,m,x,ldx,nvar,isx,nfac,wt,e,stat,com,psi,res, &
        fl,ldfl,iop,iwk,wk,lwk,ifail)
      If (ifail/=0) Then
        If (ifail<=4) Then
          Go To 100
        End If
      End If

!     Display results
      Write (nout,*) ' Loadings, Communalities and PSI'
      Write (nout,*)
      Write (fmt,99999) '(', nfac + 2, '(1X,F8.3))'
      Write (nout,fmt)(fl(i,1:nfac),com(i),psi(i),i=1,nvar)

!     Read in details of how to compute factor scores
      Read (nin,*) method

!     Compute factor scores
      ifail = 0
      Call g03ccf(method,rotate,nvar,nfac,fl,ldfl,psi,e,r,ldr,fs,ldfs,wk,      &
        ifail)

!     Display factor score coefficients
      Write (nout,*)
      Flush (nout)
      ifail = 0
      Call x04caf('General',' ',nvar,nfac,fs,ldfs,'Factor score coefficients', &
        ifail)

100   Continue

99999 Format (A,I0,A)
    End Program g03ccfe