PROGRAM ENIAC
!  Emulate the first successful numerical weather prediction.
!  It was run on the ENIAC during 1948 and 1949.
!  The results and method were written up in Tellus 2, p. 237 1950.
!      Robert Grumbine 2 May 1995. Fortran 77
! Typographical translation to Fortran 90 23 March 2019

  IMPLICIT none
  INCLUDE "grid.inc"

!  Declare fixed arrays -
!    These were used because of the memory constraint on the ENIAC --
!      these values were on punched cards recycled through the system
  REAL s(0:p,0:p), t(0:q,0:q), v(0:p,0:q)
  REAL r(0:p,0:q), f(0:p,0:q), h(0:p,0:q)

!  Declare data, physical info.
  REAL z(0:p,0:q), zeta(0:p,0:q), eta(0:p,0:q)

! loop count
  INTEGER k

!***********************************************************!!
! BEGIN THE EXECUTION HERE

  CALL initialize(s,t,v,r,f,h,z,zeta,eta)

!     END OF THE PRELIMINARY SET UP SECTION
!***********************************************************!!
!  BEGIN THE ITERATIVE SOLUTION OF THE EQUATIONS
  PRINT *,SECOND()*1000.,' ms'
  DO k = 0, 60 !60 hours is about the instability limit

    CALL step(s,t,v,f,h,z,zeta,eta, k)

  ENDDO

  PRINT *,SECOND()*1000.,' ms'

!***********************************************************!!

  END


      SUBROUTINE TD04AD( ROWCOL, M, P, INDEX, DCOEFF, LDDCOE, UCOEFF,
     $                   LDUCO1, LDUCO2, NR, A, LDA, B, LDB, C, LDC, D,
     $                   LDD, TOL, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To find a minimal state-space representation (A,B,C,D) for a
C     proper transfer matrix T(s) given as either row or column
C     polynomial vectors over denominator polynomials, possibly with
C     uncancelled common terms.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     ROWCOL  CHARACTER*1
C             Indicates whether the transfer matrix T(s) is given as
C             rows or columns over common denominators as follows:
C             = 'R':  T(s) is given as rows over common denominators;
C             = 'C':  T(s) is given as columns over common denominators.
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs.  P >= 0.
C
C     INDEX   (input) INTEGER array, dimension (porm), where porm = P,
C             if ROWCOL = 'R', and porm = M, if ROWCOL = 'C'.
C             This array must contain the degrees of the denominator
C             polynomials in D(s).
C
C     DCOEFF  (input) DOUBLE PRECISION array, dimension (LDDCOE,kdcoef),
C             where kdcoef = MAX(INDEX(I)) + 1.
C             The leading porm-by-kdcoef part of this array must contain
C             the coefficients of each denominator polynomial.
C             DCOEFF(I,K) is the coefficient in s**(INDEX(I)-K+1) of the
C             I-th denominator polynomial in D(s), where
C             K = 1,2,...,kdcoef.
C
C     LDDCOE  INTEGER
C             The leading dimension of array DCOEFF.
C             LDDCOE >= MAX(1,P) if ROWCOL = 'R';
C             LDDCOE >= MAX(1,M) if ROWCOL = 'C'.
C
C     UCOEFF  (input) DOUBLE PRECISION array, dimension
C             (LDUCO1,LDUCO2,kdcoef)
C             The leading P-by-M-by-kdcoef part of this array must
C             contain the numerator matrix U(s); if ROWCOL = 'C', this
C             array is modified internally but restored on exit, and the
C             remainder of the leading MAX(M,P)-by-MAX(M,P)-by-kdcoef
C             part is used as internal workspace.
C             UCOEFF(I,J,K) is the coefficient in s**(INDEX(iorj)-K+1)
C             of polynomial (I,J) of U(s), where K = 1,2,...,kdcoef;
C             if ROWCOL = 'R' then iorj = I, otherwise iorj = J.
C             Thus for ROWCOL = 'R', U(s) =
C             diag(s**INDEX(I))*(UCOEFF(.,.,1)+UCOEFF(.,.,2)/s+...).
C
C     LDUCO1  INTEGER
C             The leading dimension of array UCOEFF.
C             LDUCO1 >= MAX(1,P)   if ROWCOL = 'R';
C             LDUCO1 >= MAX(1,M,P) if ROWCOL = 'C'.
C
C     LDUCO2  INTEGER
C             The second dimension of array UCOEFF.
C             LDUCO2 >= MAX(1,M)   if ROWCOL = 'R';
C             LDUCO2 >= MAX(1,M,P) if ROWCOL = 'C'.
C
C     NR      (output) INTEGER
C             The order of the resulting minimal realization, i.e. the
C             order of the state dynamics matrix A.
C
C     A       (output) DOUBLE PRECISION array, dimension (LDA,N),
C                       porm
C             where N = SUM INDEX(I).
C                       I=1
C             The leading NR-by-NR part of this array contains the upper
C             block Hessenberg state dynamics matrix A of a minimal
C             realization.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     B       (output) DOUBLE PRECISION array, dimension (LDB,MAX(M,P))
C             The leading NR-by-M part of this array contains the
C             input/state matrix B of a minimal realization; the
C             remainder of the leading N-by-MAX(M,P) part is used as
C             internal workspace.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (output) DOUBLE PRECISION array, dimension (LDC,N)
C             The leading P-by-NR part of this array contains the
C             state/output matrix C of a minimal realization; the
C             remainder of the leading MAX(M,P)-by-N part is used as
C             internal workspace.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,M,P).
C
C     D       (output) DOUBLE PRECISION array, dimension (LDD,M),
C             if ROWCOL = 'R', and (LDD,MAX(M,P)) if ROWCOL = 'C'.
C             The leading P-by-M part of this array contains the direct
C             transmission matrix D; if ROWCOL = 'C', the remainder of
C             the leading MAX(M,P)-by-MAX(M,P) part is used as internal
C             workspace.
C
C     LDD     INTEGER
C             The leading dimension of array D.
C             LDD >= MAX(1,P)   if ROWCOL = 'R';
C             LDD >= MAX(1,M,P) if ROWCOL = 'C'.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in rank determination when
C             transforming (A, B, C). If the user sets TOL > 0, then
C             the given value of TOL is used as a lower bound for the
C             reciprocal condition number (see the description of the
C             argument RCOND in the SLICOT routine MB03OD);  a
C             (sub)matrix whose estimated condition number is less than
C             1/TOL is considered to be of full rank.  If the user sets
C             TOL <= 0, then an implicitly computed, default tolerance
C             (determined by the SLICOT routine TB01UD) is used instead.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N+MAX(M,P))
C             On exit, if INFO = 0, the first nonzero elements of
C             IWORK(1:N) return the orders of the diagonal blocks of A.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= MAX(1, N + MAX(N, 3*M, 3*P)).
C             For optimum performance LDWORK should be larger.
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             > 0:  if INFO = i, then i is the first integer for which
C                   ABS( DCOEFF(I,1) ) is so small that the calculations
C                   would overflow (see SLICOT Library routine TD03AY);
C                   that is, the leading coefficient of a polynomial is
C                   nearly zero; no state-space representation is
C                   calculated.
C
C     METHOD
C
C     The method for transfer matrices factorized by rows will be
C     described here: T(s) factorized by columns is dealt with by
C     operating on the dual T'(s). This description for T(s) is
C     actually the left polynomial matrix representation
C
C          T(s) = inv(D(s))*U(s),
C
C     where D(s) is diagonal with its (I,I)-th polynomial element of
C     degree INDEX(I). The first step is to check whether the leading
C     coefficient of any polynomial element of D(s) is approximately
C     zero; if so the routine returns with INFO > 0. Otherwise,
C     Wolovich's Observable Structure Theorem is used to construct a
C     state-space representation in observable companion form which
C     is equivalent to the above polynomial matrix representation.
C     The method is particularly easy here due to the diagonal form
C     of D(s). This state-space representation is not necessarily
C     controllable (as D(s) and U(s) are not necessarily relatively
C     left prime), but it is in theory completely observable; however,
C     its observability matrix may be poorly conditioned, so it is
C     treated as a general state-space representation and SLICOT
C     Library routine TB01PD is then called to separate out a minimal
C     realization from this general state-space representation by means
C     of orthogonal similarity transformations.
C
C     REFERENCES
C
C     [1] Patel, R.V.
C         Computation of Minimal-Order State-Space Realizations and
C         Observability Indices using Orthogonal Transformations.
C         Int. J. Control, 33, pp. 227-246, 1981.
C
C     [2] Wolovich, W.A.
C         Linear Multivariable Systems, (Theorem 4.3.3).
C         Springer-Verlag, 1974.
C
C     NUMERICAL ASPECTS
C                               3
C     The algorithm requires 0(N ) operations.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Univ. Leuven, Belgium, March 1998.
C     Supersedes Release 3.0 routine TD01OD.
C
C     REVISIONS
C
C     -
C
C     KEYWORDS
C
C     Controllability, elementary polynomial operations, minimal
C     realization, polynomial matrix, state-space representation,
C     transfer matrix.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      CHARACTER         ROWCOL
      INTEGER           INFO, LDA, LDB, LDC, LDD, LDDCOE, LDUCO1,
     $                  LDUCO2, LDWORK, M, NR, P
      DOUBLE PRECISION  TOL
C     .. Array Arguments ..
      INTEGER           INDEX(*), IWORK(*)
      DOUBLE PRECISION  A(LDA,*), B(LDB,*), C(LDC,*), D(LDD,*),
     $                  DCOEFF(LDDCOE,*), DWORK(*),
     $                  UCOEFF(LDUCO1,LDUCO2,*)
C     .. Local Scalars ..
      LOGICAL           LROCOC, LROCOR
      INTEGER           I, J, JSTOP, K, KDCOEF, MPLIM, MWORK, N, PWORK
C     .. External Functions ..
      LOGICAL           LSAME
      EXTERNAL          LSAME
C     .. External Subroutines ..
      EXTERNAL          DLASET, DSWAP, TB01PD, TB01XD, TD03AY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         MAX
C     .. Executable Statements ..
C
      INFO = 0
      LROCOR = LSAME( ROWCOL, 'R' )
      LROCOC = LSAME( ROWCOL, 'C' )
      MPLIM = MAX( 1, M, P )
C
C     Test the input scalar arguments.
C
      IF( .NOT.LROCOR .AND. .NOT.LROCOC ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( ( LROCOR .AND. LDDCOE.LT.MAX( 1, P ) ) .OR.
     $         ( LROCOC .AND. LDDCOE.LT.MAX( 1, M ) ) ) THEN
         INFO = -6
      ELSE IF( ( LROCOR .AND. LDUCO1.LT.MAX( 1, P ) ) .OR.
     $         ( LROCOC .AND. LDUCO1.LT.MPLIM ) ) THEN
         INFO = -8
      ELSE IF( ( LROCOR .AND. LDUCO2.LT.MAX( 1, M ) ) .OR.
     $         ( LROCOC .AND. LDUCO2.LT.MPLIM ) ) THEN
         INFO = -9
      END IF
C
      N = 0
      IF ( INFO.EQ.0 ) THEN
         IF ( LROCOR ) THEN
C
C           Initialization for T(s) given as rows over common
C           denominators.
C
            PWORK = P
            MWORK = M
         ELSE
C
C           Initialization for T(s) given as columns over common
C           denominators.
C
            PWORK = M
            MWORK = P
         END IF
C
C        Calculate N, the order of the resulting state-space
C        representation.
C
         KDCOEF = 0
C
         DO 10 I = 1, PWORK
            KDCOEF = MAX( KDCOEF, INDEX(I) )
            N = N + INDEX(I)
   10    CONTINUE
C
         KDCOEF = KDCOEF + 1
C
         IF( LDA.LT.MAX( 1, N ) ) THEN
            INFO = -12
         ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
            INFO = -14
         ELSE IF( LDC.LT.MPLIM ) THEN
            INFO = -16
         ELSE IF( ( LROCOR .AND. LDD.LT.MAX( 1, P ) ) .OR.
     $         ( LROCOC .AND. LDD.LT.MPLIM ) ) THEN
            INFO = -18
         ELSE IF( LDWORK.LT.MAX( 1, N + MAX( N, 3*M, 3*P ) ) ) THEN
            INFO = -22
         END IF
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TD04AD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MAX( N, M, P ).EQ.0 ) THEN
         NR  = 0
         DWORK(1) = ONE
         RETURN
      END IF
C
      IF ( LROCOC ) THEN
C
C        Initialize the remainder of the leading
C        MPLIM-by-MPLIM-by-KDCOEF part of U(s) to zero.
C
         IF ( P.LT.M ) THEN
C
            DO 20 K = 1, KDCOEF
               CALL DLASET( 'Full', M-P, MPLIM, ZERO, ZERO,
     $                      UCOEFF(P+1,1,K), LDUCO1 )
   20       CONTINUE
C
         ELSE IF ( P.GT.M ) THEN
C
            DO 30 K = 1, KDCOEF
               CALL DLASET( 'Full', MPLIM, P-M, ZERO, ZERO,
     $                      UCOEFF(1,M+1,K), LDUCO1 )
   30       CONTINUE
C
         END IF
C
         IF ( MPLIM.NE.1 ) THEN
C
C           Non-scalar T(s) factorized by columns: transpose it (i.e.
C           U(s)).
C
            JSTOP = MPLIM - 1
