C NCLFORTSTART
      subroutine deof11( d, nx, nt, nmodes, icovcor, dmsg,
     &		         eigenvalues, eigenvectors, variance,
     &                   princomp)
c minimal argument list
        implicit none

	integer	nx, nt, nmodes, icovcor
	double precision d(nx,nt), eigenvalues(nmodes),
     &		eigenvectors(nx,nmodes), variance(nmodes)
        double precision princomp(nt,nmodes), dmsg
C NCLEND
        integer iminnxnt, imaxnxnt
        integer n

c need  iminnxnt and imaxnxnt for automatic allocation

        iminnxnt = min(nx,nt)
        imaxnxnt = max(nx,nt)

	call deof22(d, nx, nt, nmodes, icovcor, dmsg,
     &		    eigenvalues, eigenvectors, variance,
     &		    iminnxnt, imaxnxnt, princomp )

        return
        end
c ----------------------------------------------------------------
      subroutine deof22(d, nx, nt, nmodes, icovcor, dmsg,
     &		         eigenvalues, eigenvectors, variance,
     &		         iminnxnt, imaxnxnt, princomp)
        implicit none

        integer nx, nt, nmodes, icovcor, iminnxnt, imaxnxnt
        double precision d(nx,nt), eigenvalues(nmodes),
     &          eigenvectors(nx,nmodes), variance(nmodes)
        double precision princomp(nt,nmodes), dmsg

c local and  automatic arrays
        double precision cumvariance(nmodes),
     &          spacked(iminnxnt*(iminnxnt+1)/2), evals(iminnxnt),
     &          evecs(iminnxnt,nmodes), rlawork(8*iminnxnt),
     &          tentpcs(imaxnxnt,nmodes)
        double precision  sqrootweights(nx)
        integer ilawork(5*iminnxnt), ifail(iminnxnt)
        integer n

c NCL expects the user will do weighting externally

        do n=1,nx
           sqrootweights(n) = 1.d0
        end do

        call deof( d, nx, nt, nmodes, icovcor, dmsg,
     &		eigenvalues, eigenvectors, princomp, variance, cumvariance,
     &		iminnxnt, imaxnxnt, spacked, evals, evecs, rlawork,
     &		ilawork, ifail, tentpcs, sqrootweights )
        return
        end
c ----------------------------------------------------------------
c --- Original Scripps Code: modified for missing values [dmsg]
c ---                        Dennis Shea [Aug 2005]
c ----------------------------------------------------------------
      subroutine deof( data, nx, nt, nmodes, icovcor, dmsg,
     &		eigenvalues, eigenvectors, princomp, variance, cumvariance,
     &		iminnxnt, imaxnxnt, spacked, evals, evecs, rlawork,
     &		ilawork, ifail, tentpcs, sqrootweights )

c	------------------------------------------------------------------
c	This routine generates the Empirical Orthogonal Functions (EOFs)
c	for a given time-space data set.  (Note that although the routine
c	is set up as if the data is exactly two dimensional (X,T), that
c	you can compute the EOFs of 3-D (X,Y,T) fields simply by concat-
c	enating the data along the X,Y axes into one big 2-D array and
c	then computing the EOFs of that 2-D array).  The "typical"
c	normalization is applied, i.e., the magnitude of the eigenvectors
c	is scaled to be equal to 1.
c
c	David W. Pierce
c	dpierce@ucsd.edu
c	Scripps Institution of Oceanography
c	Climate Research Division, 0224
c	Jan 29, 1996
c
c	Inputs:
c
c		data(nx,nt): data to compute the EOFs of.  THIS MUST
c			BE ANOMALIES.
c
c		nx, nt: number of space (nx) and time (nt) points in the
c			input data array.
c
c		nmodes: number of modes (EOFs) to compute.
c
c		icovcor: if =0, then compute using covariance matrix;
c			 if =1, then compute using correlation matrix.
c			See, for example, discussion in Daniel S. Wilks
c			1995, "Statistical Methods in the Atmospheric
c			Sciences", p. 383 for a discussion.
c
c		iminnxnt: the SMALLER of 'nx' and 'nt'.
c
c		imaxnxnt: the LARGER of 'nx' and 'nt'.
c
c		spacked(iminnxnt*(iminnxnt+1)/2): workspace.  This is used to
c			store the packed covariance or correlation matrix.
c
c		evals(iminnxnt): workspace.  This is used to store the
c			complete series of eigenvalues.  I suppose you
c			could access this if you wanted to, remembering
c			that a) it's more modes than you asked for; b)
c			they are in ASCENDING order rather than descending.
c
c		evecs(iminnxnt,nmodes): workspace.  This is used to store
c			the (possibly switched) eigenvectors, which are
c			in ascending order.
c
c		rlawork(8*iminnxnt): Real LAPACK workspace.
c
c		ilawork(5*iminnxnt): Integer LAPACK workspace.
c
c		ifail(iminnxnt): Integer LAPACK workspace.  This is used
c			to indicate which eigenvectors didn't converge,
c			if that happened.
c
c		tentpcs(imaxnxnt,nmodes): Real workspace.  This is
c			used to store the 'tentative' principal components.
c
c		sqrootweights(nx) : NOT USED IN NCL IMPLEMENTATION [set to 1.0]
c                       the SQUARE ROOT of the areal weighting to
c			use.  Just set this to all 1.0's if you don't care
c			about areal weighting.  I think you can set places
c			which should be ignored to zero to have them not
c			participate in the calculation, thus implementing a
c			crude form of data masking.
c
c               dmsg    missing code
c
c	Outputs:
c
c		eigenvalues(nmodes): the computed eigenvalues of
c			the data, the largest returned first.
c
c		eigenvectors(nx,nmodes): the computed eigenvectors
c			of the data, the most important returned first.
c
c		princomp(nt,nmodes): the principal components of
c			the data.
c
c		variance(nmodes): the percent of variance explained
c			by each mode.
c
c		cumvariance(nmodes): the cumulative percent of
c			variance explained by each mode.  This is
c			a bit redundant -- it's just the sum
c			of "variance".
c
c	Method:
c
c	EOFs are simply the eigenvectors of the covariance (or correlation)
c	matrix.  So form the proper matrix from the data and pass it to
c	a LAPACK routine which calculates eigenvectors/eigenvalues.  Then
c	calculate the principal components explicitly using the fact that
c	the principal component for mode M at time T is just the projection
c	of the data at time T onto eigenvector M.
c
c	There is a slight complication for efficiency's sake.  That is,
c	we often have nx >> nt, i.e., there are many more spatial than
c	temporal points.  The traditional correlation/covariance matrix
c	is size (nx,nx), which can be huge.  Think, for example, of a 3-D
c	field of size (100,100,120) which has been concatenated into a
c	2-D field of size (10000,120).  The traditional covariance/correlation
c	matrix in this case is size (10000,10000)!  That's way too big to
c	easily work with.  So, following the discussion in Preisendorfer
c	(1988, "Principal Component Analysis in Meteorology and Oceanography",
c	p. 64) we work, in such cases, in the "dual" of the space.  All
c	that means is that we logically switch X and T; the
c	covariance/correlation matrix for the example given above is then
c	size (120,120), which is much easier and more efficient to work
c	with.  If you do this kind of switch, the basic idea is that
c	the eigenvectors of the switched matrix are the principal components
c	of the original matrix, and the principal components of the switched
c	matrix are the eigenvectors of the original matrix.  Which is to
c	say, if you switch T and X to begin with, the final result is that
c	the T dependence is in the X part and the X dependence is in the
c	T part.  There is also a normalization which has to be applied--
c	see Preisendorfer for details.
c	------------------------------------------------------------------

	implicit none

	integer	covariance, correlation
	parameter( covariance=0, correlation=1 )  ! possible values of 'icovcor'

c	-----------------
c	Passed parameters
c	-----------------
	integer	nx, nt, nmodes, icovcor, iminnxnt, imaxnxnt
        integer ifail(iminnxnt)
	double precision data(nx,nt), eigenvalues(nmodes),
     &		eigenvectors(nx,nmodes), princomp(nt,nmodes),
     &		variance(nmodes), cumvariance(nmodes),
     &		spacked(iminnxnt*(iminnxnt+1)/2), evals(iminnxnt),
     &		evecs(iminnxnt,nmodes), rlawork(8*iminnxnt),
     &		tentpcs(imaxnxnt,nmodes), sqrootweights(nx)
	double precision dmsg, deps
	integer ilawork(5*iminnxnt)

c	---------------
c	Local variables
c	---------------
	logical		doswitched
	integer		orderofs, i, j, jascending, jdescending
	double precision sum, fact, totvar
	character*1	jobz, range, uplo	! for LAPACK routine
	integer		m, n, il, iu, ldz, info	! for LAPACK routine
	double precision vl, vu, abstol		! for LAPACK routine
	integer 	lwork, mode

        logical DEBUG
        DEBUG = .false.

        if (DEBUG) then
            print *, 'entering deof with nx, nt, nmodes=',nx,nt,nmodes
c c c       print *, 'sqrootweights:',sqrootweights(1:10)
        end if

c	----------------------------------------------
c	Weight the data by the square root of the area
c	----------------------------------------------
        do j=1, nt
          do i=1, nx
             if (data(i,j).ne.dmsg) then
                 data(i,j) = data(i,j) * sqrootweights(i)
             end if
          end do
        end do

c	---------------------------------------------------------
c	Figure out whether we should do the 'regular' EOF or the
c	one with switched X and T axes.  The correlation matrix
c	for the regular method is size (nx,nx) and for the
c	switched method it is size (nt,nt); choose based on which
c	of these is smaller.
c	---------------------------------------------------------
        if (DEBUG) then
            print *, 'figuring switched or not'
        end if

	doswitched = (nx .gt. nt)
	if( doswitched ) then
		orderofs = nt
		if (DEBUG) print *, 'deof: Working in switched mode'
	else
		orderofs = nx
		if (DEBUG) print *, 'deof: Working in unswitched mode'
	endif
	if( orderofs .gt. iminnxnt ) then
		print * , 'Error!  EOF routine must be supplied '
		print * , 'with enough workspace; passed parameter'
		print * , 'iminnxnt must be at least ', orderofs
		print * , 'Passed value was iminnxnt=',iminnxnt
		stop 'eof '
	endif
	if( nmodes .gt. orderofs ) then
		print * , 'Error! EOF routine called requesting more'
		print * , 'modes than exist!  Request=',nmodes,' exist=',
     &		           orderofs
		stop 'eof '
	endif

c	-------------------------------------------------
c	Form the covariance or correlation matrix, put it
c	into 's'.  Note that 's' is always symmetric --
c	the correlation between X and Y is the same as
c	between Y and X -- so use packed storage for 's'.
c	The packed storage scheme we use is the same as
c	LAPACK uses so we can pass 's' directly to the
c	solver routine: the matrix is lower triangular,
c	and s(i,j) = spacked(i+(j-1)*(2*n-j)/2).
c	-------------------------------------------------
        call deofcovcor( data, nx, nt, icovcor, covariance,
     &		correlation, spacked, doswitched, iminnxnt, dmsg )
