      SUBROUTINE TG01FD( COMPQ, COMPZ, JOBA, L, N, M, P, A, LDA, E, LDE,
     $                   B, LDB, C, LDC, Q, LDQ, Z, LDZ, RANKE, RNKA22,
     $                   TOL, IWORK, DWORK, LDWORK, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To compute for the descriptor system (A-lambda E,B,C)
C     the orthogonal transformation matrices Q and Z such that the
C     transformed system (Q'*A*Z-lambda Q'*E*Z, Q'*B, C*Z) is
C     in a SVD-like coordinate form with
C
C                  ( A11  A12 )             ( Er  0 )
C         Q'*A*Z = (          ) ,  Q'*E*Z = (       ) ,
C                  ( A21  A22 )             (  0  0 )
C
C     where Er is an upper triangular invertible matrix.
C     Optionally, the A22 matrix can be further reduced to the form
C
C                  ( Ar  X )
C            A22 = (       ) ,
C                  (  0  0 )
C
C     with Ar an upper triangular invertible matrix, and X either a full
C     or a zero matrix.
C     The left and/or right orthogonal transformations performed
C     to reduce E and A22 can be optionally accumulated.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     COMPQ   CHARACTER*1
C             = 'N':  do not compute Q;
C             = 'I':  Q is initialized to the unit matrix, and the
C                     orthogonal matrix Q is returned;
C             = 'U':  Q must contain an orthogonal matrix Q1 on entry,
C                     and the product Q1*Q is returned.
C
C     COMPZ   CHARACTER*1
C             = 'N':  do not compute Z;
C             = 'I':  Z is initialized to the unit matrix, and the
C                     orthogonal matrix Z is returned;
C             = 'U':  Z must contain an orthogonal matrix Z1 on entry,
C                     and the product Z1*Z is returned.
C
C     JOBA    CHARACTER*1
C             = 'N':  do not reduce A22;
C             = 'R':  reduce A22 to a SVD-like upper triangular form.
C             = 'T':  reduce A22 to an upper trapezoidal form.
C
C     Input/Output Parameters
C
C     L       (input) INTEGER
C             The number of rows of matrices A, B, and E.  L >= 0.
C
C     N       (input) INTEGER
C             The number of columns of matrices A, E, and C.  N >= 0.
C
C     M       (input) INTEGER
C             The number of columns of matrix B.  M >= 0.
C
C     P       (input) INTEGER
C             The number of rows of matrix C.  P >= 0.
C
C     A       (input/output) DOUBLE PRECISION array, dimension (LDA,N)
C             On entry, the leading L-by-N part of this array must
C             contain the state dynamics matrix A.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix Q'*A*Z. If JOBA = 'T', this matrix
C             is in the form
C
C                           ( A11  *   *  )
C                  Q'*A*Z = (  *   Ar  X  ) ,
C                           (  *   0   0  )
C
C             where A11 is a RANKE-by-RANKE matrix and Ar is a
C             RNKA22-by-RNKA22 invertible upper triangular matrix.
C             If JOBA = 'R' then A has the above form with X = 0.
C
C     LDA     INTEGER
C             The leading dimension of array A.  LDA >= MAX(1,L).
C
C     E       (input/output) DOUBLE PRECISION array, dimension (LDE,N)
C             On entry, the leading L-by-N part of this array must
C             contain the descriptor matrix E.
C             On exit, the leading L-by-N part of this array contains
C             the transformed matrix Q'*E*Z.
C
C                      ( Er  0 )
C             Q'*E*Z = (       ) ,
C                      (  0  0 )
C
C             where Er is a RANKE-by-RANKE upper triangular invertible
C             matrix.
C
C     LDE     INTEGER
C             The leading dimension of array E.  LDE >= MAX(1,L).
C
C     B       (input/output) DOUBLE PRECISION array, dimension (LDB,M)
C             On entry, the leading L-by-M part of this array must
C             contain the input/state matrix B.
C             On exit, the leading L-by-M part of this array contains
C             the transformed matrix Q'*B.
C
C     LDB     INTEGER
C             The leading dimension of array B.
C             LDB >= MAX(1,L) if M > 0 or LDB >= 1 if M = 0.
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 state/output matrix C.
C             On exit, the leading P-by-N part of this array contains
C             the transformed matrix C*Z.
C
C     LDC     INTEGER
C             The leading dimension of array C.  LDC >= MAX(1,P).
C
C     Q       (input/output) DOUBLE PRECISION array, dimension (LDQ,L)
C             If COMPQ = 'N':  Q is not referenced.
C             If COMPQ = 'I':  on entry, Q need not be set;
C                              on exit, the leading L-by-L part of this
C                              array contains the orthogonal matrix Q,
C                              where Q' is the product of Householder
C                              transformations which are applied to A,
C                              E, and B on the left.
C             If COMPQ = 'U':  on entry, the leading L-by-L part of this
C                              array must contain an orthogonal matrix
C                              Q1;
C                              on exit, the leading L-by-L part of this
C                              array contains the orthogonal matrix
C                              Q1*Q.
C
C     LDQ     INTEGER
C             The leading dimension of array Q.
C             LDQ >= 1,        if COMPQ = 'N';
C             LDQ >= MAX(1,L), if COMPQ = 'U' or 'I'.
C
C     Z       (input/output) DOUBLE PRECISION array, dimension (LDZ,N)
C             If COMPZ = 'N':  Z is not referenced.
C             If COMPZ = 'I':  on entry, Z need not be set;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix Z,
C                              which is the product of Householder
C                              transformations applied to A, E, and C
C                              on the right.
C             If COMPZ = 'U':  on entry, the leading N-by-N part of this
C                              array must contain an orthogonal matrix
C                              Z1;
C                              on exit, the leading N-by-N part of this
C                              array contains the orthogonal matrix
C                              Z1*Z.
C
C     LDZ     INTEGER
C             The leading dimension of array Z.
C             LDZ >= 1,        if COMPZ = 'N';
C             LDZ >= MAX(1,N), if COMPZ = 'U' or 'I'.
C
C     RANKE   (output) INTEGER
C             The estimated rank of matrix E, and thus also the order
C             of the invertible upper triangular submatrix Er.
C
C     RNKA22  (output) INTEGER
C             If JOBA = 'R' or 'T', then RNKA22 is the estimated rank of
C             matrix A22, and thus also the order of the invertible
C             upper triangular submatrix Ar.
C             If JOBA = 'N', then RNKA22 is not referenced.
C
C     Tolerances
C
C     TOL     DOUBLE PRECISION
C             The tolerance to be used in determining the rank of E
C             and of A22. If the user sets TOL > 0, then the given
C             value of TOL is used as a lower bound for the
C             reciprocal condition numbers of leading submatrices
C             of R or R22 in the QR decompositions E * P = Q * R of E
C             or A22 * P22 = Q22 * R22 of A22.
C             A submatrix 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             defined by  TOLDEF = L*N*EPS,  is used instead, where
C             EPS is the machine precision (see LAPACK Library routine
C             DLAMCH). TOL < 1.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (N)
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+P, MIN(L,N)+MAX(3*N-1,M,L) ).
C             For optimal 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     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
C     METHOD
C
C     The routine computes a truncated QR factorization with column
C     pivoting of E, in the form
C
C                       ( E11 E12 )
C           E * P = Q * (         )
C                       (  0  E22 )
C
C     and finds the largest RANKE-by-RANKE leading submatrix E11 whose
C     estimated condition number is less than 1/TOL. RANKE defines thus
C     the rank of matrix E. Further E22, being negligible, is set to
C     zero, and an orthogonal matrix Y is determined such that
C
C           ( E11 E12 ) = ( Er  0 ) * Y .
C
C     The overal transformation matrix Z results as Z = P * Y' and the
C     resulting transformed matrices Q'*A*Z and Q'*E*Z have the form
C
C                          ( Er  0 )                      ( A11  A12 )
C         E <- Q'* E * Z = (       ) ,  A <- Q' * A * Z = (          ) ,
C                          (  0  0 )                      ( A21  A22 )
C
C     where Er is an upper triangular invertible matrix.
C     If JOBA = 'R' the same reduction is performed on A22 to obtain it
C     in the form
C
C                  ( Ar  0 )
C            A22 = (       ) ,
C                  (  0  0 )
C
C     with Ar an upper triangular invertible matrix.
C     If JOBA = 'T' then A22 is row compressed using the QR
C     factorization with column pivoting to the form
C
C                  ( Ar  X )
C            A22 = (       )
C                  (  0  0 )
C
C     with Ar an upper triangular invertible matrix.
C
C     The transformations are also applied to the rest of system
C     matrices
C
C          B <- Q' * B, C <- C * Z.
C
C     NUMERICAL ASPECTS
C
C     The algorithm is numerically backward stable and requires
C     0( L*L*N )  floating point operations.
C
C     CONTRIBUTOR
C
C     A. Varga, German Aerospace Center, DLR Oberpfaffenhofen.
C     March 1999. Based on the RASP routine RPDSSV.
C
C     REVISIONS
C
C     V. Sima, Research Institute for Informatics, Bucharest, July 1999,
C     May 2003, Jan. 2009, Apr. 2011, Sep. 2016, Nov. 2016, Feb. 2017.
C
C     KEYWORDS
C
C     Descriptor system, matrix algebra, matrix operations,
C     orthogonal transformation.
C
C     ******************************************************************
C
C     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D0, ZERO = 0.0D0 )
C     .. Scalar Arguments ..
      CHARACTER          COMPQ, COMPZ, JOBA
      INTEGER            INFO, L, LDA, LDB, LDC, LDE, LDQ, LDWORK,
     $                   LDZ, M, N, P, RANKE, RNKA22
      DOUBLE PRECISION   TOL