C
            DO 50 K = 1, KDCOEF
C
               DO 40 J = 1, JSTOP
                  CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1,
     $                        UCOEFF(J,J+1,K), LDUCO1 )
   40          CONTINUE
C
   50       CONTINUE
C
         END IF
      END IF
C
C     Construct non-minimal state-space representation (by Wolovich's
C     Structure Theorem) which has transfer matrix T(s) or T'(s) as
C     appropriate ...
C
      CALL TD03AY( MWORK, PWORK, INDEX, DCOEFF, LDDCOE, UCOEFF, LDUCO1,
     $             LDUCO2, N, A, LDA, B, LDB, C, LDC, D, LDD, INFO )
      IF ( INFO.GT.0 )
     $   RETURN
C
C     and then separate out a minimal realization from this.
C
C     Workspace: need  N + MAX(N, 3*MWORK, 3*PWORK).
C
      CALL TB01PD( 'Minimal', 'Scale', N, MWORK, PWORK, A, LDA, B, LDB,
     $             C, LDC, NR, TOL, IWORK, DWORK, LDWORK, INFO )
C
      IF ( LROCOC ) THEN
C
C        If T(s) originally factorized by columns, find dual of minimal
C        state-space representation, and reorder the rows and columns
C        to get an upper block Hessenberg state dynamics matrix.
C
         K = IWORK(1)+IWORK(2)-1
         CALL TB01XD( 'D', NR, MWORK, PWORK, K, NR-1, A, LDA, B, LDB,
     $                C, LDC, D, LDD, INFO )
         IF ( MPLIM.NE.1 ) THEN
C
C           Also, retranspose U(s) if this is non-scalar.
C
            DO 70 K = 1, KDCOEF
C
               DO 60 J = 1, JSTOP
                  CALL DSWAP( MPLIM-J, UCOEFF(J+1,J,K), 1,
     $                        UCOEFF(J,J+1,K), LDUCO1 )
   60          CONTINUE
C
   70       CONTINUE
C
         END IF
      END IF
C
      RETURN
C *** Last line of TD04AD ***
      END


c
c
c***********************************************************************
      subroutine rotviaproj(alpha,nterms,m1,m2,mpole,lmp,marray2,lmpn)
c***********************************************************************
c       Purpose:
c
c	Fast and stable algorithm for applying rotation operator about
c	the y-axis determined by angle alpha.
c
c       The method is based on computing the induced potential and
c       its theta-derivative on the rotated equator
c       for each order (first index). The coefficients of  the rotated
c       expansion can then be obtained by FFT and projection.
c
c       There is some loss in speed over using recurrence relations
c       but it is stable to all orders whereas the recurrence schemes
c       are not.
c       If the rotation operator is to be used multiple times, and
c       memory is available, one can precompute and store the
c       multipliers used in evalall (see below). This has not yet been
c       implemented.
c
C---------------------------------------------------------------------
c       INPUT:
c
c       alpha:  the rotation angle about the y-axis.
c       nterms: order of multipole expansion
c
c       m1    : max m index for first expansion   NOT IMPLEMENTED
c       m2    : max m index for second expansion   NOT IMPLEMENTED
c
c               PARAMETERS CURRENTLY IGNORED.
c
C       mpole   coefficients of original multiple expansion
C       lmp     leading dim for mpole (must exceed nterms)
C       lmpn    leading dim for marray2 (must exceed nterms)
c       w     :  work array
c       lw    :  length of work array
c
C---------------------------------------------------------------------
c       OUTPUT:
c
c       marray2  coefficients of rotated expansion.
c       lused    amount of workspace used.
c       ier      error return flag
c                0 successful execution
c                1 insufficient memory
c
C---------------------------------------------------------------------
c
c
c
      implicit real *8 (a-h,o-z)
      integer nquad
      real *8 w
      allocatable w(:)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 marray2(0:lmpn,-lmpn:lmpn)
c
      nquad = 2*nterms+2
      ictheta = 1
      istheta = ictheta+nquad
      icphi = istheta+nquad
      isphi = icphi+nquad
      iynm = isphi+nquad
      iynmd = iynm + (nterms+1)**2
      irat1 = iynmd + (nterms+1)**2
      irat2 = irat1 + (nterms+1)**2
      iuval = irat2 + (nterms+1)**2
      iuder = iuval + 2*nquad*(nterms+1)
      iephi = iuder + 2*nquad*(nterms+1)
      iwsave = iephi + 2*(2*nterms+1)
      iavec = iwsave + 4*nquad+20
      ibvec = iavec + 2*nquad
      lused = ibvec + 2*nquad
      allocate (w(lused))
c
      call rotviaproj0(alpha,nquad,nterms,m1,m2,mpole,lmp,
     1           marray2,lmpn,w(ictheta),w(istheta),
     1           w(icphi),w(isphi),w(iynm),w(iynmd),
     1           w(irat1),w(irat2),w(iuval),w(iuder),
     1           w(iephi),w(iwsave),w(iavec),w(ibvec))
      deallocate(w)
      return
      end
c
c
c***********************************************************************
      subroutine rotviaproj0(alpha,nquad,nterms,m1,m2,mpole,lmp,
     1           marray2,lmpn,cthetas,sthetas,cphis,sphis,ynm,ynmd,
     1           rat1,rat2,uval,uder,ephis,wsave,avec,bvec)