c	------------------------------------------------------
c	Now call the LAPACK solver to get the eigenvalues
c	and eigenvectors.  The eigenvalues express the
c	amount of variance explained by the various modes,
c	so choose to return those 'nmodes' modes which
c	explain the most variance.
c	Dims of arrays:
c		evals  (n)	  ! The calculated eigenvalues
c		evecs  (n,nmodes) ! The calculated eigenvectors
c		rlawork(8*n)
c		ilawork(5*n)
c		ifail  (n)
c	Remember that the calculated eigenvectors may not be
c	the ones we really want if we are doing switched
c	X and T axes.  However the eigen*values* are the same
c	either way, according to Preisendorfer.
c	*NOTE* that the LAPACK routine returns the eigenvalues
c	(and corresponding eigenvectors) in ASCENDING order,
c	but this routine returns them in DESCENDING order;
c	this will be switched in the final assembly phase,
c	below.
c	------------------------------------------------------
	jobz  = 'V' 	! Both eigenvalues and eigenvectors
	range = 'I'	! Specify range of eigenvalues to get.
	uplo  = 'L'	! 'spacked' has lower triangular part of s
	n     = orderofs
	il    = n - nmodes + 1	! Smallest eigenvalue to get
	iu    = n		! Largest eigenvalue to get
	abstol= 0.0d0		! See LAPACK documentation
	ldz   = n

	lwork = 8*iminnxnt

	do j=1, nmodes
           evals(j) = 0.0d0
          do i=1, iminnxnt
             evecs(i,j) = 0.0d0
	  end do
	end do

        if (DEBUG) then
c c c       print *,'about to call dspevx, spacked=', spacked(1:10)
c c c       print *,'about to call dspevx, spacked=',(spacked(i),i=1,10)
            do i=1,10
               print *,"spacked: n=",n,"  ",spacked(i)
            end do
        end if

	call dspevx( jobz, range, uplo, n, spacked,
     &		vl, vu, il, iu, abstol, m, evals, evecs, ldz,
     &		rlawork, ilawork, ifail, info )

c	------------------------------
c	Check for LAPACK routine error
c	------------------------------
	if( info .ne. 0 ) then
		if( info .lt. 0 ) then
			print *, 'LAPACK error: argument ',
     &				-info, ' had illegal value'
			stop 'eof'
		else
			print *, 'LAPACK error: ', info,
     &				'eigenvectors failed to converge!'
			print *, 'Consult the LAPACK docs!'
			stop 'eof'
		endif
	endif

c	------------------------------------------------
c	Make sure that no eigenvalues <= zero.  Besides
c	being mathematically forbidden, this would cause
c	a divide by zero or negative sqrt error later on.
c
c       In the original code, it would exit if there was
c       an eigenvalue less than 0. For our purposes, however,
c       we'll just set the eigenvalue to 0 and let it continue.
c	------------------------------------------------
        DEPS = 1d-6
	do i=1, nmodes
          if(abs(evals(i)) .le. DEPS ) then
c	    print *, 'Error! LAPACK routine returned'
c	    print *, 'eigenvalue <= 0!! ', i, evals(i)
	    print *, 'Warning! LAPACK routine returned eigenvalue <= 0.'
	    print *, 'Setting it to zero...'
            evals(i) = 0.0d0
c	    do j=1, nmodes
c	      print *, j, evals(j)
c  	    end do
c	    print *, 'Note1: This means you may be asking'
c	    print *, 'for more modes than the data supports.'
c	    print *, 'Try reducing the number of requested'
c	    print *, 'modes.'
c  	    print *, 'Note2: missing values can'
c	    print *, 'result in a covariance matrix that'
c	    print *, 'is not positive definite.'
c	    stop 'eofunc'
          endif
	end do

c	------------------------------------------------
c	Compute the tentative principal components; they
c	are 'tentative' because they might be the PCs
c	of the switched data.  Put them into 'tentpcs',
c	which is of size (nt,nmodes) if we are doing
c	regular EOFs and (nx,nmodes) if we are doing
c	switched EOFs.  These PCs come out in order
c	corresponding to the order of 'evecs', which is
c	in ASCENDING order.
c	------------------------------------------------
	call deofpcs( data, nx, nt, nmodes, iminnxnt,
     &		imaxnxnt, evecs, doswitched, tentpcs, dmsg )

c	--------------------------------------------------
c	Now we have all the pieces to assemble our final
c	result.  How we actually assemble them depends on
c	whether we are doing switched or unswitched EOFs
c	(except for the eigenVALUES, which are the same
c	either way).
c	--------------------------------------------------
	if( doswitched ) then
c		------------------------------------------
c		In this case we must switch the principal
c		components and the eigenvectors, applying
c		the proper normalization.
c		First get the unswitched eigenvectors,
c		which are the switched (tentative) principal
c		components divided by the square root of the
c		appropriate eigenvalue.  Recall that the
c		LAPACK values are in ASCENDING order while
c		we want them in DESCENDING order; do the
c		switch in this loop.
c		--------------------------------------------
		do jascending=1, nmodes
			jdescending = nmodes - jascending + 1
                        if(abs(evals(jascending)) .le. DEPS ) then
                           fact        = 0.0d0
                        else
                           fact        = 1.0d0/sqrt(evals(jascending))
                        end if
			do i=1, nx
				eigenvectors(i,jdescending) =
     &			 	  	tentpcs(i,jascending)*fact
			end do
		end do

c		-----------------------------------------------
c		Next get unswitched principal components, which
c		are the switched eigenvectors multiplied by
c		the appropriate eigenvalues.
c		-----------------------------------------------
		do jascending=1, nmodes
			jdescending = nmodes - jascending + 1
			fact        = sqrt(evals(jascending))
			do i=1, nt
				princomp(i,jdescending) =
     &					evecs(i,jascending)*fact
			end do
		end do
	else
c		-------------------------------------------------
c		This is the unswitched case, and so it is easier.
c		All we have to do is return things in DESCENDING
c		order despite the fact that LAPACK returns them
c		in ASCENDING order.
c		Do the eigenvectors first...
c		-------------------------------------------------
		do jascending=1, nmodes
			jdescending = nmodes - jascending + 1
			do i=1, nx
				eigenvectors(i,jdescending) =
     &					evecs(i,jascending)
			end do
		end do

c		--------------------------------
c		...then the principal components
c		--------------------------------
		do jascending=1, nmodes
			jdescending = nmodes - jascending + 1
			do i=1, nt
				princomp(i,jdescending) =
     &					tentpcs(i,jascending)
			end do
		end do

	endif

c	--------------------------------------------
c	Do the second half of the areal weighting...
c	--------------------------------------------
	do mode=1, nmodes
	do i=1, nx
		if( sqrootweights(i) .eq. 0.0d0 ) then
			eigenvectors(i,mode) = 0.0d0
		else
			eigenvectors(i,mode) =
     &				eigenvectors(i,mode) / sqrootweights(i)
		endif
	end do
	end do

c	------------------------------------------------
c	Scale the eigenvectors to have a magnitude of 1;
c	scale the corresponding principal components to
c	reproduce the original data.
c	------------------------------------------------
	do mode=1, nmodes
c		----------------------------
c		Get the normalization factor
c		----------------------------
		sum = 0.0d0
		do i=1, nx
			sum = sum + eigenvectors(i,mode)*eigenvectors(i,mode)
		end do
		fact = sqrt(sum)
c		--------------------------
c		Normalize the eigenvectors
c		--------------------------
                if (fact.eq.0.0d0) then
                   do i=1, nx
			eigenvectors(i,mode) = 0.0d0
                   end do
                else
                   do i=1, nx
			eigenvectors(i,mode) = eigenvectors(i,mode)/fact
                   end do
                end if
c		----------------------------------
c		Normalize the principal components
c		----------------------------------
		do i=1, nt
			princomp(i,mode) = princomp(i,mode)*fact
		end do
	end do

c	-------------------------------------------------
c	Copy over just the requested number of
c	eigenvalues, and calculate the cumulative percent
c	variance explained.  Start by getting the total
c	variance in the field, so we can normalize by
c	that.
c	-------------------------------------------------
	call deoftotvar( data, nx, nt, totvar, doswitched,
     &		icovcor, covariance, correlation, dmsg )
        if (DEBUG) then
            print *," "
            print *,"totvar=",totvar
            print *," "
        end if

	sum = 0.0d0
	do jascending=nmodes, 1, -1
		jdescending = nmodes - jascending + 1
		eigenvalues(jdescending) = evals(jascending)
		variance(jdescending)    =
     &			eigenvalues(jdescending)/totvar*100.0d0
		sum = sum + variance(jdescending)
		cumvariance(jdescending) = sum
	end do

	return
	end
c --------------------------------------------------------

	subroutine deofcovcor( data, nx, nt, icovcor, covariance,
     &		correlation, spacked, doswitched, iminnxnt, dmsg )

c	-------------------------------------------------
c	Form the covariance or correlation matrix, put it
c	into 's'.  Note that 's' is always symmetric --
c	the correlation between X and Y is the same as
c	between Y and X -- so use packed storage for 's'.
c	The packed storage scheme we use is the same as
c	LAPACK uses so we can pass 's' directly to the
c	solver routine: the matrix is lower triangular,
c	and s(i,j) = spacked(i+(j-1)*(1*n-j)/2).
c
c	Inputs:
c		data(nx,nt): The basic data array.  THIS MUST
c			BE ANOMALIES.
c
c		nx, nt: size of data array
c			[INTEGER]
c
c		icovcor: if .eq. covariance, then calculate
c			the covariance array;
c			 if .eq. correlation, then calculate
c			the correlation array.
c			[INTEGER]
c
c		covariance, correlation: integer values to
c			indicate each of these options.
c			[INTEGER]
c
c		doswitched: if .TRUE., then calculate the
c			'switched' array (which is of size
c			(nt,nt)); if .FALSE., then calculate
c			the normal array of size (nx,nx).
c			[LOGICAL]
c
c		iminnxnt: min(nt,nx).  Used to dimension
c			'spacked'.
c
c	Outputs:
c
c		spacked(iminnxnt*(iminnxnt+1)/2): the covariance
c			or correlation array.  This is in packed
c			form corresponding to LAPACK's lower
c			triangular form.
c
c	David Pierce
c	Scripps Institution of Oceanography
c	Climate Research Division
c	dpierce@ucsd.edu
c	Jan 29, 1996
c	-------------------------------------------------

	implicit none

c	-----------------
c	Passed parameters
c	-----------------
	integer	nx, nt, icovcor, covariance, correlation, iminnxnt
	double precision data(nx,nt), spacked(iminnxnt*(iminnxnt+1)/2)
	double precision dmsg
	logical doswitched

c	---------------
c	Local variables
c	---------------
	integer	i, j, k, npts
	double precision sum, sum2, sum3, fact

	if( nx .le. 1 ) then
		print *, 'covariance: error: nx too small!! nx=', nx
c c c           call exit(-1)
                stop
	endif
	if( doswitched ) then
		do j=1, nt
		do i=j, nt
			sum  = 0.0d0
			sum2 = 0.0d0
			sum3 = 0.0d0
                        npts = 0
			do k=1, nx
                           if (data(k,i).ne.dmsg .and.
     &                         data(k,j).ne.dmsg) then
				sum  = sum  + data(k,i)*data(k,j)
				sum2 = sum2 + data(k,i)*data(k,i)
				sum3 = sum3 + data(k,j)*data(k,j)
                                npts = npts + 1
                           end if
			enddo
			if( icovcor .eq. covariance ) then