C     .. Array Arguments ..
      INTEGER            IWORK( * )
      DOUBLE PRECISION   A( LDA, * ), B( LDB, * ), C( LDC, * ),
     $                   DWORK( * ),  E( LDE, * ), Q( LDQ, * ),
     $                   Z( LDZ, * )
C     .. Local Scalars ..
      LOGICAL            ILQ, ILZ, LQUERY, REDA, REDTR, WITHB, WITHC
      INTEGER            I, ICOMPQ, ICOMPZ, IR1, IRE1, J, K, KW, LA22,
     $                   LH, LN, LWR, NA22, WRKOPT
      DOUBLE PRECISION   SVLMAX, TOLDEF
C     .. Local Arrays ..
      DOUBLE PRECISION   SVAL(3)
C     .. External Functions ..
      LOGICAL            LSAME
      DOUBLE PRECISION   DLAMCH, DLANGE
      EXTERNAL           DLAMCH, DLANGE, LSAME
C     .. External Subroutines ..
      EXTERNAL           DLASET, DORMQR, DORMRZ, DSWAP, DTZRZF, MB03OY,
     $                   XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          DBLE, INT, MAX, MIN
C
C     .. Executable Statements ..
C
C     Decode COMPQ.
C
      IF( LSAME( COMPQ, 'N' ) ) THEN
         ILQ = .FALSE.
         ICOMPQ = 1
      ELSE IF( LSAME( COMPQ, 'U' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 2
      ELSE IF( LSAME( COMPQ, 'I' ) ) THEN
         ILQ = .TRUE.
         ICOMPQ = 3
      ELSE
         ICOMPQ = 0
      END IF
C
C     Decode COMPZ.
C
      IF( LSAME( COMPZ, 'N' ) ) THEN
         ILZ = .FALSE.
         ICOMPZ = 1
      ELSE IF( LSAME( COMPZ, 'U' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 2
      ELSE IF( LSAME( COMPZ, 'I' ) ) THEN
         ILZ = .TRUE.
         ICOMPZ = 3
      ELSE
         ICOMPZ = 0
      END IF
      REDA  = LSAME( JOBA, 'R' )
      REDTR = LSAME( JOBA, 'T' )
      WITHB = M.GT.0
      WITHC = P.GT.0
      LQUERY = ( LDWORK.EQ.-1 )
C
C     Test the input parameters.
C
      LN = MIN( L, N )
      INFO = 0
      WRKOPT = MAX( 1, N+P, LN + MAX( 3*N-1, M, L ) )
      IF( ICOMPQ.LE.0 ) THEN
         INFO = -1
      ELSE IF( ICOMPZ.LE.0 ) THEN
         INFO = -2
      ELSE IF( .NOT.LSAME( JOBA, 'N' ) .AND. .NOT.REDA .AND.
     $         .NOT.REDTR ) THEN
         INFO = -3
      ELSE IF( L.LT.0 ) THEN
         INFO = -4
      ELSE IF( N.LT.0 ) THEN
         INFO = -5
      ELSE IF( M.LT.0 ) THEN
         INFO = -6
      ELSE IF( P.LT.0 ) THEN
         INFO = -7
      ELSE IF( LDA.LT.MAX( 1, L ) ) THEN
         INFO = -9
      ELSE IF( LDE.LT.MAX( 1, L ) ) THEN
         INFO = -11
      ELSE IF( LDB.LT.1 .OR. ( WITHB .AND. LDB.LT.L ) ) THEN
         INFO = -13
      ELSE IF( LDC.LT.MAX( 1, P ) ) THEN
         INFO = -15
      ELSE IF( ( ILQ .AND. LDQ.LT.L ) .OR. LDQ.LT.1 ) THEN
         INFO = -17
      ELSE IF( ( ILZ .AND. LDZ.LT.N ) .OR. LDZ.LT.1 ) THEN
         INFO = -19
      ELSE IF( TOL.GE.ONE ) THEN
         INFO = -22
      ELSE
         IF( LQUERY ) THEN
            CALL DORMQR( 'Left', 'Transpose', L, N, LN, E, LDE, DWORK,
     $                   A, LDA, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) )
            IF( WITHB ) THEN
               CALL DORMQR( 'Left', 'Transpose', L, M, LN, E, LDE,
     $                      DWORK, B, LDB, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) )
            END IF
            IF( ILQ ) THEN
               CALL DORMQR( 'Right', 'No Transpose', L, L, LN, E, LDE,
     $                      DWORK, Q, LDQ, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) )
            END IF
            CALL DTZRZF( LN, N, E, LDE, DWORK, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, LN + INT( DWORK(1) ) )
            CALL DORMRZ( 'Right', 'Transpose', L, N, LN, N, E, LDE,
     $                   DWORK, A, LDA, DWORK, -1, INFO )
            WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) )
            IF( WITHC ) THEN
               CALL DORMRZ( 'Right', 'Transpose', P, N, LN, N, E, LDE,
     $                      DWORK, C, LDC, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) )
            END IF
            IF( ILZ ) THEN
               CALL DORMRZ( 'Right', 'Transpose', N, N, LN, N, E, LDE,
     $                      DWORK, Z, LDZ, DWORK, -1, INFO )
               WRKOPT = MAX( WRKOPT, N + INT( DWORK(1) ) )
            END IF
         ELSE IF( LDWORK.LT.WRKOPT ) THEN
            INFO = -25
         END IF
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'TG01FD', -INFO )
         RETURN
      ELSE IF( LQUERY ) THEN
         DWORK(1) = WRKOPT
         RETURN
      END IF
C
C     Initialize Q and Z if necessary.
C
      IF( ICOMPQ.EQ.3 )
     $   CALL DLASET( 'Full', L, L, ZERO, ONE, Q, LDQ )
      IF( ICOMPZ.EQ.3 )
     $   CALL DLASET( 'Full', N, N, ZERO, ONE, Z, LDZ )
C
C     Quick return if possible.
C
      IF( L.EQ.0 .OR. N.EQ.0 ) THEN
         DWORK(1) = ONE
         RANKE = 0
         IF( REDA .OR. REDTR ) RNKA22 = 0
         RETURN
      END IF
C
      TOLDEF = TOL
      IF( TOLDEF.LE.ZERO ) THEN
C
C        Use the default tolerance for rank determination.
C
         TOLDEF = DBLE( L*N )*DLAMCH( 'EPSILON' )
      END IF
C
      SVLMAX = ZERO
C
C     Compute the rank-revealing QR decomposition of E,
C
C                        ( E11 E12 )
C           E * P = Qr * (         ) ,
C                        (  0  E22 )
C
C     and determine the rank of E using incremental condition
C     estimation.
C     Workspace: MIN(L,N) + 3*N - 1.
C
      LWR = LDWORK - LN
      KW  = LN + 1
C
      CALL MB03OY( L, N, E, LDE, TOLDEF, SVLMAX, RANKE, SVAL, IWORK,
     $             DWORK, DWORK(KW), INFO )
C
C     Apply transformation on the rest of matrices.
C
      IF( RANKE.GT.0 ) THEN
C
C        A <-- Qr' * A.
C        Workspace: need   MIN(L,N) + N;
C                   prefer MIN(L,N) + N*NB.
C
         CALL DORMQR( 'Left', 'Transpose', L, N, RANKE, E, LDE, DWORK,
     $                A, LDA, DWORK(KW), LWR, INFO )
         WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
C
C        B <-- Qr' * B.
C        Workspace: need   MIN(L,N) + M;
C                   prefer MIN(L,N) + M*NB.
C
         IF( WITHB ) THEN
            CALL DORMQR( 'Left', 'Transpose', L, M, RANKE, E, LDE,
     $                   DWORK, B, LDB, DWORK(KW), LWR, INFO )
            WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
         END IF
C
C        Q <-- Q * Qr.
C        Workspace: need   MIN(L,N) + L;
C                   prefer MIN(L,N) + L*NB.
C
         IF( ILQ ) THEN
            CALL DORMQR( 'Right', 'No Transpose', L, L, RANKE, E, LDE,
     $                   DWORK, Q, LDQ, DWORK(KW), LWR, INFO )
            WRKOPT = MAX( WRKOPT, LN + INT( DWORK(KW) ) )
         END IF
C
C        Set lower triangle of E to zero.
C
         IF( L.GE.2 )
     $      CALL DLASET( 'Lower', L-1, RANKE, ZERO, ZERO, E(2,1), LDE )
