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

NAG FL Interface Introduction
Example description
!   G22YCF Example Program Text
!   Mark 30.2 Release. NAG Copyright 2024.

    Module g22ycfe_mod
!     G22YCF 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                           :: print_x, read_line
!     .. Parameters ..
      Integer, Parameter, Public       :: nin = 5, nout = 6

    Contains
      Subroutine read_line(ierr,v1,v2)
!       Read in a line from NIN, remove any comments and optionally
!       split out the first word

!       .. Scalar Arguments ..
        Integer, Intent (Out)          :: ierr
        Character (*), Intent (Out)    :: v1
        Character (*), Intent (Out), Optional :: v2
!       .. Local Scalars ..
        Integer                        :: pend
!       .. Intrinsic Procedures ..
        Intrinsic                      :: adjustl, index, present
!       .. Executable Statements ..

        Read (nin,'(A200)',Iostat=ierr) v1
        If (ierr==0) Then
          pend = index(v1,'::')
          If (pend/=0) Then
            v1 = v1(1:pend-1)
          End If
          v1 = adjustl(v1)

          If (present(v2)) Then
!           split the first word from the line
            pend = index(v1,' ')
            If (pend/=0) Then
              v2 = adjustl(v1(pend:))
              v1 = adjustl(v1(1:pend))
            Else
              v2 = ''
            End If
          End If
        End If

        Return
      End Subroutine read_line
      Subroutine print_x(intcpt,plab,nobs,mx,x,text)
!       Print the transpose of the first 10 rows of the design matrix

!       .. Parameters ..
        Integer, Parameter             :: max_rows = 10
!       .. Scalar Arguments ..
        Integer, Intent (In)           :: mx, nobs
        Character (*), Intent (In)     :: intcpt, text
!       .. Array Arguments ..
        Real (Kind=nag_wp), Intent (In) :: x(:,:)
        Character (*), Intent (In)     :: plab(:)
!       .. Local Scalars ..
        Integer                        :: i, pnobs, si
!       .. Intrinsic Procedures ..
        Intrinsic                      :: min, repeat, trim
!       .. Executable Statements ..

!       PLAB holds the labels for the model parameters, so includes a label
!       for the mean effect, if one is present. As the mean effect is not
!       being explicitly included in the design matrix, we may need to skip
!       the first element of PLAB (which will always be the label for the
!       mean effect if one is present)
        If (intcpt=='M') Then
          si = 1
        Else
          si = 0
        End If

!       Printing the first MAX_ROWS rows of the design matrix
        pnobs = min(max_rows,nobs)

!       Display the design matrix
        Write (nout,99998) 'Transpose of First ', pnobs, ' Rows of the ',      &
          text, ' Design Matrix (X)'
        Write (nout,99997) 'Column Name', (i,i=1,pnobs)
        Write (nout,99996) repeat('-',15+pnobs*5)
        Do i = 1, mx
          Write (nout,99999) plab(i+si), x(1:pnobs,i)
        End Do
        Write (nout,*) 'Intercept flag = ', trim(intcpt)

        Return
99999   Format (1X,A15,100(1X,F4.1))
99998   Format (1X,A,I0,A,A,A)
99997   Format (1X,A,3X,100(3X,I2))
99996   Format (1X,A)
      End Subroutine print_x
    End Module g22ycfe_mod

    Program g22ycfe

!     .. Use Statements ..
      Use g22ycfe_mod, Only: nin, nout, print_x, read_line
      Use, Intrinsic                   :: iso_c_binding, Only: c_null_ptr,     &
                                          c_ptr
      Use nag_library, Only: g22yaf, g22ybf, g22ycf, g22ydf, g22zaf, g22zmf,   &
                             nag_wp
!     .. Implicit None Statement ..
      Implicit None
!     .. Local Scalars ..
      Type (c_ptr)                     :: hddesc, hform, hxdesc
      Integer                          :: i, ierr, ifail, ip, lddat, ldx,      &
                                          lisx, lplab, lvinfo, lvnames, mx,    &
                                          nobs, nvar, sddat, sdx
      Character (200)                  :: formula, intcpt, line, tcontrast,    &
                                          tvname