c c c                       fact = 1.0d0/float(nx-1)
                            fact = 1.0d0/float(npts-1)
			else
                            fact = 1.0d0/(sqrt(sum2)*sqrt(sum3))
			endif
                        spacked(i+(j-1)*(2*nt-j)/2) = sum*fact
		enddo
		enddo
	else
		do j=1, nx
		do i=j, nx
			sum  = 0.0d0
			sum2 = 0.0d0
			sum3 = 0.0d0
                        npts = 0
			do k=1, nt
                           if (data(i,k).ne.dmsg .and.
     &                         data(j,k).ne.dmsg) then
				sum  = sum  + data(j,k)*data(i,k)
				sum2 = sum2 + data(i,k)*data(i,k)
				sum3 = sum3 + data(j,k)*data(j,k)
                                npts = npts + 1
                           end if
			enddo
			if( icovcor .eq. covariance ) then
c c c                       fact = 1.0d0/float(nt-1)
                            fact = 1.0d0/float(npts-1)
			else
                            fact = 1.0d0/(sqrt(sum2)*sqrt(sum3))
			endif
			spacked(i+(j-1)*(2*nx-j)/2) = sum*fact
		enddo
		enddo
	endif

	return
	end

c --------------------------------------------------------

	subroutine deofpcs( data, nx, nt, nmodes, iminnxnt,
     &		imaxnxnt, evecs, doswitched, tentpcs, dmsg )

c       ------------------------------------------------
c       Compute the tentative principal components; they
c       are 'tentative' because they might be the PCs
c       of the switched data.  Put them into 'tentpcs',
c       which is of size (nt,nmodes) if we are doing
c       regular EOFs and (nx,nmodes) if we are doing
c       switched EOFs.  These PCs come out in order
c       corresponding to the order of 'evecs', which is
c       in ASCENDING order.
c
c	Inputs:
c
c		data(nx,nt): The input data.  THESE MUST
c			BE ANOMALIES.
c
c		nmodes: # of modes to calculate.
c
c		iminnxnt: min(nx,nt)
c
c		evecs(iminnxnt,nmodes): the eigenvectors
c			(which might be switched).
c
c		doswitched: if .TRUE., then we are doing
c			switched (space,time) calculation;
c			otherwise, regular (time,space)
c			calculation.
c
c	Outputs:
c
c		tentpcs(imaxnxnt,nmodes): the tentative
c			(possibly switched) principal
c			components.
c
c	David W. Pierce
c	Scripps Institution of Oceanography
c	Climate Research Division
c	dpierce@ucsd.edu
c	Jan 29, 1996
c       ------------------------------------------------

	implicit none

c	-----------------
c	Passed parameters
c	-----------------
	integer	nx, nt, nmodes, iminnxnt, imaxnxnt
	double precision data(nx,nt), evecs(iminnxnt,nmodes),
     &		tentpcs(imaxnxnt,nmodes), dmsg
	logical	doswitched

c	---------------
c	Local variables
c	---------------
	integer	i, j, k
	double precision	sum

	if( doswitched ) then
		do j=1, nmodes
		do i=1, nx
			sum = 0.0d0
			do k=1, nt
                           if (data(i,k).ne.dmsg) then
				sum = sum + data(i,k)*evecs(k,j)
                           end if
			enddo
			tentpcs(i,j) = sum
		enddo
		enddo
	else
		do j=1, nt
		do i=1, nmodes
			sum = 0.0d0
			do k=1, nx
                           if (data(k,j).ne.dmsg) then
				sum = sum + data(k,j)*evecs(k,i)
                           end if
			enddo
			tentpcs(j,i) = sum
		enddo
		enddo
	endif

	return
	end

c ------------------------------------------

	subroutine deoftotvar( data, nx, nt, totvar, doswitched,
     &		icovcor, covariance, correlation, dmsg )

c	-------------------------------------------------
c	Returns the total variance in the field so we can
c	normalize by it.
c
c	Inputs:
c
c		data(nx,nt): data to calculate upon
c
c		nx, nt:	size of 'data'.
c
c		doswitched: if .TRUE., then we are working
c			in switched (nx,nt) space, false
c			otherwise.
c
c		icovcor: if (icovcor .eq. covariance), then
c			we are using the covariance array;
c			if( icovcor .eq. correlation) then
c			we are using the correlation array.
c
c	Outputs:
c
c		totvar: estimate of total variance
c
c	-------------------------------------------------

	implicit none

	integer	nx, nt, icovcor, covariance, correlation
	double precision data(nx,nt), totvar, sum, fact, dmsg
	logical	doswitched
	integer	i, j, npts

	if( icovcor .eq. correlation ) then
		if( doswitched ) then
			totvar = nt
		else
			totvar = nx
		endif
		return
	endif

	totvar = 0.0d0
        if( doswitched ) then
            fact = 1.0d0/(nx-1.0d0)
        else
            fact = 1.0d0/(nt-1.0d0)
        endif
	do j=1, nt
		sum  = 0.0d0
		npts = 0
		do i=1, nx
                   if (data(i,j).ne.dmsg) then
			sum  = sum  + data(i,j)*data(i,j)
                        npts = npts + 1
                   end if
		enddo
                fact = 1.0d0/(npts-1.0d0)
		totvar = totvar + sum*fact
	enddo

	return
	end


!>  Contains the main types for profile data
module ProfileTypes
    use PrecisionMod, only: MK, PROFILE_POLAR_KIND
    use MathConstants, only: NaN
    implicit none
    type T_ProfilePolar
        integer :: nValues !< length of all polar vectors
        real(MK) :: Re !< Reynolds number
        real(PROFILE_POLAR_KIND), dimension(:), pointer :: alpha => null() !< Angle of attack in degrees from -XX to XX
        real(PROFILE_POLAR_KIND), dimension(:), pointer :: CL    => null() !< Lift coefficients
        real(PROFILE_POLAR_KIND), dimension(:), pointer :: CD    => null() !< Drag coefficients
        real(PROFILE_POLAR_KIND), dimension(:), pointer :: CM    => null() !< Moment coefficients
    end type

    type T_ProfileGeometry
        logical :: bFlatBack = .false. !< Is it a Flat back airfoil
        ! input data
        integer :: n_in = -1 !< dimension of x_in and y_in below
        real(MK), dimension(:), pointer :: x_in => null()
        real(MK), dimension(:), pointer :: y_in => null()
        ! normalized data, have to include the LE and TE points
        integer :: n_c = -1 !< dimension of x and y below
        real(MK), dimension(:), pointer :: x_c => null() !< x/c geometry coordinates, LE is x=, TE is x=
        real(MK), dimension(:), pointer :: y_c => null() !< y/c geometry coordinates, Upper side(Suction) is mainly y>0
        ! Data in Body coordinate, scaled with chord, twisted. etc.
        integer :: n = -1 !< dimension of x_in and y_in below
        real(MK), dimension(:), pointer :: x => null() !< x/c geometry coordinates, LE is x=, TE is x=
        real(MK), dimension(:), pointer :: y => null() !< y/c geometry coordinates, Upper side(Suction) is mainly y>0
        !
        real(MK) :: iLE !< index of LE point in x,y vectors
        real(MK) :: iTE !< index of TE point in x,y vectors
        ! "Linear theory variables"
        integer :: nMean_c = -1 !< dimension of x_mean_c and y_mean_c below
        real(MK), dimension(:), pointer :: x_mean_c => null() !< x Coordinate mean chord line, going from LE to TE
        real(MK), dimension(:), pointer :: y_mean_c => null() !<
        real(MK), dimension(:), pointer :: thickness_mean_c => null() !<
        real(MK) :: camber = NaN
        real(MK) :: thickness_max = NaN
    end type
    ! hawc type
    !      Type Tprofdata
    !          real(4) :: chord         =0.0d0                  ! Chord lenght of section
    !          real(4) :: thickness     =0.0d0                  ! Thickness in % of chord
    !          real(8),dimension(3):: vec_075to025 =[0.0d0,0.0d0,0.0d0] ! vector from C3/4 to C1/4 in [m]
    !          real(4) :: prof_set      =0.0d0                  ! Aerodynamic profile set number for this section
    !          integer :: nazi=360                             ! Number of profiles in interpolated profile coefficient arrays
    !          real(8)  :: dazi=2.0d0*3.14159265359/360     ! distance between data (is set to 2*pi/nazi)
    !          real(4),dimension(:),pointer :: CL,CD,CM         ! Interpolated profile coefficients
    !      end Type Tprofdata
    !  contains
end module ProfileTypes


c     cccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccccc
      subroutine bessj(nn,x,bj,bn)
c     ================================================================
c
c     computes spherical bessel function jl
c
      implicit   none
c
      integer    nn,l,k,i,nm
c
      real*8     flm,fll
c
      real*8     a,aj,x
      real*8     as,ac,x1,x2
c
      real*8     bj(nn),bn(nn)
      real*8     tol
      parameter  (tol=1.d-10)
c
      x1 = 1.d0/x
      if(abs(x1).lt.tol) then
        do l=1,nn
          bj(l)=0.d0
        enddo
        return
      endif
      as = sin(x)
      ac = cos(x)
      bj(1) = as*x1
c Forward recursion for small L
c (using bn as scratch space)
1     k=(int(abs(x))+2)/4+1
      bn(1)=as
      if(k.gt.1) then
	 if (k.gt.nn) k=nn
	 bn(2)=bj(1)-ac
	 bj(2)=bn(2)*x1
	 do l = 3, k
           flm = l+l-3
	   bn(l) = flm*bj(l-1)-bn(l-2)
	   bj(l)=bn(l)*x1
	 enddo
      endif

      if(k.lt.nn) then
c Backward recursion from very large L down to L=k
        a=bn(k)
        nm=nn*4
        aj=2*nm+1
        x2=x*x
        do l = nm, nn+2, -1
	   aj=(2*l-1)-x2/aj
        enddo
        bn(nn)=(2*nn+1)*aj*x1-x
        bj(nn)=bn(nn)*x1
        bn(nn-1)=(2*nn-1)*bj(nn)-aj
        do l = nn-1, k+1, -1
	   bj(l)=bn(l)*x1
	   bn(l-1)=(2*l-1)*bj(l)-bn(l+1)
        enddo
c scale to give correct bj(k)
        aj=a/bn(k)
        do l = k+1, nn
	   bj(l)=aj*bj(l)
        enddo
      endif

      return
      end


      SUBROUTINE CBALOD1
C
C CHANGE RECORD
C **  SUBROUTINES CBALOD CALCULATE GLOBAL VOLUME, MASS, MOMENTUM,
C **  AND ENERGY BALANCES
C
      USE GLOBAL
      IF(NBALO.GT.1) RETURN