C
C        Compute A*P, C*P and Z*P by forward permuting the columns of
C        A, C and Z based on information in IWORK.
C
         DO 10 J = 1, N
            IWORK(J) = -IWORK(J)
   10    CONTINUE
         DO 30 I = 1, N
            IF( IWORK(I).LT.0 ) THEN
               J = I
               IWORK(J) = -IWORK(J)
   20          CONTINUE
               K = IWORK(J)
               IF( IWORK(K).LT.0 ) THEN
                  CALL DSWAP( L, A(1,J), 1, A(1,K), 1 )
                  IF( WITHC )
     $               CALL DSWAP( P, C(1,J), 1, C(1,K), 1 )
                  IF( ILZ )
     $               CALL DSWAP( N, Z(1,J), 1, Z(1,K), 1 )
                  IWORK(K) = -IWORK(K)
                  J = K
                  GO TO 20
               END IF
            END IF
   30    CONTINUE
C
C        Determine an orthogonal matrix Y such that
C
C           ( E11 E12 ) = ( Er  0 ) * Y .
C
C        Compute E <-- E*Y', A <-- A*Y', C <-- C*Y', Z <-- Z*Y'.
C
         IF( RANKE.LT.N ) THEN
C
C           Workspace: need   2*N;
C                      prefer N + N*NB.
C
            KW = RANKE + 1
            CALL DTZRZF( RANKE, N, E, LDE, DWORK, DWORK(KW),
     $                   LDWORK-KW+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C           Workspace: need   N + MAX(L,P,N);
C                      prefer N + MAX(L,P,N)*NB.
C
            LH = N - RANKE
            CALL DORMRZ( 'Right', 'Transpose', L, N, RANKE, LH, E, LDE,
     $                   DWORK, A, LDA, DWORK(KW), LDWORK-KW+1, INFO )
            WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
            IF( WITHC ) THEN
               CALL DORMRZ( 'Right', 'Transpose', P, N, RANKE, LH, E,
     $                      LDE, DWORK, C, LDC, DWORK(KW), LDWORK-KW+1,
     $                      INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
            END IF
            IF( ILZ ) THEN
               CALL DORMRZ( 'Right', 'Transpose', N, N, RANKE, LH, E,
     $                      LDE, DWORK, Z, LDZ, DWORK(KW), LDWORK-KW+1,
     $                      INFO )
               WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
            END IF
C
C           Set E12 and E22 to zero.
C
            CALL DLASET( 'Full', L, LH, ZERO, ZERO, E(1,KW), LDE )
         END IF
      ELSE
         CALL DLASET( 'Full', L, N, ZERO, ZERO, E, LDE )
      END IF
C
C     Reduce A22 if necessary.
C
      IF( REDA .OR. REDTR ) THEN
         LA22 = L - RANKE
         NA22 = N - RANKE
         IF( MIN( LA22, NA22 ).EQ.0 ) THEN
            RNKA22 = 0
         ELSE
C
C           Compute the rank-revealing QR decomposition of A22,
C
C                              ( R11 R12 )
C              A22 * P2 = Q2 * (         ) ,
C                              (  0  R22 )
C
C           and determine the rank of A22 using incremental
C           condition estimation.
C           Workspace: MIN(L,N) + 3*N - 1.
C
C           Set the estimate of maximum singular value of A to detect
C           a negligible A matrix.
C
            SVLMAX = DLANGE( 'Frobenius', L, N, A, LDA, DWORK )
            IR1 = RANKE + 1
            KW  = MIN( LA22, NA22 ) + 1
            CALL MB03OY( LA22, NA22, A(IR1,IR1), LDA, TOLDEF,
     $                   SVLMAX, RNKA22, SVAL, IWORK, DWORK,
     $                   DWORK(KW), INFO )
C
C           Apply transformation on the rest of matrices.
C
            IF( RNKA22.GT.0 ) THEN
C
C              A <-- diag(I, Q2') * A
C              Workspace: need   MIN(L,N) + N;
C                         prefer MIN(L,N) + N*NB.
C
               CALL DORMQR( 'Left', 'Transpose', LA22, RANKE, RNKA22,
     $                      A(IR1,IR1), LDA, DWORK, A(IR1,1), LDA,
     $                      DWORK(KW), LWR, INFO )
C
C              B <-- diag(I, Q2') * B
C              Workspace: need   MIN(L,N) + M;
C                         prefer MIN(L,N) + M*NB.
C
               IF ( WITHB )
     $            CALL DORMQR( 'Left', 'Transpose', LA22, M, RNKA22,
     $                         A(IR1,IR1), LDA, DWORK, B(IR1,1), LDB,
     $                         DWORK(KW), LWR, INFO )
C
C              Q <-- Q * diag(I, Q2)
C              Workspace: need   MIN(L,N) + L;
C                         prefer MIN(L,N) + L*NB.
C
               IF( ILQ )
     $            CALL DORMQR( 'Right', 'No transpose', L, LA22, RNKA22,
     $                         A(IR1,IR1), LDA, DWORK, Q(1,IR1), LDQ,
     $                         DWORK(KW), LWR, INFO )
C
C              Set lower triangle of A22 to zero.
C
               IF( LA22.GE.2 )
     $            CALL DLASET( 'Lower', LA22-1, RNKA22, ZERO, ZERO,
     $                         A(IR1+1,IR1), LDA )
C
C              Compute A*diag(I,P2), C*diag(I,P2) and Z*diag(I,P2)
C              by forward permuting the columns of A, C and Z based
C              on information in IWORK.
C
               DO 40 J = 1, NA22
                  IWORK(J) = -IWORK(J)
   40          CONTINUE
               DO 60 I = 1, NA22
                  IF( IWORK(I).LT.0 ) THEN
                     J = I
                     IWORK(J) = -IWORK(J)
   50                CONTINUE
                     K = IWORK(J)
                     IF( IWORK(K).LT.0 ) THEN
                        CALL DSWAP( RANKE, A(1,RANKE+J), 1,
     $                              A(1,RANKE+K), 1 )
                        IF( WITHC )
     $                     CALL DSWAP( P, C(1,RANKE+J), 1,
     $                                 C(1,RANKE+K), 1 )
                        IF( ILZ )
     $                     CALL DSWAP( N, Z(1,RANKE+J), 1,
     $                                 Z(1,RANKE+K), 1 )
                        IWORK(K) = -IWORK(K)
                        J = K
                        GO TO 50
                     END IF
                  END IF
   60          CONTINUE
C
               IF( REDA .AND. RNKA22.LT.NA22 ) THEN
C
C                 Determine an orthogonal matrix Y2 such that
C
C                 ( R11 R12 ) = ( Ar  0 ) * Y2 .
C
C                 Compute A <-- A*diag(I, Y2'), C <-- C*diag(I, Y2'),
C                         Z <-- Z*diag(I, Y2').
C                 Workspace: need   2*N.
C                            prefer N + N*NB.
C
                  KW = RANKE + 1
                  CALL DTZRZF( RNKA22, NA22, A(IR1,IR1), LDA, DWORK,
     $                         DWORK(KW), LDWORK-KW+1, INFO )
                  WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
C
C                 Workspace: need   N + MAX(P,N);
C                            prefer N + MAX(P,N)*NB.
C
                  LH = NA22 - RNKA22
                  CALL DORMRZ( 'Right', 'Transpose', RANKE, NA22,
     $                         RNKA22, LH, A(IR1,IR1), LDA, DWORK,
     $                         A(1,IR1), LDA, DWORK(KW), LDWORK-KW+1,
     $                         INFO )
                  IF( WITHC ) THEN
                     CALL DORMRZ( 'Right', 'Transpose', P, NA22, RNKA22,
     $                            LH, A(IR1,IR1), LDA, DWORK, C(1,IR1),
     $                            LDC, DWORK(KW), LDWORK-KW+1, INFO )
                     WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
                  END IF
                  IF( ILZ ) THEN
                     CALL DORMRZ( 'Right', 'Transpose', N, NA22, RNKA22,
     $                            LH, A(IR1,IR1), LDA, DWORK, Z(1,IR1),
     $                            LDZ, DWORK(KW), LDWORK-KW+1, INFO )
                     WRKOPT = MAX( WRKOPT, INT( DWORK(KW) ) + KW - 1 )
                  END IF
                  IRE1 = RANKE + RNKA22 + 1
C
C                 Set R12 and R22 to zero.
C
                  CALL DLASET( 'Full', LA22, LH, ZERO, ZERO,
     $                         A(IR1,IRE1), LDA )
               END IF
            ELSE
               CALL DLASET( 'Full', LA22, NA22, ZERO, ZERO,
     $                      A(IR1,IR1), LDA)
            END IF
         END IF
      END IF
C
      DWORK(1) = WRKOPT
C
      RETURN
C *** Last line of TG01FD ***
      END


PROGRAM test_hypotenuse
!
!  Purpose:
!    Program to test the operation of subroutine calc_hypotenuse.
!
!  Record of revisions:
!      Date       Programmer          Description of change
!      ====       ==========          =====================
!    11/18/06    S. J. Chapman        Original code
!
IMPLICIT NONE

! Data dictionary: declare variable types & definitions
REAL :: s1             ! Length of side 1
REAL :: s2             ! Length of side 2
REAL :: hypot          ! Hypotenuse

! Get the lengths of the two sides.
WRITE (*,*) 'Program to test subroutine calc_hypotenuse: '
WRITE (*,*) 'Enter the length of side 1: '
READ (*,*) s1
WRITE (*,*) 'Enter the length of side 2: '
READ (*,*) s2

! Call calc_hypotenuse.
CALL calc_hypotenuse ( s1, s2, hypot )

! Write out hypotenuse.
WRITE (*,1000) hypot
1000 FORMAT (1X,'The length of the hypotenuse is: ', F10.4 )

END PROGRAM test_hypotenuse


module leap
  implicit none

contains

  pure logical function is_leap_year(year)
    integer, intent(in) :: year

    is_leap_year = is_div(year, 4) &
        & .AND. .NOT. is_div(year, 100) &
        & .OR. is_div(year, 400)
  end function

  pure logical function is_div(a, b)
    integer, intent(in) :: a, b

    is_div = 0 == modulo(a, b)
  end function

end module


      integer,parameter::m=10000
      real::a(m), b(m)
      real::fact=0.5

      do concurrent (i=1:m)
        a(i) = a(i) + fact*b(i)
      end do
      write(*,"(A)") "Done"
      end


submodule (a1:a2) a3

contains

module procedure get_pi
  get_pi = 4.*atan(1.)
end procedure get_pi

end submodule a3


! 10. Write a program that prints the next 20 leap years.

    program Exercises
    implicit none
    integer :: currentYear
    integer :: count

    integer dateTimeResult(8)
    character(len=12) unused(3)

    ! Intrinsic subroutine
    call date_and_time(unused(1), unused(2), unused(3), dateTimeResult)

    currentYear = dateTimeResult(1)
    count = 0

10&

    if (mod(currentYear, 4) .ne. 0) then
        ! Not a leap year

    else if (mod(currentYear, 100) .ne. 0) then
        ! It is a leap year
        print *, currentYear
        count = count + 1

    else if (mod(currentYear, 400) .ne. 0) then
        ! Not a leap year

    else
        ! It is a leap year
        print *, currentYear
        count = count + 1
    end if

    if (count .lt. 20) then
        currentYear = currentYear + 1
        goto 10
    end if

    end Program Exercises


!> \file covariance.f90
!! @todo rewrite each program/module that uses the old module \a  covariance to use the \a evd_covariance module. The \a evd_covariance module works together with \a kronecker modules
!!
!! \brief General module for covariance matrix
!!
!! @author Innocent Souopgui
!!
! !! \note In recent update, the old covariance module was separated into Kronecker module and the current covariance module. User need to reference the kronecker module for compilation
! !!
! !! \details This module implements a set of subroutines for the covariance matrix for one and two dimensional problems
! !! Using the positive (semi) definiteness of the covariance matrices, the covariance matrix B is diagonalizable
! !! and its singular value decomposition is also its diagonalization in a basis of eigenvectors.
! !! We consider the case where B is approximated using only the leading eigenvectors, the full case being similar.
! !! The covariance matrix is supposed to be given under a factorized forms
! !!   \f[ B \approx UDU^T \f] where the colums of U are the leading eigenvectors
! !!   of B and D is the diagonal matrix of the leading eigenvalues of B.
! !! For the 2D, we consider the covariance function that factorises as a product of covariance functions
! !! in each spatial dimension; so that the covariance matrix B is the kronecker product of the covariance
! !! matrices in the single dimensions \f[ B = Kron(Bx,By) \f]. Bx and By are given under their factorized forms
! !! \f[ B Kron(Ux,Uy)*Kron(Dx,Dy)*Kron(Ux,Uy)^T \f], where Dx is a diagonal matrix with leading eigenvalues
! !! of Bx on the diagonal and Dy is a diagonal matrix with eigenvalues of By on the diagonal
! !! Bx = Ux*Dx*Ux^T,  By = Uy*Dy*Uy^T.
! !!The 2D covariance matrix applies to a vector that correspond to a discretization of
! !!  a 2d function (function of two variables) on the same grid as the control
! !!  variable. The chronecker product factorization depends on the ordering of
! !!  the dimensions in the discretization as well as the vectorization of the
! !!  2D discretized function.
! !!Suppose that the covariance function factorizes such that the covariances on
! !!  the grid are combinations of the covariances in each direction,
! !!  cov(p1, p2) = cov_x(x1,x2)cov_y(y1,y2) where p1 is the point of coordinates
! !!  (x1,y1) and p2 (x2,y2). In this case B*f = Kron(B_x,B_y)*f where B_x and
! !!  B_y are respectively the covariances in the direction x, resp. y.
! !! According to the ordering of the discretization points and the vectorization
! !!   order, that formula may change:
! !! Let F be the matrix of a discretized function, and f its vectorized representation.
! !!if the first dimension of F corresponds to the x direction (x-leading) then,
! !!  g=B*f = Kron(B_x,B_y)*f, if f is a row major vectorization (C-prefered ordering);
! !!  and g=B*f = Kron(B_y,B_x)*f, if f is a column major vectorization
! !!  (Fortran-prefered ordering).
! !!if the first dimension of F corresponds to the y direction (y-leading) then,
! !! g=B*f = Kron(B_y,B_x)*f with a row major vectorization (C-prefered ordering)
! !! of F; and g=B*f = Kron(B_x,B_y)*f, with a column major vectorization
! !! (Fortran-prefered ordering) of F.
! !! All the 2D routines in this module supposed either:
! !! x-leading and and row major vectorization or
! !! y-leading and the column major vectorization
! !!
! !<
! MODULE covariance
!   USE general_constant
!   USE general_tools, only: readInfo, readMatrix
!   USE debug_tools
!   use kronecker
! IMPLICIT NONE
!
!   private
!   public svd_cov_matrix, load_svd_covariance, apply_svd_cov&
!     , apply_svd_cov_inv, apply_svd_square_cov, get_svd_cov_size&
!     , apply_svd_square_covb, apply_svd_square_cov_inv, get_svd_cov_nsv
!   !, cov_mv, cov_inv_mv, cov_square_mv, cov_square_mvb, cov_square_inv_mv&
!
!
!   !> \brief default number of factors in the Kronecker factorization of the covariance matrix, used for non initialized covariance matrix
!   !<
!   INTEGER, PARAMETER :: default_nFact=-1
!
! !> Derived type for singular values decomposed covariance matrices
! !! It is assumed that the covariance matrix is provided as its Singular Value Decomposition: B = UDUt. Furthermore, it can be (Kronecker) factorized along the physical dimensions of the problem: B = Bx kron By kron Bz
! type svd_cov_matrix
!
!   !> \brief number of terms in the Kronecker factorization of the covariance matrix.
!   !!Conceptually, it corresponds to the number of physical dimensions of the problem if the covariance is factorized.
!   !!Logically, it can be any Kronecker factorization.
!   !<
!   INTEGER :: im_nFac = default_nFact
!
!   !> \brief matrix(ces) of singular vector of the covariance matrix
!   !! If the covariance matrix B is not factorized, only Ux is initialized
!   !! IF B is factorized as B = Bx kron By (two terms), Ux and Uy are provided
!   !! A maximum of 3 terms in the factorization is supported. Only 1 and 2 terms are implemented for now.
!   !<
!   REAL(cp), ALLOCATABLE, DIMENSION(:,:):: Ux, Uy, Uz
!
!   !> vector(s) of singular values of the SVD of B
!   REAL(cp), ALLOCATABLE, DIMENSION(:) :: Dx, Dy, Dz
!
! end type svd_cov_matrix
!
! !private procedures interface
!   !> Covariance matrix vector product
!   INTERFACE cov_mv
!     MODULE PROCEDURE cov_mv_default
!     MODULE PROCEDURE cov_mv_2Fac
!     !MODULE PROCEDURE cov_mv_3Fac
!   END INTERFACE cov_mv
!
!   !> Inverse covariance matrix vector product
!   INTERFACE cov_inv_mv
!     MODULE PROCEDURE cov_inv_mv_default
!     MODULE PROCEDURE cov_inv_mv_2Fac
!     !MODULE PROCEDURE cov_inv_mv_3Fac
!   END INTERFACE cov_inv_mv
!
!   !> square root covariance matrix vector product
!   INTERFACE cov_square_mv
!     MODULE PROCEDURE cov_square_mv_default
!     !MODULE PROCEDURE cov_square_mv_1D
!     MODULE PROCEDURE cov_square_mv_2Fac
!   END INTERFACE cov_square_mv
!
!   !> square root covariance matrix vector product (adjoint)
!   INTERFACE cov_square_mvb
!     MODULE PROCEDURE cov_square_mvb_default
!     MODULE PROCEDURE cov_square_mvb_2Fac
!     !MODULE PROCEDURE cov_square_mv_3Fac
!   END INTERFACE cov_square_mvb
!
!   !> Inverse square root covariance matrix vector product
!   INTERFACE cov_square_inv_mv
!     MODULE PROCEDURE cov_square_inv_mv_default
!     MODULE PROCEDURE cov_square_inv_mv_2Fac
!     !MODULE PROCEDURE cov_square_inv_mv_3Fac
!   END INTERFACE cov_square_inv_mv
!
!   !> Checks the parameters for the application of the covariance matrix or its inverse
!   INTERFACE cov_mv_check
!     MODULE PROCEDURE cov_mv_check_default
!     MODULE PROCEDURE cov_mv_check_2Fac
!   END INTERFACE cov_mv_check
!
!   !> Check the parameters for the application of the square root of the covariance matrix or its inverse
!   INTERFACE cov_square_mv_check
!     MODULE PROCEDURE cov_square_mv_check_default
!     MODULE PROCEDURE cov_square_mv_check_2Fac
!   END INTERFACE cov_square_mv_check
! !end of private procedures interface
!
! CONTAINS
!
! !public procedures
!
!   !> \brief returns the number of singular values used to define the approximation of the covariance matrix; that is also the size of the changed state variable
!   !! \param[in] C covariance matrix derived type
!   !! \param[in] [nctl] size of the control vector
!   !! If a call to load_covariance has not been done before: the function returns nctl if it is provided, otherwise, the program is stopped. If a call to load_covariance have been done before, the associated value is returned
!   !<
!   FUNCTION get_svd_cov_nsv(C, nctl) RESULT(nsv)
!     type(svd_cov_matrix), intent(in) :: C
!     INTEGER, OPTIONAL, INTENT(IN) :: nctl
!     !local variables
!     INTEGER :: nsv
!
!     SELECT CASE(C%im_nFac)
!       CASE (1)
!         nsv = SIZE(C%Dx)
!       CASE (2)
!         nsv = SIZE(C%Dx)*SIZE(C%Dy)
!       CASE (default_nFact)!default value
!         IF( PRESENT(nctl) )THEN
!           nsv = nctl
!         ELSE
!           CALL stop_program( 'In svd_cov_nsv, covariance not loaded and nctl not provided' )
!         END IF
!       CASE DEFAULT
!         CALL stop_program( 'In svd_cov_nsv, covariance operations are define only for 1D and 2D' )
!     END SELECT
!   END FUNCTION get_svd_cov_nsv
!
!   !> \brief Reads a covariance matrix stored under the form of an SVD decomposition
!   !! \param[in] UFName file name of the matrix of singular vectors
!   !! \param[in] DFName file name of the matrix of singular values
!   !! \param[inout] U matrix of singular vectors
!   !! \param[inout] D vector of singular values
!   !<
!   SUBROUTINE readSVD( UFName, DFName, U, D )
!     CHARACTER(len=*), INTENT(IN)  :: UFName, DFName
!     REAL(cp), DIMENSION(:,:), INTENT(INOUT) :: U
!     REAL(cp), DIMENSION(:), INTENT(INOUT) :: D
!     !local variables
!     REAL(cp), DIMENSION(:,:), ALLOCATABLE :: T
!     INTEGER :: il_n, il_k, il_nRow, il_nCol, ibj
!
!     CALL readSVDSize( UFName, DFName, il_n, il_k, il_nRow, il_nCol )
!     ALLOCATE( T(il_nRow, il_nCol) )
!
!     CALL readMatrix( UFName, U )
!     CALL readMatrix( DFName, T )
!
!     IF(il_nRow == 1) THEN
!       D = T(1,:)
!     ELSE IF(il_nCol == 1) THEN
!       D = T(:,1)
!     ELSE
!       DO ibj = 1, il_nCol
!         D(ibj) = T( ibj, ibj )
!       END DO
!     END IF
!   END SUBROUTINE readSVD
!
!   !> \brief read the size of the SVD decomposition of B: size of each singular vector, and number of singular vector
!   !! \param[in] UFName file name of the matrix of singular vectors
!   !! \param[in] DFName file name of the matrix of singular values
!   !! \param[inout] n size of each singular vector (number of rows/colums of B)
!   !! \param[inout] k number of singular values (or vector)
!   !! \param[inout] nrD (optional) number of rows of D
!   !! \param[inout] ncD (optional) number of colums of D
!   !! if the sizes in UFName and DFName do not match, the program terminates
!   !<
!   SUBROUTINE readSVDSize(UFName, DFName, n, k, nrD, ncD)
!     CHARACTER(len=*), INTENT(IN)  :: UFName, DFName
!     INTEGER, INTENT(OUT) :: n, k
!     INTEGER, OPTIONAL, INTENT(OUT) :: nrD, ncD
!     INTEGER :: il_nrD, il_ncD
!
!     CALL readInfo( UFName, n, k )
!     CALL readInfo( DFName, il_nrD, il_ncD )
!     CALL SVD_check( n, k, il_nrD, il_ncD )
!     IF( PRESENT(nrD) ) nrD = il_nrD
!     IF( PRESENT(ncD) ) ncD = il_ncD
!   END SUBROUTINE readSVDSize
!
!   !> \brief Loads the covariance matrix represented by its singular value decomposition
!   !! \param[in, out] C covariance matrix derived type
!   !! \param[in] dir directory containing the data files
!   !!
!   !! \details It is assumed that the covariance matrix B is provided as its
!   !!  Singular Value Decomposition: B = UDU^t. Furthermore, it can be
!   !!  (Kronecker) factorized (for example along the physical dimensions of
!   !!  the problem) in which case it is given under the form:
!   !! - B = Bx kron By = (UxDxUx^t) kron (UyDyUy^t) or
!   !! - B = Bx kron By kron Bz = (UxDxUx^t) kron (UyDyUy^t) kron (UzDzUz^t)
!   !! Conventions for the file names. Data files are named after the matrices names with the extension 'dat'
!   !! - 'U.dat' and 'D.dat' for the non factorized case
!   !! - 'Ux.dat',  'Uy.dat', 'Uz.dat' and 'Dx.dat', 'Dy.dat', 'Dz.dat' for the factorized case
!   !! the existence of files is checked to determine the appropriate configuration.
!   !! ('U.dat' and 'D.dat') or ('Ux.dat' and 'Dx.dat') should be present, otherwise the program terminates
!   !!
!   !<
!   SUBROUTINE load_svd_covariance(C, dir)
!     type(svd_cov_matrix), intent(in out) :: C
!     CHARACTER(len=*), INTENT(IN)  :: dir
!     !local variables
!     INTEGER :: il_N, il_K
!     CHARACTER(len=ip_fnl) :: UFName, DFName
!
!     CALL debug('Entering load_covariance ', tag=dALLWAYS )
!     !Checking files
!     IF( ACCESS(TRIM(dir)//'/U.dat', MODE='r')==0 )THEN
!       UFName = TRIM(dir)//'/U.dat'
!       DFName = TRIM(dir)//'/D.dat'
!     ELSE
!       UFName = TRIM(dir)//'/Ux.dat'
!       DFName = TRIM(dir)//'/Dx.dat'
!     END IF
!
!     CALL debug(100, ' In load_svd_covariance ', tag=dALLWAYS )
!     CALL readSVDSize(UFName, DFName, il_N, il_K)
!     ALLOCATE( C%Ux(il_N, il_K), C%Dx(il_K) )
!     CALL readSVD( UFName, DFName, C%Ux, C%Dx )
!     CALL debug(C%Ux, 'Ux = ')
!     CALL debug(C%Dx, 'Dx = ')
!     C%im_nFac = 1
!
!     CALL debug(200, ' In load_svd_covariance ', tag=dALLWAYS )
!     UFName = TRIM(dir)//'/Uy.dat'
!     DFName = TRIM(dir)//'/Dy.dat'
!     IF( ACCESS(uFName, MODE='r')==0 )THEN
!       CALL readSVDSize(UFName, DFName, il_N, il_K)
!       ALLOCATE( C%Uy(il_N, il_K), C%Dy(il_K) )
!       CALL readSVD( UFName, DFName, C%Uy, C%Dy )
!       CALL debug(C%Uy, 'Uy = ')
!       CALL debug(C%Dy, 'Dy = ')
!       C%im_nFac = C%im_nFac + 1
!     END IF
!
!     CALL debug('Exiting load_svd_covariance ', tag=dALLWAYS )
!   END SUBROUTINE load_svd_covariance
!
!   !> Gets the sizes of the factorized arrays that make up the EV decomposed covariance matrix
!   !! \param[in] C covariance matrix derived type
!   !! \param[out] Nx number of components [in the x direction]
!   !! \param[out] Kx number of singular vectors [in the x direction]
!   !! \param[out] Ny number  of components in the y direction
!   !! \param[out] Ky number of singular vectors in the y direction
!   !!
!   !! \details Negatives value means that there is no component in the given direction.
!   !<
!   subroutine get_svd_cov_size(C, Nx, Kx, Ny, Ky)
!     type(svd_cov_matrix), intent(in out) :: C
!     INTEGER, INTENT(OUT), OPTIONAL :: Nx, Kx, Ny, Ky
!
!     if(C%im_nFac>=1)then
!       if( present(Nx) )Nx = size(C%Ux,1)
!       if( present(Kx) )Kx = size(C%Ux,2)
!     else
!       if( present(Nx) )Nx = -1
!       if( present(Kx) )Kx = -1
!     end if
!
!     if(C%im_nFac>=2)then
!       if( present(Ny) )Ny = size(C%Uy,1)
!       if( present(Ky) )Ky = size(C%Uy,2)
!     else
!       if( present(Ny) )Ny = -1
!       if( present(Ky) )Ky = -1
!     end if
!   end subroutine get_svd_cov_size
!
!   !> \brief applies the covariance matrix to the vector f, g = Bf
!   !! \param[in] C covariance matrix derived type
!   !! \param[in] f input vector
!   !! \param[in] g output vector
!   !! \param[in] [die] specify the behavior of the program if the covariance matrix is not loaded. if TRUE, the program stops, otherwise g =f. The user should make sure that f and g have the same size.
!   !<
!   SUBROUTINE apply_svd_cov(C, f, g, die)
!     type(svd_cov_matrix), intent(in) :: C
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     LOGICAL, OPTIONAL, INTENT(IN) :: die
!     !local variables
!     LOGICAL :: ll_die
!
!     IF( PRESENT(die) )THEN
!       ll_die = die
!     ELSE
!       ll_die = .TRUE.
!     END IF
!
!     SELECT CASE(C%im_nFac)
!       CASE (1)
!         CALL stop_program('apply_svd_cov is not yed defined for 1D')
!       CASE (2)
!         CALL cov_mv(C%Ux, C%Dx, C%Uy, C%Dy, f, g)
!       CASE (default_nFact)!default value
!         IF(ll_die)THEN
!           CALL stop_program('In apply_svd_cov covariance matrix is not loaded')
!         ELSE
!           g=f
!         END IF
!     END SELECT
!   END SUBROUTINE apply_svd_cov
!
!   !> \brief applies the inverse of covariance matrix, g = B^-1 f
!   !! \param[in] C covariance matrix derived type
!   !! \param[in] f input vector
!   !! \param[in] g output vector
!   !! \param[in] [die] specify the behaviour of the program if the covariance matrix is not loaded. if TRUE, the program stops, otherwise g =f. The user should make sure that f and g have the same size.
!   !<
!   SUBROUTINE apply_svd_cov_inv(C, f, g, die)
!     type(svd_cov_matrix), intent(in) :: C
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     LOGICAL, OPTIONAL, INTENT(IN) :: die
!     !local variables
!     LOGICAL :: ll_die
!
!     IF( PRESENT(die) )THEN
!       ll_die = die
!     ELSE
!       ll_die = .TRUE.
!     END IF
!
!     SELECT CASE(C%im_nFac)
!       CASE (1)
!         CALL stop_program('apply_svd_cov_inv is not yed defined for 1D')
!       CASE (2)
!         CALL cov_inv_mv(C%Ux, C%Dx, C%Uy, C%Dy, f, g)
!       CASE (default_nFact)!default value
!         IF(ll_die)THEN
!           CALL stop_program('In apply_svd_cov_inv covariance matrix is not loaded')
!         ELSE
!           g=f
!         END IF
!     END SELECT
!   END SUBROUTINE apply_svd_cov_inv
!
!   !> \brief apply the square root of the covariance matrix to the vector f and result g
!   !! \param[in] C covariance matrix derived type
!   !! \param[in] f input vector
!   !! \param[in] g output vector
!   !! \param[in] [die] specify the behaviour of the program if the covariance matrix is not loaded. if TRUE, the program stops, otherwise g =f, the user should make sure that f and g have the same size.
!   !<
!   SUBROUTINE apply_svd_square_cov(C, f, g, die)
!     type(svd_cov_matrix), intent(in) :: C
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     LOGICAL, OPTIONAL, INTENT(IN) :: die
!     !local variables
!     LOGICAL :: ll_die
!
!     IF( PRESENT(die) )THEN
!       ll_die = die
!     ELSE
!       ll_die = .TRUE.
!     END IF
!
!     SELECT CASE(C%im_nFac)
!       CASE (1)
!         CALL stop_program('apply_svd_square_cov is not yed defined for 1D')
!       CASE (2)
!         CALL cov_square_mv(C%Ux, C%Dx, C%Uy, C%Dy, f, g)
!       CASE (default_nFact)!default value
!         IF(ll_die)THEN
!           CALL stop_program('In apply_svd_square_cov, covariance matrix is not loaded')
!         ELSE
!           g=f
!         END IF
!     END SELECT
!   END SUBROUTINE apply_svd_square_cov
!
!   !> \brief apply the adjoint of the square root of the covariance matrix to the vector f and result g
!   !! \param[in] C covariance matrix derived type
!   !! \param[in] f input vector
!   !! \param[in] g output vector
!   !! \param[in] [die] specify the behaviour of the program if the covariance matrix is not loaded. if TRUE, the program stops, otherwise g =f. The user should make sure that f and g have the same size.
!   !<
!   SUBROUTINE apply_svd_square_covb(C, fb, gb, die)
!     type(svd_cov_matrix), intent(in) :: C
!     REAL(cp), DIMENSION(:), INTENT(INOUT)  :: fb
!     REAL(cp), DIMENSION(:), INTENT(INOUT) :: gb
!     LOGICAL, OPTIONAL, INTENT(IN) :: die
!     !local variables
!     LOGICAL :: ll_die
!
!     IF( PRESENT(die) )THEN
!       ll_die = die
!     ELSE
!       ll_die = .TRUE.
!     END IF
!
!     SELECT CASE(C%im_nFac)
!       CASE (1)
!         CALL stop_program('apply_svd_square_covb is not yed defined for 1D')
!       CASE (2)
!         CALL cov_square_mvb(C%Ux, C%Dx, C%Uy, C%Dy, fb, gb)
!       CASE (default_nFact)!default value
!         IF(ll_die)THEN
!           CALL stop_program('In apply_svd_square_covb, covariance matrix is not loaded')
!         ELSE
!           fb=fb+gb
!           gb=0.0_cp
!         END IF
!     END SELECT
!   END SUBROUTINE apply_svd_square_covb
!
!   !> \brief apply the inverse of the square root of the covariance matrix to the vector f and result g
!   !! \param[in] C covariance matrix derived type
!   !! \param[in] f input vector
!   !! \param[in] g output vector
!   !! \param[in] [die] specify the behaviour of the program if the covariance matrix is not loaded. if TRUE, the program stops, otherwise g =f. The user should make sure that f and g have the same size.
!   !<
!   SUBROUTINE apply_svd_square_cov_inv(C, f, g, die)
!     type(svd_cov_matrix), intent(in) :: C
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     LOGICAL, OPTIONAL, INTENT(IN) :: die
!     !local variables
!     LOGICAL :: ll_die
!
!     IF( PRESENT(die) )THEN
!       ll_die = die
!     ELSE
!       ll_die = .TRUE.
!     END IF
!
!     SELECT CASE(C%im_nFac)
!       CASE (1)
!         CALL stop_program( 'apply_square_cov_inv is not yed defined for 1D' )
!       CASE (2)
!         CALL cov_square_inv_mv( C%Ux, C%Dx, C%Uy, C%Dy, f, g )
!       CASE ( default_nFact )!default value
!         IF (ll_die) THEN
!           CALL stop_program('In apply_svd_square_cov_inv, covariance matrix is not loaded')
!         ELSE
!           g=f
!         END IF
!     END SELECT
!   END SUBROUTINE apply_svd_square_cov_inv
!
! !end of public procedures
!
! !privates procedures
!   !> \brief Checks the parameters for the application of the covariance matrix or its inverse
!   !! @see cov_mv_2Fac for the description of the parameters
!   !<
!   SUBROUTINE cov_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
!     REAL(cp), DIMENSION(:), INTENT(IN) :: g
!     !local variables
!     INTEGER :: nx, ny, kx, ky, nf_predict
!
!     nx = SIZE(Ux,1)
!     ny = SIZE(Uy,1)
!     kx = SIZE(Ux,2)
!     ky = SIZE(Uy,2)
!     nf_predict = nx*ny
!     IF( (SIZE(Dx)/=kx).OR.(SIZE(Dy)/=ky).OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=nf_predict) )THEN
!       CALL debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
!       CALL debug(kx, 'Dx of size :', tag=dALLWAYS)
!       CALL debug(ky, 'Dy of size :', tag=dALLWAYS)
!       CALL debug(nf_predict, 'f and g of size :', tag=dALLWAYS)
!       CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
!       CALL debug(SIZE(Dx), 'SIZE(Dx)', tag=dALLWAYS)
!       CALL debug(SIZE(Dy), 'SIZE(Dy)', tag=dALLWAYS)
!       CALL debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
!       CALL debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
!       CALL debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
!       CALL debug(SHAPE(Ux), 'SHAPE(Ux)', tag=dALLWAYS)
!       CALL debug(SHAPE(Uy), 'SHAPE(Uy)', tag=dALLWAYS)
!       CALL stop_program('Non consistant input for the application of the covariance matrix or its inverse')
!     END IF
!   END SUBROUTINE cov_mv_check_2Fac
!
!   !> \brief multiply a vector by the covariance matrix given as a Kronecker product of two covariance Bx and By. Each one being given by its SVD. Best suited for two physical dimensions problems where the covariance factorizes.
!   !! param[in] Ux matrix whose columns are the leading eigenvalues vector of the covariance matrix Bx in the direction x, size nx \times kx
!   !! param[in] Dx vector of leading eigenvalues in the direction x, size kx
!   !! param[in] Uy matrix whose columns are the leading eigenvalues vector of the covariance matrix By in the direction y, size ny \times ky
!   !! param[in] Dy vector of leading eigenvalues in the direction y, size ky
!   !! param[in] f input vector of size nx*ny (size of the discretization grid)
!   !! param[out] g output vector of size nx*ny
!   !! \details
!   !! computes g = Bf
!   !! this routine assumes either :
!   !! - the x-leading and and row major vectorization or
!   !! - the y-leading and the column major vectorization
!   !<
!   SUBROUTINE cov_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: t1, t2
!
!     !checking the input parameters
!     CALL cov_mv_check(Ux, Dx, Uy, Dy, f, g)
!
!     CALL kron_matvec(Ux, Uy, f , t1, trans=.TRUE.)
!     CALL kron_matvec(Dx, Dy, t1, t2)
!     CALL kron_matvec(Ux, Uy, t2, g , trans=.FALSE.)
!   END SUBROUTINE cov_mv_2Fac
!
!   !> \brief Checks the parameters for the application of the covariance matrix or its inverse
!   !! @see cov_mv_2Fac for the description of the parameters
!   !<
!   SUBROUTINE cov_mv_check_default(U, D, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     INTEGER :: n, k
!
!     n = SIZE(U,1)
!     k = SIZE(U,2)
!     IF( (SIZE(D)/=k).OR.(SIZE(f)/=n).OR.(SIZE(g)/=n) )THEN
!       CALL debug('cov_mv_check_default: Expecting data with following specification, based on the shape of U', tag=dALLWAYS)
!       CALL debug(k, 'D of size :', tag=dALLWAYS)
!       CALL debug(n, 'f and g of size :', tag=dALLWAYS)
!       CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
!       CALL debug(SIZE(D), 'SIZE(D)', tag=dALLWAYS)
!       CALL debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
!       CALL debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
!       CALL debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
!       CALL debug(SHAPE(U), 'SHAPE(U)', tag=dALLWAYS)
!       CALL stop_program('Non consistant input for the application of the covariance matrix or its inverse')
!     END IF
!   END SUBROUTINE cov_mv_check_default
!
!   !> \brief multiply a vector by the covariance matrix given as its SVD
!   !! param[in] U matrix whose columns are the leading eigenvectors of the covariance matrix B, size n \times k
!   !! param[in] D vector of leading eigenvalues, size k
!   !! param[in] f input vector of size n (size of the discretization grid)
!   !! param[out] g output vector of size n
!   !! \details
!   !! computes g = Bf
!   !<
!   SUBROUTINE cov_mv_default(U, D, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION( SIZE(D) ) :: t1, t2
!
!     !checking the input parameters
!     CALL cov_mv_check( U, D, f, g )
!
!     t1 = MATMUL(f, U) !transpose
!     t2 = D*t1
!     g  = MATMUL(U, t2)
!   END SUBROUTINE cov_mv_default
!
!   !> \brief multiplies a vector by the inverse of the covariance matrix, two physical dimensions problem
!   !! param[in] Ux matrix whose columns are the leading eigenvalues vector of the covariance matrix Bx in the direction x, size nx \times kx
!   !! param[in] Dx vector of leading eigenvalues in the direction x, size kx
!   !! param[in] Uy matrix whose columns are the leading eigenvalues vector of the covariance matrix By in the direction y, size ny \times ky
!   !! param[in] Dy vector of leading eigenvalues in the direction y, size ky
!   !! param[in] f input vector of size nx*ny (size of the discretization grid)
!   !! param[out] g output vector of size nx*ny
!   !! \details
!   !! computes g = B^-1 f
!   !! this routine assumes either :
!   !! - the x-leading and and row major vectorization or
!   !! - the y-leading and the column major vectorization
!   !<
!   SUBROUTINE cov_inv_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION(SIZE(Dx)) :: DxInv
!     REAL(cp), DIMENSION(SIZE(Dy)) :: DyInv
!     REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: t1, t2
!
!     !checking the input parameters
!     CALL cov_mv_check(Ux, Dx, Uy, Dy, f, g)
!
!     DxInv = 1.0/Dx
!     DyInv = 1.0/Dy
!     CALL kron_matvec(Ux, Uy, f , t1, trans=.TRUE.)
!     CALL kron_matvec(DxInv, DyInv, t1, t2)
!     CALL kron_matvec(Ux, Uy, t2, g , trans=.FALSE.)
!   END SUBROUTINE cov_inv_mv_2Fac
!
!   !> \brief multiplies a vector by the inverse of the covariance matrix given as its SVD
!   !! param[in] U matrix whose columns are the leading eigenvalues vector of the covariance matrix B, size n \times k
!   !! param[in] D vector of leading eigenvalues, size k
!   !! param[in] f input vector of size n (size of the discretization grid)
!   !! param[out] g output vector of size n
!   !! \details
!   !! computes g = B^-1 f
!   !! this routine assumes either :
!   !! - the x-leading and and row major vectorization or
!   !! - the y-leading and the column major vectorization
!   !<
!   SUBROUTINE cov_inv_mv_default(U, D, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION(SIZE(D)) :: t1, t2
!
!     !checking the input parameters
!     CALL cov_mv_check( U, D, f, g )
!
!     t1 = MATMUL(f, U) !transpose
!     t2 = t1/D
!     g  = MATMUL(U, t2)
!   END SUBROUTINE cov_inv_mv_default
!
!   !> \brief Checks the parameters for the application of the square root of the covariance matrix or its inverse
!   !! @see cov_square_mv_default for the description of the parameters
!   !<
!   SUBROUTINE cov_square_mv_check_default(U, D, f, g, inv)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     LOGICAL, OPTIONAL :: inv
!     !local variables
!     INTEGER :: n, k, nf_predict, ng_predict
!     LOGICAL :: ll_inv
!
!     IF( PRESENT(inv) )THEN
!       ll_inv = inv
!     ELSE
!       ll_inv = .FALSE.
!     END IF
!     n = SIZE(U,1)
!     k = SIZE(U,2)
!     IF(ll_inv)THEN
!       nf_predict = n
!       ng_predict = k
!     ELSE
!       nf_predict = k
!       ng_predict = n
!     END IF
!     IF( (SIZE(D)/=k).OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=ng_predict) )THEN
!       CALL debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
!       CALL debug(k, 'D of size :', tag=dALLWAYS)
!       CALL debug(nf_predict, 'f of size :', tag=dALLWAYS)
!       CALL debug(ng_predict, 'g of size :', tag=dALLWAYS)
!       CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
!       CALL debug(SIZE(D), 'SIZE(Dx)', tag=dALLWAYS)
!       CALL debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
!       CALL debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
!       CALL debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
!       CALL debug(SHAPE(U), 'SHAPE(U)', tag=dALLWAYS)
!       IF(ll_inv) CALL debug('The purpose is to compute apply the inverse square root', tag=dALLWAYS)
!       CALL stop_program('Non consistant input for the application of the covariance matrix or its inverse')
!     END IF
!   END SUBROUTINE cov_square_mv_check_default
!
!   !> \brief Checks the parameters for the application of the square root of the covariance matrix or its inverse
!   !! @see cov_square_mv_2Fac for the description of the parameters
!   !<
!   SUBROUTINE cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g, inv)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
!     REAL(cp), DIMENSION(:), INTENT(IN) :: g
!     LOGICAL, OPTIONAL :: inv
!     !local variables
!     INTEGER :: nx, ny, kx, ky, nf_predict, ng_predict
!     LOGICAL :: ll_inv
!
!     IF( PRESENT(inv) )THEN
!       ll_inv = inv
!     ELSE
!       ll_inv = .FALSE.
!     END IF
!     nx = SIZE(Ux,1)
!     ny = SIZE(Uy,1)
!     kx = SIZE(Ux,2)
!     ky = SIZE(Uy,2)
!     IF(ll_inv)THEN
!       nf_predict = nx*ny
!       ng_predict = kx*ky
!     ELSE
!       nf_predict = kx*ky
!       ng_predict = nx*ny
!     END IF
!     IF( (SIZE(Dx)/=kx).OR.(SIZE(Dy)/=ky).OR.(SIZE(f)/=nf_predict).OR.(SIZE(g)/=ng_predict) )THEN
!       CALL debug('Expecting data with following specification, based on the shape of Ux and Uy', tag=dALLWAYS)
!       CALL debug(kx, 'Dx of size :', tag=dALLWAYS)
!       CALL debug(ky, 'Dy of size :', tag=dALLWAYS)
!       CALL debug(nf_predict, 'f of size :', tag=dALLWAYS)
!       CALL debug(ng_predict, 'g of size :', tag=dALLWAYS)
!       CALL debug('Get the following, check and try aigain', tag=dALLWAYS)
!       CALL debug(SIZE(Dx), 'SIZE(Dx)', tag=dALLWAYS)
!       CALL debug(SIZE(Dy), 'SIZE(Dy)', tag=dALLWAYS)
!       CALL debug(SIZE(f), 'SIZE(f)', tag=dALLWAYS)
!       CALL debug(SIZE(g), 'SIZE(g)', tag=dALLWAYS)
!       CALL debug('For debuging purpose, here are the shapes of Ux and Uy', tag=dALLWAYS)
!       CALL debug(SHAPE(Ux), 'SHAPE(Ux)', tag=dALLWAYS)
!       CALL debug(SHAPE(Uy), 'SHAPE(Uy)', tag=dALLWAYS)
!       IF(ll_inv) CALL debug('The purpose is to compute apply the inverse square root', tag=dALLWAYS)
!       CALL stop_program('Non consistant input for the application of the covariance matrix or its inverse')
!     END IF
!   END SUBROUTINE cov_square_mv_check_2Fac
!
!   !> \brief multiplies a vector by the square root of the covariance matrix given as its SVD
!   !! param[in] U matrix whose columns are the leading eigenvalues vector of the covariance matrix B, size n \times k
!   !! param[in] D vector of leading eigenvalues, size k
!   !! param[in] f input vector of size n (size of the discretization grid)
!   !! param[out] g output vector of size n
!   !! \details
!   !! computes g = B^0.5 f
!   !<
!   SUBROUTINE cov_square_mv_default(U, D, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION( SIZE(D) ) :: t
!
!     !checking the input parameters
!     CALL cov_square_mv_check(U, D, f, g, inv=.FALSE.)
!
!     t = SQRT(D)*f
!     g = MATMUL(U, t)
!   END SUBROUTINE cov_square_mv_default
!
!   !> \brief multiplies a vector by the square root of the covariance matrix, two physical dimensions problem
!   !! param[in] Ux matrix whose columns are the leading eigenvalues vector of the covariance matrix Bx in the direction x, size nx \times kx
!   !! param[in] Dx vector of leading eigenvalues in the direction x, size kx
!   !! param[in] Uy matrix whose columns are the leading eigenvalues vector of the covariance matrix By in the direction y, size ny \times ky
!   !! param[in] Dy vector of leading eigenvalues in the direction y, size ky
!   !! param[in] f input vector of size nx*ny (size of the discretization grid)
!   !! param[out] g output vector of size nx*ny
!   !! \details
!   !! computes g = B^0.5 f
!   !! this routine assumes either :
!   !! - the x-leading and and row major vectorization or
!   !! - the y-leading and the column major vectorization
!   !<
!   SUBROUTINE cov_square_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION(SIZE(Dx)) :: Dx05
!     REAL(cp), DIMENSION(SIZE(Dy)) :: Dy05
!     REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: t
!
!     !checking the input parameters
!     CALL cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g, inv=.FALSE.)
!
!     Dx05 = SQRT(Dx)
!     Dy05 = SQRT(Dy)
!
!     CALL kron_matvec(Dx05, Dy05, f, t)
!     CALL kron_matvec(Ux, Uy, t, g , trans=.FALSE.)
!   END SUBROUTINE cov_square_mv_2Fac
!
!   !> adjoint subroutine, used mathmatical formulation of the adjoint with linear operators
!   SUBROUTINE cov_square_mvb_default(U, D, fb, gb)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: D
!     REAL(cp), DIMENSION(:), INTENT(INOUT) :: gb, fb
!     !local variables
!     REAL(cp), DIMENSION( SIZE(D) ) :: tb
!
!     !checking the input parameters
!     CALL cov_square_mv_check(U, D, fb, gb, inv=.FALSE.)
!
!     tb = tb + MATMUL(gb, U)
!     gb = 0.0_cp
!     fb = fb + SQRT(D)*tb
!     tb = 0.0_cp
!   END SUBROUTINE cov_square_mvb_default
!
!   !> adjoint subroutine, used mathmatical formulation of the adjoint with linear operators
!   SUBROUTINE cov_square_mvb_2Fac(Ux, Dx, Uy, Dy, fb, gb)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy
!     REAL(cp), DIMENSION(:), INTENT(INOUT) :: gb, fb
!     !local variables
!     REAL(cp), DIMENSION(SIZE(Dx)) :: Dx05
!     REAL(cp), DIMENSION(SIZE(Dy)) :: Dy05
!     REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: tb
!     REAL(cp), DIMENSION( SIZE(fb) ) :: tmp
!
!     !checking the input parameters
!     CALL cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, fb, gb, inv=.FALSE.)
!     !initialization
!
!     Dx05 = SQRT(Dx)
!     Dy05 = SQRT(Dy)
!
!     CALL kron_matvec( Ux, Uy, gb, tb , trans=.TRUE. )!/!\optimised, knowing that tb is zero
!     gb = 0.0_cp
!     CALL kron_matvec( Dx05, Dy05, tb, tmp )! No need for transpose with diagonal square matrices
!     fb = fb + tmp
!     tb = 0.0_cp
!   END SUBROUTINE cov_square_mvb_2Fac
!
!   !> \brief multiplies a vector by the inverse of the square root of the covariance matrix, two physical dimensions problem
!   !! param[in] Ux matrix whose columns are the leading eigenvalues vector of the covariance matrix Bx in the direction x, size nx \times kx
!   !! param[in] Dx vector of leading eigenvalues in the direction x, size kx
!   !! param[in] Uy matrix whose columns are the leading eigenvalues vector of the covariance matrix By in the direction y, size ny \times ky
!   !! param[in] Dy vector of leading eigenvalues in the direction y, size ky
!   !! param[in] f input vector of size nx*ny (size of the discretization grid)
!   !! param[out] g output vector of size nx*ny
!   !! \details
!   !! computes g = B^-0.5 f
!   !! this routine assumes either :
!   !! - the x-leading and and row major vectorization or
!   !! - the y-leading and the column major vectorization
!   !<
!   SUBROUTINE cov_square_inv_mv_2Fac(Ux, Dx, Uy, Dy, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: Ux, Uy
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: Dx, Dy, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION(SIZE(Dx)) :: DxInv
!     REAL(cp), DIMENSION(SIZE(Dy)) :: DyInv
!     REAL(cp), DIMENSION( SIZE(Dx)*SIZE(Dy) ) :: t
!
!     !checking the input parameters
!     CALL cov_square_mv_check_2Fac(Ux, Dx, Uy, Dy, f, g, inv=.TRUE.)
!
!     DxInv = SQRT(1.0/Dx)
!     DyInv = SQRT(1.0/Dy)
!     CALL kron_matvec(Ux, Uy, f, t , trans=.TRUE.)
!     CALL kron_matvec(DxInv, DyInv, t, g)
!   END SUBROUTINE cov_square_inv_mv_2Fac
!
!   !> \brief multiplies a vector by the inverse of the square root of the covariance matrix given as its SVD
!   !! param[in] U matrix whose columns are the leading eigenvalues vector of the covariance matrix B, size n \times k
!   !! param[in] D vector of leading eigenvalues, size k
!   !! param[in] f input vector of size n (size of the discretization grid)
!   !! param[out] g output vector of size n
!   !! \details
!   !! computes g = B^-0.5 f
!   !<
!   SUBROUTINE cov_square_inv_mv_default(U, D, f, g)
!     REAL(cp), DIMENSION(:,:), INTENT(IN) :: U
!     REAL(cp), DIMENSION(:), INTENT(IN)  :: D, f
!     REAL(cp), DIMENSION(:), INTENT(OUT) :: g
!     !local variables
!     REAL(cp), DIMENSION( SIZE(D) ) :: t
!
!     !checking the input parameters
!     CALL cov_square_mv_check(U, D, f, g, inv=.TRUE.)
!
!     t = MATMUL(f, U)
!     g = t/SQRT(D)
!   END SUBROUTINE cov_square_inv_mv_default
!
!   ! ***************************************************
!   ! **************** debugging routines ***************
!   ! ***************************************************
!
!   !> \brief Check the conformity of the shape of matrices forming an SVD
!   !! the program stops in case of non conformity
!   !! \param[in] nU size of each singular vector
!   !! \param[in] kU number singular vectors
!   !! \param[in] kD1 number of singular values or on size of the diagonal matrix
!   !! \param[in] kD2 optional (default 1) other size of the diagonal matrix
!   !! kD1 x kD2 is the shape of the diagonal matrix of singular values. It can be stored as a full matrix or as a vector.
!   !<
!   SUBROUTINE SVD_check(nU, kU, kD1, kD2)
!     INTEGER, INTENT(IN) :: nU, kU, kD1
!     INTEGER, OPTIONAL, INTENT(IN) :: kD2
!     !local variables
!     INTEGER :: il_kD2
!
!     IF( PRESENT(kD2)  )THEN
!       il_kD2 = kD2
!     ELSE
!       il_kD2 = 1
!     END IF
!
!     IF( ( (kD1 == il_kD2).OR.( MIN(kD1, il_kD2) == 1 ) ) &
!       .AND.( MAX(kD1, il_kD2) == kU ).AND.( nU >= kU ) )THEN
!       !good configuration, nothing to do
!     ELSE
!       !bad configuration, message and stop the program
!       CALL debug( 'Expecting SVD UDU^t to have the following specifications', tag=dALLWAYS )
!       CALL debug( ' - U: number of rows greater or equal to the number of columns', tag=dALLWAYS )
!       CALL debug( ' - D: vector or square matrix', tag=dALLWAYS )
!       CALL debug( ' - MIN size of U equal to the MAX size of D', tag=dALLWAYS )
!       CALL debug( 'For debuging purpose, here are the shapes of U and D', tag=dALLWAYS )
!       CALL debug( (/nU, kU/), ' - SHAPE(U) = ', tag=dALLWAYS )
!       CALL debug( (/kD1, il_kD2/), ' - SHAPE(D) = ', tag=dALLWAYS )
!       CALL stop_program( 'Non consistant SVD' )
!     END IF
!   END SUBROUTINE SVD_check
! !end of privates procedures
! END MODULE covariance