c***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nquad,nterms
      real *8 cthetas(nquad),cphis(nquad)
      real *8 sthetas(nquad),sphis(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
      complex *16 avec(nquad)
      complex *16 bvec(nquad)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 marray2(0:lmpn,-lmpn:lmpn)
      complex *16 uder(nquad,0:nterms),uval(nquad,0:nterms)
      complex *16 ephis(-nterms:nterms)
      real *8 wsave(4*nquad+20)
C
C
      call getmeridian(alpha,nquad,cthetas,sthetas,cphis,sphis)
      call evalall(alpha,nquad,cthetas,sthetas,cphis,sphis,mpole,
     2           lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
      call projectonynm(nquad,uval,uder,ynm,ynmd,marray2,lmpn,nterms,
     2           m2,wsave,avec,bvec)
      return
      end
C
C
C***********************************************************************
      subroutine getmeridian(alpha,nquad,cthetas,sthetas,cphis,sphis)
C***********************************************************************
C     Purpose:
C
C           For a rotation of angle ALPHA about the y-axis, this
C           subroutine returns the NQUAD equispaced nodes on the
C           rotated equator in the original coordinate system.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     alpha  = angle of rotation
C     nquad = number of quadrature nodes in equator.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     cthetas = cos(theta) values in original coordinate system of
C                    nquad equispaced nodes
C     sthetas = sin(theta) values in original coordinate system of
C                    nquad equispaced nodes
C     cphis =  cos(phi) values in original coordinate system of
C                    nquad equispaced nodes
C     sphis =  cos(phi) values in original coordinate system of
C                    nquad equispaced nodes
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nquad
      real *8 cthetas(nquad)
      real *8 sthetas(nquad)
      real *8 cphis(nquad)
      real *8 sphis(nquad)
C
      pi = 4.0d0*datan(1.0d0)
C
      ca = cos(alpha)
      sa = sin(alpha)
      do i = 1,nquad
	 im1 = i-1
         phi = 2*pi*im1/nquad
	 theta = pi/2.0d0
         xp = cos(phi)*sin(theta)
         yp = sin(phi)*sin(theta)
         zp = cos(theta)
         x = ca*xp + sa*zp
         y = yp
         z = -sa*xp + ca*zp
         proj = sqrt(x**2+y**2)
	 if (proj.le.1.0d-16) then
	    cphis(i) = 1.0d0
	    sphis(i) = 0.0d0
	 else
	    cphis(i) = x/proj
	    sphis(i) = y/proj
	 endif
	 cthetas(i) = z
	 sthetas(i) = proj
      enddo
      return
      end
C
C***********************************************************************
      subroutine evalall(alpha,nquad,cthetas,sthetas,cphis,sphis,
     1           mpole,lmp,nterms,uval,uder,ynm,ynmd,ephis,rat1,rat2)
C***********************************************************************
C
C     This subroutine evaluates the multipole expansion for each
C     order at the nquad nodes on the rotated equator.
C
C---------------------------------------------------------------------
C     INPUT:
C
C     alpha    : angle of rotation about y-axis.
C     nquad    : number of target point son unit sphere
C     cthetas  : cos(theta) values of target points.
C     sthetas  : sin(theta) values of target points.
C     cphis    : cos(phi) values of target points.
C     sphis    : sin(phi) values of target points.
C     mpole    : original multipole expansion
C     nterms   : order of multipole expansion
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     ephis    : work array for exp(i m phi) values
C     rat1     : work array for accelerating ynm calculation.
C     rat2     : work array for accelerating ynm calculation.
C
C---------------------------------------------------------------------
C     OUTPUT:
C
C     uval(i,j) : contribution to potential
C                 of multipole terms of order j at ith quad node.
C     uder(i,j) : contributions to theta derivative of potential
C                 of multipole terms of order j at ith quad node.
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer ndeg,morder, nquad
      real *8 cthetas(nquad),cphis(nquad)
      real *8 sthetas(nquad),sphis(nquad)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
ccc      complex *16 mpole(0:nterms,-nterms:nterms)
      complex *16 mpole(0:lmp,-lmp:lmp)
      complex *16 ephi1,ephis(-nterms:nterms)
      complex *16 uder(nquad,0:nterms),uval(nquad,0:nterms)
      complex *16 uv,utheta,uphi,ztmp1,ztmp2,ztsum
      complex *16 ux,uy,uz,imag
      real *8 rat1(0:nterms,0:nterms)
      real *8 rat2(0:nterms,0:nterms)
C
      data imag/(0.0d0,1.0d0)/
      pi = 4.0d0*datan(1.0d0)
C
      calpha = cos(alpha)
      salpha = -sin(alpha)
      call ylgndrini(nterms,rat1,rat2)
      do jj=1,nquad
	 ctheta = cthetas(jj)
	 stheta = sthetas(jj)
	 cphi = cphis(jj)
	 sphi = sphis(jj)
         dir1 = -salpha
         dir2 = 0
         dir3 = calpha
         tang1 = cphi*ctheta
         tang2 = sphi*ctheta
         tang3 = -stheta
         proj2 = tang1*dir1 + tang2*dir2 + tang3*dir3
         tang1 = -sphi
         tang2 = cphi
         tang3 = 0
         proj1 = tang1*dir1 + tang2*dir2 + tang3*dir3
ccc	 call ylgndr2s(nterms,ctheta,ynm,ynmd)
	 call ylgndr2sf(nterms,ctheta,ynm,ynmd,rat1,rat2)
         ephi1 = dcmplx(cphis(jj),sphis(jj))
	 ephis(1) = ephi1
	 ephis(-1) = dconjg(ephi1)
	 do i = 2,nterms
	    ephis(i) = ephis(i-1)*ephi1
	    ephis(-i) = ephis(-i+1)*dconjg(ephi1)
	 enddo
c
	 do ndeg = 0,nterms
	    uv = ynm(ndeg,0)*mpole(ndeg,0)
	    utheta=ynmd(ndeg,0)*stheta*mpole(ndeg,0)
	    uphi = 0.0d0
	    do morder = 1,ndeg
               ztmp1 = ephis(morder)*mpole(ndeg,morder)
               ztmp2 = ephis(-morder)*mpole(ndeg,-morder)
	       ztsum = ztmp1+ztmp2
	       uv = uv + stheta*ynm(ndeg,morder)*ztsum
	       utheta = utheta + ynmd(ndeg,morder)*ztsum
	       uphi = uphi - ynm(ndeg,morder)*morder*(ztmp1-ztmp2)
	    enddo
            uval(jj,ndeg) = uv
            uder(jj,ndeg) = utheta*proj2+uphi*imag*proj1
	 enddo
      enddo
      return
      end
C
C
C
C
C
C
C***********************************************************************
      subroutine projectonynm(nquad,uval,uder,
     1           ynm,ynmd,marray,lmpn,nterms,m2,wsave,avec,bvec)
C***********************************************************************
C
C     This subroutine projects from values on equator for each multipole
C     order (uval, uder = dudthteta)
C     onto spherical harmonics
C
C---------------------------------------------------------------------
C     INPUT:
C
C     nquad    : number of points on equator
C     uval     : F values on equator
C     uder     : dFdtheta values on equator
C     ynm      : work array for ynm values
C     ynmd     : work array for ynmd values
C     lmpn     : leading dim of marray (must exceed nterms)
C     nterms   : order of expansion
C     m2       : NOT YET IMPLEMENTED (for reduced number of degrees in
C                expansion (second index)
C     wsave    : work array for FFT (dimension at least 4*nquad+20)
C     avec     : work array of length nquad for FFT (complex)
C     bvec     : work array of length nquad for FFT (complex)
C---------------------------------------------------------------------
C     OUTPUT:
C
C     marray   : rotated expansion
C
C
C***********************************************************************
      implicit real *8 (a-h,o-z)
      integer nquad, norder
      complex *16 ephi,ephi1,uval(nquad,0:1)
      complex *16 uder(nquad,0:1)
      complex *16 utheta,uphi,ztmp1,ztmp2
      complex *16 alpha,beta,imag
      complex *16 marray(0:lmpn,-lmpn:lmpn)
      real *8 ynm(0:nterms,0:nterms)
      real *8 ynmd(0:nterms,0:nterms)
      real *8 wsave(4*nquad+20)
      complex *16 avec(nquad)
      complex *16 bvec(nquad)
C
      data imag/(0.0d0,1.0d0)/
      pi = 4.0d0*datan(1.0d0)
C
      theta = pi/2.0d0
      ctheta = cos(theta)
      stheta = sin(theta)
      h = stheta/nquad
      h = 1.0d0/nquad
      call ylgndr2s(nterms,ctheta,ynm,ynmd)
      call zffti(nquad,wsave)
      do norder=0,nterms
	 do ii = 1,nquad
	    avec(ii) = uval(ii,norder)
	    bvec(ii) = uder(ii,norder)
         enddo
	 call zfftf(nquad,avec,wsave)
	 call zfftf(nquad,bvec,wsave)
         do m = -norder,norder
	    if (m.ge.0)  alpha = avec(m+1)*h
	    if (m.lt.0)  alpha = avec(nquad+m+1)*h
	    if (m.ge.0)  beta = bvec(m+1)*h
	    if (m.lt.0)  beta = bvec(nquad+m+1)*h
            marray(norder,m) = (alpha*ynm(norder,abs(m)) -
     1        beta*ynmd(norder,abs(m))*stheta)/
     1        (ynm(norder,abs(m))**2 + (stheta*ynmd(norder,abs(m)))**2)
         enddo
      enddo
      return
      end
c


!
! Part of the LLVM Project, under the Apache License v2.0 with LLVM Exceptions.
! See https://llvm.org/LICENSE.txt for license information.
! SPDX-License-Identifier: Apache-2.0 WITH LLVM-exception
!
      program test
      integer, parameter :: num = 25
      integer results(num)
      integer, parameter :: expect(num)= (/32,0,2,32,0,2,16,0,0,11,5,32,1,4,32,5,0,32,32,32,26,32,30,27,32/)
      integer, parameter :: arr(5)=(/0,1,-108,4294901760,4294967295/)
      integer*8 var_test
     !1.a Use of constants
      results(1)=trailz(0)
      results(2)=trailz(1)
      results(3)=trailz(-108)
      results(4:8)=trailz(arr)
     !1.b Use of variables
      var_test=5_8
      results(9)=trailz(var_test)
      var_test= 2048_8
      results(10)=trailz(var_test)

     !1.d Chain use with trailz
      do i=11,15
          results(i)= trailz(trailz(arr(i-10)))
      end do
     !1.e Chain use of trailz and leadz
     !chain of trailz(leadz))
      do i=16,20
           results(i)=trailz(leadz(arr(i-15)))
      end do
     !chain of leadz(tarilz)
      do i=21,25
           results(i)=leadz(trailz(arr(i-20)))
      end do

      if (all( expect .eq. results)) then
          print *, 'expect  vs results match'
      else
          print *, 'expectz vs results  mismatch'
      endif

      call check(results, expect, num)
      end program


! 3.20 в учебнике

program ex_3_20
    implicit none
    integer                 :: arrayX, arrayY, Out = 0, In = 0
    integer, allocatable    :: input(:), A(:,:), B(:), C(:)
    character(*), parameter :: output_file = "output.txt", &
                               input_file = "../data/input.txt", &
                               E_ = "UTF-8"

    open (file=input_file, encoding=E_, newunit=In)
        read(In, '(1I3)') arrayX
        read(In, '(1I3)') arrayY

        allocate(input(arrayY * arrayX))

        allocate(A(arrayY, arrayX))
        allocate(B(arrayY * arrayX))
        allocate(C(arrayY * arrayX))

        read(In,'(I2)') input(:)

    close (In)

    A = reshape(input, [arrayX, arrayY])
    C = reshape(A, [arrayX * arrayY])
    A = reshape(input, [arrayX, arrayY], order=[2, 1])
    B = reshape(A, [arrayX * arrayY])

    open (file=output_file, encoding=E_, newunit=Out)
        write(Out,*) 'A'
        write(Out,'(:(/,3i3))') A
        write(Out,*) 'B'
        write(Out,'(I3)') B(:)
        write(Out,*) 'C'
        write(Out,'(I3)') C(:)
    close (Out)

end program ex_3_20


c===========================================================================
c
c   This file is part of TISEAN
c
c   Copyright (c) 1998-2007 Rainer Hegger, Holger Kantz, Thomas Schreiber
c
c   TISEAN is free software; you can redistribute it and/or modify
c   it under the terms of the GNU General Public License as published by
c   the Free Software Foundation; either version 2 of the License, or
c   (at your option) any later version.
c
c   TISEAN is distributed in the hope that it will be useful,
c   but WITHOUT ANY WARRANTY; without even the implied warranty of
c   MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
c   GNU General Public License for more details.
c
c   You should have received a copy of the GNU General Public License
c   along with TISEAN; if not, write to the Free Software
c   Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA  02110-1301  USA
c
c===========================================================================
c   compare.f
c   compare two data sets
c   author T. Schreiber
c===========================================================================

      parameter(nx=1000000,mx=2)
      character*72 file
      dimension x(nx,mx), icol(mx)
      data iverb/1/

      call whatido("compare time series in RMS sense",iverb)
      nmaxx=ican("l",nx)
      nexcl=ican("x",0)
      call columns(mc,mx,icol)
      mcmax=mx
      if(nstrings().ne.1) call usage()
      call nthstring(1,file)

      nmax=nmaxx
      call xreadfile(nmax,mcmax,nx,x,nexcl,icol,file,iverb)
      if(file.eq."-") file="stdin"

      call rms(nmax,x(1,1),sc1,sd1)
      call rms(nmax,x(1,2),sc2,sd2)
      do 10 n=1,nmax
 10      x(n,1)=x(n,2)-x(n,1)
      call rms(nmax,x(1,1),scd,sdd)

      write(istderr(),*)
      write(istderr(),*) "col ", icol(1), ": Mean ", sc1,
     .   ", standard deviation ", sd1
      write(istderr(),*) "col ", icol(2), ": Mean ", sc2,
     .   ", standard deviation ", sd2
      write(istderr(),*)
      write(istderr(),*) "mean difference              ", scd
      write(istderr(),*)
     .   "root mean squared difference ", sqrt(sdd**2+scd**2)
      write(istderr(),*) "standard deviation           ", sdd
      end

      subroutine usage()
c usage message

      call whatineed(
     .   "[-l# -x# -c#[,#] -V# -h] file")
      call popt("l","number of values to be read (all)")
      call popt("x","number of values to be skipped (0)")
      call popt("c","columns to be read (1,2)")
      call pall()
      stop
      end


module prolongation_methods
	use structured_grids
	use unstructured_grids
	use precision_specs
	implicit none

	interface linear_interp
		module procedure linear_interp_2d
		module procedure linear_interp_3d
	end interface linear_interp

	interface cubic_interp
		module procedure cubic_interp_2d
		module procedure cubic_interp_3d
	end interface cubic_interp

	contains

	subroutine linear_interp_2d(grid, UC, UF)
		type(Grid2D), intent(in) :: grid
		real(R64), dimension(1:grid%nx, 1:grid%ny), intent(in) :: UC
		real(R64), dimension(1:(2 * grid%nx - 1), 1:(2 * grid%ny - 1)), intent(inout) :: UF

		! Map the course points to the fine points.
		UF(1:size(UF, 1):2, 1:size(UF, 2):2) = UC

		! Interpolate the points for each x-line.
		UF(2:(size(UF, 1) - 1):2, 3:(size(UF, 2) - 2):2) = 0.5 *	( &
																		UF(1:(size(UF, 1) - 2):2, 3:(size(UF, 2) - 2):2) + &
																		UF(3:size(UF, 1):2, 3:(size(UF, 2) - 2):2) &
																	)

		! Interpolate the points for each y-line.
		UF(3:(size(UF, 1) - 2):2, 2:(size(UF, 2) - 1):2) = 0.5 *	( &
																		UF(3:(size(UF, 1) - 2):2, 1:(size(UF, 2) - 2):2) + &
																		UF(3:(size(UF, 1) - 2):2, 3:size(UF, 2):2) &
																	)

		! Interpolate the interior points.
		UF(2:(size(UF, 1) - 1):2, 2:(size(UF, 2) - 1):2) = 0.25 *	( &
																		UF(1:(size(UF, 1) - 2):2, 1:(size(UF, 2) - 2):2) + &
																		UF(1:(size(UF, 1) - 2):2, 3:size(UF, 2):2) + &
																		UF(3:size(UF, 1):2, 1:(size(UF, 2) - 2):2) + &
																		UF(3:size(UF, 1):2, 3:size(UF, 2):2) &
																	)

		! TODO: Interpolation of boundaries.
	end subroutine linear_interp_2d

	subroutine linear_interp_3d(grid, UC, UF)
		type(Grid3D), intent(in) :: grid
		real(R64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz), intent(in) :: UC
		real(R64), dimension(1:(2 * grid%nx - 1), 1:(2 * grid%ny - 1), 1:(2 * grid%nz - 1)), intent(inout) :: UF

		! Map the course points to the fine points.
		UF(1:size(UF, 1):2, 1:size(UF, 2):2, 1:size(UF, 3):2) = UC

		! Interpolate points for each coarse x plane.
		xplane_linear_interp_3d(grid, UC, UF)

		! Interpolate points for each coarse y plane.
		UF(3:(size(UF, 1) - 2):2, 2:(size(UF, 2) - 1):2) = 0.5 *	( &
																		UF(3:(size(UF, 1) - 2):2, 1:(size(UF, 2) - 2):2) + &
																		UF(3:(size(UF, 1) - 2):2, 3:size(UF, 2):2) &
																	)

		! Interpolate points for each coarse z plane.

		! Interpolate the interior points.
		UF(2:(size(UF, 1) - 1):2, 2:(size(UF, 2) - 1):2, 2:(size(UF, 3) - 1):2) = &

		0.125 * ( &
			UF(1:(size(UF, 1) - 2):2, 1:(size(UF, 2) - 2):2, 1:(size(UF, 3) - 2):2) + &
			UF(1:(size(UF, 1) - 2):2, 3:size(UF, 2):2, 1:(size(UF, 3) - 2):2) + &
			UF(3:size(UF, 1):2, 1:(size(UF, 2) - 2):2, 1:(size(UF, 3) - 2):2) + &
			UF(3:size(UF, 1):2, 3:size(UF, 2):2, 1:(size(UF, 3) - 2):2) + &

			UF(1:(size(UF, 1) - 2):2, 1:(size(UF, 2) - 2):2, 3:size(UF, 3):2) + &
			UF(1:(size(UF, 1) - 2):2, 3:size(UF, 2):2, 3:size(UF, 3):2) + &
			UF(3:size(UF, 1):2, 1:(size(UF, 2) - 2):2, 3:size(UF, 3):2) + &
			UF(3:size(UF, 1):2, 3:size(UF, 2):2, 3:size(UF, 3):2) &
		)

		! TODO: Interpolation of boundaries.
	end subroutine linear_interp_3d

	!
	! Subroutine which interpolates the coarse planes of the solution.
	!
	subroutine xplane_linear_interp_3d(grid, UC, UF)
		type(Grid3D), intent(in) :: grid
		real(R64), dimension(1:grid%nx, 1:grid%ny, 1:grid%nz), intent(in) :: UC
		real(R64), dimension(1:(2 * grid%nx - 1), 1:(2 * grid%ny - 1), 1:(2 * grid%nz - 1)), intent(inout) :: UF

		!
		! For each z-level, interpolate the x-lines, y-lines, and interior points.
		!

		! First compute the fine x-line values.
		UF(2:(SIZE(UF, 1) - 1):2, 3:(SIZE(UF, 2) - 2):2, 3:(SIZE(UF, 3) - 2):2) = &

		0.5 * ( &
			UF(1:(SIZE(UF, 1) - 2):2, 3:(SIZE(UF, 2) - 2):2, 3:(SIZE(UF, 3) - 2):2) + &
			UF(3:SIZE(UF, 1):2, 3:(SIZE(UF, 2) - 2):2, 3:(SIZE(UF, 3) - 2):2) &
		)

		! Now compute the fine y-line values.
		UF(3:(SIZE(UF, 1) - 2):2, 2:(SIZE(UF, 2) - 1):2, 3:(SIZE(UF, 3) - 2):2) = &

		0.5 * ( &
			UF(3:(SIZE(UF, 1) - 2):2, 2:(SIZE(UF, 2) - 1):2, 3:(SIZE(UF, 3) - 2):2) + &
			UF(3:(SIZE(UF, 1) - 2):2, 2:(SIZE(UF, 2) - 1):2, 3:(SIZE(UF, 3) - 2):2) &
		)

		! Now compute the interior points
		UF(2:(SIZE(UF, 1) - 1):2, 2:(SIZE(UF, 1) - 1):2, 3:(SIZE(UF, 3) - 2):2) = &

		0.25 * ( &
			UF(i - 1, j - 1, k) + &
			UF(i - 1, j + 1, k) + &
			UF(i + 1, j - 1, k) + &
			UF(i + 1, j + 1, k) + &
		)
	end subroutine xplane_linear_interp_3d

end module


program test2_constHelmholtz

  use multigrid

  implicit none

  integer, parameter :: num=selected_real_kind(p=15)
!  real(num) :: pi = 4.0_num * ATAN(1.0_num)

  integer :: nx, ny, ix, iy

  real(num) :: dx, dy, L2, x_min, x_max, y_min, y_max

  real(num), dimension(:), allocatable :: xc, yc
  real(num), dimension(:,:), allocatable :: f,analytic, phi
  real(num), dimension(:), allocatable :: L2_arr, n_arr

  integer :: power, power_min, power_max

  type(mg_input) :: input

  ! setup a test problem

  print *,' As test 2 but passed to the const helmholtz mode with alpha=0 beta = -1 '
  print *,' (i.e., test the relaxation for CH mode reduces to poissions equation)'

  power_min = 3
  power_max = 10

  allocate(L2_arr(1:1+power_max-power_min))
  allocate(n_arr(1:1+power_max-power_min))
  L2_arr = 1e6_num
  n_arr = 0

  different_resolutions: do power= power_min, power_max

    nx = 2**power
    ny = nx
    x_min = 0.0_num
    x_max = 1.0_num
    y_min = x_min
    y_max = x_max

    allocate(xc(-1:nx+2))
    allocate(yc(-1:ny+2))

    dx = (x_max - x_min) / real(nx,num)
    xc(-1) = x_min - 3.0_num * dx / 2.0_num
    do ix = 0,nx+2
      xc(ix) = xc(ix-1) + dx
    enddo

    dy = (y_max - y_min) / real(ny,num)
    yc(-1) = y_min - 3.0_num * dy / 2.0_num
    do iy = 0,ny+2
      yc(iy) = yc(iy-1) + dy
    enddo

    allocate(phi(-1:nx+2,-1:ny+2)) ! again, redundant ghosts but for comparison to CCAPS
    phi = 0.0_num

    allocate(analytic(1:nx,1:ny)) ! again, redundant ghosts but for comparison to CCAPS
    analytic = 0.0_num

    allocate(f(1:nx,1:ny))

    do iy = 1, ny
    do ix = 1, nx
      f(ix,iy) = -2.0_num * ((1.0_num-6.0_num*xc(ix)**2)*(yc(iy)**2)*(1.0_num-yc(iy)**2) &
        & + (1.0_num-6.0_num*yc(iy)**2)*(xc(ix)**2)*(1.0_num-xc(ix)**2))
    enddo
    enddo

!    ! Solve for phi
!    nlevels = -1 ! auto
!    call mg_interface(f = f, phi=phi, tol = 1e-12_num, &
!                    & nx = nx, ny = ny, dx = dx, dy = dy, &
!                    &  nlevels = nlevels, &
!    & bc_xmin_in = fixed, bc_ymin_in = fixed, bc_xmax_in = fixed, bc_ymax_in = fixed)

  input = mg_input(tol = 1e-12_num, nx=nx, ny = ny, dx=dx, dy=dy, f = f, phi = phi, &
            & bc_xmin = 'fixed', bc_ymin='fixed', bc_xmax='fixed', bc_ymax = 'fixed', &
            & const_helmholtz = .true., ch_alpha = 0.0_num, ch_beta = -1.0_num, &
            & deallocate_after = .true.)

  call mg_interface(input)

  phi = input%phi

    ! test against analytical solution

    do iy = 1, ny
    do ix = 1, nx
      analytic(ix,iy) = (xc(ix)**2-xc(ix)**4) * (yc(iy)**4-yc(iy)**2)
    enddo
    enddo

    L2 = sqrt(sum(abs(analytic(1:nx,1:ny)-phi(1:nx,1:ny))**2) / real(nx*ny,num))

    print *,'L2',L2

    L2_arr(power-power_min+1) = L2
    n_arr(power-power_min+1) = real(nx,num)

    ! deallocate all so can do again

    deallocate(xc)
    deallocate(yc)
    deallocate(f)
    deallocate(phi)
    deallocate(analytic)

  enddo different_resolutions

  print *, 'L2 _arr',L2_arr
  print *, 'n _arr',n_arr

  call execute_command_line("rm -rf test2_l2.dat")
  call execute_command_line("rm -rf test2_nx.dat")

  open(10, file="test2_l2.dat", access="stream")
  write(10) L2_arr
  close(10)

  open(10, file="test2_nx.dat", access="stream")
  write(10) n_arr
  close(10)

  call execute_command_line("python test2_plots.py")
  call execute_command_line("rm test2_l2.dat")
  call execute_command_line("rm test2_nx.dat")

end program test2_constHelmholtz


! Like array_constructor_6.f90, but check constructors that mix iterators
! and individual scalar elements.
! { dg-do run }
program main
  implicit none
  call build (42)
contains
  subroutine build (order)
    integer :: order, i

    call test (order, 8, 5, (/ ((/ 1, 2, 3, 4, 5, 6, 7, 8 /), i = 1, order), &
                               100, 200, 300, 400, 500 /))

    call test (order, 2, 3, (/ ((/ 1, 2 /), i = 1, order), &
                               100, 200, 300 /))

    call test (order, 3, 5, (/ ((/ 1, 2, 3 /), i = 1, order), &
                               100, 200, 300, 400, 500 /))

    call test (order, 6, 1, (/ ((/ 1, 2, 3, 4, 5, 6 /), i = 1, order), &
                               100 /))

    call test (order, 5, 0, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, order) /))

    call test (order, 0, 4, (/ 100, 200, 300, 400 /))

    call test (11, 5, 2, (/ ((/ 1, 2, 3, 4, 5 /), i = 1, 11), &
                            100, 200 /))

    call test (6, 2, order, (/ ((/ 1, 2 /), i = 1, 6), &
                               (i * 100, i = 1, order) /))
  end subroutine build

  subroutine test (order, repeat, trail, values)
    integer, dimension (:) :: values
    integer :: order, repeat, trail, i

    if (size (values, dim = 1) .ne. order * repeat + trail) STOP 1
    do i = 1, order * repeat
      if (values (i) .ne. mod (i - 1, repeat) + 1) STOP 2
    end do
    do i = 1, trail
      if (values (i + order * repeat) .ne. i * 100) STOP 3
    end do
  end subroutine test