C
C **  INITIALIZE VOLUME, SALT MASS, DYE MASS, MOMENTUM, KINETIC ENERGY
C **  AND POTENTIAL ENERGY, AND ASSOCIATED FLUXES
C
      VOLBEGO=0.
      SALBEGO=0.
      DYEBEGO=0.
      UMOBEGO=0.
      VMOBEGO=0.
      UUEBEGO=0.
      VVEBEGO=0.
      PPEBEGO=0.
      BBEBEGO=0.
      VOLOUTO=0.
      SALOUTO=0.
      DYEOUTO=0.
      UMOOUTO=0.
      VMOOUTO=0.
      UUEOUTO=0.
      VVEOUTO=0.
      PPEOUTO=0.
      BBEOUTO=0.
      DO L=2,LA
        LN=LNC(L)
        VOLBEGO=VOLBEGO+SPB(L)*DXYP(L)*H1P(L)
        UMOBEGO=UMOBEGO+SPB(L)*0.5*DXYP(L)*H1P(L)
     &      *(DYIU(L)*UHDY1E(L)/H1U(L)+DYIU(LEAST(L))*UHDY1E(LEAST(L))/H1U(LEAST(L)))
        VMOBEGO=VMOBEGO+SPB(L)*0.5*DXYP(L)*H1P(L)
     &      *(DXIV(L)*VHDX1E(L)/H1V(L)+DXIV(LN)*VHDX1E(LN)/H1V(LN))
        PPEBEGO=PPEBEGO+SPB(L)*0.5*DXYP(L)
     &      *(GI*P1(L)*P1(L)-G*BELV(L)*BELV(L))
      ENDDO
      AMOBEGO=SQRT(UMOBEGO*UMOBEGO+VMOBEGO*VMOBEGO)
      DO K=1,KC
        DO L=2,LA
          LN=LNC(L)
          SALBEGO=SALBEGO+SCB(L)*DXYP(L)*H1P(L)*SAL1(L,K)*DZC(K)
          DYEBEGO=DYEBEGO+SCB(L)*DXYP(L)*H1P(L)*DYE1(L,K)*DZC(K)
          UUEBEGO=UUEBEGO+SPB(L)*0.125*DXYP(L)*H1P(L)*DZC(K)
     &        *( (U1(L,K)+U1(LEAST(L),K))*(U1(L,K)+U1(LEAST(L),K)) )
          VVEBEGO=VVEBEGO+SPB(L)*0.125*DXYP(L)*H1P(L)*DZC(K)
     &        *( (V1(L,K)+V1(LN,K))*(V1(L,K)+V1(LN,K)) )
          BBEBEGO=BBEBEGO+SPB(L)*GP*DXYP(L)*H1P(L)*DZC(K)*( BELV(L)
     &        +0.5*H1P(L)*(Z(K)+Z(K-1)) )*B1(L,K)
        ENDDO
      ENDDO
      RETURN
      END


      SUBROUTINE IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U,
     $                   LDU, Y, LDY, R, LDR, IWORK, DWORK, LDWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To construct an upper triangular factor  R  of the concatenated
C     block Hankel matrices using input-output data.  The input-output
C     data can, optionally, be processed sequentially.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     METH    CHARACTER*1
C             Specifies the subspace identification method to be used,
C             as follows:
C             = 'M':  MOESP  algorithm with past inputs and outputs;
C             = 'N':  N4SID  algorithm.
C
C     ALG     CHARACTER*1
C             Specifies the algorithm for computing the triangular
C             factor R, as follows:
C             = 'C':  Cholesky algorithm applied to the correlation
C                     matrix of the input-output data;
C             = 'F':  Fast QR algorithm;
C             = 'Q':  QR algorithm applied to the concatenated block
C                     Hankel matrices.
C
C     BATCH   CHARACTER*1
C             Specifies whether or not sequential data processing is to
C             be used, and, for sequential processing, whether or not
C             the current data block is the first block, an intermediate
C             block, or the last block, as follows:
C             = 'F':  the first block in sequential data processing;
C             = 'I':  an intermediate block in sequential data
C                     processing;
C             = 'L':  the last block in sequential data processing;
C             = 'O':  one block only (non-sequential data processing).
C             NOTE that when  100  cycles of sequential data processing
C                  are completed for  BATCH = 'I',  a warning is
C                  issued, to prevent for an infinite loop.
C
C     CONCT   CHARACTER*1
C             Specifies whether or not the successive data blocks in
C             sequential data processing belong to a single experiment,
C             as follows:
C             = 'C':  the current data block is a continuation of the
C                     previous data block and/or it will be continued
C                     by the next data block;
C             = 'N':  there is no connection between the current data
C                     block and the previous and/or the next ones.
C             This parameter is not used if BATCH = 'O'.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             The number of block rows,  s,  in the input and output
C             block Hankel matrices to be processed.  NOBR > 0.
C             (In the MOESP theory,  NOBR  should be larger than  n,
C             the estimated dimension of state vector.)
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C             When M = 0, no system inputs are processed.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     NSMP    (input) INTEGER
C             The number of rows of matrices  U  and  Y  (number of
C             samples,  t). (When sequential data processing is used,
C             NSMP  is the number of samples of the current data
C             block.)
C             NSMP >= 2*(M+L+1)*NOBR - 1,  for non-sequential
C                                          processing;
C             NSMP >= 2*NOBR,  for sequential processing.
C             The total number of samples when calling the routine with
C             BATCH = 'L'  should be at least  2*(M+L+1)*NOBR - 1.
C             The  NSMP  argument may vary from a cycle to another in
C             sequential data processing, but  NOBR, M,  and  L  should
C             be kept constant. For efficiency, it is advisable to use
C             NSMP  as large as possible.
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU,M)
C             The leading NSMP-by-M part of this array must contain the
C             t-by-m input-data sequence matrix  U,
C             U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
C             NSMP  values of the j-th input component for consecutive
C             time increments.
C             If M = 0, this array is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= NSMP, if M > 0;
C             LDU >= 1,    if M = 0.
C
C     Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
C             The leading NSMP-by-L part of this array must contain the
C             t-by-l output-data sequence matrix  Y,
C             Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
C             NSMP  values of the j-th output component for consecutive
C             time increments.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= NSMP.
C
C     R       (output or input/output) DOUBLE PRECISION array, dimension
C             ( LDR,2*(M+L)*NOBR )
C             On exit, if INFO = 0 and ALG = 'Q', or (ALG = 'C' or 'F',
C             and BATCH = 'L' or 'O'), the leading
C             2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of
C             this array contains the (current) upper triangular factor
C             R from the QR factorization of the concatenated block
C             Hankel matrices. The diagonal elements of R are positive
C             when the Cholesky algorithm was successfully used.
C             On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading
C             2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this
C             array contains the current upper triangular part of the
C             correlation matrix in sequential data processing.
C             If ALG = 'F' and BATCH = 'F' or 'I', the array R is not
C             referenced.
C             On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or
C             'L', the leading  2*(M+L)*NOBR-by-2*(M+L)*NOBR  upper
C             triangular part of this array must contain the upper
C             triangular matrix R computed at the previous call of this
C             routine in sequential data processing. The array R need
C             not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'.
C
C     LDR     INTEGER
C             The leading dimension of the array  R.
C             LDR >= 2*(M+L)*NOBR.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK >= MAX(3,M+L), if ALG = 'F';
C             LIWORK >= 3,          if ALG = 'C' or 'Q'.
C             On entry with  BATCH = 'I'  or  BATCH = 'L',  IWORK(1:3)
C             must contain the values of ICYCLE, MAXWRK, and NSMPSM
C             set by the previous call of this routine.
C             On exit with  BATCH = 'F'  or  BATCH = 'I',  IWORK(1:3)
C             contains the values of ICYCLE, MAXWRK, and NSMPSM to be
C             used by the next call of the routine.
C             ICYCLE  counts the cycles for  BATCH = 'I'.
C             MAXWRK  stores the current optimal workspace.
C             NSMPSM  sums up the  NSMP  values for  BATCH <> 'O'.
C             The first three elements of  IWORK  should be preserved
C             during successive calls of the routine with  BATCH = 'F'
C             or  BATCH = 'I',  till the final call with   BATCH = 'L'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1)  returns the optimal
C             value of LDWORK.
C             On exit, if  INFO = -17,  DWORK(1)  returns the minimum
C             value of LDWORK.
C             Let
C             k = 0,               if CONCT = 'N' and ALG = 'C' or 'Q';
C             k = 2*NOBR-1,        if CONCT = 'C' and ALG = 'C' or 'Q';
C             k = 2*NOBR*(M+L+1),  if CONCT = 'N' and ALG = 'F';
C             k = 2*NOBR*(M+L+2),  if CONCT = 'C' and ALG = 'F'.
C             The first (M+L)*k elements of  DWORK  should be preserved
C             during successive calls of the routine with  BATCH = 'F'
C             or  'I',  till the final call with  BATCH = 'L'.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH <> 'O' and
C                                     CONCT = 'C';
C             LDWORK >= 1,            if ALG = 'C', BATCH = 'O' or
C                                     CONCT = 'N';
C             LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F',
C                                     BATCH <> 'O' and CONCT = 'C';
C             LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F',
C                                     BATCH = 'F', 'I' and CONCT = 'N';
C             LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F',
C                                     BATCH = 'L' and CONCT = 'N', or
C                                     BATCH = 'O';
C             LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O',
C                                     and LDR >= NS = NSMP - 2*NOBR + 1;
C             LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F' or 'O',
C                                     and LDR < NS, or BATCH = 'I' or
C                                     'L' and CONCT = 'N';
C             LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I'
C                                     or 'L' and CONCT = 'C'.
C             The workspace used for ALG = 'Q' is
C                       LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR,
C             where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended
C             value LDRWRK = NS, assuming a large enough cache size.
C             For good performance,  LDWORK  should be larger.
C
C             If LDWORK = -1, then a workspace query is assumed;
C             the routine only calculates the optimal size of the
C             DWORK array, returns this value as the first entry of
C             the DWORK array, and no error message related to LDWORK
C             is issued by XERBLA.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  the number of 100 cycles in sequential data
C                   processing has been exhausted without signaling
C                   that the last block of data was get; the cycle
C                   counter was reinitialized;
C             = 2:  a fast algorithm was requested (ALG = 'C' or 'F'),
C                   but it failed, and the QR algorithm was then used
C                   (non-sequential data processing).
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  a fast algorithm was requested (ALG = 'C', or 'F')
C                   in sequential data processing, but it failed. The
C                   routine can be repeatedly called again using the
C                   standard QR algorithm.
C
C     METHOD
C
C     1) For non-sequential data processing using QR algorithm, a
C     t x 2(m+l)s  matrix H is constructed, where
C
C          H = [ Uf'         Up'      Y'      ],  for METH = 'M',
C                  s+1,2s,t    1,s,t   1,2s,t
C
C          H = [ U'       Y'      ],              for METH = 'N',
C                 1,2s,t   1,2s,t
C
C     and  Up     , Uf        , U      , and  Y        are block Hankel
C            1,s,t    s+1,2s,t   1,2s,t        1,2s,t
C     matrices defined in terms of the input and output data [3].
C     A QR factorization is used to compress the data.
C     The fast QR algorithm uses a QR factorization which exploits
C     the block-Hankel structure. Actually, the Cholesky factor of H'*H
C     is computed.
C
C     2) For sequential data processing using QR algorithm, the QR
C     decomposition is done sequentially, by updating the upper
C     triangular factor  R.  This is also performed internally if the
C     workspace is not large enough to accommodate an entire batch.
C
C     3) For non-sequential or sequential data processing using
C     Cholesky algorithm, the correlation matrix of input-output data is
C     computed (sequentially, if requested), taking advantage of the
C     block Hankel structure [7].  Then, the Cholesky factor of the
C     correlation matrix is found, if possible.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Dewilde, P.
C         Subspace Model Identification. Part 1: The output-error
C         state-space model identification class of algorithms.
C         Int. J. Control, 56, pp. 1187-1210, 1992.
C
C     [2] Verhaegen M.
C         Subspace Model Identification. Part 3: Analysis of the
C         ordinary output-error state-space model identification
C         algorithm.
C         Int. J. Control, 58, pp. 555-586, 1993.
C
C     [3] Verhaegen M.
C         Identification of the deterministic part of MIMO state space
C         models given in innovations form from input-output data.
C         Automatica, Vol.30, No.1, pp.61-74, 1994.
C
C     [4] Van Overschee, P., and De Moor, B.
C         N4SID: Subspace Algorithms for the Identification of
C         Combined Deterministic-Stochastic Systems.
C         Automatica, Vol.30, No.1, pp. 75-93, 1994.
C
C     [5] Peternell, K., Scherrer, W. and Deistler, M.
C         Statistical Analysis of Novel Subspace Identification Methods.
C         Signal Processing, 52, pp. 161-177, 1996.
C
C     [6] Sima, V.
C         Subspace-based Algorithms for Multivariable System
C         Identification.
C         Studies in Informatics and Control, 5, pp. 335-344, 1996.
C
C     [7] Sima, V.
C         Cholesky or QR Factorization for Data Compression in
C         Subspace-based Identification ?
C         Proceedings of the Second NICONET Workshop on ``Numerical
C         Control Software: SLICOT, a Useful Tool in Industry'',
C         December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable (when QR algorithm is
C     used), reliable and efficient. The fast Cholesky or QR algorithms
C     are more efficient, but the accuracy could diminish by forming the
C     correlation matrix.
C                                        2
C     The QR algorithm needs 0(t(2(m+l)s) ) floating point operations.
C                                           2              3
C     The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating
C     point operations.
C                                          2           3 2
C     The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating
C     point operations.
C
C     FURTHER COMMENTS
C
C     For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the
C     calculations could be rather inefficient if only minimal workspace
C     (see argument LDWORK) is provided. It is advisable to provide as
C     much workspace as possible. Almost optimal efficiency can be
C     obtained for  LDWORK = (NS+2)*(2*(M+L)*NOBR),  assuming that the
C     cache size is large enough to accommodate R, U, Y, and DWORK.
C
C     CONTRIBUTOR
C
C     V. Sima, Research Institute for Informatics, Bucharest, Aug. 1999.
C
C     REVISIONS
C
C     Feb. 2000, Aug. 2000, Feb. 2004, Apr. 2011, June 2012, May 2020.
C
C     KEYWORDS
C
C     Cholesky decomposition, Hankel matrix, identification methods,
C     multivariable systems, QR decomposition.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ZERO, ONE
      PARAMETER          ( ZERO = 0.0D0, ONE = 1.0D0 )
      INTEGER            MAXCYC
      PARAMETER          ( MAXCYC = 100 )
