! @section Synopsis
!
! Machine Learning subprograms for VIF. Needs LAPACK.
!
! @author J. Marcel van der Veer
!
! @section copyright
!
! This file is part of VIF - vintage fortran compiler.
! Copyright 2020-2025 J. Marcel van der Veer <algol68g@xs4all.nl>.
!
! @section 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 3 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. If not, see <http://www.gnu.org/licenses/>.
!
      SUBROUTINE ml colmean(a, m, n)
      IMPLICIT none
      INTEGER i, j, m, n
      REAL*8 a(m, n), mean
      REAL*16 sum
      DO i = 1, n
        sum = 0.0q0
        DO j = 1, m
          sum = sum + a(j, i)
        END DO
        mean = dble (sum / m)
        DO j = 1, m
          a(j, i) = a(j, i) - mean
        END DO
      END DO
      END
!
      SUBROUTINE ml ols(a, m, n, x, y, a inv, u, vt, s, tol)
! Solve 'A' 'x' = 'y' by computing the pseudo-inverse of 'A'.
! 'A' is a 'm'x'n' matrix which is overwritten.
! 'Ainv' will contain the 'n'x'm' pseudo-inverse.
! 'U' will contain U, and 'VT' will contain V^T.
! 'S' will contain reciprocal singular values.
! 'Tol' is the threshold ratio relative to the largest singular value.
! 'Info' is a status indicator. Zero on exit is good.
      IMPLICIT none
      INTEGER i, info, j, k, lmax, lwork, m, n
! Work dimension should be at least 8 * min(m, n)
      REAL*8 a(m, n), x(m), y(m), u(m, m), vt(n, n), s(n), a inv(n, m), tol
! Solve A x = b.
      CALL ml pinv (a, m, n, a inv, u, vt, s, tol)
      CALL dgemv ('n', n, m, 1.0d0, a inv, n, y, 1, 0.0d0, x, 1)
      RETURN
      END
!
      SUBROUTINE ml pinv(a, m, n, a inv, u, vt, s, tol)
! Compute pseudo-inverse of 'A'.
! 'A' is a 'm'x'n' matrix which is overwritten.
! 'Ainv' will contain the 'n'x'm' pseudo-inverse.
! 'U' will contain U, and 'VT' will contain V^T.
! 'S' will contain reciprocal singular values.
! 'Tol' is the threshold ratio relative to the largest singular value.
! 'Info' is a status indicator. Zero on exit is good.
      IMPLICIT none
      REAL*8 work
      INTEGER iwork, lwmax
      parameter (lwmax = 100000)
      common /work/ work(lwmax), iwork(lwmax)
      INTEGER i, info, j, k, lmax, lwork, m, n
! Work dimension should be at least 8 * min(m, n)
      REAL*8 a(m, n), u(m, m), vt(n, n), s(n), a inv(n, m)
      REAL*8 s1, tol
      REAL*16 sum
! find optimal workspace.
      lwork = -1
      CALL dgesdd('a', m, n, a, m, s, u, m, vt, n, work, lwork, iwork, info)
      lwork = min(lwmax, int(work(1)))
! compute svd.
      CALL dgesdd('a', m, n, a, m, s, u, m, vt, n, work, lwork, iwork, info)
      IF (info > 0) THEN
         write (*, *) 'failed to converge'
      END IF
! compute pseudo inverse V * S^+ * U^T
! blas has no routines for multiplying diagonal matrices.
      s1 = s(1)
      DO i = 1, n
        IF (s(i) > tol * s1) THEN
          s(i) = 1.0d0 / s(i)
        ELSE
          s(i) = 0.0d0
        END IF
      END DO
      DO i = 1, n
        DO j = 1, m
          sum = 0
          DO k = 1, m
            sum = sum + vt(k, i) * s(k) * u (j, k)
          END DO
          a inv(i, j) = dble (sum)
        END DO
      END DO
      END

      SUBROUTINE ml testsignal(a, m, n, y)
! make a dummy test signal.
      IMPLICIT none
      INTEGER j, k, l, m, n
      REAL*8 a(m, n), y(n), x, pi
      CALL pi8(pi)
      DO j = 1, m
      y(j) = j
        DO k = 1, n
          a(j, k) = j * sin ((k - 0.5) / n * pi)
        END DO
      END DO
      RETURN
      END

      SUBROUTINE ml svddd(a, m, n, u, vt, s, iwork)
!
! compute the SVD of rectangular matrix using a divide and conquer algorithm.
! the svd reads
!
! a = u * sigma * vt
!
! where sigma is an m x n matrix which is zero except for its min(m, n)
! diagonal elements, u is an m x m orthogonal matrix and vt (v transposed)
! is an n x n orthogonal matrix.
!
! the diagonal elements of sigma are the real non - negative singular values
! of a- negative, in descending order.
! the first min(m, n) columns of u and v are the left and right singular vectors of a.
!
! left singular vectors are stored columnwise, right singular vectors are stored rowwise.
! note that the routine returns vt, not v.
!
! iwork dimension should be at least 8 * min(m, n)
!
      IMPLICIT none
      REAL*8 work
      INTEGER iwork, lwmax
      parameter (lwmax = 100000)
      common /work/ work(lwmax), iwork(lwmax)
      INTEGER info, lda, ldu, ldvt, lwork, m, n
! work dimension should be at least 8 * min(m, n)
      REAL*8 a(m, n), u(m, m), vt(n, n), s(n)
      lda = m
      ldu = m
      ldvt = n
! find optimal workspace.
      lwork = -1
      CALL dgesdd('a', m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, iwork, info)
      lwork = min(lwmax, int(work(1)))
! compute svd.
      CALL dgesdd('a', m, n, a, lda, s, u, ldu, vt, ldvt, work, lwork, iwork, info)
      IF (info > 0) THEN
        write (*, *) 'failed to converge'
      END IF
      END

      SUBROUTINE ml wmatrow(a, l, n, m)
      IMPLICIT none
      INTEGER k, l, m, n
      REAL*8 a(n, m)
! Print row n of a having width m.
      IF (m <= 6) THEN
        write (*, *) (sngl(a(l, k))i, ' ', k = 1, m)
      ELSE
        write (*, *) (sngl(a(l, k)), k = 1, 3) , ' ... ', (sngl(a(l, k)), k = m - 2, m)
      END IF
      END

      SUBROUTINE ml wmatrix(caption, a, n, m)
      IMPLICIT none
      INTEGER k, m, n
! ML Write MATRIX.
      REAL*8 a(n, m)
      character*(*) caption
      write (*, *) caption, ': ', n, 'x', m, ' matrix'
      IF (n <= 20) THEN
        DO k = 1, n
          CALL ml wmatrow(a, k, n, m)
        END DO
      ELSE
        DO k = 1, 10
          CALL ml wmatrow(a, k, n, m)
        END DO
        write (*, *) ' ... '
        DO k = n - 10, n
          CALL ml wmatrow(a, k, n, m)
        END DO
      END IF
      END

      SUBROUTINE ml wcolvec(caption, v, n)
! ML Write COLumn VECtor.
      CALL ml wmatrix(caption, v, 1, n)
      END

      SUBROUTINE mlwrowvec(caption, v, m)
! ML Write ROW VECtor.
      CALL ml wmatrix(caption, v, m, 1)
      END