end program main


      SUBROUTINE TG01WD( N, M, P, A, LDA, E, LDE, B, LDB, C, LDC,
     $                   Q, LDQ, Z, LDZ, ALPHAR, ALPHAI, BETA, DWORK,
     $                   LDWORK, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To reduce the pair (A,E) to a real generalized Schur form
C     by using an orthogonal equivalence transformation
C     (A,E) <-- (Q'*A*Z,Q'*E*Z) and to apply the transformation
C     to the matrices B and C: B <-- Q'*B and C <-- C*Z.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     N       (input) INTEGER
C             The order of the original state-space representation,
C             i.e., the order of the matrices A and E.  N >= 0.
C
C     M       (input) INTEGER
C             The number of system inputs, or of columns of B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of system outputs, or of rows of C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original state dynamics matrix A.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Q' * A * Z in an upper quasi-triangular form.
C             The elements below the first subdiagonal are set to zero.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,N).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading N-by-N part of this array must
C             contain the original descriptor matrix E.
C             On exit, the leading N-by-N part of this array contains
C             the matrix Q' * E * Z in an upper triangular form.
C             The elements below the diagonal are set to zero.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,N).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading N-by-M part of this array must
C             contain the input matrix B.
C             On exit, the leading N-by-M part of this array contains
C             the transformed input matrix Q' * B.
C
C     LDB     INTEGER
C             The leading dimension of array B.  LDB >= MAX(1,N).
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N)
C             On entry, the leading P-by-N part of this array must
C             contain the output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed output matrix C * Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (output) DOUBLE PRECISION array, dimension (LDQ,N)
C             The leading N-by-N part of this array contains the left
C             orthogonal transformation matrix used to reduce (A,E) to
C             the real generalized Schur form.
C             The columns of Q are the left generalized Schur vectors
C             of the pair (A,E).
C
C     LDQ     INTEGER
C             The leading dimension of array Q.  LDQ >= max(1,N).
C
C     Z       (output) DOUBLE PRECISION array, dimension (LDZ,N)
C             The leading N-by-N part of this array contains the right
C             orthogonal transformation matrix used to reduce (A,E) to
C             the real generalized Schur form.
C             The columns of Z are the right generalized Schur vectors
C             of the pair (A,E).
C
C     LDZ     INTEGER
C             The leading dimension of array Z.  LDZ >= max(1,N).
C
C     ALPHAR  (output) DOUBLE PRECISION array, dimension (N)
C     ALPHAI  (output) DOUBLE PRECISION array, dimension (N)
C     BETA    (output) DOUBLE PRECISION array, dimension (N)
C             On exit, if INFO = 0, (ALPHAR(j) + ALPHAI(j)*i)/BETA(j),
C             j=1,...,N, will be the generalized eigenvalues.
C             ALPHAR(j) + ALPHAI(j)*i, and BETA(j), j=1,...,N, are the
C             diagonals of the complex Schur form that would result if
C             the 2-by-2 diagonal blocks of the real Schur form of
C             (A,E) were further reduced to triangular form using
C             2-by-2 complex unitary transformations.
C             If ALPHAI(j) is zero, then the j-th eigenvalue is real;
C             if positive, then the j-th and (j+1)-st eigenvalues are a
C             complex conjugate pair, with ALPHAI(j+1) negative.
C
C     Workspace
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK.
C
C     LDWORK  INTEGER
C             The dimension of working array DWORK.  LDWORK >= 8*N+16.
C             For optimum performance LDWORK should be larger.
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             > 0:  if INFO = i, the QZ algorithm failed to compute
C                   the generalized real Schur form; elements i+1:N of
C                   ALPHAR, ALPHAI, and BETA should be correct.
C
C     METHOD
C
C     The pair (A,E) is reduced to a real generalized Schur form using
C     an orthogonal equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z)
C     and the transformation is applied to the matrices B and C:
C     B <-- Q'*B and C <-- C*Z.
C
C     NUMERICAL ASPECTS
C                                     3
C     The algorithm requires about 25N  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center,
C     DLR Oberpfaffenhofen, July 2000.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, Mar. 2001.
C
C     KEYWORDS
C
C     Orthogonal transformation, generalized real Schur form, similarity
C     transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, LDA, LDB, LDC, LDE, LDQ, LDWORK, LDZ,
     $                  M, N, P
C     .. Array Arguments ..
      DOUBLE PRECISION  A(LDA,*), ALPHAI(*), ALPHAR(*), B(LDB,*),
     $                  BETA(*),  C(LDC,*),  DWORK(*),  E(LDE,*),
     $                  Q(LDQ,*), Z(LDZ,*)
C     .. Local Scalars ..
      LOGICAL           BLAS3, BLOCK
      INTEGER           BL, CHUNK, I, J, MAXWRK, SDIM
C     .. Local Arrays ..
      LOGICAL           BWORK(1)
C     .. External Functions ..
      LOGICAL           LSAME, DELCTG
      EXTERNAL          LSAME, DELCTG
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEMM, DGEMV, DGGES, DLACPY, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
      INFO = 0