C     .. Scalar Arguments ..
      INTEGER            INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, NOBR,
     $                   NSMP
      CHARACTER          ALG, BATCH, CONCT, METH
C     .. Array Arguments ..
      INTEGER            IWORK(*)
      DOUBLE PRECISION   DWORK(*), R(LDR, *), U(LDU, *), Y(LDY, *)
C     .. Local Scalars ..
      DOUBLE PRECISION   UPD, TEMP
      INTEGER            I, ICOL, ICYCLE, ID, IERR, II, INICYC, INIT,
     $                   INITI, INU, INY, IREV, ISHFT2, ISHFTU, ISHFTY,
     $                   ITAU, J, JD, JWORK, LDRWMX, LDRWRK, LLDRW,
     $                   LMNOBR, LNOBR, MAXWRK, MINWRK, MLDRW, MMNOBR,
     $                   MNOBR, NCYCLE, NICYCL, NOBR2, NOBR21, NOBRM1,
     $                   NR, NS, NSF, NSL, NSLAST, NSMPSM
      LOGICAL            CHALG, CONNEC, FIRST, FQRALG, INTERM, LAST,
     $                   LINR, LQUERY, MOESP, N4SID, ONEBCH, QRALG
C     .. Local Arrays ..
      DOUBLE PRECISION   DUM( 1 )
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           DAXPY, DCOPY, DGEMM, DGEQRF, DGER, DLACPY,
     $                   DLASET, DPOTRF, DSWAP, DSYRK, IB01MY, MB04OD,
     $                   XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          INT, MAX, MIN
C     ..
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MOESP  = LSAME( METH,  'M' )
      N4SID  = LSAME( METH,  'N' )
      FQRALG = LSAME( ALG,   'F' )
      QRALG  = LSAME( ALG,   'Q' )
      CHALG  = LSAME( ALG,   'C' )
      ONEBCH = LSAME( BATCH, 'O' )
      FIRST  = LSAME( BATCH, 'F' ) .OR. ONEBCH
      INTERM = LSAME( BATCH, 'I' )
      LAST   = LSAME( BATCH, 'L' ) .OR. ONEBCH
      IF( .NOT.ONEBCH ) THEN
         CONNEC = LSAME( CONCT, 'C' )
      ELSE
         CONNEC = .FALSE.
      END IF
C
      MNOBR  = M*NOBR
      LNOBR  = L*NOBR
      LMNOBR = LNOBR + MNOBR
      MMNOBR = MNOBR + MNOBR
      NOBRM1 = NOBR - 1
      NOBR21 = NOBR + NOBRM1
      NOBR2  = NOBR21 + 1
      IWARN  = 0
      INFO   = 0
      IERR   = 0
      IF( FIRST ) THEN
         ICYCLE = 1
         MAXWRK = 1
         NSMPSM = 0
      ELSE IF( .NOT.ONEBCH ) THEN
         ICYCLE = IWORK(1)
         MAXWRK = IWORK(2)
         NSMPSM = IWORK(3)
      END IF
      NSMPSM = NSMPSM + NSMP
      NR = LMNOBR + LMNOBR
C
C     Check the scalar input parameters.
C
      IF( .NOT.( MOESP .OR. N4SID ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN
         INFO = -2
      ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN
         INFO = -3
      ELSE IF( .NOT. ONEBCH ) THEN
         IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) )
     $      INFO = -4
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( NOBR.LE.0 ) THEN
            INFO = -5
         ELSE IF( M.LT.0 ) THEN
            INFO = -6
         ELSE IF( L.LE.0 ) THEN
            INFO = -7
         ELSE IF( NSMP.LT.NOBR2 .OR.
     $          ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN
            INFO = -8
         ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN
            INFO = -10
         ELSE IF( LDY.LT.NSMP ) THEN
            INFO = -12
         ELSE IF( LDR.LT.NR ) THEN
            INFO = -14
         ELSE
            LQUERY = LDWORK.EQ.-1
C
C           Compute workspace.
C           (Note: Comments in the code beginning "Workspace:" describe
C           the minimal amount of workspace needed at that point in the
C           code, as well as the preferred amount for good performance.
C           NB refers to the optimal block size for the immediately
C           following subroutine, as returned by ILAENV.)
C
            NS = NSMP - NOBR21
            IF ( CHALG ) THEN
               IF ( .NOT.ONEBCH .AND. CONNEC ) THEN
                  MINWRK = 2*( NR - M - L )
               ELSE
                  MINWRK = 1
               END IF
            ELSE IF ( FQRALG ) THEN
               IF ( .NOT.ONEBCH .AND. CONNEC ) THEN
                  MINWRK = NR*( M + L + 3 )
               ELSE IF ( FIRST .OR. INTERM ) THEN
                  MINWRK = NR*( M + L + 1 )
               ELSE
                  MINWRK = 2*NR*( M + L + 1 ) + NR
               END IF
               IF ( LQUERY ) THEN
                  CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U,
     $                         LDU, Y, LDY, R, LDR, IWORK, DWORK, -1,
     $                         IWARN, IERR )
                  MAXWRK = INT( DWORK(1) )
               END IF
            ELSE
               MINWRK = 2*NR
               CALL DGEQRF( NS, NR, DWORK, NS, DWORK, DWORK, -1, IERR )
               MAXWRK = NR + INT( DWORK(1) )
               IF ( FIRST ) THEN
                  IF ( LDR.LT.NS ) THEN
                     MINWRK = MINWRK + NR
                     MAXWRK = NS*NR  + MAXWRK
                  END IF
               ELSE
                  IF ( CONNEC ) THEN
                     MINWRK = MINWRK*( NOBR + 1 )
                  ELSE
                     MINWRK = MINWRK + NR
                  END IF
                  MAXWRK = NS*NR + MAXWRK
               END IF
            END IF
            MAXWRK = MAX( MINWRK, MAXWRK )
