! Copyright (C) 2026 Martin Köhler <koehlerm(AT)mpi-magdeburg.mpg.de>
!
! This file is part of qrupdate-ng.
!
! qrupdate 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 software; see the file COPYING.  If not, see
! <http://www.gnu.org/licenses/>.
!
!> \brief Tests input validation (qrupdate_xerror) for all qrupdate functions.
program test_qrupdate_validation
    use iso_fortran_env
    use qrupdate_error
    use test_state
    implicit none

    integer, parameter :: n = 5
    external sch1dn, dch1dn, cch1dn, zch1dn
    external schdex, dchdex, cchdex, zchdex
    external schinx, dchinx, cchinx, zchinx
    external schshx, dchshx, cchshx, zchshx
    external slu1up, dlu1up, clu1up, zlu1up
    external slup1up, dlup1up, clup1up, zlup1up
    external sqr1up, dqr1up, cqr1up, zqr1up
    external sqrdec, dqrdec, cqrdec, zqrdec
    external sqrder, dqrder, cqrder, zqrder
    external sqrinc, dqrinc, cqrinc, zqrinc
    external sqrinr, dqrinr, cqrinr, zqrinr
    external sqrshc, dqrshc, cqrshc, zqrshc
    external sqrot, dqrot, cqrot, zqrot
    external sqhqr, dqhqr, cqhqr, zqhqr
    external sqrqh, dqrqh, cqrqh, zqrqh
    external sgqvec, dgqvec, cgqvec, zgqvec

    integer :: info
    real(real32) :: R_s(n,n), u_s(n), w_s(n), rw_s(n)
    real(real64) :: R_d(n,n), u_d(n), w_d(n), rw_d(n)
    complex(real32) :: R_c(n,n), u_c(n), rw_c(n)
    complex(real32) :: R_z(n,n), u_z(n), rw_z(n)
    real(real32) :: Q_s(n,n), c_s(n-1), s_s(n-1), rhs_s(n)
    real(real64) :: Q_d(n,n), c_d(n-1), s_d(n-1), rhs_d(n)
    complex(real32) :: Q_c(n,n), Q_z(n,n), rhs_c(n), rhs_z(n)
    real(real32) :: c_c(n-1), c_z(n-1)
    complex(real32) :: s_c(n-1), s_z(n-1)
    real(real32) :: L_s(n,n), v_s(n), wv_s(n)
    real(real64) :: L_d(n,n), v_d(n), wv_d(n)
    complex(real32) :: L_c(n,n), v_c(n), wv_c(n), L_z(n,n), v_z(n), wv_z(n)
    real(real32) :: p_s(n), p2_s(n)
    real(real64) :: p_d(n), p2_d(n)
    complex(real32) :: p_c(n), p2_c(n), p_z(n), p2_z(n)
    real(real32) :: x_s(n), x_d(n), x_c(n), x_z(n)
    character(len=1) :: dir
    procedure(error_handler_if), pointer :: p_handler

    print *, 'Testing input validation for all qrupdate functions...'

    ! Initialize arrays to avoid undefined values
    R_s = 0; u_s = 0; w_s = 0; rw_s = 0
    R_d = 0; u_d = 0; w_d = 0; rw_d = 0
    R_c = 0; u_c = 0; rw_c = 0
    R_z = 0; u_z = 0; rw_z = 0
    Q_s = 0; c_s = 0; s_s = 0; rhs_s = 0
    Q_d = 0; c_d = 0; s_d = 0; rhs_d = 0
    Q_c = 0; c_c = 0; s_c = 0; rhs_c = 0
    Q_z = 0; c_z = 0; s_z = 0; rhs_z = 0
    L_s = 0; v_s = 0; wv_s = 0
    L_d = 0; v_d = 0; wv_d = 0
    L_c = 0; v_c = 0; wv_c = 0
    L_z = 0; v_z = 0; wv_z = 0
    p_s = 0; p2_s = 0; p_d = 0; p2_d = 0
    p_c = 0; p2_c = 0; p_z = 0; p2_z = 0
    x_s = 0; x_d = 0; x_c = 0; x_z = 0

    p_handler => pxerbla
    call qrupdate_set_error(p_handler)

    ! ====== Cholesky downdate ======
    ! sch1dn(n,R,ldr,u,w,info): validates n>=0, ldr>=n (negates info before xerror)
    call reset()
    call sch1dn(-1, R_s, n, u_s, w_s, info)
    call check_error('SCH1DN', 1)
    call reset()
    call sch1dn(n, R_s, n-1, u_s, w_s, info)
    call check_error('SCH1DN', 3)
    call reset()
    call dch1dn(-1, R_d, n, u_d, w_d, info)
    call check_error('DCH1DN', 1)
    call reset()
    call dch1dn(n, R_d, n-1, u_d, w_d, info)
    call check_error('DCH1DN', 3)
    call reset()
    call cch1dn(-1, R_c, n, u_c, rw_c, info)
    call check_error('CCH1DN', 1)
    call reset()
    call cch1dn(n, R_c, n-1, u_c, rw_c, info)
    call check_error('CCH1DN', 3)
    call reset()
    call zch1dn(-1, R_z, n, u_z, rw_z, info)
    call check_error('ZCH1DN', 1)
    call reset()
    call zch1dn(n, R_z, n-1, u_z, rw_z, info)
    call check_error('ZCH1DN', 3)

    ! ====== Cholesky delete ======
    ! schdex(n,R,ldr,j,w): validates n>=0, j in [1,n]
    call reset()
    call schdex(-1, R_s, n, 1, w_s)
    call check_error('SCHDEX', 1)
    call reset()
    call schdex(n, R_s, n, 0, w_s)
    call check_error('SCHDEX', 4)
    call reset()
    call dchdex(-1, R_d, n, 1, w_d)
    call check_error('DCHDEX', 1)
    call reset()
    call dchdex(n, R_d, n, 0, w_d)
    call check_error('DCHDEX', 4)
    call reset()
    call cchdex(-1, R_c, n, 1, rw_c)
    call check_error('CCHDEX', 1)
    call reset()
    call cchdex(n, R_c, n, 0, rw_c)
    call check_error('CCHDEX', 4)
    call reset()
    call zchdex(-1, R_z, n, 1, rw_z)
    call check_error('ZCHDEX', 1)
    call reset()
    call zchdex(n, R_z, n, 0, rw_z)
    call check_error('ZCHDEX', 4)

    ! ====== Cholesky insert ======
    ! schinx(n,R,ldr,j,u,w,info): validates n>=0, j in [1,n+1] (passes info directly)
    ! dchinx uses -info before xerror, others pass info directly
    call reset()
    call schinx(-1, R_s, n, 1, u_s, w_s, info)
    call check_error('SCHINX', -1)
    call reset()
    call schinx(n, R_s, n, 0, u_s, w_s, info)
    call check_error('SCHINX', -4)
    call reset()
    call dchinx(-1, R_d, n, 1, u_d, w_d, info)
    call check_error('DCHINX', 1)
    call reset()
    call dchinx(n, R_d, n, 0, u_d, w_d, info)
    call check_error('DCHINX', 4)
    call reset()
    call cchinx(-1, R_c, n, 1, u_c, rw_c, info)
    call check_error('CCHINX', -1)
    call reset()
    call cchinx(n, R_c, n, 0, u_c, rw_c, info)
    call check_error('CCHINX', -4)
    call reset()
    call zchinx(-1, R_z, n, 1, u_z, rw_z, info)
    call check_error('ZCHINX', -1)
    call reset()
    call zchinx(n, R_z, n, 0, u_z, rw_z, info)
    call check_error('ZCHINX', -4)

    ! ====== Cholesky shift ======
    ! schshx(n,R,ldr,i,j,w): validates n>=0, i in [1,n], j in [1,n]
    call reset()
    call schshx(-1, R_s, n, 1, 1, w_s)
    call check_error('SCHSHX', 1)
    call reset()
    call schshx(n, R_s, n, 0, 1, w_s)
    call check_error('SCHSHX', 4)
    call reset()
    call schshx(n, R_s, n, 1, 0, w_s)
    call check_error('SCHSHX', 5)
    call reset()
    call dchshx(-1, R_d, n, 1, 1, w_d)
    call check_error('DCHSHX', 1)
    call reset()
    call dchshx(n, R_d, n, 0, 1, w_d)
    call check_error('DCHSHX', 4)
    call reset()
    call dchshx(n, R_d, n, 1, 0, w_d)
    call check_error('DCHSHX', 5)
    call reset()
    call cchshx(-1, R_c, n, 1, 1, rw_s, rw_c)
    call check_error('CCHSHX', 1)
    call reset()
    call cchshx(n, R_c, n, 0, 1, rw_s, rw_c)
    call check_error('CCHSHX', 4)
    call reset()
    call cchshx(n, R_c, n, 1, 0, rw_s, rw_c)
    call check_error('CCHSHX', 5)
    call reset()
    call zchshx(-1, R_z, n, 1, 1, rw_d, rw_z)
    call check_error('ZCHSHX', 1)
    call reset()
    call zchshx(n, R_z, n, 0, 1, rw_d, rw_z)
    call check_error('ZCHSHX', 4)
    call reset()
    call zchshx(n, R_z, n, 1, 0, rw_d, rw_z)
    call check_error('ZCHSHX', 5)

    ! ====== LU rank-1 update ======
    ! slu1up(m,n,L,ldl,R,ldr,u,v): validates m>=0, n>=0, ldl>=m, ldr>=min(m,n)
    call reset()
    call slu1up(-1, n, L_s, n, R_s, n, rhs_s, v_s)
    call check_error('SLU1UP', 1)
    call reset()
    call slu1up(n, -1, L_s, n, R_s, n, rhs_s, v_s)
    call check_error('SLU1UP', 2)
    call reset()
    call slu1up(n, n, L_s, n-1, R_s, n, rhs_s, v_s)
    call check_error('SLU1UP', 4)
    call reset()
    call slu1up(n, n, L_s, n, R_s, n-1, rhs_s, v_s)
    call check_error('SLU1UP', 6)
    call reset()
    call dlu1up(-1, n, L_d, n, R_d, n, rhs_d, v_d)
    call check_error('DLU1UP', 1)
    call reset()
    call dlu1up(n, -1, L_d, n, R_d, n, rhs_d, v_d)
    call check_error('DLU1UP', 2)
    call reset()
    call dlu1up(n, n, L_d, n-1, R_d, n, rhs_d, v_d)
    call check_error('DLU1UP', 4)
    call reset()
    call dlu1up(n, n, L_d, n, R_d, n-1, rhs_d, v_d)
    call check_error('DLU1UP', 6)
    call reset()
    call clu1up(-1, n, L_c, n, R_c, n, rhs_c, v_c)
    call check_error('CLU1UP', 1)
    call reset()
    call clu1up(n, -1, L_c, n, R_c, n, rhs_c, v_c)
    call check_error('CLU1UP', 2)
    call reset()
    call clu1up(n, n, L_c, n-1, R_c, n, rhs_c, v_c)
    call check_error('CLU1UP', 4)
    call reset()
    call clu1up(n, n, L_c, n, R_c, n-1, rhs_c, v_c)
    call check_error('CLU1UP', 6)
    call reset()
    call zlu1up(-1, n, L_z, n, R_z, n, rhs_z, v_z)
    call check_error('ZLU1UP', 1)
    call reset()
    call zlu1up(n, -1, L_z, n, R_z, n, rhs_z, v_z)
    call check_error('ZLU1UP', 2)
    call reset()
    call zlu1up(n, n, L_z, n-1, R_z, n, rhs_z, v_z)
    call check_error('ZLU1UP', 4)
    call reset()
    call zlu1up(n, n, L_z, n, R_z, n-1, rhs_z, v_z)
    call check_error('ZLU1UP', 6)

    ! ====== LU+perm rank-1 update ======
    ! slup1up(m,n,L,ldl,R,ldr,p,u,v,w): validates m>=0, n>=0, ldl>=m, ldr>=min(m,n)
    call reset()
    call slup1up(-1, n, L_s, n, R_s, n, p_s, rhs_s, v_s, wv_s)
    call check_error('SLUP1UP', 1)
    call reset()
    call slup1up(n, -1, L_s, n, R_s, n, p_s, rhs_s, v_s, wv_s)
    call check_error('SLUP1UP', 2)
    call reset()
    call slup1up(n, n, L_s, n-1, R_s, n, p_s, rhs_s, v_s, wv_s)
    call check_error('SLUP1UP', 4)
    call reset()
    call slup1up(n, n, L_s, n, R_s, n-1, p_s, rhs_s, v_s, wv_s)
    call check_error('SLUP1UP', 6)
    call reset()
    call dlup1up(-1, n, L_d, n, R_d, n, p_d, rhs_d, v_d, wv_d)
    call check_error('DLUP1UP', 1)
    call reset()
    call dlup1up(n, -1, L_d, n, R_d, n, p_d, rhs_d, v_d, wv_d)
    call check_error('DLUP1UP', 2)
    call reset()
    call dlup1up(n, n, L_d, n-1, R_d, n, p_d, rhs_d, v_d, wv_d)
    call check_error('DLUP1UP', 4)
    call reset()
    call dlup1up(n, n, L_d, n, R_d, n-1, p_d, rhs_d, v_d, wv_d)
    call check_error('DLUP1UP', 6)
    call reset()
    call clup1up(-1, n, L_c, n, R_c, n, p_c, rhs_c, v_c, wv_s)
    call check_error('CLUP1UP', 1)
    call reset()
    call clup1up(n, -1, L_c, n, R_c, n, p_c, rhs_c, v_c, wv_s)
    call check_error('CLUP1UP', 2)
    call reset()
    call clup1up(n, n, L_c, n-1, R_c, n, p_c, rhs_c, v_c, wv_s)
    call check_error('CLUP1UP', 4)
    call reset()
    call clup1up(n, n, L_c, n, R_c, n-1, p_c, rhs_c, v_c, wv_s)
    call check_error('CLUP1UP', 6)
    call reset()
    call zlup1up(-1, n, L_z, n, R_z, n, p_z, rhs_z, v_z, wv_d)
    call check_error('ZLUP1UP', 1)
    call reset()
    call zlup1up(n, -1, L_z, n, R_z, n, p_z, rhs_z, v_z, wv_d)
    call check_error('ZLUP1UP', 2)
    call reset()
    call zlup1up(n, n, L_z, n-1, R_z, n, p_z, rhs_z, v_z, wv_d)
    call check_error('ZLUP1UP', 4)
    call reset()
    call zlup1up(n, n, L_z, n, R_z, n-1, p_z, rhs_z, v_z, wv_d)
    call check_error('ZLUP1UP', 6)

    ! ====== QR rank-1 update ======
    ! sqr1up(m,n,k,Q,ldq,R,ldr,u,v,w): validates m>=0, n>=0, k valid, ldq>=m, ldr>=k
    call reset()
    call sqr1up(-1, n, n, Q_s, n, R_s, n, rhs_s, v_s, wv_s)
    call check_error('SQR1UP', 1)
    call reset()
    call sqr1up(n, -1, n, Q_s, n, R_s, n, rhs_s, v_s, wv_s)
    call check_error('SQR1UP', 2)
    call reset()
    call sqr1up(n, n, 99, Q_s, n, R_s, n, rhs_s, v_s, wv_s)
    call check_error('SQR1UP', 3)
    call reset()
    call sqr1up(n, n, n, Q_s, n-1, R_s, n, rhs_s, v_s, wv_s)
    call check_error('SQR1UP', 5)
    call reset()
    call sqr1up(n, n, n, Q_s, n, R_s, n-1, rhs_s, v_s, wv_s)
    call check_error('SQR1UP', 7)
    call reset()
    call dqr1up(-1, n, n, Q_d, n, R_d, n, rhs_d, v_d, wv_d)
    call check_error('DQR1UP', 1)
    call reset()
    call dqr1up(n, -1, n, Q_d, n, R_d, n, rhs_d, v_d, wv_d)
    call check_error('DQR1UP', 2)
    call reset()
    call dqr1up(n, n, 99, Q_d, n, R_d, n, rhs_d, v_d, wv_d)
    call check_error('DQR1UP', 3)
    call reset()
    call dqr1up(n, n, n, Q_d, n-1, R_d, n, rhs_d, v_d, wv_d)
    call check_error('DQR1UP', 5)
    call reset()
    call dqr1up(n, n, n, Q_d, n, R_d, n-1, rhs_d, v_d, wv_d)
    call check_error('DQR1UP', 7)
    call reset()
    call cqr1up(-1, n, n, Q_c, n, R_c, n, rhs_c, v_c, wv_s)
    call check_error('CQR1UP', 1)
    call reset()
    call cqr1up(n, -1, n, Q_c, n, R_c, n, rhs_c, v_c, wv_s)
    call check_error('CQR1UP', 2)
    call reset()
    call cqr1up(n, n, 99, Q_c, n, R_c, n, rhs_c, v_c, wv_s)
    call check_error('CQR1UP', 3)
    call reset()
    call cqr1up(n, n, n, Q_c, n-1, R_c, n, rhs_c, v_c, wv_s)
    call check_error('CQR1UP', 5)
    call reset()
    call cqr1up(n, n, n, Q_c, n, R_c, n-1, rhs_c, v_c, wv_s)
    call check_error('CQR1UP', 7)
    call reset()
    call zqr1up(-1, n, n, Q_z, n, R_z, n, rhs_z, v_z, wv_d)
    call check_error('ZQR1UP', 1)
    call reset()
    call zqr1up(n, -1, n, Q_z, n, R_z, n, rhs_z, v_z, wv_d)
    call check_error('ZQR1UP', 2)
    call reset()
    call zqr1up(n, n, 99, Q_z, n, R_z, n, rhs_z, v_z, wv_d)
    call check_error('ZQR1UP', 3)
    call reset()
    call zqr1up(n, n, n, Q_z, n-1, R_z, n, rhs_z, v_z, wv_d)
    call check_error('ZQR1UP', 5)
    call reset()
    call zqr1up(n, n, n, Q_z, n, R_z, n-1, rhs_z, v_z, wv_d)
    call check_error('ZQR1UP', 7)

    ! ====== QR delete (column) ======
    ! sqrdec(m,n,k,Q,ldq,R,ldr,j,w): validates m>=0, n>=0, k valid, ldq>=m, ldr>=k, j in [1,n+1]
    call reset()
    call sqrdec(-1, n, n, Q_s, n, R_s, n, 1, w_s)
    call check_error('SQRDEC', 1)
    call reset()
    call sqrdec(n, -1, n, Q_s, n, R_s, n, 1, w_s)
    call check_error('SQRDEC', 2)
    call reset()
    call sqrdec(n, n, 99, Q_s, n, R_s, n, 1, w_s)
    call check_error('SQRDEC', 3)
    call reset()
    call sqrdec(n, n, n, Q_s, n-1, R_s, n, 1, w_s)
    call check_error('SQRDEC', 5)
    call reset()
    call sqrdec(n, n, n, Q_s, n, R_s, n-1, 1, w_s)
    call check_error('SQRDEC', 7)
    call reset()
    call sqrdec(n, n, n, Q_s, n, R_s, n, 0, w_s)
    call check_error('SQRDEC', 8)
    call reset()
    call dqrdec(-1, n, n, Q_d, n, R_d, n, 1, w_d)
    call check_error('DQRDEC', 1)
    call reset()
    call dqrdec(n, -1, n, Q_d, n, R_d, n, 1, w_d)
    call check_error('DQRDEC', 2)
    call reset()
    call dqrdec(n, n, 99, Q_d, n, R_d, n, 1, w_d)
    call check_error('DQRDEC', 3)
    call reset()
    call dqrdec(n, n, n, Q_d, n-1, R_d, n, 1, w_d)
    call check_error('DQRDEC', 5)
    call reset()
    call dqrdec(n, n, n, Q_d, n, R_d, n-1, 1, w_d)
    call check_error('DQRDEC', 7)
    call reset()
    call dqrdec(n, n, n, Q_d, n, R_d, n, 0, w_d)
    call check_error('DQRDEC', 8)
    call reset()
    call cqrdec(-1, n, n, Q_c, n, R_c, n, 1, rw_c)
    call check_error('CQRDEC', 1)
    call reset()
    call cqrdec(n, -1, n, Q_c, n, R_c, n, 1, rw_c)
    call check_error('CQRDEC', 2)
    call reset()
    call cqrdec(n, n, 99, Q_c, n, R_c, n, 1, rw_c)
    call check_error('CQRDEC', 3)
    call reset()
    call cqrdec(n, n, n, Q_c, n-1, R_c, n, 1, rw_c)
    call check_error('CQRDEC', 5)
    call reset()
    call cqrdec(n, n, n, Q_c, n, R_c, n-1, 1, rw_c)
    call check_error('CQRDEC', 7)
    call reset()
    call cqrdec(n, n, n, Q_c, n, R_c, n, 0, rw_c)
    call check_error('CQRDEC', 8)
    call reset()
    call zqrdec(-1, n, n, Q_z, n, R_z, n, 1, rw_z)
    call check_error('ZQRDEC', 1)
    call reset()
    call zqrdec(n, -1, n, Q_z, n, R_z, n, 1, rw_z)
    call check_error('ZQRDEC', 2)
    call reset()
    call zqrdec(n, n, 99, Q_z, n, R_z, n, 1, rw_z)
    call check_error('ZQRDEC', 3)
    call reset()
    call zqrdec(n, n, n, Q_z, n-1, R_z, n, 1, rw_z)
    call check_error('ZQRDEC', 5)
    call reset()
    call zqrdec(n, n, n, Q_z, n, R_z, n-1, 1, rw_z)
    call check_error('ZQRDEC', 7)
    call reset()
    call zqrdec(n, n, n, Q_z, n, R_z, n, 0, rw_z)
    call check_error('ZQRDEC', 8)

    ! ====== QR delete (row) ======
    ! sqrder(m,n,Q,ldq,R,ldr,j,w): validates m>=1, j in [1,m]
    call reset()
    call sqrder(0, n, Q_s, n, R_s, n, 1, w_s)
    call check_error('SQRDER', 1)
    call reset()
    call sqrder(n, n, Q_s, n, R_s, n, 0, w_s)
    call check_error('SQRDER', 7)
    call reset()
    call dqrder(0, n, Q_d, n, R_d, n, 1, w_d)
    call check_error('DQRDER', 1)
    call reset()
    call dqrder(n, n, Q_d, n, R_d, n, 0, w_d)
    call check_error('DQRDER', 7)
    call reset()
    call cqrder(0, n, Q_c, n, R_c, n, 1, rw_c)
    call check_error('CQRDER', 1)
    call reset()
    call cqrder(n, n, Q_c, n, R_c, n, 0, rw_c)
    call check_error('CQRDER', 7)
    call reset()
    call zqrder(0, n, Q_z, n, R_z, n, 1, rw_z)
    call check_error('ZQRDER', 1)
    call reset()
    call zqrder(n, n, Q_z, n, R_z, n, 0, rw_z)
    call check_error('ZQRDER', 7)

    ! ====== QR increment (column) ======
    ! sqrinc(m,n,k,Q,ldq,R,ldr,j,x,w): validates m>=0, n>=0, k valid, ldq>=m, ldr>=min(m,k+1), j in [1,n+1]
    call reset()
    call sqrinc(-1, n, n, Q_s, n, R_s, n, 1, x_s, w_s)
    call check_error('SQRINC', 1)
    call reset()
    call sqrinc(n, -1, n, Q_s, n, R_s, n, 1, x_s, w_s)
    call check_error('SQRINC', 2)
    call reset()
    call sqrinc(n, n, 99, Q_s, n, R_s, n, 1, x_s, w_s)
    call check_error('SQRINC', 3)
    call reset()
    call sqrinc(n, n, n, Q_s, n-1, R_s, n, 1, x_s, w_s)
    call check_error('SQRINC', 5)
    call reset()
    call sqrinc(n, n, n, Q_s, n, R_s, 0, 1, x_s, w_s)
    call check_error('SQRINC', 7)
    call reset()
    call sqrinc(n, n, n, Q_s, n, R_s, n, 0, x_s, w_s)
    call check_error('SQRINC', 8)
    call reset()
    call dqrinc(-1, n, n, Q_d, n, R_d, n, 1, x_d, w_d)
    call check_error('DQRINC', 1)
    call reset()
    call dqrinc(n, -1, n, Q_d, n, R_d, n, 1, x_d, w_d)
    call check_error('DQRINC', 2)
    call reset()
    call dqrinc(n, n, 99, Q_d, n, R_d, n, 1, x_d, w_d)
    call check_error('DQRINC', 3)
    call reset()
    call dqrinc(n, n, n, Q_d, n-1, R_d, n, 1, x_d, w_d)
    call check_error('DQRINC', 5)
    call reset()
    call dqrinc(n, n, n, Q_d, n, R_d, 0, 1, x_d, w_d)
    call check_error('DQRINC', 7)
    call reset()
    call dqrinc(n, n, n, Q_d, n, R_d, n, 0, x_d, w_d)
    call check_error('DQRINC', 8)
    call reset()
    call cqrinc(-1, n, n, Q_c, n, R_c, n, 1, x_c, rw_c)
    call check_error('CQRINC', 1)
    call reset()
    call cqrinc(n, -1, n, Q_c, n, R_c, n, 1, x_c, rw_c)
    call check_error('CQRINC', 2)
    call reset()
    call cqrinc(n, n, 99, Q_c, n, R_c, n, 1, x_c, rw_c)
    call check_error('CQRINC', 3)
    call reset()
    call cqrinc(n, n, n, Q_c, n-1, R_c, n, 1, x_c, rw_c)
    call check_error('CQRINC', 5)
    call reset()
    call cqrinc(n, n, n, Q_c, n, R_c, 0, 1, x_c, rw_c)
    call check_error('CQRINC', 7)
    call reset()
    call cqrinc(n, n, n, Q_c, n, R_c, n, 0, x_c, rw_c)
    call check_error('CQRINC', 8)
    call reset()
    call zqrinc(-1, n, n, Q_z, n, R_z, n, 1, x_z, rw_z)
    call check_error('ZQRINC', 1)
    call reset()
    call zqrinc(n, -1, n, Q_z, n, R_z, n, 1, x_z, rw_z)
    call check_error('ZQRINC', 2)
    call reset()
    call zqrinc(n, n, 99, Q_z, n, R_z, n, 1, x_z, rw_z)
    call check_error('ZQRINC', 3)
    call reset()
    call zqrinc(n, n, n, Q_z, n-1, R_z, n, 1, x_z, rw_z)
    call check_error('ZQRINC', 5)
    call reset()
    call zqrinc(n, n, n, Q_z, n, R_z, 0, 1, x_z, rw_z)
    call check_error('ZQRINC', 7)
    call reset()
    call zqrinc(n, n, n, Q_z, n, R_z, n, 0, x_z, rw_z)
    call check_error('ZQRINC', 8)

    ! ====== QR inner (row) ======
    ! sqrinr(m,n,Q,ldq,R,ldr,j,x,w): validates n>=0, j in [1,m+1]
    call reset()
    call sqrinr(n, -1, Q_s, n, R_s, n, 1, x_s, w_s)
    call check_error('SQRINR', 2)
    call reset()
    call sqrinr(n, n, Q_s, n, R_s, n, 0, x_s, w_s)
    call check_error('SQRINR', 7)
    call reset()
    call dqrinr(n, -1, Q_d, n, R_d, n, 1, x_d, w_d)
    call check_error('DQRINR', 2)
    call reset()
    call dqrinr(n, n, Q_d, n, R_d, n, 0, x_d, w_d)
    call check_error('DQRINR', 7)
    call reset()
    call cqrinr(n, -1, Q_c, n, R_c, n, 1, x_c, rw_c)
    call check_error('CQRINR', 2)
    call reset()
    call cqrinr(n, n, Q_c, n, R_c, n, 0, x_c, rw_c)
    call check_error('CQRINR', 7)
    call reset()
    call zqrinr(n, -1, Q_z, n, R_z, n, 1, x_z, rw_z)
    call check_error('ZQRINR', 2)
    call reset()
    call zqrinr(n, n, Q_z, n, R_z, n, 0, x_z, rw_z)
    call check_error('ZQRINR', 7)

    ! ====== QR shift ======
    ! sqrshc(m,n,k,Q,ldq,R,ldr,i,j,w): validates m>=0, n>=0, k valid, i in [1,n], j in [1,n]
    call reset()
    call sqrshc(-1, n, n, Q_s, n, R_s, n, 1, 1, w_s)
    call check_error('SQRSHC', 1)
    call reset()
    call sqrshc(n, -1, n, Q_s, n, R_s, n, 1, 1, w_s)
    call check_error('SQRSHC', 2)
    call reset()
    call sqrshc(n, n, 99, Q_s, n, R_s, n, 1, 1, w_s)
    call check_error('SQRSHC', 3)
    call reset()
    call sqrshc(n, n, n, Q_s, n, R_s, n, 0, 1, w_s)
    call check_error('SQRSHC', 6)
    call reset()
    call sqrshc(n, n, n, Q_s, n, R_s, n, 1, 0, w_s)
    call check_error('SQRSHC', 7)
    call reset()
    call dqrshc(-1, n, n, Q_d, n, R_d, n, 1, 1, w_d)
    call check_error('DQRSHC', 1)
    call reset()
    call dqrshc(n, -1, n, Q_d, n, R_d, n, 1, 1, w_d)
    call check_error('DQRSHC', 2)
    call reset()
    call dqrshc(n, n, 99, Q_d, n, R_d, n, 1, 1, w_d)
    call check_error('DQRSHC', 3)
    call reset()
    call dqrshc(n, n, n, Q_d, n, R_d, n, 0, 1, w_d)
    call check_error('DQRSHC', 6)
    call reset()
    call dqrshc(n, n, n, Q_d, n, R_d, n, 1, 0, w_d)
    call check_error('DQRSHC', 7)
    call reset()
    call cqrshc(-1, n, n, Q_c, n, R_c, n, 1, 1, rw_s)
    call check_error('CQRSHC', 1)
    call reset()
    call cqrshc(n, -1, n, Q_c, n, R_c, n, 1, 1, rw_s)
    call check_error('CQRSHC', 2)
    call reset()
    call cqrshc(n, n, 99, Q_c, n, R_c, n, 1, 1, rw_s)
    call check_error('CQRSHC', 3)
    call reset()
    call cqrshc(n, n, n, Q_c, n, R_c, n, 0, 1, rw_s)
    call check_error('CQRSHC', 6)
    call reset()
    call cqrshc(n, n, n, Q_c, n, R_c, n, 1, 0, rw_s)
    call check_error('CQRSHC', 7)
    call reset()
    call zqrshc(-1, n, n, Q_z, n, R_z, n, 1, 1, rw_d)
    call check_error('ZQRSHC', 1)
    call reset()
    call zqrshc(n, -1, n, Q_z, n, R_z, n, 1, 1, rw_d)
    call check_error('ZQRSHC', 2)
    call reset()
    call zqrshc(n, n, 99, Q_z, n, R_z, n, 1, 1, rw_d)
    call check_error('ZQRSHC', 3)
    call reset()
    call zqrshc(n, n, n, Q_z, n, R_z, n, 0, 1, rw_d)
    call check_error('ZQRSHC', 6)
    call reset()
    call zqrshc(n, n, n, Q_z, n, R_z, n, 1, 0, rw_d)
    call check_error('ZQRSHC', 7)

    ! ====== Givens rotations ======
    ! sqrot(dir,m,n,Q,ldq,c,s): validates dir in {F,B}, m>=0, n>=0, ldq>=m
    call reset()
    dir = 'X'
    call sqrot(dir, n, n, Q_s, n, c_s, s_s)
    call check_error('SQROT', 1)
    call reset()
    dir = 'F'
    call sqrot(dir, -1, n, Q_s, n, c_s, s_s)
    call check_error('SQROT', 2)
    call reset()
    call sqrot(dir, n, -1, Q_s, n, c_s, s_s)
    call check_error('SQROT', 3)
    call reset()
    call sqrot(dir, n, n, Q_s, n-1, c_s, s_s)
    call check_error('SQROT', 5)
    call reset()
    dir = 'X'
    call dqrot(dir, n, n, Q_d, n, c_d, s_d)
    call check_error('DQROT', 1)
    call reset()
    dir = 'F'
    call dqrot(dir, -1, n, Q_d, n, c_d, s_d)
    call check_error('DQROT', 2)
    call reset()
    call dqrot(dir, n, -1, Q_d, n, c_d, s_d)
    call check_error('DQROT', 3)
    call reset()
    call dqrot(dir, n, n, Q_d, n-1, c_d, s_d)
    call check_error('DQROT', 5)
    call reset()
    dir = 'X'
    call cqrot(dir, n, n, Q_c, n, c_c, s_c)
    call check_error('CQROT', 1)
    call reset()
    dir = 'F'
    call cqrot(dir, -1, n, Q_c, n, c_c, s_c)
    call check_error('CQROT', 2)
    call reset()
    call cqrot(dir, n, -1, Q_c, n, c_c, s_c)
    call check_error('CQROT', 3)
    call reset()
    call cqrot(dir, n, n, Q_c, n-1, c_c, s_c)
    call check_error('CQROT', 5)
    call reset()
    dir = 'X'
    call zqrot(dir, n, n, Q_z, n, c_z, s_z)
    call check_error('ZQROT', 1)
    call reset()
    dir = 'F'
    call zqrot(dir, -1, n, Q_z, n, c_z, s_z)
    call check_error('ZQROT', 2)
    call reset()
    call zqrot(dir, n, -1, Q_z, n, c_z, s_z)
    call check_error('ZQROT', 3)
    call reset()
    call zqrot(dir, n, n, Q_z, n-1, c_z, s_z)
    call check_error('ZQROT', 5)

    ! ====== QH factor ======
    ! sqhqr(m,n,R,ldr,c,s): validates m>=0, n>=0, ldr>=m
    call reset()
    call sqhqr(-1, n, R_s, n, c_s, s_s)
    call check_error('SQHQR', 1)
    call reset()
    call sqhqr(n, -1, R_s, n, c_s, s_s)
    call check_error('SQHQR', 2)
    call reset()
    call sqhqr(n, n, R_s, n-1, c_s, s_s)
    call check_error('SQHQR', 4)
    call reset()
    call dqhqr(-1, n, R_d, n, c_d, s_d)
    call check_error('DQHQR', 1)
    call reset()
    call dqhqr(n, -1, R_d, n, c_d, s_d)
    call check_error('DQHQR', 2)
    call reset()
    call dqhqr(n, n, R_d, n-1, c_d, s_d)
    call check_error('DQHQR', 4)
    call reset()
    call cqhqr(-1, n, R_c, n, c_c, s_c)
    call check_error('CQHQR', 1)
    call reset()
    call cqhqr(n, -1, R_c, n, c_c, s_c)
    call check_error('CQHQR', 2)
    call reset()
    call cqhqr(n, n, R_c, n-1, c_c, s_c)
    call check_error('CQHQR', 4)
    call reset()
    call zqhqr(-1, n, R_z, n, c_z, s_z)
    call check_error('ZQHQR', 1)
    call reset()
    call zqhqr(n, -1, R_z, n, c_z, s_z)
    call check_error('ZQHQR', 2)
    call reset()
    call zqhqr(n, n, R_z, n-1, c_z, s_z)
    call check_error('ZQHQR', 4)

    ! ====== QR-QH ======
    ! sqrqh(m,n,R,ldr,c,s): validates m>=0, n>=0, ldr>=m
    call reset()
    call sqrqh(-1, n, R_s, n, c_s, s_s)
    call check_error('SQRQH', 1)
    call reset()
    call sqrqh(n, -1, R_s, n, c_s, s_s)
    call check_error('SQRQH', 2)
    call reset()
    call sqrqh(n, n, R_s, n-1, c_s, s_s)
    call check_error('SQRQH', 4)
    call reset()
    call dqrqh(-1, n, R_d, n, c_d, s_d)
    call check_error('DQRQH', 1)
    call reset()
    call dqrqh(n, -1, R_d, n, c_d, s_d)
    call check_error('DQRQH', 2)
    call reset()
    call dqrqh(n, n, R_d, n-1, c_d, s_d)
    call check_error('DQRQH', 4)
    call reset()
    call cqrqh(-1, n, R_c, n, c_c, s_c)
    call check_error('CQRQH', 1)
    call reset()
    call cqrqh(n, -1, R_c, n, c_c, s_c)
    call check_error('CQRQH', 2)
    call reset()
    call cqrqh(n, n, R_c, n-1, c_c, s_c)
    call check_error('CQRQH', 4)
    call reset()
    call zqrqh(-1, n, R_z, n, c_z, s_z)
    call check_error('ZQRQH', 1)
    call reset()
    call zqrqh(n, -1, R_z, n, c_z, s_z)
    call check_error('ZQRQH', 2)
    call reset()
    call zqrqh(n, n, R_z, n-1, c_z, s_z)
    call check_error('ZQRQH', 4)

    ! ====== Givens Q vector ======
    ! sgqvec(m,n,Q,ldq,u): validates m>=0, n>=0, ldq>=m
    call reset()
    call sgqvec(-1, n, Q_s, n, rhs_s)
    call check_error('SGQVEC', 1)
    call reset()
    call sgqvec(n, -1, Q_s, n, rhs_s)
    call check_error('SGQVEC', 2)
    call reset()
    call sgqvec(n, n, Q_s, n-1, rhs_s)
    call check_error('SGQVEC', 4)
    call reset()
    call dgqvec(-1, n, Q_d, n, rhs_d)
    call check_error('DGQVEC', 1)
    call reset()
    call dgqvec(n, -1, Q_d, n, rhs_d)
    call check_error('DGQVEC', 2)
    call reset()
    call dgqvec(n, n, Q_d, n-1, rhs_d)
    call check_error('DGQVEC', 4)
    call reset()
    call cgqvec(-1, n, Q_c, n, rhs_c)
    call check_error('CGQVEC', 1)
    call reset()
    call cgqvec(n, -1, Q_c, n, rhs_c)
    call check_error('CGQVEC', 2)
    call reset()
    call cgqvec(n, n, Q_c, n-1, rhs_c)
    call check_error('CGQVEC', 4)
    call reset()
    call zgqvec(-1, n, Q_z, n, rhs_z)
    call check_error('ZGQVEC', 1)
    call reset()
    call zgqvec(n, -1, Q_z, n, rhs_z)
    call check_error('ZGQVEC', 2)
    call reset()
    call zgqvec(n, n, Q_z, n-1, rhs_z)
    call check_error('ZGQVEC', 4)

    print *, 'All validation tests passed!'

contains

    subroutine check_error(expected_name, expected_code)
        character(len=*), intent(in) :: expected_name
        integer, intent(in) :: expected_code
        if (.not. xerbla_called) then
            print '(A)', 'FAIL: xerbla not called for '//expected_name
            stop 1
        end if
        if (last_srname /= expected_name) then
            print '(A,A,A,I0)', 'FAIL: expected srname "', expected_name, '" but got "', trim(last_srname), '"'
            stop 1
        end if
        if (last_info /= expected_code) then
            print '(A,A,A,I0,A,I0)', 'FAIL: expected info=', expected_name, ' but got info=', last_info
            stop 1
        end if
        print '(A,A,A,I0)', 'PASS: ', trim(expected_name), ' info=', last_info
    end subroutine check_error

    subroutine pxerbla(srname, info, aux)
        use test_state
        implicit none
        character(len=*), intent(in) :: srname
        integer, intent(in) :: info
        class(*), intent(in), optional :: aux
        xerbla_called = .true.
        last_srname = trim(srname)
        last_info = info
    end subroutine pxerbla
end program test_qrupdate_validation