C
C     Check the scalar input parameters.
C
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( M.LT.0 ) THEN
         INFO = -2
      ELSE IF( P.LT.0 ) THEN
         INFO = -3
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -5
      ELSE IF( LDE.LT.MAX( 1, N ) ) THEN
         INFO = -7
      ELSE IF( LDB.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -11
      ELSE IF( LDQ.LT.MAX( 1, N ) ) THEN
         INFO = -13
      ELSE IF( LDZ.LT.MAX( 1, N ) ) THEN
         INFO = -15
      ELSE IF( LDWORK.LT.8*N+16 ) THEN
         INFO = -20
      END IF
C
      IF( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'TG01WD', -INFO )
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF( N.EQ.0 ) THEN
         DWORK(1) = ONE
         RETURN
      END IF
C
C     Reduce (A,E) to real generalized Schur form using an orthogonal
C     equivalence transformation (A,E) <-- (Q'*A*Z,Q'*E*Z), accumulate
C     the transformations in Q and Z, and compute the generalized
C     eigenvalues of the pair (A,E) in (ALPHAR, ALPHAI, BETA).
C
C     Workspace:  need   8*N+16;
C                 prefer larger.
C
      CALL DGGES( 'Vectors', 'Vectors', 'Not ordered', DELCTG, N,
     $            A, LDA, E, LDE, SDIM, ALPHAR, ALPHAI, BETA, Q, LDQ,
     $            Z, LDZ, DWORK, LDWORK, BWORK, INFO )
      IF( INFO.NE.0 )
     $   RETURN
      MAXWRK = INT( DWORK(1) )
C
C     Apply the transformation: B <-- Q'*B. Use BLAS 3, if enough space.
C
      CHUNK = LDWORK / N
      BLOCK = M.GT.1
      BLAS3 = CHUNK.GE.M .AND. BLOCK
C
      IF( BLAS3 ) THEN
C
C        Enough workspace for a fast BLAS 3 algorithm.
C
         CALL DLACPY( 'Full', N, M, B, LDB, DWORK, N )
         CALL DGEMM( 'Transpose', 'No transpose', N, M, N, ONE, Q, LDQ,
     $               DWORK, N, ZERO, B, LDB )
C
      ELSE IF ( BLOCK ) THEN
C
C        Use as many columns of B as possible.
C
         DO 10 J = 1, M, CHUNK
            BL = MIN( M-J+1, CHUNK )
            CALL DLACPY( 'Full', N, BL, B(1,J), LDB, DWORK, N )
            CALL DGEMM( 'Transpose', 'NoTranspose', N, BL, N, ONE, Q,
     $                  LDQ, DWORK, N, ZERO, B(1,J), LDB )
   10    CONTINUE
C
      ELSE
C
C        Use a BLAS 2 algorithm. Here, M <= 1.
C
         IF ( M.GT.0 ) THEN
            CALL DCOPY( N, B, 1, DWORK, 1 )
            CALL DGEMV( 'Transpose', N, N, ONE, Q, LDQ, DWORK, 1, ZERO,
     $                  B, 1 )
         END IF
      END IF
      MAXWRK = MAX( MAXWRK, N*M )
C
C     Apply the transformation: C <-- C*Z.  Use BLAS 3, if enough space.
C
      BLOCK = P.GT.1
      BLAS3 = CHUNK.GE.P .AND. BLOCK
C
      IF ( BLAS3 ) THEN
         CALL DLACPY( 'Full', P, N, C, LDC, DWORK, P )
         CALL DGEMM( 'No transpose', 'No transpose', P, N, N, ONE,
     $               DWORK, P, Z, LDZ, ZERO, C, LDC )
C
      ELSE IF ( BLOCK ) THEN
C
C        Use as many rows of C as possible.
C
         DO 20 I = 1, P, CHUNK
            BL = MIN( P-I+1, CHUNK )
            CALL DLACPY( 'Full', BL, N, C(I,1), LDC, DWORK, BL )
            CALL DGEMM( 'NoTranspose', 'NoTranspose', BL, N, N, ONE,
     $                  DWORK, BL, Z, LDZ, ZERO, C(I,1), LDC )
   20    CONTINUE
C
      ELSE
C
C        Use a BLAS 2 algorithm. Here, P <= 1.
C
         IF ( P.GT.0 ) THEN
            CALL DCOPY( N, C, LDC, DWORK, 1 )
            CALL DGEMV( 'Transpose', N, N, ONE, Z, LDZ, DWORK, 1, ZERO,
     $                  C, LDC )
         END IF
C
      END IF
      MAXWRK = MAX( MAXWRK, P*N )
C
      DWORK(1) = DBLE( MAXWRK )
C
      RETURN
C *** Last line of TG01WD ***
      END


      SUBROUTINE MB02ND( M, N, L, RANK, THETA, C, LDC, X, LDX, Q, INUL,
     $                   TOL, RELTOL, IWORK, DWORK, LDWORK, BWORK,
     $                   IWARN, INFO )
C
C     SLICOT RELEASE 5.5.
C
C     Copyright (c) 2002-2012 NICONET e.V.
C
C     PURPOSE
C
C     To solve the Total Least Squares (TLS) problem using a Partial
C     Singular Value Decomposition (PSVD) approach.
C     The TLS problem assumes an overdetermined set of linear equations
C     AX = B, where both the data matrix A as well as the observation
C     matrix B are inaccurate. The routine also solves determined and
C     underdetermined sets of equations by computing the minimum norm
C     solution.
C     It is assumed that all preprocessing measures (scaling, coordinate
C     transformations, whitening, ... ) of the data have been performed
C     in advance.
C
C     ARGUMENTS
C
C     Input/Output Parameters
C
C     M       (input) INTEGER
C             The number of rows in the data matrix A and the
C             observation matrix B.  M >= 0.
C
C     N       (input) INTEGER
C             The number of columns in the data matrix A.  N >= 0.
C
C     L       (input) INTEGER
C             The number of columns in the observation matrix B.
C             L >= 0.
C
C     RANK    (input/output) INTEGER
C             On entry, if RANK < 0, then the rank of the TLS
C             approximation [A+DA|B+DB] (r say) is computed by the
C             routine.
C             Otherwise, RANK must specify the value of r.
C             RANK <= min(M,N).
C             On exit, if RANK < 0 on entry and INFO = 0, then RANK
C             contains the computed rank of the TLS approximation
C             [A+DA|B+DB].
C             Otherwise, the user-supplied value of RANK may be
C             changed by the routine on exit if the RANK-th and the
C             (RANK+1)-th singular values of C = [A|B] are considered
C             to be equal, or if the upper triangular matrix F (as
C             defined in METHOD) is (numerically) singular.
C
C     THETA   (input/output) DOUBLE PRECISION
C             On entry, if RANK < 0, then the rank of the TLS
C             approximation [A+DA|B+DB] is computed using THETA as
C             (min(M,N+L) - d), where d is the number of singular
C             values of [A|B] <= THETA. THETA >= 0.0.
C             Otherwise, THETA is an initial estimate (t say) for
C             computing a lower bound on the RANK largest singular
C             values of [A|B]. If THETA < 0.0 on entry however, then
C             t is computed by the routine.
C             On exit, if RANK >= 0 on entry, then THETA contains the
C             computed bound such that precisely RANK singular values
C             of C = [A|B] are greater than THETA + TOL.
C             Otherwise, THETA is unchanged.
C
C     C       (input/output) DOUBLE PRECISION array, dimension (LDC,N+L)
C             On entry, the leading M-by-(N+L) part of this array must
C             contain the matrices A and B. Specifically, the first N
C             columns must contain the data matrix A and the last L
C             columns the observation matrix B (right-hand sides).
C             On exit, if INFO = 0, the first N+L components of the
C             columns of this array whose index i corresponds with
C             INUL(i) = .TRUE., are the possibly transformed (N+L-RANK)
C             base vectors of the right singular subspace corresponding
C             to the singular values of C = [A|B] which are less than or
C             equal to THETA. Specifically, if L = 0, or if RANK = 0 and
C             IWARN <> 2, these vectors are indeed the base vectors
C             above. Otherwise, these vectors form the matrix V2,
C             transformed as described in Step 4 of the PTLS algorithm
C             (see METHOD). The TLS solution is computed from these
C             vectors. The other columns of array C contain no useful
C             information.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= max(1,M,N+L).
C
C     X       (output) DOUBLE PRECISION array, dimension (LDX,L)
C             If INFO = 0, the leading N-by-L part of this array
C             contains the solution X to the TLS problem specified by
C             A and B.
C
C     LDX     INTEGER
C             The leading dimension of array X.  LDX >= max(1,N).
C
C     Q       (output) DOUBLE PRECISION array, dimension
C             (max(1,2*min(M,N+L)-1))
C             This array contains the partially diagonalized bidiagonal
C             matrix J computed from C, at the moment that the desired
C             singular subspace has been found. Specifically, the
C             leading p = min(M,N+L) entries of Q contain the diagonal
C             elements q(1),q(2),...,q(p) and the entries Q(p+1),Q(p+2),
C             ...,Q(2*p-1) contain the superdiagonal elements e(1),e(2),
C             ...,e(p-1) of J.
C
C     INUL    (output) LOGICAL array, dimension (N+L)
C             The indices of the elements of this array with value
C             .TRUE. indicate the columns in C containing the base
C             vectors of the right singular subspace of C from which
C             the TLS solution has been computed.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             This parameter defines the multiplicity of singular values
C             by considering all singular values within an interval of
C             length TOL as coinciding. TOL is used in checking how many
C             singular values are less than or equal to THETA. Also in
C             computing an appropriate upper bound THETA by a bisection
C             method, TOL is used as a stopping criterion defining the
C             minimum (absolute) subinterval width. TOL is also taken
C             as an absolute tolerance for negligible elements in the
C             QR/QL iterations. If the user sets TOL to be less than or
C             equal to 0, then the tolerance is taken as specified in
C             SLICOT Library routine MB04YD document.
C
C     RELTOL  DOUBLE PRECISION
C             This parameter specifies the minimum relative width of an
C             interval. When an interval is narrower than TOL, or than
C             RELTOL times the larger (in magnitude) endpoint, then it
C             is considered to be sufficiently small and bisection has
C             converged. If the user sets RELTOL to be less than
C             BASE * EPS, where BASE is machine radix and EPS is machine
C             precision (see LAPACK Library routine DLAMCH), then the
C             tolerance is taken as BASE * EPS.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N+2*L)
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if INFO = 0, DWORK(1) returns the optimal value
C             of LDWORK, and DWORK(2) returns the reciprocal of the
C             condition number of the matrix F.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK = max(2, max(M,N+L) + 2*min(M,N+L),
C                          min(M,N+L) + LW + max(6*(N+L)-5,
C                                                L*L+max(N+L,3*L)),
C             where
C             LW = (N+L)*(N+L-1)/2,  if M >= N+L,
C             LW = M*(N+L-(M-1)/2),  if M <  N+L.
C             For optimum 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     BWORK   LOGICAL array, dimension (N+L)
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warnings;
C             = 1:  if the rank of matrix C has been lowered because a
C                   singular value of multiplicity greater than 1 was
C                   found;
C             = 2:  if the rank of matrix C has been lowered because the
C                   upper triangular matrix F is (numerically) singular.
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:  if the maximum number of QR/QL iteration steps
C                   (30*MIN(M,N)) has been exceeded;
C             = 2:  if the computed rank of the TLS approximation
C                   [A+DA|B+DB] exceeds MIN(M,N). Try increasing the
C                   value of THETA or set the value of RANK to min(M,N).
C
C     METHOD
C
C     The method used is the Partial Total Least Squares (PTLS) approach
C     proposed by Van Huffel and Vandewalle [5].
C
C     Let C = [A|B] denote the matrix formed by adjoining the columns of
C     B to the columns of A on the right.
C
C     Total Least Squares (TLS) definition:
C     -------------------------------------
C
C       Given matrices A and B, find a matrix X satisfying
C
C            (A + DA) X = B + DB,
C
C       where A and DA are M-by-N matrices, B and DB are M-by-L matrices
C       and X is an N-by-L matrix.
C       The solution X must be such that the Frobenius norm of [DA|DB]
C       is a minimum and each column of B + DB is in the range of
C       A + DA. Whenever the solution is not unique, the routine singles
C       out the minimum norm solution X.
C
C     Let V denote the right singular subspace of C. Since the TLS
C     solution can be computed from any orthogonal basis of the subspace
C     of V corresponding to the smallest singular values of C, the
C     Partial Singular Value Decomposition (PSVD) can be used instead of
C     the classical SVD. The dimension of this subspace of V may be
C     determined by the rank of C or by an upper bound for those
C     smallest singular values.
C
C     The PTLS algorithm proceeds as follows (see [2 - 5]):
C
C     Step 1: Bidiagonalization phase
C             -----------------------
C      (a) If M is large enough than N + L, transform C into upper
C          triangular form R by Householder transformations.
C      (b) Transform C (or R) into upper bidiagonal form
C          (p = min(M,N+L)):
C
C                     |q(1) e(1)  0   ...  0   |
C                (0)  | 0   q(2) e(2)      .   |
C               J   = | .                  .   |
C                     | .                e(p-1)|
C                     | 0             ... q(p) |
C
C          if M >= N + L, or lower bidiagonal form:
C
C                     |q(1)  0    0   ...  0     0   |
C                (0)  |e(1) q(2)  0        .     .   |
C               J   = | .                  .     .   |
C                     | .                 q(p)   .   |
C                     | 0             ... e(p-1) q(p)|
C
C          if M < N + L, using Householder transformations.
C          In the second case, transform the matrix to the upper
C          bidiagonal form by applying Givens rotations.
C      (c) Initialize the right singular base matrix with the identity
C          matrix.
C
C     Step 2: Partial diagonalization phase
C             -----------------------------
C     If the upper bound THETA is not given, then compute THETA such
C     that precisely p - RANK singular values (p=min(M,N+L)) of the
C     bidiagonal matrix are less than or equal to THETA, using a
C     bisection method [5]. Diagonalize the given bidiagonal matrix J
C     partially, using either QL iterations (if the upper left diagonal
C     element of the considered bidiagonal submatrix is smaller than the
C     lower right diagonal element) or QR iterations, such that J is
C     split into unreduced bidiagonal submatrices whose singular values
C     are either all larger than THETA or are all less than or equal
C     to THETA. Accumulate the Givens rotations in V.
C
C     Step 3: Back transformation phase
C             -------------------------
C     Apply the Householder transformations of Step 1(b) onto the base
C     vectors of V associated with the bidiagonal submatrices with all
C     singular values less than or equal to THETA.
C
C     Step 4: Computation of F and Y
C             ----------------------
C     Let V2 be the matrix of the columns of V corresponding to the
C     (N + L - RANK) smallest singular values of C.
C     Compute with Householder transformations the matrices F and Y
C     such that:
C
C                       |VH   Y|
C              V2 x Q = |      |
C                       |0    F|
C
C     where Q is an orthogonal matrix, VH is an N-by-(N-RANK) matrix,
C     Y is an N-by-L matrix and F is an L-by-L upper triangular matrix.
C     If F is singular, then reduce the value of RANK by one and repeat
C     Steps 2, 3 and 4.
C
C     Step 5: Computation of the TLS solution
C             -------------------------------
C     If F is non-singular then the solution X is obtained by solving
C     the following equations by forward elimination:
C
C              X F = -Y.
C
C     Notes:
C     If RANK is lowered in Step 4, some additional base vectors must
C     be computed in Step 2. The additional computations are kept to
C     a minimum.
C     If RANK is lowered in Step 4 but the multiplicity of the RANK-th
C     singular value is larger than 1, then the value of RANK is further
C     lowered with its multiplicity defined by the parameter TOL. This
C     is done at the beginning of Step 2 by calling SLICOT Library
C     routine MB03MD (from MB04YD), which estimates THETA using a
C     bisection method. If F in Step 4 is singular, then the computed
C     solution is infinite and hence does not satisfy the second TLS
C     criterion (see TLS definition). For these cases, Golub and
C     Van Loan [1] claim that the TLS problem has no solution. The
C     properties of these so-called nongeneric problems are described
C     in [6] and the TLS computations are generalized in order to solve
C     them. As proven in [6], the proposed generalization satisfies the
C     TLS criteria for any number L of observation vectors in B provided
C     that, in addition, the solution | X| is constrained to be
C                                     |-I|
C     orthogonal to all vectors of the form |w| which belong to the
C                                           |0|
C     space generated by the columns of the submatrix |Y|.
C                                                     |F|
C
C     REFERENCES
C
C     [1] Golub, G.H. and Van Loan, C.F.
C         An Analysis of the Total Least-Squares Problem.
C         SIAM J. Numer. Anal., 17, pp. 883-893, 1980.
C
C     [2] Van Huffel, S., Vandewalle, J. and Haegemans, A.
C         An Efficient and Reliable Algorithm for Computing the
C         Singular Subspace of a Matrix Associated with its Smallest
C         Singular Values.
C         J. Comput. and Appl. Math., 19, pp. 313-330, 1987.
C
C     [3] Van Huffel, S.
C         Analysis of the Total Least Squares Problem and its Use in
C         Parameter Estimation.
C         Doctoral dissertation, Dept. of Electr. Eng., Katholieke
C         Universiteit Leuven, Belgium, June 1987.
C
C     [4] Chan, T.F.
C         An Improved Algorithm for Computing the Singular Value
C         Decomposition.
C         ACM TOMS, 8, pp. 72-83, 1982.
C
C     [5] Van Huffel, S. and Vandewalle, J.
C         The Partial Total Least Squares Algorithm.
C         J. Comput. Appl. Math., 21, pp. 333-341, 1988.
C
C     [6] Van Huffel, S. and Vandewalle, J.
C         Analysis and Solution of the Nongeneric Total Least Squares
C         Problem.
C         SIAM J. Matr. Anal. and Appl., 9, pp. 360-372, 1988.
C
C     NUMERICAL ASPECTS
C
C     The computational efficiency of the PTLS algorithm compared with
C     the classical TLS algorithm (see [2 - 5]) is obtained by making
C     use of PSVD (see [1]) instead of performing the entire SVD.
C     Depending on the gap between the RANK-th and the (RANK+1)-th
C     singular values of C, the number (N + L - RANK) of base vectors to
C     be computed with respect to the column dimension (N + L) of C and
C     the desired accuracy RELTOL, the algorithm used by this routine is
C     approximately twice as fast as the classical TLS algorithm at the
C     expense of extra storage requirements, namely:
C       (N + L) x (N + L - 1)/2  if M >= N + L or
C       M x (N + L - (M - 1)/2)  if M <  N + L.
C     This is because the Householder transformations performed on the
C     rows of C in the bidiagonalization phase (see Step 1) must be kept
C     until the end (Step 5).
C
C     CONTRIBUTOR
C
C     Release 3.0: V. Sima, Katholieke Univ. Leuven, Belgium, Apr. 1997.
C     Supersedes Release 2.0 routine MB02BD by S. Van Huffel, Katholieke
C     University, Leuven, Belgium.
C
C     REVISIONS
C
C     V. Sima. June 30, 1997, Oct. 19, 2003, Feb. 15, 2004, Aug. 2011.
C
C     KEYWORDS
C
C     Least-squares approximation, singular subspace, singular value
C     decomposition, singular values, total least-squares.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION  ZERO, ONE, TWO
      PARAMETER         ( ZERO = 0.0D0, ONE = 1.0D0, TWO = 2.0D0 )
C     .. Scalar Arguments ..
      INTEGER           INFO, IWARN, L, LDC, LDWORK, LDX, M, N, RANK
      DOUBLE PRECISION  RELTOL, THETA, TOL
C     .. Array Arguments ..
      LOGICAL           BWORK(*), INUL(*)
      INTEGER           IWORK(*)
      DOUBLE PRECISION  C(LDC,*), DWORK(*), Q(*), X(LDX,*)
C     .. Local Scalars ..
      LOGICAL           LFIRST, LQUERY, SUFWRK, USEQR
      INTEGER           I, I1, IFAIL, IHOUSH, IJ, IOFF, ITAUP, ITAUQ,
     $                  IWARM, J, J1, JF, JV, JWORK, K, KF, KJ, LDF, LW,
     $                  MC, MINWRK, MJ, MNL, N1, NJ, NL, P, WRKOPT
      DOUBLE PRECISION  CS, EPS, FIRST, FNORM, HH, INPROD, RCOND, SN,
     $                  TEMP
C     .. Local Arrays ..
      DOUBLE PRECISION  DUMMY(2)
C     .. External Functions ..
      LOGICAL           LSAME
      INTEGER           ILAENV
      DOUBLE PRECISION  DLAMCH, DLANGE, DLANTR
      EXTERNAL          DLAMCH, DLANGE, DLANTR, ILAENV, LSAME
C     .. External Subroutines ..
      EXTERNAL          DCOPY, DGEBRD, DGEQRF, DGERQF, DLARF, DLARFG,
     $                  DLARTG, DLASET, DORMBR, DORMRQ, DTRCON, DTRSM,
     $                  MB04YD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC         INT, MAX, MIN
C     .. Executable Statements ..
C
      IWARN = 0
      INFO  = 0
      NL = N + L
      K  = MAX( M, NL )
      P  = MIN( M, NL )
      IF ( M.GE.NL ) THEN
         LW = ( NL*( NL - 1 ) )/2
      ELSE
         LW = M*NL - ( M*( M - 1 ) )/2
      END IF
      JV = P + LW + MAX( 6*NL - 5, L*L + MAX( NL, 3*L ) )
C
C     Test the input scalar arguments.
C
      IF( M.LT.0 ) THEN
         INFO = -1
      ELSE IF( N.LT.0 ) THEN
         INFO = -2
      ELSE IF( L.LT.0 ) THEN
         INFO = -3
      ELSE IF( RANK.GT.MIN( M, N ) ) THEN
         INFO = -4
      ELSE IF( ( RANK.LT.0 ) .AND. ( THETA.LT.ZERO ) ) THEN
         INFO = -5
      ELSE IF( LDC.LT.MAX( 1, K ) ) THEN
         INFO = -7
      ELSE IF( LDX.LT.MAX( 1, N ) ) THEN
         INFO = -9
      ELSE
         USEQR = M.GE.MAX( NL, ILAENV( 6, 'DGESVD', 'N' // 'N', M, NL,
     $                                 0, 0 ) )
         LQUERY = LDWORK.EQ.-1
         MINWRK = MAX( 2, K + 2*P, JV )
         WRKOPT = MINWRK
         IF ( USEQR ) THEN
            MNL = NL
         ELSE
            MNL = M
         END IF
         IF( LQUERY ) THEN
            IF ( USEQR ) THEN
               CALL DGEQRF( M, NL, C, LDC, DWORK, DWORK, -1, IFAIL )
               WRKOPT = MAX( WRKOPT, NL + INT( DWORK(1) ) )
            END IF
            CALL DGEBRD( MNL, NL, C, LDC, Q, Q, DWORK, DWORK, DWORK, -1,
     $                   IFAIL )
            CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, NL,
     $                   MNL, DWORK, P, DWORK, DWORK, NL, DWORK(2), -1,
     $                   IFAIL )
            CALL DGERQF( L, NL, DWORK, NL, DWORK, DUMMY, -1, IFAIL )
            CALL DORMRQ( 'Right', 'Transpose', N, NL, L, DWORK, NL,
     $                   DWORK, DWORK, NL, DUMMY(2), -1, IFAIL )
            TEMP   = MAX( DWORK(2), DUMMY(1), DUMMY(2) )
            WRKOPT = MAX( WRKOPT, 2*P + INT( DWORK(1) ),
     $                    P + P*NL + MAX( 6*NL-5,
     $                                    NL**2 + MAX( INT( TEMP ),
     $                                                 3*L ) ) )
         END IF
         IF( LDWORK.LT.MINWRK .AND. .NOT.LQUERY )
     $       INFO = -16
      END IF