C
            IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY ) THEN
               INFO = -17
               DWORK( 1 ) = MINWRK
            END IF
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         IF( .NOT.ONEBCH ) THEN
            IWORK(1) = 1
            IWORK(2) = MAXWRK
            IWORK(3) = 0
         END IF
         IF ( INFO.EQ.-17 )
     $      DWORK(1) = MINWRK
         CALL XERBLA( 'IB01MD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = MAXWRK
         RETURN
      END IF
C
      IF ( CHALG ) THEN
C
C        Compute the  R  factor from a Cholesky factorization of the
C        input-output data correlation matrix.
C
C        Set the parameters for constructing the correlations of the
C        current block.
C
         LDRWRK = 2*NOBR2 - 2
         IF( FIRST ) THEN
            UPD = ZERO
         ELSE
            UPD = ONE
         END IF
C
         IF( .NOT.FIRST .AND. CONNEC ) THEN
C
C           Restore the saved (M+L)*(2*NOBR-1) "connection" elements of
C           U  and  Y  into their appropriate position in sequential
C           processing. The process is performed column-wise, in
C           reverse order, first for  Y  and then for  U.
C           Workspace: need   (4*NOBR-2)*(M+L).
C
            IREV =     NR - M - L   - NOBR21 + 1
            ICOL = 2*( NR - M - L ) - LDRWRK + 1
C
            DO 10 J = 2, M + L
               DO 5 I = NOBR21 - 1, 0, -1
                  DWORK(ICOL+I) = DWORK(IREV+I)
    5          CONTINUE
               IREV = IREV - NOBR21
               ICOL = ICOL - LDRWRK
   10       CONTINUE
C
            IF ( M.GT.0 )
     $         CALL DLACPY( 'Full', NOBR21, M, U, LDU, DWORK(NOBR2),
     $                      LDRWRK )
            CALL DLACPY( 'Full', NOBR21, L, Y, LDY,
     $                   DWORK(LDRWRK*M+NOBR2), LDRWRK )
         END IF
C
         IF ( M.GT.0 ) THEN
C
C           Let  Guu(i,j) = Guu0(i,j) + u_i*u_j' + u_(i+1)*u_(j+1)' +
C                                 ... + u_(i+NS-1)*u_(j+NS-1)',
C           where  u_i'  is the i-th row of  U,  j = 1 : 2s,  i = 1 : j,
C           NS = NSMP - 2s + 1,  and  Guu0(i,j)  is a zero matrix for
C           BATCH = 'O' or 'F', and it is the matrix Guu(i,j) computed
C           till the current block for BATCH = 'I' or 'L'. The matrix
C           Guu(i,j)  is  m-by-m,  and  Guu(j,j)  is symmetric. The
C           upper triangle of the U-U correlations,  Guu,  is computed
C           (or updated) column-wise in the array  R,  that is, in the
C           order  Guu(1,1),  Guu(1,2),  Guu(2,2),  ...,  Guu(2s,2s).
C           Only the submatrices of the first block-row are fully
C           computed (or updated). The remaining ones are determined
C           exploiting the block-Hankel structure, using the updating
C           formula
C
C           Guu(i+1,j+1) = Guu0(i+1,j+1) - Guu0(i,j) + Guu(i,j) +
C                                 u_(i+NS)*u_(j+NS)' - u_i*u_j'.
C
            IF( .NOT.FIRST ) THEN
C
C              Subtract the contribution of the previous block of data
C              in sequential processing. The columns must be processed
C              in backward order.
C
               DO 20 I = NOBR21*M, 1, -1
                  CALL DAXPY( I, -ONE, R(1,I), 1, R(M+1,M+I), 1 )
   20          CONTINUE
C
            END IF
C
C           Compute/update  Guu(1,1).
C
            IF( .NOT.FIRST .AND. CONNEC )
     $         CALL DSYRK( 'Upper', 'Transpose', M, NOBR21, ONE, DWORK,
     $                     LDRWRK, UPD, R, LDR )
            CALL DSYRK( 'Upper', 'Transpose', M, NS, ONE, U, LDU, UPD,
     $                  R, LDR )
C
            JD = 1
C
            IF( FIRST .OR. .NOT.CONNEC ) THEN
C
               DO 70 J = 2, NOBR2
                  JD = JD + M
                  ID = M  + 1
C
C                 Compute/update  Guu(1,j).
C
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE,
     $                        U, LDU, U(J,1), LDU, UPD, R(1,JD), LDR )
C
C                 Compute/update  Guu(2:j,j), exploiting the
C                 block-Hankel structure.
C
                  IF( FIRST ) THEN
C
                     DO 30 I = JD - M, JD - 1
                        CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 )
   30                CONTINUE
C
                  ELSE
C
                     DO 40 I = JD - M, JD - 1
                        CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 )
   40                CONTINUE
C
                  END IF
C
                  DO 50 I = 2, J - 1
                     CALL DGER( M, M, ONE, U(NS+I-1,1), LDU,
     $                          U(NS+J-1,1), LDU, R(ID,JD), LDR )
                     CALL DGER( M, M, -ONE, U(I-1,1), LDU, U(J-1,1),
     $                          LDU, R(ID,JD), LDR )
                     ID = ID + M
   50             CONTINUE
C
                  DO 60 I = 1, M
                     CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU,
     $                           R(JD,JD+I-1), 1 )
                     CALL DAXPY( I, -U(J-1,I), U(J-1,1), LDU,
     $                           R(JD,JD+I-1), 1 )
   60             CONTINUE
C
   70          CONTINUE
C
            ELSE
C
               DO 120 J = 2, NOBR2
                  JD = JD + M
                  ID = M  + 1
C
C                 Compute/update  Guu(1,j)  for sequential processing
C                 with connected blocks.
C
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NOBR21,
     $                        ONE, DWORK, LDRWRK, DWORK(J), LDRWRK, UPD,
     $                        R(1,JD), LDR )
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, M, NS, ONE,
     $                        U, LDU, U(J,1), LDU, ONE, R(1,JD), LDR )
C
C                 Compute/update  Guu(2:j,j)  for sequential processing
C                 with connected blocks, exploiting the block-Hankel
C                 structure.
C
                  IF( FIRST ) THEN
C
                     DO 80 I = JD - M, JD - 1
                        CALL DCOPY( I, R(1,I), 1, R(M+1,M+I), 1 )
   80                CONTINUE
C
                  ELSE
C
                     DO 90 I = JD - M, JD - 1
                        CALL DAXPY( I, ONE, R(1,I), 1, R(M+1,M+I), 1 )
   90                CONTINUE
C
                  END IF
C
                  DO 100 I = 2, J - 1
                     CALL DGER( M, M, ONE, U(NS+I-1,1), LDU,
     $                          U(NS+J-1,1), LDU, R(ID,JD), LDR )
                     CALL DGER( M, M, -ONE, DWORK(I-1), LDRWRK,
     $                          DWORK(J-1), LDRWRK, R(ID,JD), LDR )
                     ID = ID + M
  100             CONTINUE
C
                  DO 110 I = 1, M
                     CALL DAXPY( I, U(NS+J-1,I), U(NS+J-1,1), LDU,
     $                           R(JD,JD+I-1), 1 )
                     CALL DAXPY( I, -DWORK((I-1)*LDRWRK+J-1),
     $                           DWORK(J-1), LDRWRK, R(JD,JD+I-1), 1 )
  110             CONTINUE
C
  120          CONTINUE
C
            END IF
C
            IF ( LAST .AND. MOESP ) THEN
C
C              Interchange past and future parts for MOESP algorithm.
C              (Only the upper triangular parts are interchanged, and
C              the (1,2) part is transposed in-situ.)
C
               TEMP = R(1,1)
               R(1,1) = R(MNOBR+1,MNOBR+1)
               R(MNOBR+1,MNOBR+1) = TEMP
C
               DO 130 J = 2, MNOBR
                  CALL DSWAP( J, R(1,J), 1, R(MNOBR+1,MNOBR+J), 1 )
                  CALL DSWAP( J-1, R(1,MNOBR+J), 1, R(J,MNOBR+1), LDR )
  130          CONTINUE
C
            END IF
C
C           Let  Guy(i,j) = Guy0(i,j) + u_i*y_j' + u_(i+1)*y_(j+1)' +
C                                 ... + u_(i+NS-1)*y_(j+NS-1)',
C           where  u_i'  is the i-th row of  U,  y_j'  is the j-th row
C           of  Y,  j = 1 : 2s,  i = 1 : 2s,  NS = NSMP - 2s + 1,  and
C           Guy0(i,j)  is a zero matrix for  BATCH = 'O' or 'F', and it
C           is the matrix Guy(i,j) computed till the current block for
C           BATCH = 'I' or 'L'.  Guy(i,j) is m-by-L. The U-Y
C           correlations,  Guy,  are computed (or updated) column-wise
C           in the array  R. Only the submatrices of the first block-
C           column and block-row are fully computed (or updated). The
C           remaining ones are determined exploiting the block-Hankel
C           structure, using the updating formula
C
C           Guy(i+1,j+1) = Guy0(i+1,j+1) - Guy0(i,j) + Guy(i,j) +
C                                 u_(i+NS)*y(j+NS)' - u_i*y_j'.
C
            II = MMNOBR - M
            IF( .NOT.FIRST ) THEN
C
C              Subtract the contribution of the previous block of data
C              in sequential processing. The columns must be processed
C              in backward order.
C
               DO 140 I = NR - L, MMNOBR + 1, -1
                  CALL DAXPY( II, -ONE, R(1,I), 1, R(M+1,L+I), 1 )
  140          CONTINUE
C
            END IF
C
C           Compute/update the first block-column of  Guy,  Guy(i,1).
C
            IF( FIRST .OR. .NOT.CONNEC ) THEN
C
               DO 150 I = 1, NOBR2
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE,
     $                        U(I,1), LDU, Y, LDY, UPD,
     $                        R((I-1)*M+1,MMNOBR+1), LDR )
  150          CONTINUE
C
            ELSE
C
               DO 160 I = 1, NOBR2
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21,
     $                        ONE, DWORK(I), LDRWRK, DWORK(LDRWRK*M+1),
     $                        LDRWRK, UPD, R((I-1)*M+1,MMNOBR+1), LDR )
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE,
     $                        U(I,1), LDU, Y, LDY, ONE,
     $                        R((I-1)*M+1,MMNOBR+1), LDR )
  160          CONTINUE
C
            END IF
C
            JD = MMNOBR + 1
C
            IF( FIRST .OR. .NOT.CONNEC ) THEN
C
               DO 200 J = 2, NOBR2
                  JD = JD + L
                  ID = M  + 1
C
C                 Compute/update  Guy(1,j).
C
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE,
     $                        U, LDU, Y(J,1), LDY, UPD, R(1,JD), LDR )
C
C                 Compute/update  Guy(2:2*s,j), exploiting the
C                 block-Hankel structure.
C
                  IF( FIRST ) THEN
C
                     DO 170 I = JD - L, JD - 1
                        CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 )
  170                CONTINUE
C
                  ELSE
C
                     DO 180 I = JD - L, JD - 1
                        CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 )
  180                CONTINUE
C
                  END IF
C
                  DO 190 I = 2, NOBR2
                     CALL DGER( M, L, ONE, U(NS+I-1,1), LDU,
     $                          Y(NS+J-1,1), LDY, R(ID,JD), LDR )
                     CALL DGER( M, L, -ONE, U(I-1,1), LDU, Y(J-1,1),
     $                          LDY, R(ID,JD), LDR )
                     ID = ID + M
  190             CONTINUE
C
  200          CONTINUE
C
            ELSE
C
               DO 240 J = 2, NOBR2
                  JD = JD + L
                  ID = M  + 1
C
C                 Compute/update  Guy(1,j)  for sequential processing
C                 with connected blocks.
C
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NOBR21,
     $                        ONE, DWORK, LDRWRK, DWORK(LDRWRK*M+J),
     $                        LDRWRK, UPD, R(1,JD), LDR )
                  CALL DGEMM( 'Transpose', 'NoTranspose', M, L, NS, ONE,
     $                        U, LDU, Y(J,1), LDY, ONE, R(1,JD), LDR )
C
C                 Compute/update  Guy(2:2*s,j)  for sequential
C                 processing with connected blocks, exploiting the
C                 block-Hankel structure.
C
                  IF( FIRST ) THEN
C
                     DO 210 I = JD - L, JD - 1
                        CALL DCOPY( II, R(1,I), 1, R(M+1,L+I), 1 )
  210                CONTINUE
C
                  ELSE
C
                     DO 220 I = JD - L, JD - 1
                        CALL DAXPY( II, ONE, R(1,I), 1, R(M+1,L+I), 1 )
  220                CONTINUE
C
                  END IF
C
                  DO 230 I = 2, NOBR2
                     CALL DGER( M, L, ONE, U(NS+I-1,1), LDU,
     $                          Y(NS+J-1,1), LDY, R(ID,JD), LDR )
                     CALL DGER( M, L, -ONE, DWORK(I-1), LDRWRK,
     $                          DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD),
     $                          LDR )
                     ID = ID + M
  230             CONTINUE
C
  240          CONTINUE
C
            END IF
C
            IF ( LAST .AND. MOESP ) THEN
