PROGRAM g02kbfe

!      G02KBF Example Program Text

!      Mark 23 Release. NAG Copyright 2011.

!      .. Use Statements ..
       USE nag_library, ONLY : g02kbf, nag_wp
!      .. Implicit None Statement ..
       IMPLICIT NONE
!      .. Parameters ..
       INTEGER, PARAMETER              :: nin = 5, nout = 6
!      .. Local Scalars ..
       INTEGER                         :: i, ifail, ip, ldb, ldpe, ldvf, ldx,  &
                                          lh, lpec, m, n, pl, tdb, tdpe, tdvf, &
                                          wantb, wantvf
!      .. Local Arrays ..
       REAL (KIND=nag_wp), ALLOCATABLE :: b(:,:), h(:), nep(:), pe(:,:),       &
                                          vf(:,:), x(:,:), y(:)
       INTEGER, ALLOCATABLE            :: isx(:)
       CHARACTER (1), ALLOCATABLE      :: pec(:)
!      .. Intrinsic Functions ..
       INTRINSIC                          count, min
!      .. Executable Statements ..
       WRITE (nout,*) 'G02KBF Example Program Results'
       WRITE (nout,*)

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

!      Read in the problem size 
       READ (nin,*) n, m, lh, lpec, wantb, wantvf

       ldx = n
       ALLOCATE (x(ldx,m),isx(m),y(n),h(lh),pec(lpec))

!      Read in data
       IF (lpec>0) THEN
          READ (nin,*) pec(1:lpec)
       END IF
       READ (nin,*) (x(i,1:m),y(i),i=1,n)

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

!      Read in the ridge coefficients
       READ (nin,*) h(1:lh)

!      Calculate IP
       ip = count(isx(1:m)==1)

       IF (wantb/=0) THEN
          ldb = ip + 1
          tdb = lh
       ELSE
          ldb = 0
          tdb = 0
       END IF
       IF (wantvf/=0) THEN
          ldvf = ip
          tdvf = lh
       ELSE
          ldvf = 0
          tdvf = 0
       END IF
       IF (lpec>0) THEN
          ldpe = lpec
          tdpe = lh
       ELSE
          ldpe = 0
          tdpe = 0
       END IF
       ALLOCATE (nep(lh),b(ldb,tdb),vf(ldvf,tdvf),pe(ldpe,tdpe))

!      Fit ridge regression
       ifail = 0
       CALL g02kbf(n,m,x,ldx,isx,ip,y,lh,h,nep,wantb,b,ldb,wantvf,vf,ldvf, &
          lpec,pec,pe,ldpe,ifail)

!      Display results
       WRITE (nout,99994) 'Number of parameters used = ', ip + 1
       WRITE (nout,*) 'Effective number of parameters (NEP):'
       WRITE (nout,*) '   Ridge   '
       WRITE (nout,*) '   Coeff.  ', 'NEP'
       WRITE (nout,99993) (h(i),nep(i),i=1,lh)

!      Parameter estimates
       IF (wantb/=0) THEN
          WRITE (nout,*)
          IF (wantb==1) THEN
             WRITE (nout,*) 'Parameter Estimates (Original scalings)'
          ELSE
             WRITE (nout,*) 'Parameter Estimates (Standarised)'
          END IF
          pl = min(ip,4)
          WRITE (nout,*) '  Ridge  '
          WRITE (nout,99997) '   Coeff.  ', ' Intercept ', (i,i=1,pl)
          IF (pl<ip-1) THEN
             WRITE (nout,99996) (i,i=pl+1,ip-1)
          END IF
          pl = min(ip+1,5)
          DO i = 1, lh
             WRITE (nout,99999) h(i), b(1:pl,i)
             IF (pl<ip) THEN
                WRITE (nout,99998) b((pl+1):ip,i)
             END IF
          END DO
       END IF

!      Variance inflation factors
       IF (wantvf/=0) THEN
          WRITE (nout,*)
          WRITE (nout,*) 'Variance Inflation Factors'
          pl = min(ip,5)
          WRITE (nout,*) '  Ridge  '
          WRITE (nout,99995) '  Coeff.  ', (i,i=1,pl)
          IF (pl<ip) THEN
             WRITE (nout,99996) (i,i=pl+1,ip)
          END IF
          DO i = 1, lh
             WRITE (nout,99999) h(i), vf(1:pl,i)
             IF (pl<ip) THEN
                WRITE (nout,99998) vf((pl+1):ip,i)
             END IF
          END DO
       END IF

!      Prediction error criterion
       IF (lpec>0) THEN
          WRITE (nout,*)
          WRITE (nout,*) 'Prediction error criterion'
          pl = min(lpec,5)
          WRITE (nout,*) '  Ridge  '
          WRITE (nout,99995) '  Coeff.  ', (i,i=1,pl)
          IF (pl<lpec) THEN
             WRITE (nout,99996) (i,i=pl+1,lpec)
          END IF
          DO i = 1, lh
             WRITE (nout,99999) h(i), pe(1:pl,i)
             IF (pl<ip) THEN
                WRITE (nout,99998) pe((pl+1):ip,i)
             END IF
          END DO
          WRITE (nout,*)
          WRITE (nout,*) 'Key:'
          DO i = 1, lpec
             SELECT CASE (pec(i))
             CASE ('L')
                WRITE (nout,99992) i, 'Leave one out cross-validation'
             CASE ('G')
                WRITE (nout,99992) i, 'Generalised cross-validation'
             CASE ('U')
                WRITE (nout,99992) i, 'Unbiased estimate of variance'
             CASE ('F')
                WRITE (nout,99992) i, 'Final prediction error'
             CASE ('B')
                WRITE (nout,99992) i, 'Bayesian information criterion'
             END SELECT
          END DO
       END IF

99999  FORMAT (1X,F10.4,5F10.4)
99998  FORMAT (1X,10X,5F10.4)
99997  FORMAT (1X,A,A,4I10)
99996  FORMAT (10X,5I10)
99995  FORMAT (1X,A,5I10)
99994  FORMAT (1X,A,I10)
99993  FORMAT (1X,F10.4,F10.4)
99992  FORMAT (1X,1X,I5,1X,A)
    END PROGRAM g02kbfe