C
      IF ( INFO.NE.0 ) THEN
C
C        Error return.
C
         CALL XERBLA( 'MB02ND', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Quick return if possible.
C
      IF ( MIN( M, NL ).EQ.0 ) THEN
         IF ( M.EQ.0 ) THEN
            CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC )
            CALL DLASET( 'Full', N, L, ZERO, ZERO, X, LDX )
C
            DO 10 I = 1, NL
               INUL(I) = .TRUE.
   10       CONTINUE
C
         END IF
         IF ( RANK.GE.0 )
     $      THETA = ZERO
         RANK = 0
         DWORK(1) = TWO
         DWORK(2) = ONE
         RETURN
      END IF
C
      WRKOPT = 2
      N1 = N + 1
C
      EPS = DLAMCH( 'Precision' )
      LFIRST = .TRUE.
C
C     Initializations.
C
      DO 20 I = 1, P
         INUL(I)  = .FALSE.
         BWORK(I) = .FALSE.
   20 CONTINUE
C
      DO 40 I = P + 1, NL
         INUL(I)  = .TRUE.
         BWORK(I) = .FALSE.
   40 CONTINUE
C
C     Subroutine MB02ND solves a set of linear equations by a Total
C     Least Squares Approximation, based on the Partial SVD.
C
C     Step 1: Bidiagonalization phase
C             -----------------------
C     1.a): If M is large enough than N+L, transform C into upper
C           triangular form R by Householder transformations.
C
C     (Note: Comments in the code beginning "Workspace:" describe the
C     minimal amount of real 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
      IF ( USEQR ) THEN
C
C        Workspace: need   2*(N+L),
C                   prefer N+L + (N+L)*NB.
C
         ITAUQ = 1
         JWORK = ITAUQ + NL
         CALL DGEQRF( M, NL, C, LDC, DWORK(ITAUQ), DWORK(JWORK),
     $                LDWORK-JWORK+1, IFAIL )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
         IF ( NL.GT.1 )
     $      CALL DLASET( 'Lower', NL-1, NL-1, ZERO, ZERO, C(2,1), LDC )
      END IF
C
C     1.b): Transform C (or R) into bidiagonal form Q using Householder
C           transformations.
C     Workspace: need   2*min(M,N+L) + max(M,N+L),
C                prefer 2*min(M,N+L) + (M+N+L)*NB.
C
      ITAUP = 1
      ITAUQ = ITAUP + P
      JWORK = ITAUQ + P
      CALL DGEBRD( MNL, NL, C, LDC, Q, Q(P+1), DWORK(ITAUQ),
     $             DWORK(ITAUP), DWORK(JWORK), LDWORK-JWORK+1, IFAIL )
      WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C     If the matrix is lower bidiagonal, rotate to be upper bidiagonal
C     by applying Givens rotations on the left.
C
      IF ( M.LT.NL ) THEN
         IOFF = 0
C
         DO 60 I = 1, P - 1
            CALL DLARTG( Q(I), Q(P+I), CS, SN, TEMP )
            Q(I)   = TEMP
            Q(P+I) = SN*Q(I+1)
            Q(I+1) = CS*Q(I+1)
   60    CONTINUE
C
      ELSE
         IOFF = 1
      END IF
C
C     Store the Householder transformations performed onto the rows of C
C     in the extra storage locations DWORK(IHOUSH).
C     Workspace: need   LDW = min(M,N+L) + (N+L)*(N+L-1)/2, if M >= N+L,
C                       LDW = min(M,N+L) + M*(N+L-(M-1)/2), if M <  N+L;
C                prefer LDW = min(M,N+L) + (N+L)**2,        if M >= N+L,
C                       LDW = min(M,N+L) + M*(N+L),         if M <  N+L.
C
      IHOUSH = ITAUQ
      MC = NL - IOFF
      KF = IHOUSH + P*NL
      SUFWRK = LDWORK.GE.( KF + MAX( 6*NL-5,
     $                               NL**2 + MAX( NL, 3*L ) - 1 ) )
      IF ( SUFWRK ) THEN
C
C        Enough workspace for a fast algorithm.
C
         CALL DLACPY( 'Upper', P, NL, C, LDC, DWORK(IHOUSH), P )
         KJ = KF
         WRKOPT = MAX( WRKOPT, KF - 1 )
      ELSE
C
C        Not enough workspace for a fast algorithm.
C
         KJ = IHOUSH
C
         DO 80 NJ = 1, MIN( P, MC )
            J = MC - NJ + 1
            CALL DCOPY( J, C(NJ,NJ+IOFF), LDC, DWORK(KJ), 1 )
            KJ = KJ + J
   80    CONTINUE
C
      END IF
C
C     1.c): Initialize the right singular base matrix V with the
C           identity matrix (V overwrites C).
C
      CALL DLASET( 'Full', NL, NL, ZERO, ONE, C, LDC )
      JV = KJ
      IWARM = 0