C
C              Interchange past and future parts of U-Y correlations
C              for MOESP algorithm.
C
               DO 250 J = MMNOBR + 1, NR
                  CALL DSWAP( MNOBR, R(1,J), 1, R(MNOBR+1,J), 1 )
  250          CONTINUE
C
            END IF
         END IF
C
C        Let  Gyy(i,j) = Gyy0(i,j) + y_i*y_i' + y_(i+1)*y_(i+1)' + ... +
C                                    y_(i+NS-1)*y_(i+NS-1)',
C        where  y_i'  is the i-th row of  Y,  j = 1 : 2s,  i = 1 : j,
C        NS = NSMP - 2s + 1,  and  Gyy0(i,j)  is a zero matrix for
C        BATCH = 'O' or 'F', and it is the matrix Gyy(i,j) computed till
C        the current block for BATCH = 'I' or 'L'.  Gyy(i,j) is L-by-L,
C        and  Gyy(j,j)  is symmetric. The upper triangle of the Y-Y
C        correlations,  Gyy,  is computed (or updated) column-wise in
C        the corresponding part of the array  R,  that is, in the order
C        Gyy(1,1),  Gyy(1,2),  Gyy(2,2),  ...,  Gyy(2s,2s).  Only the
C        submatrices of the first block-row are fully computed (or
C        updated). The remaining ones are determined exploiting the
C        block-Hankel structure, using the updating formula
C
C        Gyy(i+1,j+1) = Gyy0(i+1,j+1) - Gyy0(i,j) + Gyy(i,j) +
C                              y_(i+NS)*y_(j+NS)' - y_i*y_j'.
C
         JD = MMNOBR + 1
C
         IF( .NOT.FIRST ) THEN
C
C           Subtract the contribution of the previous block of data
C           in sequential processing. The columns must be processed in
C           backward order.
C
            DO 260 I = NR - L, MMNOBR + 1, -1
               CALL DAXPY( I-MMNOBR, -ONE, R(JD,I), 1, R(JD+L,L+I), 1 )
  260       CONTINUE
C
         END IF
C
C        Compute/update  Gyy(1,1).
C
         IF( .NOT.FIRST .AND. CONNEC )
     $      CALL DSYRK( 'Upper', 'Transpose', L, NOBR21, ONE,
     $                  DWORK(LDRWRK*M+1), LDRWRK, UPD, R(JD,JD), LDR )
         CALL DSYRK( 'Upper', 'Transpose', L, NS, ONE, Y, LDY, UPD,
     $               R(JD,JD), LDR )
C
         IF( FIRST .OR. .NOT.CONNEC ) THEN
C
            DO 310 J = 2, NOBR2
               JD = JD + L
               ID = MMNOBR + L + 1
C
C              Compute/update  Gyy(1,j).
C
               CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y,
     $                     LDY, Y(J,1), LDY, UPD, R(MMNOBR+1,JD), LDR )
C
C              Compute/update  Gyy(2:j,j), exploiting the block-Hankel
C              structure.
C
               IF( FIRST ) THEN
C
                  DO 270 I = JD - L, JD - 1
                     CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1,
     $                           R(MMNOBR+L+1,L+I), 1 )
  270             CONTINUE
C
               ELSE
C
                  DO 280 I = JD - L, JD - 1
                     CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1,
     $                           R(MMNOBR+L+1,L+I), 1 )
  280             CONTINUE
C
               END IF
C
               DO 290 I = 2, J - 1
                  CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1),
     $                       LDY, R(ID,JD), LDR )
                  CALL DGER( L, L, -ONE, Y(I-1,1), LDY, Y(J-1,1), LDY,
     $                       R(ID,JD), LDR )
                  ID = ID + L
  290          CONTINUE
C
               DO 300 I = 1, L
                  CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY,
     $                        R(JD,JD+I-1), 1 )
                  CALL DAXPY( I, -Y(J-1,I), Y(J-1,1), LDY, R(JD,JD+I-1),
     $                        1 )
  300          CONTINUE
C
  310       CONTINUE
C
         ELSE
C
            DO 360 J = 2, NOBR2
               JD = JD + L
               ID = MMNOBR + L + 1
C
C              Compute/update  Gyy(1,j)  for sequential processing with
C              connected blocks.
C
               CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NOBR21,
     $                     ONE, DWORK(LDRWRK*M+1), LDRWRK,
     $                     DWORK(LDRWRK*M+J), LDRWRK, UPD,
     $                     R(MMNOBR+1,JD), LDR )
               CALL DGEMM( 'Transpose', 'NoTranspose', L, L, NS, ONE, Y,
     $                     LDY, Y(J,1), LDY, ONE, R(MMNOBR+1,JD), LDR )
C
C              Compute/update  Gyy(2:j,j)  for sequential processing
C              with connected blocks, exploiting the block-Hankel
C              structure.
C
               IF( FIRST ) THEN
C
                  DO 320 I = JD - L, JD - 1
                     CALL DCOPY( I-MMNOBR, R(MMNOBR+1,I), 1,
     $                           R(MMNOBR+L+1,L+I), 1 )
  320             CONTINUE
C
               ELSE
C
                  DO 330 I = JD - L, JD - 1
                     CALL DAXPY( I-MMNOBR, ONE, R(MMNOBR+1,I), 1,
     $                           R(MMNOBR+L+1,L+I), 1 )
  330             CONTINUE
C
               END IF
C
               DO 340 I = 2, J - 1
                  CALL DGER( L, L, ONE, Y(NS+I-1,1), LDY, Y(NS+J-1,1),
     $                       LDY, R(ID,JD), LDR )
                  CALL DGER( L, L, -ONE, DWORK(LDRWRK*M+I-1), LDRWRK,
     $                       DWORK(LDRWRK*M+J-1), LDRWRK, R(ID,JD),
     $                       LDR )
                  ID = ID + L
  340          CONTINUE
C
               DO 350 I = 1, L
                  CALL DAXPY( I, Y(NS+J-1,I), Y(NS+J-1,1), LDY,
     $                        R(JD,JD+I-1), 1 )
                  CALL DAXPY( I, -DWORK(LDRWRK*(M+I-1)+J-1),
     $                        DWORK(LDRWRK*M+J-1), LDRWRK, R(JD,JD+I-1),
     $                        1 )
  350          CONTINUE
C
  360       CONTINUE
C
         END IF
C
         IF ( .NOT.LAST ) THEN
            IF ( CONNEC ) THEN
C
C              For sequential processing with connected data blocks,
C              save the remaining ("connection") elements of  U  and  Y
C              in the first  (M+L)*(2*NOBR-1)  locations of  DWORK.
C
               IF ( M.GT.0 )
     $            CALL DLACPY( 'Full', NOBR21, M, U(NS+1,1), LDU, DWORK,
     $                         NOBR21 )
               CALL DLACPY( 'Full', NOBR21, L, Y(NS+1,1), LDY,
     $                      DWORK(MMNOBR-M+1), NOBR21 )
            END IF
C
C           Return to get new data.
C
            ICYCLE = ICYCLE + 1
            IWORK(1) = ICYCLE
            IWORK(2) = MAXWRK
            IWORK(3) = NSMPSM
            IF ( ICYCLE.GT.MAXCYC )
     $         IWARN = 1
            RETURN
C
         ELSE
C
C           Try to compute the Cholesky factor of the correlation
C           matrix.
C
            CALL DPOTRF( 'Upper', NR, R, LDR, IERR )
            GO TO 370
         END IF
      ELSE IF ( FQRALG ) THEN
C
C        Compute the  R  factor from a fast QR factorization of the
C        input-output data correlation matrix.
C
         CALL IB01MY( METH, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU,
     $                Y, LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN,
     $                IERR )
         MAXWRK = MAX( MAXWRK, INT( DWORK(1) ) )
         IWORK(1) = ICYCLE
         IWORK(2) = MAXWRK
         IWORK(3) = NSMPSM
         IF( .NOT.LAST )
     $      RETURN
      END IF
C
  370 CONTINUE
C
      IF( IERR.NE.0 ) THEN
C
C        Error return from a fast factorization algorithm of the
C        input-output data correlation matrix.
C
         IF( ONEBCH ) THEN
            QRALG  = .TRUE.
            IWARN  = 2
            MINWRK = 2*NR
            CALL DGEQRF( NS, NR, DWORK, NS, DWORK, DWORK, -1, IERR )
            MAXWRK = NR + INT( DWORK(1) )
            IF ( LDR.LT.NS ) THEN
               MINWRK = MINWRK + NR
               MAXWRK = NS*NR + MAXWRK
            END IF
            MAXWRK = MAX( MINWRK, MAXWRK )
C
            IF( LDWORK.LT.MINWRK ) THEN
               INFO = -17
C
C              Return: Not enough workspace.
C
               DWORK( 1 ) = MINWRK
               CALL XERBLA( 'IB01MD', -INFO )
               RETURN
            END IF
         ELSE
            INFO = 1
            RETURN
         END IF
      END IF
C
      IF ( QRALG ) THEN
C
C        Compute the  R  factor from a QR factorization of the matrix  H
C        of concatenated block Hankel matrices.
C
C        Construct the matrix  H.
C
C        Set the parameters for constructing the current segment of the
C        Hankel matrix, taking the available memory space into account.
C        INITI+1 points to the beginning rows of  U  and  Y  from which
C                data are taken when NCYCLE > 1 inner cycles are needed,
C                or for sequential processing with connected blocks.
C        LDRWMX is the number of rows that can fit in the working space.
C        LDRWRK is the actual number of rows processed in this space.
C        NSLAST is the number of samples to be processed at the last
C               inner cycle.
C
         INITI  = 0
         LDRWMX = LDWORK / NR - 2
         NCYCLE = 1
         NSLAST = NSMP
         LINR   = .FALSE.
         IF ( FIRST ) THEN
            LINR   = LDR.GE.NS
            LDRWRK = NS
         ELSE IF ( CONNEC ) THEN
            LDRWRK = NSMP
         ELSE
            LDRWRK = NS
         END IF
         INICYC = 1
C
         IF ( .NOT.LINR ) THEN
            IF ( LDRWMX.LT.LDRWRK ) THEN
C
C              Not enough working space for doing a single inner cycle.
C              NCYCLE inner cycles are to be performed for the current
C              data block using the working space.
C
               NCYCLE = LDRWRK / LDRWMX
               NSLAST = MOD( LDRWRK, LDRWMX )
               IF ( NSLAST.NE.0 ) THEN
                  NCYCLE = NCYCLE + 1
               ELSE
                  NSLAST = LDRWMX
               END IF
               LDRWRK = LDRWMX
               NS = LDRWRK
               IF ( FIRST ) INICYC = 2
            END IF
            MLDRW = M*LDRWRK
            LLDRW = L*LDRWRK
            INU = MLDRW*NOBR  + 1
            INY = MLDRW*NOBR2 + 1
         END IF
C
C        Process the data given at the current call.
C
         IF ( .NOT.FIRST .AND. CONNEC ) THEN
C
C           Restore the saved (M+L)*(2*NOBR-1) "connection" elements of
C           U  and  Y  into their appropriate position in sequential
C           processing. The process is performed column-wise, in
C           reverse order, first for  Y  and then for  U.
C
            IREV = NR - M - L - NOBR21 + 1
            ICOL = INY + LLDRW - LDRWRK