!     .. Local Arrays ..
      Real (Kind=nag_wp), Allocatable  :: dat(:,:), x(:,:)
      Real (Kind=nag_wp)               :: tx(0,0)
      Integer, Allocatable             :: isx(:), levels(:), vinfo(:)
      Character (50), Allocatable      :: plab(:), vnames(:)
!     .. Intrinsic Procedures ..
      Intrinsic                        :: trim
!     .. Executable Statements ..
      Write (nout,*) 'G22YCF Example Program Results'
      Write (nout,*)

      hform = c_null_ptr
      hddesc = c_null_ptr
      hxdesc = c_null_ptr

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

!     Read in the formula for the first specification of the model,
!     remove comments and parse it
      Call read_line(ierr,formula)
      ifail = 0
      Call g22yaf(hform,formula,ifail)

!     Read in the contrast to use for all parameters, remove comments and
!     set the contrast optional parameter
      Call read_line(ierr,tcontrast)
      line = 'Contrast=' // trim(tcontrast)
      ifail = 0
      Call g22zmf(hform,line,ifail)

!     Read in size of the data matrix and number of variable labels supplied
      Read (nin,*) nobs, nvar, lvnames

!     Read in number of levels and names for the variables
      Allocate (levels(nvar),vnames(lvnames))
      Read (nin,*) levels(1:nvar)
      If (lvnames>0) Then
        Read (nin,*) vnames(1:lvnames)
      End If

!     Create a description of the data matrix
      ifail = 0
      Call g22ybf(hddesc,nobs,nvar,levels,lvnames,vnames,ifail)

!     Read in the data matrix
      lddat = nobs
      sddat = nvar
      Allocate (dat(lddat,sddat))
      Read (nin,*)(dat(i,1:nvar),i=1,nobs)

!     Calculate the size of the design matrix
      ldx = 0
      sdx = 0
      ifail = 1
      Call g22ycf(hform,hddesc,dat,lddat,sddat,hxdesc,tx,ldx,sdx,mx,ifail)
      If (ifail/=81 .And. ifail/=82 .And. ifail/=91 .And. ifail/=92) Then
!       Redisplay any error messages not related to X being too small
        ifail = 0
        Call g22ycf(hform,hddesc,dat,lddat,sddat,hxdesc,tx,ldx,sdx,mx,ifail)
      End If

!     Generate the design matrix, X
      ldx = nobs
      sdx = mx
      Allocate (x(ldx,sdx))
      ifail = 0
      Call g22ycf(hform,hddesc,dat,lddat,sddat,hxdesc,x,ldx,sdx,mx,ifail)

!     Generate labels for the columns of X
      lplab = mx + 1
      lvinfo = 0
      lisx = 0
      Allocate (isx(lisx),vinfo(lvinfo),plab(lplab))
      ifail = 0
      Call g22ydf('X',hform,hxdesc,intcpt,ip,lisx,isx,lplab,plab,lvinfo,vinfo, &
        ifail)

!     Display the design matrix
      Call print_x(intcpt,plab,nobs,mx,x,'First')

c_lp: Do
!       Read in the name of the variable whose contrasts need to be changed,
!       the value to change them to, remove comments and set the contrast
!       optional argument for the specified variable
        Call read_line(ierr,tvname,tcontrast)
        If (ierr/=0) Then
          Exit c_lp
        End If
        line = 'Contrast:' // trim(tvname) // '=' // trim(tcontrast)
        ifail = 0
        Call g22zmf(hform,line,ifail)
      End Do c_lp

!     Regenerate the design matrix using the new contrasts
!     (the size of X should be the same as previously)
      ifail = 0
      Call g22ycf(hform,hddesc,dat,lddat,sddat,hxdesc,x,ldx,sdx,mx,ifail)

!     Generate labels for the columns of X
      ifail = 0
      Call g22ydf('X',hform,hxdesc,intcpt,ip,lisx,isx,lplab,plab,lvinfo,vinfo, &
        ifail)

!     Display the design matrix
      Write (nout,*)
      Call print_x(intcpt,plab,nobs,mx,x,'Second')

!     Clean-up the G22 handles
      ifail = 0
      Call g22zaf(hform,ifail)
      Call g22zaf(hddesc,ifail)
      Call g22zaf(hxdesc,ifail)

      Deallocate (dat,x)
      Deallocate (isx,levels,vinfo)
      Deallocate (plab,vnames)

    End Program g22ycfe