C
C     REPEAT
C
C     Compute the Householder matrix Q and matrices F and Y such that
C     F is nonsingular.
C
C     Step 2: Partial diagonalization phase.
C             -----------------------------
C     Diagonalize the bidiagonal Q partially until convergence to
C     the desired right singular subspace.
C     Workspace: LDW + 6*(N+L)-5.
C
  100 CONTINUE
      JWORK = JV
      CALL MB04YD( 'No U', 'Update V', P, NL, RANK, THETA, Q, Q(P+1),
     $             DUMMY, 1, C, LDC, INUL, TOL, RELTOL, DWORK(JWORK),
     $             LDWORK-JWORK+1, IWARN, INFO )
      WRKOPT = MAX( WRKOPT, JWORK + 6*NL - 6 )
C
      IWARN = MAX( IWARN, IWARM )
      IF ( INFO.GT.0 )
     $   RETURN
C
C     Set pointers to the selected base vectors in the right singular
C     matrix of C.
C
      K = 0
C
      DO 120 I = 1, NL
         IF ( INUL(I) ) THEN
            K = K + 1
            IWORK(K) = I
         END IF
  120 CONTINUE
C
      IF ( K.LT.L ) THEN
C
C        Rank of the TLS approximation is larger than min(M,N).
C
         INFO = 2
         RETURN
      END IF
C
C     Step 3: Back transformation phase.
C             -------------------------
C     Apply in backward order the Householder transformations (stored
C     in DWORK(IHOUSH)) performed onto the rows of C during the
C     bidiagonalization phase, to the selected base vectors (specified
C     by INUL(I) = .TRUE.). Already transformed vectors are those for
C     which BWORK(I) = .TRUE..
C
      KF = K
      IF ( SUFWRK.AND.LFIRST ) THEN
C
C        Enough workspace for a fast algorithm and first pass.
C
         IJ = JV
C
         DO 140 J = 1, K
            CALL DCOPY (NL, C(1,IWORK(J)), 1, DWORK(IJ), 1 )
            IJ = IJ + NL
  140    CONTINUE
C
C        Workspace: need   LDW + (N+L)*K + K,
C                   prefer LDW + (N+L)*K + K*NB.
C
         IJ = JV
         JWORK = IJ + NL*K
         CALL DORMBR( 'P vectors', 'Left', 'No transpose', NL, K,
     $                MNL, DWORK(IHOUSH), P, DWORK(ITAUP), DWORK(IJ),
     $                NL, DWORK(JWORK), LDWORK-JWORK+1, IFAIL )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
         DO 160 I = 1, NL
            IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) )
     $         BWORK(I) = .TRUE.
  160    CONTINUE
C
      ELSE
C
C        Not enough workspace for a fast algorithm or subsequent passes.
C
         DO 180 I = 1, NL
            IF ( INUL(I) .AND. ( .NOT. BWORK(I) ) ) THEN
               KJ = JV
C
               DO 170 NJ = MIN( P, MC ), 1, -1
                  J = MC - NJ + 1
                  KJ = KJ - J
                  FIRST = DWORK(KJ)
                  DWORK(KJ) = ONE
                  CALL DLARF( 'Left', J, 1, DWORK(KJ), 1,
     $                        DWORK(ITAUP+NJ-1), C(NJ+IOFF,I), LDC,
     $                        DWORK(JWORK) )
                  DWORK(KJ) = FIRST
  170          CONTINUE
C
               BWORK(I) = .TRUE.
            END IF
  180    CONTINUE
      END IF
C
      IF ( RANK.LE.0 )
     $   RANK = 0
      IF ( MIN( RANK, L ).EQ.0 ) THEN
         IF ( SUFWRK.AND.LFIRST )
     $      CALL DLACPY( 'Full', NL, K, DWORK(JV), NL, C, LDC )
         DWORK(1) = WRKOPT
         DWORK(2) = ONE
         RETURN
      END IF
C
C     Step 4: Compute matrices F and Y
C             ------------------------
C             using Householder transformation Q.
C
C     Compute the orthogonal matrix Q (in factorized form) and the
C     matrices F and Y using RQ factorization. It is assumed that,
C     generically, the last L rows of V2 matrix have full rank.
C     The code could not be the most efficient when RANK has been
C     lowered, because the already created zero pattern of the last
C     L rows of V2 matrix is not exploited.
C
      IF ( SUFWRK.AND.LFIRST ) THEN
C
C        Enough workspace for a fast algorithm and first pass.
C        Workspace: need   LDW1 + 2*L,
C                   prefer LDW1 + L + L*NB, where
C                          LDW1 = LDW + (N+L)*K;
C
         ITAUQ = JWORK
         JWORK = ITAUQ + L
         CALL DGERQF( L, K, DWORK(JV+N), NL, DWORK(ITAUQ), DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
C        Workspace: need   LDW1 + N+L,
C                   prefer LDW1 + L + N*NB.
C
         CALL DORMRQ( 'Right', 'Transpose', N, K, L, DWORK(JV+N), NL,
     $                DWORK(ITAUQ), DWORK(JV), NL, DWORK(JWORK),
     $                LDWORK-JWORK+1, INFO )
         WRKOPT = MAX( WRKOPT, INT( DWORK(JWORK) )+JWORK-1 )
C
         JF = JV + NL*(K-L) + N
         LDF = NL
         JWORK = JF + LDF*L - N
         CALL DLASET( 'Full', L, K-L, ZERO, ZERO, DWORK(JV+N), LDF )
         IF ( L.GT.1 )
     $      CALL DLASET( 'Lower', L-1, L-1, ZERO, ZERO, DWORK(JF+1),
     $                   LDF )
         IJ = JV
C
         DO 200 J = 1, K
            CALL DCOPY( NL, DWORK(IJ), 1, C(1,IWORK(J)), 1 )
            IJ = IJ + NL
  200    CONTINUE
C
      ELSE
C
C        Not enough workspace for a fast algorithm or subsequent passes.
C        Workspace: LDW2 + N+L, where LDW2 = LDW + L*L.
C
         I  = NL
         JF = JV
         LDF = L
         JWORK  = JF + LDF*L
         WRKOPT = MAX( WRKOPT, JWORK+NL-1 )
C
C        WHILE ( ( K >= 1 ) .AND. ( I > N ) ) DO
  220    CONTINUE
         IF ( ( K.GE.1 ) .AND. ( I.GT.N ) ) THEN
C
            DO 240 J = 1, K
               DWORK(JWORK+J-1) = C(I,IWORK(J))
  240       CONTINUE
C
C           Compute Householder transformation.
C
            CALL DLARFG( K, DWORK(JWORK+K-1), DWORK(JWORK), 1, TEMP )
            C(I,IWORK(K)) = DWORK(JWORK+K-1)
            IF ( TEMP.NE.ZERO ) THEN
C
C              Apply Householder transformation onto the selected base
C              vectors.
C
               DO 300 I1 = 1, I - 1
                  INPROD = C(I1,IWORK(K))
C
                  DO 260 J = 1, K - 1
                     INPROD = INPROD + DWORK(JWORK+J-1)*C(I1,IWORK(J))
  260             CONTINUE
C
                  HH = INPROD*TEMP
                  C(I1,IWORK(K)) = C(I1,IWORK(K)) - HH
C
                  DO 280 J = 1, K - 1
                     J1 = IWORK(J)
                     C(I1,J1) = C(I1,J1) - DWORK(JWORK+J-1)*HH
                     C(I,J1)  = ZERO
  280             CONTINUE
C
  300          CONTINUE
C
            END IF
            CALL DCOPY( I-N, C(N1,IWORK(K)), 1, DWORK(JF+(I-N-1)*L), 1 )
            K = K - 1
            I = I - 1
            GO TO 220
         END IF
C        END WHILE 220
      END IF
C
C     Estimate the reciprocal condition number of the matrix F.
C     If F singular, lower the rank of the TLS approximation.
C     Workspace: LDW1 + 3*L or
C                LDW2 + 3*L.
C
      CALL DTRCON( '1-norm', 'Upper', 'Non-unit', L, DWORK(JF), LDF,
     $             RCOND, DWORK(JWORK), IWORK(KF+1), INFO )
      WRKOPT = MAX( WRKOPT, JWORK + 3*L - 1 )
C
      DO 320 J = 1, L
         CALL DCOPY( N, C(1,IWORK(KF-L+J)), 1, X(1,J), 1 )
  320 CONTINUE
C
      FNORM = DLANTR( '1-norm', 'Upper', 'Non-unit', L, L, DWORK(JF),
     $                LDF, DWORK(JWORK) )
      IF ( RCOND.LE.EPS*FNORM ) THEN
         RANK = RANK - 1
         GO TO 340
      END IF
      IF ( FNORM.LE.EPS*DLANGE( '1-norm', N, L, X, LDX,
     $                             DWORK(JWORK) ) ) THEN
         RANK = RANK - L
         GO TO 340
      ELSE
         GO TO 400
      END IF
C
  340    CONTINUE
         IWARM = 2
         THETA = -ONE
         IF ( SUFWRK.AND.LFIRST ) THEN
C
C           Rearrange the stored Householder transformations for
C           subsequent passes, taking care to avoid overwriting.
C
            IF ( P.LT.NL ) THEN
               KJ = IHOUSH + NL*(NL - 1)
               MJ = IHOUSH +  P*(NL - 1)
C
               DO 360 NJ = 1, NL
                  DO 350 J = P - 1, 0, -1
                     DWORK(KJ+J) = DWORK(MJ+J)
  350             CONTINUE
                  KJ = KJ - NL
                  MJ = MJ - P
  360          CONTINUE
C
            END IF
            KJ = IHOUSH
            MJ = IHOUSH + NL*IOFF
C
            DO 380 NJ = 1, MIN( P, MC )
               DO 370 J = 0, MC - NJ
                  DWORK(KJ) = DWORK(MJ+J*P)
                  KJ = KJ + 1
  370          CONTINUE
               MJ = MJ + NL + 1
  380       CONTINUE
C
            JV = KJ
            LFIRST = .FALSE.
         END IF
         GO TO 100
C     UNTIL ( F nonsingular, i.e., RCOND.GT.EPS*FNORM or
C                                  FNORM.GT.EPS*norm(Y) )
  400 CONTINUE
C
C     Step 5: Compute TLS solution.
C             --------------------
C     Solve X F = -Y  by forward elimination  (F is upper triangular).
C
      CALL DTRSM( 'Right', 'Upper', 'No transpose', 'Non-unit', N, L,
     $            -ONE, DWORK(JF), LDF, X, LDX )
C
C     Set the optimal workspace and reciprocal condition number of F.
C
      DWORK(1) = WRKOPT
      DWORK(2) = RCOND
C
      RETURN
C *** Last line of MB02ND ***
      END


* Obtained from http://www.nag.com/local/nagping/np006a3.asp
*     D02CJF Example Program Text
*     Mark 14 Revised.  NAG Copyright 1989.
*     .. Parameters ..
      CHARACTER        RELABS*15                                        !NEW
      INTEGER          NOUT
      PARAMETER        (NOUT=6)
      INTEGER          N, IW
      PARAMETER        (N=3,IW=21*N+28)
*     .. Scalars in Common ..
      DOUBLE PRECISION H, XEND
      INTEGER          K
*     .. Local Scalars ..
      DOUBLE PRECISION PI, TOL, X
      INTEGER          I, IFAIL, J
*     .. Local Arrays ..
      DOUBLE PRECISION W(IW), Y(N)
*     .. External Functions ..
      DOUBLE PRECISION D02CJW, G, X01AAF
      STDCALL EXTERNAL D02CJW, G, X01AAF                                !CHANGE
*     .. External Subroutines ..
      STDCALL EXTERNAL D02CJF, D02CJX, FCN, OUT                         !CHANGE
*     .. Intrinsic Functions ..
      INTRINSIC        DBLE
*     .. Common blocks ..
      COMMON           XEND, H, K
*     .. Executable Statements ..
      WRITE (NOUT,*) 'D02CJF Example Program Results'
      RELABS = "Default"                                                !NEW
      XEND = 10.0D0
      PI = X01AAF(0.0D0)
      WRITE (NOUT,*)
      WRITE (NOUT,*) 'Case 1: intermediate output, root-finding'
      DO 20 J = 4, 5
         TOL = 10.0D0**(-J)
         WRITE (NOUT,*)
         WRITE (NOUT,99999) ' Calculation with TOL =', TOL
         X = 0.0D0
         Y(1) = 0.5D0
         Y(2) = 0.5D0
         Y(3) = PI/5.0D0
         K = 4
         H = (XEND-X)/DBLE(K+1)
         WRITE (NOUT,*) '     X         Y(1)         Y(2)         Y(3)'
         IFAIL = 0
*
         CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),OUT,G,W,!CHANGE
     +               IFAIL)
*
         WRITE (NOUT,99998) '  Root of Y(1) = 0.0 at', X
         WRITE (NOUT,99997) '  Solution is', (Y(I),I=1,N)
   20 CONTINUE
      WRITE (NOUT,*)
      WRITE (NOUT,*)
      WRITE (NOUT,*) 'Case 2: no intermediate output, root-finding'
      DO 40 J = 4, 5
         TOL = 10.0D0**(-J)
         WRITE (NOUT,*)
         WRITE (NOUT,99999) ' Calculation with TOL =', TOL
         X = 0.0D0
         Y(1) = 0.5D0
         Y(2) = 0.5D0
         Y(3) = PI/5.0D0
         IFAIL = 0
*
         CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),D02CJX, !CHANGE
     +               G,W,IFAIL)