C
            DO 380 J = 1, L
               DO 375 I = NOBR21 - 1, 0, -1
                  DWORK(ICOL+I) = DWORK(IREV+I)
  375          CONTINUE
               IREV = IREV - NOBR21
               ICOL = ICOL - LDRWRK
  380       CONTINUE
C
            IF( MOESP ) THEN
               ICOL = INU + MLDRW - LDRWRK
            ELSE
               ICOL = MLDRW - LDRWRK + 1
            END IF
C
            DO 390 J = 1, M
               DO 385 I = NOBR21 - 1, 0, -1
                  DWORK(ICOL+I) = DWORK(IREV+I)
  385          CONTINUE
               IREV = IREV - NOBR21
               ICOL = ICOL - LDRWRK
  390       CONTINUE
C
            IF( MOESP )
     $         CALL DLACPY( 'Full', NOBRM1, M, DWORK(INU+NOBR), LDRWRK,
     $                      DWORK, LDRWRK )
         END IF
C
C        Data compression using QR factorization.
C
         IF ( FIRST ) THEN
C
C           Non-sequential data processing or first block in
C           sequential data processing:
C           Use the general QR factorization algorithm.
C
            IF ( LINR ) THEN
C
C              Put the input-output data in the array  R.
C
               IF( M.GT.0 ) THEN
                  IF( MOESP ) THEN
C
                     DO 400 I = 1, NOBR
                        CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU,
     $                               R(1,M*(I-1)+1), LDR )
  400                CONTINUE
C
                     DO 410 I = 1, NOBR
                        CALL DLACPY( 'Full', NS, M, U(I,1), LDU,
     $                               R(1,MNOBR+M*(I-1)+1), LDR )
  410                CONTINUE
C
                  ELSE
C
                     DO 420 I = 1, NOBR2
                        CALL DLACPY( 'Full', NS, M, U(I,1), LDU,
     $                               R(1,M*(I-1)+1), LDR )
  420                CONTINUE
C
                  END IF
               END IF
C
               DO 430 I = 1, NOBR2
                  CALL DLACPY( 'Full', NS, L, Y(I,1), LDY,
     $                         R(1,MMNOBR+L*(I-1)+1), LDR )
  430          CONTINUE
C
C              Workspace: need   4*(M+L)*NOBR,
C                         prefer 2*(M+L)*NOBR+2*(M+L)*NOBR*NB.
C
               ITAU  = 1
               JWORK = ITAU + NR
               CALL DGEQRF( NS, NR, R, LDR, DWORK(ITAU), DWORK(JWORK),
     $                      LDWORK-JWORK+1, IERR )
            ELSE
C
C              Put the input-output data in the array  DWORK.
C
               IF( M.GT.0 ) THEN
                  ISHFTU = 1
                  IF( MOESP ) THEN
                     ISHFT2 = INU
C
                     DO 440 I = 1, NOBR
                        CALL DLACPY( 'Full', NS, M, U(NOBR+I,1), LDU,
     $                               DWORK(ISHFTU), LDRWRK )
                        ISHFTU = ISHFTU + MLDRW
  440                CONTINUE
C
                     DO 450 I = 1, NOBR
                        CALL DLACPY( 'Full', NS, M, U(I,1), LDU,
     $                               DWORK(ISHFT2), LDRWRK )
                        ISHFT2 = ISHFT2 + MLDRW
  450                CONTINUE
C
                  ELSE
C
                     DO 460 I = 1, NOBR2
                        CALL DLACPY( 'Full', NS, M, U(I,1), LDU,
     $                               DWORK(ISHFTU), LDRWRK )
                        ISHFTU = ISHFTU + MLDRW
  460                CONTINUE
C
                  END IF
               END IF
C
               ISHFTY = INY
C
               DO 470 I = 1, NOBR2
                  CALL DLACPY( 'Full', NS, L, Y(I,1), LDY,
     $                         DWORK(ISHFTY), LDRWRK )
                  ISHFTY = ISHFTY + LLDRW
  470          CONTINUE
C
C              Workspace: need   2*(M+L)*NOBR + 4*(M+L)*NOBR,
C                         prefer NS*2*(M+L)*NOBR + 2*(M+L)*NOBR
C                                                + 2*(M+L)*NOBR*NB,
C                         used LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR,
C                         where  NS = NSMP - 2*NOBR + 1,
C                            LDRWRK = min(NS, LDWORK/(2*(M+L)*NOBR)-2).
C
               ITAU  = LDRWRK*NR + 1
               JWORK = ITAU + NR
               CALL DGEQRF( NS, NR, DWORK, LDRWRK, DWORK(ITAU),
     $                      DWORK(JWORK), LDWORK-JWORK+1, IERR )
               CALL DLACPY( 'Upper ', MIN(NS,NR), NR, DWORK, LDRWRK, R,
     $                      LDR )
            END IF
C
            IF ( NS.LT.NR )
     $         CALL DLASET( 'Upper ', NR - NS, NR - NS, ZERO, ZERO,
     $                      R(NS+1,NS+1), LDR )
            INITI = INITI + NS
         END IF
C
         IF ( NCYCLE.GT.1 .OR. .NOT.FIRST ) THEN
C
C           Remaining segments of the first data block or
C           remaining segments/blocks in sequential data processing:
C           Use a structure-exploiting QR factorization algorithm.
C
            NSL = LDRWRK
            IF ( .NOT.CONNEC ) NSL = NS
            ITAU  = LDRWRK*NR + 1
            JWORK = ITAU + NR
C
            DO 560 NICYCL = INICYC, NCYCLE
C
C              INIT  denotes the beginning row where new data are put.
C
               IF ( CONNEC .AND. NICYCL.EQ.1 ) THEN
                  INIT = NOBR2
               ELSE
                  INIT = 1
               END IF
               IF ( NCYCLE.GT.1 .AND. NICYCL.EQ.NCYCLE ) THEN
C
C                 Last samples in the last data segment of a block.
C
                  NS  = NSLAST
                  NSL = NSLAST
               END IF
C
C              Put the input-output data in the array  DWORK.
C
               NSF = NS
               IF ( INIT.GT.1 .AND. NCYCLE.GT.1 ) NSF = NSF - NOBR21
               IF ( M.GT.0 ) THEN
                  ISHFTU = INIT
C
                  IF( MOESP ) THEN
                     ISHFT2 = INIT + INU - 1
C
                     DO 480 I = 1, NOBR
                        CALL DLACPY( 'Full', NSF, M, U(INITI+NOBR+I,1),
     $                               LDU, DWORK(ISHFTU), LDRWRK )
                        ISHFTU = ISHFTU + MLDRW
  480                CONTINUE
C
                     DO 490 I = 1, NOBR
                        CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU,
     $                               DWORK(ISHFT2), LDRWRK )
                        ISHFT2 = ISHFT2 + MLDRW
  490                CONTINUE
C
                  ELSE
C
                     DO 500 I = 1, NOBR2
                        CALL DLACPY( 'Full', NSF, M, U(INITI+I,1), LDU,
     $                               DWORK(ISHFTU), LDRWRK )
                        ISHFTU = ISHFTU + MLDRW
  500                CONTINUE
C
                  END IF
               END IF
C
               ISHFTY = INIT + INY - 1
C
               DO 510 I = 1, NOBR2
                  CALL DLACPY( 'Full', NSF, L, Y(INITI+I,1), LDY,
     $                         DWORK(ISHFTY), LDRWRK )
                  ISHFTY = ISHFTY + LLDRW
  510          CONTINUE
C
               IF ( INIT.GT.1 ) THEN
C
C                 Prepare the connection to the previous block of data
C                 in sequential processing.
C
                  IF( MOESP .AND. M.GT.0 )
     $               CALL DLACPY( 'Full', NOBR, M, U, LDU, DWORK(NOBR),
     $                            LDRWRK )
C
C                 Shift the elements from the connection to the previous
C                 block of data in sequential processing.
C
                  IF ( M.GT.0 ) THEN
                     ISHFTU = MLDRW + 1
C
                     IF( MOESP ) THEN
                        ISHFT2 = MLDRW + INU
C
                        DO 520 I = 1, NOBRM1
                           CALL DLACPY( 'Full', NOBR21, M,
     $                                  DWORK(ISHFTU-MLDRW+1), LDRWRK,
     $                                  DWORK(ISHFTU), LDRWRK )
                           ISHFTU = ISHFTU + MLDRW
  520                  CONTINUE
C
                        DO 530 I = 1, NOBRM1
                           CALL DLACPY( 'Full', NOBR21, M,
     $                                  DWORK(ISHFT2-MLDRW+1), LDRWRK,
     $                                  DWORK(ISHFT2), LDRWRK )
                          ISHFT2 = ISHFT2 + MLDRW
  530                  CONTINUE
C
                     ELSE
C
                        DO 540 I = 1, NOBR21
                           CALL DLACPY( 'Full', NOBR21, M,
     $                                  DWORK(ISHFTU-MLDRW+1), LDRWRK,
     $                                  DWORK(ISHFTU), LDRWRK )
                           ISHFTU = ISHFTU + MLDRW
  540                   CONTINUE
C
                     END IF
                  END IF
C
                  ISHFTY = LLDRW + INY
C
                  DO 550 I = 1, NOBR21
                     CALL DLACPY( 'Full', NOBR21, L,
     $                            DWORK(ISHFTY-LLDRW+1), LDRWRK,
     $                            DWORK(ISHFTY), LDRWRK )
                     ISHFTY = ISHFTY + LLDRW
  550             CONTINUE
C
               END IF
C
C              Workspace: need LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR.
C
               CALL MB04OD( 'Full', NR, 0, NSL, R, LDR, DWORK, LDRWRK,
     $                      DUM, NR, DUM, NR, DWORK(ITAU), DWORK(JWORK)
     $                    )
               INITI = INITI + NSF
  560       CONTINUE
C
         END IF
C
         IF ( .NOT.LAST ) THEN
            IF ( CONNEC ) THEN
C
C              For sequential processing with connected data blocks,
C              save the remaining ("connection") elements of  U  and  Y
C              in the first  (M+L)*(2*NOBR-1)  locations of  DWORK.
C
               IF ( M.GT.0 )
     $            CALL DLACPY( 'Full', NOBR21, M, U(INITI+1,1), LDU,
     $                         DWORK, NOBR21 )
               CALL DLACPY( 'Full', NOBR21, L, Y(INITI+1,1), LDY,
     $                      DWORK(MMNOBR-M+1), NOBR21 )
            END IF
C
C           Return to get new data.
C
            ICYCLE   = ICYCLE + 1
            IWORK(1) = ICYCLE
            IWORK(2) = MAXWRK
            IWORK(3) = NSMPSM
            IF ( ICYCLE.LE.MAXCYC )
     $         RETURN
            IWARN  = 1
            ICYCLE = 1
C
         END IF
C
      END IF
C
C     Return optimal workspace in  DWORK(1).
C
      DWORK( 1 ) = MAXWRK
      IF( .NOT.ONEBCH ) THEN
         IWORK(1) = ICYCLE
         IWORK(2) = MAXWRK
         IWORK(3) = NSMPSM
      END IF
      RETURN
C
C *** Last line of IB01MD ***
      END