*
         WRITE (NOUT,99998) '  Root of Y(1) = 0.0 at', X
         WRITE (NOUT,99997) '  Solution is', (Y(I),I=1,N)
   40 CONTINUE
      WRITE (NOUT,*)
      WRITE (NOUT,*)
      WRITE (NOUT,*) 'Case 3: intermediate output, no root-finding'
      DO 60 J = 4, 5
         TOL = 10.0D0**(-J)
         WRITE (NOUT,*)
         WRITE (NOUT,99999) ' Calculation with TOL =', TOL
         X = 0.0D0
         Y(1) = 0.5D0
         Y(2) = 0.5D0
         Y(3) = PI/5.0D0
         K = 4
         H = (XEND-X)/DBLE(K+1)
         WRITE (NOUT,*) '     X         Y(1)         Y(2)         Y(3)'
         IFAIL = 0
*
         CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),OUT,    CHANGE
     +               D02CJW,W,IFAIL)
*
   60 CONTINUE
      WRITE (NOUT,*)
      WRITE (NOUT,*)
      WRITE (NOUT,*)
     +'Case 4: no intermediate output, no root-finding ( integrate to XE
     +ND)'
      DO 80 J = 4, 5
         TOL = 10.0D0**(-J)
         WRITE (NOUT,*)
         WRITE (NOUT,99999) ' Calculation with TOL =', TOL
         X = 0.0D0
         Y(1) = 0.5D0
         Y(2) = 0.5D0
         Y(3) = PI/5.0D0
         WRITE (NOUT,*) '     X         Y(1)         Y(2)         Y(3)'
         WRITE (NOUT,99996) X, (Y(I),I=1,N)
         IFAIL = 0
*
         CALL D02CJF(X,XEND,N,Y,FCN,TOL,VAL(LOC(RELABS)),VAL(7),D02CJX, !CHANGE
     +               D02CJW,W,IFAIL)
*
         WRITE (NOUT,99996) X, (Y(I),I=1,N)
   80 CONTINUE
      STOP
*
99999 FORMAT (1X,A,D8.1)
99998 FORMAT (1X,A,F7.3)
99997 FORMAT (1X,A,3F13.5)
99996 FORMAT (1X,F8.2,3F13.5)
      END
*
      STDCALL SUBROUTINE OUT(X,Y)                                       !CHANGE
*     .. Parameters ..
      INTEGER        NOUT
      PARAMETER      (NOUT=6)
      INTEGER        N
      PARAMETER      (N=3)
*     .. Scalar Arguments ..
      DOUBLE PRECISION X
*     .. Array Arguments ..
      DOUBLE PRECISION Y(N)
*     .. Scalars in Common ..
      DOUBLE PRECISION H, XEND
      INTEGER        I
*     .. Local Scalars ..
      INTEGER        J
*     .. Intrinsic Functions ..
      INTRINSIC      DBLE
*     .. Common blocks ..
      COMMON         XEND, H, I
*     .. Executable Statements ..
      WRITE (NOUT,99999) X, (Y(J),J=1,N)
      X = XEND - DBLE(I)*H
      I = I - 1
      RETURN
*
99999 FORMAT (1X,F8.2,3F13.5)
      END
*
      STDCALL SUBROUTINE FCN(T,Y,F)                                     !CHANGE
*     .. Parameters ..
      INTEGER        N
      PARAMETER      (N=3)
*     .. Scalar Arguments ..
      DOUBLE PRECISION T
*     .. Array Arguments ..
      DOUBLE PRECISION F(N), Y(N)
*     .. Intrinsic Functions ..
      INTRINSIC      COS, TAN
*     .. Executable Statements ..
      F(1) = TAN(Y(3))
      F(2) = -0.032D0*TAN(Y(3))/Y(2) - 0.02D0*Y(2)/COS(Y(3))
      F(3) = -0.032D0/Y(2)**2
      RETURN
      END
*
      STDCALL DOUBLE PRECISION FUNCTION G(T,Y)                          !CHANGE
*     .. Parameters ..
      INTEGER                     N
      PARAMETER                   (N=3)
*     .. Scalar Arguments ..
      DOUBLE PRECISION            T
*     .. Array Arguments ..
      DOUBLE PRECISION            Y(N)
*     .. Executable Statements ..
      G = Y(1)
      RETURN
      END


module check_result_mod

  implicit none
  contains

    pure subroutine check_result(y)
      use iso_fortran_env, only: real64
      implicit none

      real(real64), intent(in), dimension(:) :: y
      integer :: i, flag
      real(real64) :: delta, correct
      real(real64), parameter :: eps = 1.0d-3

      flag = 0

      do i = 1, size(y)
        correct = 25.0d0 + real(i, real64)
        if (abs(y(i) - correct)/correct > eps) flag = flag - 1
      end do

      if (flag < 0) error stop 'ERROR: Wrong integration result'

    end subroutine check_result

end module check_result_mod


module m
  implicit none
  type wrapper
     integer::i
  end type wrapper
  interface operator (+)
     module procedure addw
  end interface
contains
  function addw(a,b)
    type(wrapper),intent(in)::a,b
    type(wrapper)::addw
    addw%i=a%i+b%i
  end function addw
end module m

program t
  use m
  implicit none
  type(wrapper)::x,y
  x%i=2
  y%i=3
  print *,x+y
end program t


!The Fortran module (to be wrapped with f2py)
!for doing certain TT-matrix stuff
module tt_matrix
  use tensor_util_lib
contains
  subroutine tt_mv_full(n,d,m,r,ps,crm,crm_size,x,x_size,rb,y,y_size)
    integer, intent(in) :: d
    integer, intent(in) :: n(d)
    integer, intent(in) :: ps(d+1)
    integer, intent(in) :: r(d+1)
    integer, intent(in) :: m(d)
    integer, intent(in) :: crm_size
    integer, intent(in) :: x_size,y_size
    integer, intent(in) :: rb !In the case we multiply by a matrix
    double precision, intent(in) :: crm(crm_size)
    double precision, intent(in) :: x(x_size,rb)
    double precision, intent(out) :: y(y_size)  !We have to provide the size of the output array here
    !Local variables
    integer i,max_mem,c_size,c0
    double precision, allocatable :: b(:),c(:)
    double precision, allocatable :: cr(:),cr1(:)
    integer :: sz1(4),sz2(2)
    integer :: prm1(4),prm2(2)
    max_mem=0
    do i=1,d
       max_mem = max(max_mem,r(i)*n(i)*m(i)*r(i+1))
    end do
    !print *,'max_mem1=',max_mem
    allocate(cr(max_mem))
    allocate(cr1(max_mem))
    max_mem = 0
    c_size=product(m)*rb
    do i=1,d
       max_mem = max(max_mem,c_size)
       c_size = n(i)*r(i+1)*c_size/(r(i)*m(i))
    end do

    allocate(c(max_mem))
    allocate(b(max_mem))
    prm1(1) = 2
    prm1(2) = 4
    prm1(3) = 1
    prm1(4) = 3
    prm2(1) = 2
    prm2(2) = 1
    c_size=product(m)*rb

    call dcopy(c_size,x,1,c,1)
    do i = 1, d
       cr(1:r(i)*n(i)*m(i)*r(i+1))=crm(ps(i):ps(i+1)-1)
       sz1(1) = r(i)
       sz1(2) = n(i)
       sz1(3) = m(i)
       sz1(4) = r(i+1)
       call permute(cr,product(sz1),sz1,4,cr1,prm1)
       c0 = c_size/(r(i)*m(i))
       !print *,'c before:',c(1:8)
       !print *,'cr:',cr1(:)
       call dgemm('n','n',n(i)*r(i+1),c0,r(i)*m(i),1.d0,cr1,n(i)*r(i+1),c,r(i)*m(i),0.d0,b,n(i)*r(i+1))
       !print *,'b after:',b(1:8)
       !The size of b is
       !n(i)*r(i+1)*c_size/(r(i)*m(i))
       c_size = n(i)*r(i+1)*c0
       sz2(1) = n(i)
       sz2(2) =  r(i+1)*c0
       call permute(b,product(sz2),sz2,2,c,prm2)
       !print *,'c after:',c(1:8)
    end do
    call dcopy(c_size,c,1,y,1)
    !cr=cra(ps(k):ps(k+1)-1);
    !  cr=reshape(cr,[r(k),n(k),m(k),r(k+1)]);
    !  cr=permute(cr,[2,4,1,3]); cr=reshape(cr,[n(k)*r(k+1),r(k)*m(k)]);
    !  M=numel(c);
    !  c=reshape(c,[r(k)*m(k),M/(r(k)*m(k))]);
    !  c=cr*c; c=reshape(c,[n(k),numel(c)/n(k)]);
    !  c=permute(c,[2,1]);
    !end
    !c=c(:); c=reshape(c,[rb,numel(c)/rb]);
    !c=c.';
    deallocate(c)
    deallocate(b)
    deallocate(cr)
    deallocate(cr1)

  end subroutine tt_mv_full
!    subroutine tt_mv(n,d,m,r,ps,crm,crm_size,rx,psx,crx,x_size,ry,psy,cry,y_size)
!    integer, intent(in) :: d
!    integer, intent(in) :: n(d)
!    integer, intent(in) :: ps(d+1)
!    integer, intent(in) :: r(d+1)
!    integer, intent(in) :: m(d)
!    integer, intent(in) :: crm_size
!    integer, intent(in) :: x_size,y_size
!    integer, intent(in) :: rb !In the case we multiply by a matrix
!    double precision, intent(in) :: crm(crm_size)
!    double precision, intent(in) :: crx(x_size)
!    double precision, intent(out) :: cry(y_size)  !We have to provide the size of the output array here
    !Local variables
!    integer i,max_mem,c_size,c0
!    double precision, allocatable :: b(:),c(:)
!    double precision, allocatable :: cr(:),cr1(:)
!    integer :: sz1(4),sz2(2)
!    integer :: prm1(4),prm2(2)
!    end subroutine tt_mv
end module tt_matrix


      SUBROUTINE slPM (R0, D0, PR, PD, PX, RV, EP0, EP1, R1, D1)
*+
*     - - -
*      P M
*     - - -
*
*  Apply corrections for proper motion to a star RA,Dec
*  (double precision)
*
*  References:
*     1984 Astronomical Almanac, pp B39-B41.
*     (also Lederle & Schwan, Astron. Astrophys. 134,
*      1-6, 1984)
*
*  Given:
*     R0,D0    dp     RA,Dec at epoch EP0 (rad)
*     PR,PD    dp     proper motions:  RA,Dec changes per year of epoch
*     PX       dp     parallax (arcsec)
*     RV       dp     radial velocity (km/sec, +ve if receding)
*     EP0      dp     start epoch in years (e.g. Julian epoch)
*     EP1      dp     end epoch in years (same system as EP0)
*
*  Returned:
*     R1,D1    dp     RA,Dec at epoch EP1 (rad)
*
*  Called:
*     slDS2C       spherical to Cartesian
*     slDC2S       Cartesian to spherical
*     slDA2P      normalize angle 0-2Pi
*
*  Notes:
*
*  1  The proper motions in RA are dRA/dt rather than cos(Dec)*dRA/dt,
*     and are in the same coordinate system as R0,D0.
*
*  2  If the available proper motions are pre-FK5 they will be per
*     tropical year rather than per Julian year, and so the epochs
*     must both be Besselian rather than Julian.  In such cases, a
*     scaling factor of 365.2422D0/365.25D0 should be applied to the
*     radial velocity before use.
*
*  P.T.Wallace   Starlink   19 January 2000
*
*  Copyright (C) 2000 Rutherford Appleton Laboratory
*
*  License:
*    This program is free software; you can redistribute it and/or modify
*    it under the terms of the GNU General Public License as published by
*    the Free Software Foundation; either version 2 of the License, or
*    (at your option) any later version.
*
*    This program is distributed in the hope that it will be useful,
*    but WITHOUT ANY WARRANTY; without even the implied warranty of
*    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
*    GNU General Public License for more details.
*
*    You should have received a copy of the GNU General Public License
*    along with this program (see SLA_CONDITIONS); if not, write to the
*    Free Software Foundation, Inc., 51 Franklin Street, Fifth Floor,
*    Boston, MA  02110-1301  USA
*
*  Copyright (C) 1995 Association of Universities for Research in Astronomy Inc.
*-

      IMPLICIT NONE

      DOUBLE PRECISION R0,D0,PR,PD,PX,RV,EP0,EP1,R1,D1

*  Km/s to AU/year multiplied by arcseconds to radians
      DOUBLE PRECISION VFR
      PARAMETER (VFR=(365.25D0*86400D0/149597870D0)*4.8481368111D-6)

      INTEGER I
      DOUBLE PRECISION slDA2P
      DOUBLE PRECISION W,EM(3),T,P(3)

*  Spherical to Cartesian
      CALL slDS2C(R0,D0,P)

*  Space motion (radians per year)
      W=VFR*RV*PX
      EM(1)=-PR*P(2)-PD*COS(R0)*SIN(D0)+W*P(1)
      EM(2)= PR*P(1)-PD*SIN(R0)*SIN(D0)+W*P(2)
      EM(3)=         PD*COS(D0)        +W*P(3)

*  Apply the motion
      T=EP1-EP0
      DO I=1,3
         P(I)=P(I)+T*EM(I)
      END DO

*  Cartesian to spherical
      CALL slDC2S(P,R1,D1)
      R1=slDA2P(R1)

      END