program test_submatrix
  use mod_orrb
  implicit none

  character(len=*), parameter :: fmt="(A45, 'error: ',ES8.2, ', ', A10)"
  character(len=45) :: test_name

  integer(kind=int32) :: na, lbw, ubw, la, k0, k1, j0, j1
  type(error_info) :: error
  real(kind=dp), parameter :: tol=1e-15, c=7.0
  !
  real(kind=dp), dimension(:,:), allocatable :: a_d, a0_d
  complex(kind=dp), dimension(:,:), allocatable :: a_z, a0_z

  type(d_ub), allocatable :: ub_d, ub0_d
  type(d_bv), allocatable :: bv_d, bv0_d
  type(d_bt), allocatable :: bt_d, bt0_d
  type(d_wb), allocatable :: wb_d, wb0_d
  type(d_ubt), allocatable :: ubt_d, ubt0_d
  type(d_wbv), allocatable :: wbv_d, wbv0_d

  type(z_ub), allocatable :: ub_z, ub0_z
  type(z_bv), allocatable :: bv_z, bv0_z
  type(z_bt), allocatable :: bt_z, bt0_z
  type(z_wb), allocatable :: wb_z, wb0_z
  type(z_ubt), allocatable :: ubt_z, ubt0_z
  type(z_wbv), allocatable :: wbv_z, wbv0_z

  call initialize_errors
  print *
  print *, "--------------------------------"
  print *
  print *, "Tests of Real Structured Leading and Trailing Submatrices"
  print *

  na=50; la=10; lbw=3; ubw=4
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  ub0_d  = leading(ub_d,la,error=error)
  a0_d=general(ub0_d,error)
  test_name = "Real UB Submatrix na=50, la=10:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  ub0_d  = leading(ub_d,la,error=error)
  a0_d=general(ub0_d,error)
  test_name = "Real UB Submatrix na=50, la=50:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  ub0_d  = leading(ub_d,la,error=error)
  a0_d=general(ub0_d,error)
  test_name = "Real UB Submatrix na=50, la=1:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  ub0_d  = leading(ub_d,la,error=error)
  a0_d=general(ub0_d,error)
  test_name = "Real UB Submatrix na=50, la=2:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  bv0_d  = trailing(bv_d,la,error=error)
  a0_d=general(bv0_d,error)
  test_name = "Real BV Submatrix na=50, la=10:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  bv0_d  = trailing(bv_d,la,error=error)
  a0_d=general(bv0_d,error)
  test_name = "Real BV Submatrix na=50, la=50:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  bv0_d  = trailing(bv_d,la,error=error)
  a0_d=general(bv0_d,error)
  test_name = "Real BV Submatrix na=50, la=1:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  bv0_d  = trailing(bv_d,la,error=error)
  a0_d=general(bv0_d,error)
  test_name = "Real BV Submatrix na=50, la=2:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  bt0_d  = leading(bt_d,la,error=error)
  a0_d=general(bt0_d,error)
  test_name = "Real BT Submatrix na=50, la=10:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  bt0_d  = leading(bt_d,la,error=error)
  a0_d=general(bt0_d,error)
  test_name = "Real BT Submatrix na=50, la=50:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  bt0_d  = leading(bt_d,la,error=error)
  a0_d=general(bt0_d,error)
  test_name = "Real BT Submatrix na=50, la=1:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  bt0_d  = leading(bt_d,la,error=error)
  a0_d=general(bt0_d,error)
  test_name = "Real BT Submatrix na=50, la=2:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  wb0_d  = trailing(wb_d,la,error=error)
  a0_d=general(wb0_d,error)
  test_name = "Real WB Submatrix na=50, la=10:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  wb0_d  = trailing(wb_d,la,error=error)
  a0_d=general(wb0_d,error)
  test_name = "Real WB Submatrix na=50, la=50:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  wb0_d  = trailing(wb_d,la,error=error)
  a0_d=general(wb0_d,error)
  test_name = "Real WB Submatrix na=50, la=1:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  wb0_d  = trailing(wb_d,la,error=error)
  a0_d=general(wb0_d,error)
  test_name = "Real WB Submatrix na=50, la=2:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  ubt_d=d_random_ubt(na,lbw,ubw,error=error)
  a_d = general(ubt_d,error)
  ubt0_d  = leading(ubt_d,la,error=error)
  a0_d=general(ubt0_d,error)
  test_name = "Real UBT Submatrix na=50, la=10:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  ubt_d=d_random_ubt(na,lbw,ubw,error=error)
  a_d = general(ubt_d,error)
  ubt0_d  = leading(ubt_d,la,error=error)
  a0_d=general(ubt0_d,error)
  test_name = "Real UBT Submatrix na=50, la=50:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  ubt_d=d_random_ubt(na,lbw,ubw,error=error)
  a_d = general(ubt_d,error)
  ubt0_d  = leading(ubt_d,la,error=error)
  a0_d=general(ubt0_d,error)
  test_name = "Real UBT Submatrix na=50, la=1:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  ubt_d=d_random_ubt(na,lbw,ubw,error=error)
  a_d = general(ubt_d,error)
  ubt0_d  = leading(ubt_d,la,error=error)
  a0_d=general(ubt0_d,error)
  test_name = "Real UBT Submatrix na=50, la=2:"
  call d_output_result(test_name,a_d(1:la,1:la),a0_d,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  wbv_d=d_random_wbv(na,lbw,ubw,error=error)
  a_d = general(wbv_d,error)
  wbv0_d  = trailing(wbv_d,la,error=error)
  a0_d=general(wbv0_d,error)
  test_name = "Real WBV Submatrix na=50, la=10:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  wbv_d=d_random_wbv(na,lbw,ubw,error=error)
  a_d = general(wbv_d,error)
  wbv0_d  = trailing(wbv_d,la,error=error)
  a0_d=general(wbv0_d,error)
  test_name = "Real WBV Submatrix na=50, la=50:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  wbv_d=d_random_wbv(na,lbw,ubw,error=error)
  a_d = general(wbv_d,error)
  wbv0_d  = trailing(wbv_d,la,error=error)
  a0_d=general(wbv0_d,error)
  test_name = "Real WBV Submatrix na=50, la=1:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  wbv_d=d_random_wbv(na,lbw,ubw,error=error)
  a_d = general(wbv_d,error)
  wbv0_d  = trailing(wbv_d,la,error=error)
  a0_d=general(wbv0_d,error)
  test_name = "Real WBV Submatrix na=50, la=2:"
  call d_output_result(test_name,a_d(na-la+1:na,na-la+1:na),a0_d,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Tests of Complex Structured Leading and Trailing Submatrices"
  print *

  na=50; la=10; lbw=3; ubw=4
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  ub0_z  = leading(ub_z,la,error=error)
  a0_z=general(ub0_z,error)
  test_name = "Complex UB Submatrix na=50, la=10:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  ub0_z  = leading(ub_z,la,error=error)
  a0_z=general(ub0_z,error)
  test_name = "Complex UB Submatrix na=50, la=50:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  ub0_z  = leading(ub_z,la,error=error)
  a0_z=general(ub0_z,error)
  test_name = "Complex UB Submatrix na=50, la=1:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  ub0_z  = leading(ub_z,la,error=error)
  a0_z=general(ub0_z,error)
  test_name = "Complex UB Submatrix na=50, la=2:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  bv0_z  = trailing(bv_z,la,error=error)
  a0_z=general(bv0_z,error)
  test_name = "Complex BV Submatrix na=50, la=10:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  bv0_z  = trailing(bv_z,la,error=error)
  a0_z=general(bv0_z,error)
  test_name = "Complex BV Submatrix na=50, la=50:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  bv0_z  = trailing(bv_z,la,error=error)
  a0_z=general(bv0_z,error)
  test_name = "Complex BV Submatrix na=50, la=1:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  bv0_z  = trailing(bv_z,la,error=error)
  a0_z=general(bv0_z,error)
  test_name = "Complex BV Submatrix na=50, la=2:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  bt0_z  = leading(bt_z,la,error=error)
  a0_z=general(bt0_z,error)
  test_name = "Complex BT Submatrix na=50, la=10:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  bt0_z  = leading(bt_z,la,error=error)
  a0_z=general(bt0_z,error)
  test_name = "Complex BT Submatrix na=50, la=50:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  bt0_z  = leading(bt_z,la,error=error)
  a0_z=general(bt0_z,error)
  test_name = "Complex BT Submatrix na=50, la=1:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  bt0_z  = leading(bt_z,la,error=error)
  a0_z=general(bt0_z,error)
  test_name = "Complex BT Submatrix na=50, la=2:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  wb0_z  = trailing(wb_z,la,error=error)
  a0_z=general(wb0_z,error)
  test_name = "Complex WB Submatrix na=50, la=10:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  wb0_z  = trailing(wb_z,la,error=error)
  a0_z=general(wb0_z,error)
  test_name = "Complex WB Submatrix na=50, la=50:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  wb0_z  = trailing(wb_z,la,error=error)
  a0_z=general(wb0_z,error)
  test_name = "Complex WB Submatrix na=50, la=1:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  wb0_z  = trailing(wb_z,la,error=error)
  a0_z=general(wb0_z,error)
  test_name = "Complex WB Submatrix na=50, la=2:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  ubt_z=z_random_ubt(na,lbw,ubw,error=error)
  a_z = general(ubt_z,error)
  ubt0_z  = leading(ubt_z,la,error=error)
  a0_z=general(ubt0_z,error)
  test_name = "Complex UBT Submatrix na=50, la=10:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  ubt_z=z_random_ubt(na,lbw,ubw,error=error)
  a_z = general(ubt_z,error)
  ubt0_z  = leading(ubt_z,la,error=error)
  a0_z=general(ubt0_z,error)
  test_name = "Complex UBT Submatrix na=50, la=50:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  ubt_z=z_random_ubt(na,lbw,ubw,error=error)
  a_z = general(ubt_z,error)
  ubt0_z  = leading(ubt_z,la,error=error)
  a0_z=general(ubt0_z,error)
  test_name = "Complex UBT Submatrix na=50, la=1:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  ubt_z=z_random_ubt(na,lbw,ubw,error=error)
  a_z = general(ubt_z,error)
  ubt0_z  = leading(ubt_z,la,error=error)
  a0_z=general(ubt0_z,error)
  test_name = "Complex UBT Submatrix na=50, la=2:"
  call z_output_result(test_name,a_z(1:la,1:la),a0_z,c*tol,error)

  na=50; la=10; lbw=3; ubw=4
  wbv_z=z_random_wbv(na,lbw,ubw,error=error)
  a_z = general(wbv_z,error)
  wbv0_z  = trailing(wbv_z,la,error=error)
  a0_z=general(wbv0_z,error)
  test_name = "Complex WBV Submatrix na=50, la=10:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=50; lbw=3; ubw=4
  wbv_z=z_random_wbv(na,lbw,ubw,error=error)
  a_z = general(wbv_z,error)
  wbv0_z  = trailing(wbv_z,la,error=error)
  a0_z=general(wbv0_z,error)
  test_name = "Complex WBV Submatrix na=50, la=50:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=1; lbw=3; ubw=4
  wbv_z=z_random_wbv(na,lbw,ubw,error=error)
  a_z = general(wbv_z,error)
  wbv0_z  = trailing(wbv_z,la,error=error)
  a0_z=general(wbv0_z,error)
  test_name = "Complex WBV Submatrix na=50, la=1:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  na=50; la=2; lbw=3; ubw=4
  wbv_z=z_random_wbv(na,lbw,ubw,error=error)
  a_z = general(wbv_z,error)
  wbv0_z  = trailing(wbv_z,la,error=error)
  a0_z=general(wbv0_z,error)
  test_name = "Complex WBV Submatrix na=50, la=2:"
  call z_output_result(test_name,a_z(na-la+1:na,na-la+1:na),a0_z,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Tests of Real Unstructured Columns and Rows"
  print *

  na=50; lbw=3; ubw=4; k0=25; k1=30
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  a0_d=columns_of_ub(k0,k1,ub_d,error)
  test_name = "Real columns of UB na=50, k0=25, k1=30:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=50
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  a0_d=columns_of_ub(k0,k1,ub_d,error)
  test_name = "Real columns of UB na=50, k0=1, k1=50:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=5; k1=5
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  a0_d=columns_of_ub(k0,k1,ub_d,error)
  test_name = "Real columns of UB na=50, k0=5, k1=5:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=1
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  a0_d=columns_of_ub(k0,k1,ub_d,error)
  test_name = "Real columns of UB na=50, k0=1, k1=1:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=50; k1=50
  ub_d=d_random_ub(na,lbw,ubw,error=error)
  a_d = general(ub_d,error)
  a0_d=columns_of_ub(k0,k1,ub_d,error)
  test_name = "Real columns of UB na=50, k0=50, k1=50:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=25; j1=30
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  a0_d=rows_of_bv(j0,j1,bv_d,error)
  test_name = "Real rows of BV na=50, j0=25, j1=30:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=50
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  a0_d=rows_of_bv(j0,j1,bv_d,error)
  test_name = "Real rows of BV na=50, j0=1, j1=50:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=5; j1=5
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  a0_d=rows_of_bv(j0,j1,bv_d,error)
  test_name = "Real rows of BV na=50, j0=5, j1=5:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=1
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  a0_d=rows_of_bv(j0,j1,bv_d,error)
  test_name = "Real rows of BV na=50, j0=1, j1=1:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=50; j1=50
  bv_d=d_random_bv(na,lbw,ubw,error=error)
  a_d = general(bv_d,error)
  a0_d=rows_of_bv(j0,j1,bv_d,error)
  test_name = "Real rows of BV na=50, j0=50, j1=50:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=25; k1=30
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  a0_d=columns_of_wb(k0,k1,wb_d,error)
  test_name = "Real columns of WB na=50, k0=25, k1=30:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=50
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  a0_d=columns_of_wb(k0,k1,wb_d,error)
  test_name = "Real columns of WB na=50, k0=1, k1=50:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=5; k1=5
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  a0_d=columns_of_wb(k0,k1,wb_d,error)
  test_name = "Real columns of WB na=50, k0=5, k1=5:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=1
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  a0_d=columns_of_wb(k0,k1,wb_d,error)
  test_name = "Real columns of WB na=50, k0=1, k1=1:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; k0=50; k1=50
  wb_d=d_random_wb(na,lbw,ubw,error=error)
  a_d = general(wb_d,error)
  a0_d=columns_of_wb(k0,k1,wb_d,error)
  test_name = "Real columns of WB na=50, k0=50, k1=50:"
  call d_output_result(test_name,a_d(:,k0:k1),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=25; j1=30
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  a0_d=rows_of_bt(j0,j1,bt_d,error)
  test_name = "Real rows of BT na=50, j0=25, j1=30:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=50
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  a0_d=rows_of_bt(j0,j1,bt_d,error)
  test_name = "Real rows of BT na=50, j0=1, j1=50:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=5; j1=5
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  a0_d=rows_of_bt(j0,j1,bt_d,error)
  test_name = "Real rows of BT na=50, j0=5, j1=5:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=1
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  a0_d=rows_of_bt(j0,j1,bt_d,error)
  test_name = "Real rows of BT na=50, j0=1, j1=1:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  na=50; lbw=3; ubw=4; j0=50; j1=50
  bt_d=d_random_bt(na,lbw,ubw,error=error)
  a_d = general(bt_d,error)
  a0_d=rows_of_bt(j0,j1,bt_d,error)
  test_name = "Real rows of BT na=50, j0=50, j1=50:"
  call d_output_result(test_name,a_d(j0:j1,:),a0_d,c*tol,error)

  print *
  print *, "--------------------------------"
  print *
  print *, "Tests of Complex Unstructured Columns and Rows"
  print *

  na=50; lbw=3; ubw=4; k0=25; k1=30
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  a0_z=columns_of_ub(k0,k1,ub_z,error)
  test_name = "Complex columns of UB na=50, k0=25, k1=30:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=50
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  a0_z=columns_of_ub(k0,k1,ub_z,error)
  test_name = "Complex columns of UB na=50, k0=1, k1=50:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=5; k1=5
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  a0_z=columns_of_ub(k0,k1,ub_z,error)
  test_name = "Complex columns of UB na=50, k0=5, k1=5:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=1
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  a0_z=columns_of_ub(k0,k1,ub_z,error)
  test_name = "Complex columns of UB na=50, k0=1, k1=1:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=50; k1=50
  ub_z=z_random_ub(na,lbw,ubw,error=error)
  a_z = general(ub_z,error)
  a0_z=columns_of_ub(k0,k1,ub_z,error)
  test_name = "Complex columns of UB na=50, k0=50, k1=50:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=25; j1=30
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  a0_z=rows_of_bv(j0,j1,bv_z,error)
  test_name = "Complex rows of BV na=50, j0=25, j1=30:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=50
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  a0_z=rows_of_bv(j0,j1,bv_z,error)
  test_name = "Complex rows of BV na=50, j0=1, j1=50:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=5; j1=5
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  a0_z=rows_of_bv(j0,j1,bv_z,error)
  test_name = "Complex rows of BV na=50, j0=5, j1=5:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=1
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  a0_z=rows_of_bv(j0,j1,bv_z,error)
  test_name = "Complex rows of BV na=50, j0=1, j1=1:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=50; j1=50
  bv_z=z_random_bv(na,lbw,ubw,error=error)
  a_z = general(bv_z,error)
  a0_z=rows_of_bv(j0,j1,bv_z,error)
  test_name = "Complex rows of BV na=50, j0=50, j1=50:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=25; k1=30
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  a0_z=columns_of_wb(k0,k1,wb_z,error)
  test_name = "Complex columns of WB na=50, k0=25, k1=30:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=50
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  a0_z=columns_of_wb(k0,k1,wb_z,error)
  test_name = "Complex columns of WB na=50, k0=1, k1=50:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=5; k1=5
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  a0_z=columns_of_wb(k0,k1,wb_z,error)
  test_name = "Complex columns of WB na=50, k0=5, k1=5:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=1; k1=1
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  a0_z=columns_of_wb(k0,k1,wb_z,error)
  test_name = "Complex columns of WB na=50, k0=1, k1=1:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; k0=50; k1=50
  wb_z=z_random_wb(na,lbw,ubw,error=error)
  a_z = general(wb_z,error)
  a0_z=columns_of_wb(k0,k1,wb_z,error)
  test_name = "Complex columns of WB na=50, k0=50, k1=50:"
  call z_output_result(test_name,a_z(:,k0:k1),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=50
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  a0_z=rows_of_bt(j0,j1,bt_z,error)
  test_name = "Complex rows of BT na=50, j0=1, j1=50:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=5; j1=5
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  a0_z=rows_of_bt(j0,j1,bt_z,error)
  test_name = "Complex rows of BT na=50, j0=5, j1=5:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=1; j1=1
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  a0_z=rows_of_bt(j0,j1,bt_z,error)
  test_name = "Complex rows of BT na=50, j0=1, j1=1:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

  na=50; lbw=3; ubw=4; j0=50; j1=50
  bt_z=z_random_bt(na,lbw,ubw,error=error)
  a_z = general(bt_z,error)
  a0_z=rows_of_bt(j0,j1,bt_z,error)
  test_name = "Complex rows of BT na=50, j0=50, j1=50:"
  call z_output_result(test_name,a_z(j0:j1,:),a0_z,c*tol,error)

contains

  subroutine d_output_result(name,a0,a1,bnd,error)
    character(len=*) :: name
    real(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd
    type(error_info) :: error

    real(kind=dp) :: err
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       err = maxabs(a1-a0)
       if (err < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, err, test_result
    end if
  end subroutine d_output_result

  subroutine z_output_result(name,a0,a1,bnd,error)
    character(len=*) :: name
    complex(kind=dp), dimension(:,:) :: a0, a1
    real(kind=dp) :: bnd
    type(error_info) :: error

    real(kind=dp) :: err
    character(len=10) :: test_result

    if (error%code > 0) then
       print *, "Calling error in test: ", name
    else
       err = maxabs(a1-a0)
       if (err < bnd) then
          test_result="PASSED"
       else
          test_result="    FAILED"
       end if
       write (*,fmt) name, err, test_result
    end if
  end subroutine z_output_result

end program test_submatrix


! { dg-do run }
! { dg-options "-std=f2008 " }

! Check BLOCK with SAVE'ed variables.

PROGRAM main
  IMPLICIT NONE
  INTEGER :: i

  DO i = 1, 100
    BLOCK
      INTEGER, SAVE :: summed = 0
      summed = summed + i
      IF (i == 100 .AND. summed /= 5050) STOP 1
    END BLOCK
  END DO
END PROGRAM main


!***********************************/
!	Name:Sutherland's lawに基づき粘度を求めるプログラム
!	Alias:UGetLaminarViscosity
!	Description:
!	Type:
!	Input:
!	Output:
!	Note:
!	Author:Akitaka Toyota
!	Date:2018.11.13
!	Update:-
!	Other:
!***********************************/
subroutine UGetLaminarViscosity(UConf, UG,UCC)
    use StructVar_Mod
    use LoopVar_Mod
    use FrequentOperation
    use ConstantVar_Mod, gamma => SpecificOfHeatRatio
    implicit none
    type(Configulation), intent(in) :: UConf
    type(UnstructuredGrid), intent(in) :: UG
    type(CellCenter), intent(inout) :: UCC
    double precision :: Mu0, STS, SC1, Mach2!, Tref

    if(UConf%UseSutherlandLaw == 0) then
        UCC%LaminarViscosity = 1.0d0

    else
        Mu0 = ReferenceViscosity_Mu0
        !Tref = ReferenceTemperature_Tref
        STS = SutherlandTemperature_S
        SC1 = SutherlandCoefficient1
        Mach2 = MachNumber ** 2

        do iCell = 1, UG%GI%RealCells
            UCC%Temparature(iCell, 1, 1) = gamma * UCC%PrimitiveVariable(5, iCell, 1, 1) / UCC%PrimitiveVariable(1, iCell, 1, 1) * Mach2
            UCC%LaminarViscosity(iCell, 1, 1) = SC1 * UCC%Temparature(iCell, 1, 1) ** 1.5d0 / (UCC%Temparature(iCell, 1, 1) + STS)
        end do

    end if

    return
end subroutine UGetLaminarViscosity


program main
  implicit none

  integer, parameter :: dp = 8
  integer, parameter :: dimEspace = 3
  integer, parameter :: nbPoints = 1000
  integer, parameter :: nbTimes = 20
  integer, parameter :: nb = 8

  real(dp), allocatable, dimension(:,:) :: points
  real(dp), allocatable, dimension(:,:) :: distance
  integer :: i, j, k, ii, jj
  ! integer :: beginning, end, rate
  real(dp) :: beginning, end
  real(dp) :: time, sum_squares, sum_time

  allocate(points(1:dimEspace, 1:nbPoints))
  allocate(distance(1:nbPoints, 1:nbPoints))
  call random_number(points)

  do j = 1, nbPoints
     do i = 1, nbPoints
        distance(i, j) =     &
             (points(1, i) - points(1, j))**2 + &
             (points(2, i) - points(2, j))**2 + &
             (points(3, i) - points(3, j))**2
     end do
  end do

  sum_squares=0.0
  sum_time = 0.0
  ! call system_clock(COUNT_RATE=rate)
  do k = 1, nbTimes
     ! call system_clock(beginning)
     call cpu_time(beginning)
     do j = 1, nbPoints
        do i = 1, nbPoints
           distance(i, j) =      &
                (points(1, i) - points(1, j))**2 + &
                (points(2, i) - points(2, j))**2 + &
                (points(3, i) - points(3, j))**2
        end do
     end do
     ! call system_clock(end)
     call cpu_time(end)
     ! time = 1e-3*real(end - beginning) / real(rate)
     time = 1e3*(end - beginning)
     write(*,*) 'fortran time = ', time, ' ms'! , ' end = ',end, ' beginning = ',beginning ! , ' rate = ',rate
     sum_squares = sum_squares + time*time
     sum_time = sum_time + time
  end do

  ! do k = 1, nbTimes
  !    call system_clock(beginning, rate)
  !    do ii=1,nbPoints,nb ! < nb is blocking factor
  !       do jj=1,nbPoints,nb
  !          do i=ii,min(nbPoints,ii+nb-1)
  !             do j=jj,min(nbPoints,jj+nb-1)
  !                distance(i,j) =   &
  !                     (points(1, i) - points(1, j))**2 + &
  !                     (points(2, i) - points(2, j))**2 + &
  !                     (points(3, i) - points(3, j))**2
  !             end do
  !          end do
  !       end do
  !    end do
  !    call system_clock(end)
  !    time = 1e3*real(end - beginning) / real(rate)
  !    sum_squares = sum_squares + time*time
  !    sum_time = sum_time + time
  ! end do

  write (*,8) sum_time/nbTimes, sqrt( sum_squares/nbTimes - sum_time/nbTimes * sum_time/nbTimes)

8 format(' Time taken: ', F6.2, ' +- ', F0.2, ' ms')

end program main


      SUBROUTINE IB01AD( METH, ALG, JOBD, BATCH, CONCT, CTRL, NOBR, M,
     $                   L, NSMP, U, LDU, Y, LDY, N, R, LDR, SV, RCOND,
     $                   TOL, IWORK, DWORK, LDWORK, IWARN, INFO )
C
C     SLICOT RELEASE 5.7.
C
C     Copyright (c) 2002-2020 NICONET e.V.
C
C     PURPOSE
C
C     To preprocess the input-output data for estimating the matrices
C     of a linear time-invariant dynamical system and to find an
C     estimate of the system order. The input-output data can,
C     optionally, be processed sequentially.
C
C     ARGUMENTS
C
C     Mode Parameters
C
C     METH    CHARACTER*1
C             Specifies the subspace identification method to be used,
C             as follows:
C             = 'M':  MOESP  algorithm with past inputs and outputs;
C             = 'N':  N4SID  algorithm.
C
C     ALG     CHARACTER*1
C             Specifies the algorithm for computing the triangular
C             factor R, as follows:
C             = 'C':  Cholesky algorithm applied to the correlation
C                     matrix of the input-output data;
C             = 'F':  Fast QR algorithm;
C             = 'Q':  QR algorithm applied to the concatenated block
C                     Hankel matrices.
C
C     JOBD    CHARACTER*1
C             Specifies whether or not the matrices B and D should later
C             be computed using the MOESP approach, as follows:
C             = 'M':  the matrices B and D should later be computed
C                     using the MOESP approach;
C             = 'N':  the matrices B and D should not be computed using
C                     the MOESP approach.
C             This parameter is not relevant for METH = 'N'.
C
C     BATCH   CHARACTER*1
C             Specifies whether or not sequential data processing is to
C             be used, and, for sequential processing, whether or not
C             the current data block is the first block, an intermediate
C             block, or the last block, as follows:
C             = 'F':  the first block in sequential data processing;
C             = 'I':  an intermediate block in sequential data
C                     processing;
C             = 'L':  the last block in sequential data processing;
C             = 'O':  one block only (non-sequential data processing).
C             NOTE that when  100  cycles of sequential data processing
C                  are completed for  BATCH = 'I',  a warning is
C                  issued, to prevent for an infinite loop.
C
C     CONCT   CHARACTER*1
C             Specifies whether or not the successive data blocks in
C             sequential data processing belong to a single experiment,
C             as follows:
C             = 'C':  the current data block is a continuation of the
C                     previous data block and/or it will be continued
C                     by the next data block;
C             = 'N':  there is no connection between the current data
C                     block and the previous and/or the next ones.
C             This parameter is not used if BATCH = 'O'.
C
C     CTRL    CHARACTER*1
C             Specifies whether or not the user's confirmation of the
C             system order estimate is desired, as follows:
C             = 'C':  user's confirmation;
C             = 'N':  no confirmation.
C             If  CTRL = 'C',  a reverse communication routine,  IB01OY,
C             is indirectly called (by SLICOT Library routine IB01OD),
C             and, after inspecting the singular values and system order
C             estimate,  n,  the user may accept  n  or set a new value.
C             IB01OY  is not called if CTRL = 'N'.
C
C     Input/Output Parameters
C
C     NOBR    (input) INTEGER
C             The number of block rows,  s,  in the input and output
C             block Hankel matrices to be processed.  NOBR > 0.
C             (In the MOESP theory,  NOBR  should be larger than  n,
C             the estimated dimension of state vector.)
C
C     M       (input) INTEGER
C             The number of system inputs.  M >= 0.
C             When M = 0, no system inputs are processed.
C
C     L       (input) INTEGER
C             The number of system outputs.  L > 0.
C
C     NSMP    (input) INTEGER
C             The number of rows of matrices  U  and  Y  (number of
C             samples,  t). (When sequential data processing is used,
C             NSMP  is the number of samples of the current data
C             block.)
C             NSMP >= 2*(M+L+1)*NOBR - 1,  for non-sequential
C                                          processing;
C             NSMP >= 2*NOBR,  for sequential processing.
C             The total number of samples when calling the routine with
C             BATCH = 'L'  should be at least  2*(M+L+1)*NOBR - 1.
C             The  NSMP  argument may vary from a cycle to another in
C             sequential data processing, but  NOBR, M,  and  L  should
C             be kept constant. For efficiency, it is advisable to use
C             NSMP  as large as possible.
C
C     U       (input) DOUBLE PRECISION array, dimension (LDU,M)
C             The leading NSMP-by-M part of this array must contain the
C             t-by-m input-data sequence matrix  U,
C             U = [u_1 u_2 ... u_m].  Column  j  of  U  contains the
C             NSMP  values of the j-th input component for consecutive
C             time increments.
C             If M = 0, this array is not referenced.
C
C     LDU     INTEGER
C             The leading dimension of the array U.
C             LDU >= NSMP, if M > 0;
C             LDU >= 1,    if M = 0.
C
C     Y       (input) DOUBLE PRECISION array, dimension (LDY,L)
C             The leading NSMP-by-L part of this array must contain the
C             t-by-l output-data sequence matrix  Y,
C             Y = [y_1 y_2 ... y_l].  Column  j  of  Y  contains the
C             NSMP  values of the j-th output component for consecutive
C             time increments.
C
C     LDY     INTEGER
C             The leading dimension of the array Y.  LDY >= NSMP.
C
C     N       (output) INTEGER
C             The estimated order of the system.
C             If  CTRL = 'C',  the estimated order has been reset to a
C             value specified by the user.
C
C     R       (output or input/output) DOUBLE PRECISION array, dimension
C             ( LDR,2*(M+L)*NOBR )
C             On exit, if ALG = 'C' and BATCH = 'F' or 'I', the leading
C             2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of this
C             array contains the current upper triangular part of the
C             correlation matrix in sequential data processing.
C             If ALG = 'F' and BATCH = 'F' or 'I', the array R is not
C             referenced.
C             On exit, if INFO = 0, ALG = 'Q', and BATCH = 'F' or 'I',
C             the leading 2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular
C             part of this array contains the current upper triangular
C             factor R from the QR factorization of the concatenated
C             block Hankel matrices. Denote  R_ij, i,j = 1:4,  the
C             ij submatrix of  R,  partitioned by M*NOBR,  M*NOBR,
C             L*NOBR,  and  L*NOBR  rows and columns.
C             On exit, if INFO = 0 and BATCH = 'L' or 'O', the leading
C             2*(M+L)*NOBR-by-2*(M+L)*NOBR upper triangular part of
C             this array contains the matrix S, the processed upper
C             triangular factor R from the QR factorization of the
C             concatenated block Hankel matrices, as required by other
C             subroutines. Specifically, let  S_ij, i,j = 1:4,  be the
C             ij submatrix of  S,  partitioned by M*NOBR,  L*NOBR,
C             M*NOBR,  and  L*NOBR  rows and columns. The submatrix
C             S_22  contains the matrix of left singular vectors needed
C             subsequently. Useful information is stored in  S_11  and
C             in the block-column  S_14 : S_44.  For METH = 'M' and
C             JOBD = 'M', the upper triangular part of  S_31  contains
C             the upper triangular factor in the QR factorization of the
C             matrix  R_1c = [ R_12'  R_22'  R_11' ]',  and  S_12
C             contains the corresponding leading part of the transformed
C             matrix  R_2c = [ R_13'  R_23'  R_14' ]'.  For  METH = 'N',
C             the subarray  S_41 : S_43  contains the transpose of the
C             matrix contained in  S_14 : S_34.
C             The details of the contents of R need not be known if this
C             routine is followed by SLICOT Library routine IB01BD.
C             On entry, if ALG = 'C', or ALG = 'Q', and BATCH = 'I' or
C             'L', the leading  2*(M+L)*NOBR-by-2*(M+L)*NOBR  upper
C             triangular part of this array must contain the upper
C             triangular matrix R computed at the previous call of this
C             routine in sequential data processing. The array R need
C             not be set on entry if ALG = 'F' or if BATCH = 'F' or 'O'.
C
C     LDR     INTEGER
C             The leading dimension of the array  R.
C             LDR >= MAX( 2*(M+L)*NOBR, 3*M*NOBR ),
C                                  for METH = 'M' and JOBD = 'M';
C             LDR >= 2*(M+L)*NOBR, for METH = 'M' and JOBD = 'N' or
C                                  for METH = 'N'.
C
C     SV      (output) DOUBLE PRECISION array, dimension ( L*NOBR )
C             The singular values used to estimate the system order.
C
C     Tolerances
C
C     RCOND   DOUBLE PRECISION
C             The tolerance to be used for estimating the rank of
C             matrices. If the user sets  RCOND > 0,  the given value
C             of  RCOND  is used as a lower bound for the reciprocal
C             condition number;  an m-by-n matrix whose estimated
C             condition number is less than  1/RCOND  is considered to
C             be of full rank.  If the user sets  RCOND <= 0,  then an
C             implicitly computed, default tolerance, defined by
C             RCONDEF = m*n*EPS,  is used instead, where  EPS  is the
C             relative machine precision (see LAPACK Library routine
C             DLAMCH).
C             This parameter is not used for  METH = 'M'.
C
C     TOL     DOUBLE PRECISION
C             Absolute tolerance used for determining an estimate of
C             the system order. If  TOL >= 0,  the estimate is
C             indicated by the index of the last singular value greater
C             than or equal to  TOL.  (Singular values less than  TOL
C             are considered as zero.) When  TOL = 0,  an internally
C             computed default value,  TOL = NOBR*EPS*SV(1),  is used,
C             where  SV(1)  is the maximal singular value, and  EPS  is
C             the relative machine precision (see LAPACK Library routine
C             DLAMCH). When  TOL < 0,  the estimate is indicated by the
C             index of the singular value that has the largest
C             logarithmic gap to its successor.
C
C     Workspace
C
C     IWORK   INTEGER array, dimension (LIWORK)
C             LIWORK >= MAX(3,(M+L)*NOBR), if METH = 'N';
C             LIWORK >= MAX(3,M+L), if METH = 'M' and ALG = 'F';
C             LIWORK >= 3,   if METH = 'M' and ALG = 'C' or 'Q'.
C             On entry with  BATCH = 'I'  or  BATCH = 'L',  IWORK(1:3)
C             must contain the values of ICYCLE, MAXWRK, and NSMPSM
C             set by the previous call of this routine.
C             On exit with  BATCH = 'F'  or  BATCH = 'I',  IWORK(1:3)
C             contains the values of ICYCLE, MAXWRK, and NSMPSM to be
C             used by the next call of the routine.
C             ICYCLE  counts the cycles for  BATCH = 'I'.
C             MAXWRK  stores the current optimal workspace.
C             NSMPSM  sums up the  NSMP  values for  BATCH <> 'O'.
C             The first three elements of  IWORK  should be preserved
C             during successive calls of the routine with  BATCH = 'F'
C             or  BATCH = 'I',  till the final call with   BATCH = 'L'.
C
C     DWORK   DOUBLE PRECISION array, dimension (LDWORK)
C             On exit, if  INFO = 0,  DWORK(1) returns the optimal value
C             of LDWORK,  and, for  METH = 'N',  and  BATCH = 'L'  or
C             'O',  DWORK(2)  and  DWORK(3)  contain the reciprocal
C             condition numbers of the triangular factors of the
C             matrices  U_f  and  r_1  [6].
C             On exit, if  INFO = -23,  DWORK(1)  returns the minimum
C             value of LDWORK.
C             Let
C             k = 0,               if CONCT = 'N' and ALG = 'C' or 'Q';
C             k = 2*NOBR-1,        if CONCT = 'C' and ALG = 'C' or 'Q';
C             k = 2*NOBR*(M+L+1),  if CONCT = 'N' and ALG = 'F';
C             k = 2*NOBR*(M+L+2),  if CONCT = 'C' and ALG = 'F'.
C             The first (M+L)*k elements of  DWORK  should be preserved
C             during successive calls of the routine with  BATCH = 'F'
C             or  'I',  till the final call with  BATCH = 'L'.
C
C     LDWORK  INTEGER
C             The length of the array DWORK.
C             LDWORK >= (4*NOBR-2)*(M+L), if ALG = 'C', BATCH = 'F' or
C                             'I' and CONCT = 'C';
C             LDWORK >= 1, if ALG = 'C', BATCH = 'F' or 'I' and
C                             CONCT = 'N';
C             LDWORK >= max((4*NOBR-2)*(M+L), 5*L*NOBR), if METH = 'M',
C                             ALG = 'C', BATCH = 'L' and CONCT = 'C';
C             LDWORK >= max((2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR),
C                             if METH = 'M', JOBD = 'M', ALG = 'C',
C                              BATCH = 'O', or
C                             (BATCH = 'L' and CONCT = 'N');
C             LDWORK >= 5*L*NOBR, if METH = 'M', JOBD = 'N', ALG = 'C',
C                              BATCH = 'O', or
C                             (BATCH = 'L' and CONCT = 'N');
C             LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'C', and
C                             BATCH = 'L' or 'O';
C             LDWORK >= (M+L)*2*NOBR*(M+L+3), if ALG = 'F',
C                             BATCH <> 'O' and CONCT = 'C';
C             LDWORK >= (M+L)*2*NOBR*(M+L+1), if ALG = 'F',
C                             BATCH = 'F', 'I' and CONCT = 'N';
C             LDWORK >= (M+L)*4*NOBR*(M+L+1)+(M+L)*2*NOBR, if ALG = 'F',
C                             BATCH = 'L' and CONCT = 'N', or
C                             BATCH = 'O';
C             LDWORK >= 4*(M+L)*NOBR, if ALG = 'Q', BATCH = 'F', and
C                             LDR >= NS = NSMP - 2*NOBR + 1;
C             LDWORK >= max(4*(M+L)*NOBR, 5*L*NOBR), if METH = 'M',
C                             ALG = 'Q', BATCH = 'O', and LDR >= NS;
C             LDWORK >= 5*(M+L)*NOBR+1, if METH = 'N', ALG = 'Q',
C                             BATCH = 'O', and LDR >= NS;
C             LDWORK >= 6*(M+L)*NOBR, if ALG = 'Q', (BATCH = 'F' or 'O',
C                             and LDR < NS), or (BATCH = 'I' or
C                             'L' and CONCT = 'N');
C             LDWORK >= 4*(NOBR+1)*(M+L)*NOBR, if ALG = 'Q', BATCH = 'I'
C                             or 'L' and CONCT = 'C'.
C             The workspace used for ALG = 'Q' is
C                       LDRWRK*2*(M+L)*NOBR + 4*(M+L)*NOBR,
C             where LDRWRK = LDWORK/(2*(M+L)*NOBR) - 2; recommended
C             value LDRWRK = NS, assuming a large enough cache size.
C             For good performance,  LDWORK  should be larger.
C
C     Warning Indicator
C
C     IWARN   INTEGER
C             = 0:  no warning;
C             = 1:  the number of 100 cycles in sequential data
C                   processing has been exhausted without signaling
C                   that the last block of data was get; the cycle
C                   counter was reinitialized;
C             = 2:  a fast algorithm was requested (ALG = 'C' or 'F'),
C                   but it failed, and the QR algorithm was then used
C                   (non-sequential data processing);
C             = 3:  all singular values were exactly zero, hence  N = 0
C                   (both input and output were identically zero);
C             = 4:  the least squares problems with coefficient matrix
C                   U_f,  used for computing the weighted oblique
C                   projection (for METH = 'N'), have a rank-deficient
C                   coefficient matrix;
C             = 5:  the least squares problem with coefficient matrix
C                   r_1  [6], used for computing the weighted oblique
C                   projection (for METH = 'N'), has a rank-deficient
C                   coefficient matrix.
C             NOTE: the values 4 and 5 of IWARN have no significance
C                   for the identification problem.
C
C     Error Indicator
C
C     INFO    INTEGER
C             = 0:  successful exit;
C             < 0:  if INFO = -i, the i-th argument had an illegal
C                   value;
C             = 1:  a fast algorithm was requested (ALG = 'C', or 'F')
C                   in sequential data processing, but it failed; the
C                   routine can be repeatedly called again using the
C                   standard QR algorithm;
C             = 2:  the singular value decomposition (SVD) algorithm did
C                   not converge.
C
C     METHOD
C
C     The procedure consists in three main steps, the first step being
C     performed by one of the three algorithms included.
C
C     1.a) For non-sequential data processing using QR algorithm, a
C     t x 2(m+l)s  matrix H is constructed, where
C
C          H = [ Uf'         Up'      Y'      ],  for METH = 'M',
C                  s+1,2s,t    1,s,t   1,2s,t
C
C          H = [ U'       Y'      ],              for METH = 'N',
C                 1,2s,t   1,2s,t
C
C     and  Up     , Uf        , U      , and  Y        are block Hankel
C            1,s,t    s+1,2s,t   1,2s,t        1,2s,t
C     matrices defined in terms of the input and output data [3].
C     A QR factorization is used to compress the data.
C     The fast QR algorithm uses a QR factorization which exploits
C     the block-Hankel structure. Actually, the Cholesky factor of H'*H
C     is computed.
C
C     1.b) For sequential data processing using QR algorithm, the QR
C     decomposition is done sequentially, by updating the upper
C     triangular factor  R.  This is also performed internally if the
C     workspace is not large enough to accommodate an entire batch.
C
C     1.c) For non-sequential or sequential data processing using
C     Cholesky algorithm, the correlation matrix of input-output data is
C     computed (sequentially, if requested), taking advantage of the
C     block Hankel structure [7].  Then, the Cholesky factor of the
C     correlation matrix is found, if possible.
C
C     2) A singular value decomposition (SVD) of a certain matrix is
C     then computed, which reveals the order  n  of the system as the
C     number of "non-zero" singular values. For the MOESP approach, this
C     matrix is  [ R_24'  R_34' ]' := R(ms+1:(2m+l)s,(2m+l)s+1:2(m+l)s),
C     where  R  is the upper triangular factor  R  constructed by SLICOT
C     Library routine  IB01MD.  For the N4SID approach, a weighted
C     oblique projection is computed from the upper triangular factor  R
C     and its SVD is then found.
C
C     3) The singular values are compared to the given, or default TOL,
C     and the estimated order  n  is returned, possibly after user's
C     confirmation.
C
C     REFERENCES
C
C     [1] Verhaegen M., and Dewilde, P.
C         Subspace Model Identification. Part 1: The output-error
C         state-space model identification class of algorithms.
C         Int. J. Control, 56, pp. 1187-1210, 1992.
C
C     [2] Verhaegen M.
C         Subspace Model Identification. Part 3: Analysis of the
C         ordinary output-error state-space model identification
C         algorithm.
C         Int. J. Control, 58, pp. 555-586, 1993.
C
C     [3] Verhaegen M.
C         Identification of the deterministic part of MIMO state space
C         models given in innovations form from input-output data.
C         Automatica, Vol.30, No.1, pp.61-74, 1994.
C
C     [4] Van Overschee, P., and De Moor, B.
C         N4SID: Subspace Algorithms for the Identification of
C         Combined Deterministic-Stochastic Systems.
C         Automatica, Vol.30, No.1, pp. 75-93, 1994.
C
C     [5] Peternell, K., Scherrer, W. and Deistler, M.
C         Statistical Analysis of Novel Subspace Identification Methods.
C         Signal Processing, 52, pp. 161-177, 1996.
C
C     [6] Sima, V.
C         Subspace-based Algorithms for Multivariable System
C         Identification.
C         Studies in Informatics and Control, 5, pp. 335-344, 1996.
C
C     [7] Sima, V.
C         Cholesky or QR Factorization for Data Compression in
C         Subspace-based Identification ?
C         Proceedings of the Second NICONET Workshop on ``Numerical
C         Control Software: SLICOT, a Useful Tool in Industry'',
C         December 3, 1999, INRIA Rocquencourt, France, pp. 75-80, 1999.
C
C     NUMERICAL ASPECTS
C
C     The implemented method is numerically stable (when QR algorithm is
C     used), reliable and efficient. The fast Cholesky or QR algorithms
C     are more efficient, but the accuracy could diminish by forming the
C     correlation matrix.
C     The most time-consuming computational step is step 1:
C                                        2
C     The QR algorithm needs 0(t(2(m+l)s) ) floating point operations.
C                                           2              3
C     The Cholesky algorithm needs 0(2t(m+l) s)+0((2(m+l)s) ) floating
C     point operations.
C                                          2           3 2
C     The fast QR algorithm needs 0(2t(m+l) s)+0(4(m+l) s ) floating
C     point operations.
C                                                3
C     Step 2 of the algorithm requires 0(((m+l)s) ) floating point
C     operations.
C
C     FURTHER COMMENTS
C
C     For ALG = 'Q', BATCH = 'O' and LDR < NS, or BATCH <> 'O', the
C     calculations could be rather inefficient if only minimal workspace
C     (see argument LDWORK) is provided. It is advisable to provide as
C     much workspace as possible. Almost optimal efficiency can be
C     obtained for  LDWORK = (NS+2)*(2*(M+L)*NOBR),  assuming that the
C     cache size is large enough to accommodate R, U, Y, and DWORK.
C
C     CONTRIBUTOR
C
C     V. Sima, Katholieke Universiteit Leuven, Feb. 2000.
C
C     REVISIONS
C
C     August 2000, March 2005, May 2020.
C
C     KEYWORDS
C
C     Cholesky decomposition, Hankel matrix, identification methods,
C     multivariable systems, QR decomposition, singular value
C     decomposition.
C
C     ******************************************************************
C
C     .. Scalar Arguments ..
      DOUBLE PRECISION   RCOND, TOL
      INTEGER            INFO, IWARN, L, LDR, LDU, LDWORK, LDY, M, N,
     $                   NOBR, NSMP
      CHARACTER          ALG, BATCH, CONCT, CTRL, JOBD, METH
C     .. Array Arguments ..
      INTEGER            IWORK(*)
      DOUBLE PRECISION   DWORK(*), R(LDR, *), SV(*), U(LDU, *),
     $                   Y(LDY, *)
C     .. Local Scalars ..
      INTEGER            ICYCLE, IWARNL, LMNOBR, LNOBR, MAXWRK, MINWRK,
     $                   MNOBR, NOBR21, NR, NS, NSMPSM
      LOGICAL            CHALG, CONNEC, CONTRL, FIRST, FQRALG, INTERM,
     $                   JOBDM, LAST, MOESP, N4SID, ONEBCH, QRALG
C     .. External Functions ..
      LOGICAL            LSAME
      EXTERNAL           LSAME
C     .. External Subroutines ..
      EXTERNAL           IB01MD, IB01ND, IB01OD, XERBLA
C     .. Intrinsic Functions ..
      INTRINSIC          MAX
C     ..
C     .. Executable Statements ..
C
C     Decode the scalar input parameters.
C
      MOESP  = LSAME( METH,  'M' )
      N4SID  = LSAME( METH,  'N' )
      FQRALG = LSAME( ALG,   'F' )
      QRALG  = LSAME( ALG,   'Q' )
      CHALG  = LSAME( ALG,   'C' )
      JOBDM  = LSAME( JOBD,  'M' )
      ONEBCH = LSAME( BATCH, 'O' )
      FIRST  = LSAME( BATCH, 'F' ) .OR. ONEBCH
      INTERM = LSAME( BATCH, 'I' )
      LAST   = LSAME( BATCH, 'L' ) .OR. ONEBCH
      CONTRL = LSAME( CTRL,  'C' )
C
      IF( .NOT.ONEBCH ) THEN
         CONNEC = LSAME( CONCT, 'C' )
      ELSE
         CONNEC = .FALSE.
      END IF
C
      MNOBR  = M*NOBR
      LNOBR  = L*NOBR
      LMNOBR = LNOBR  + MNOBR
      NR     = LMNOBR + LMNOBR
      NOBR21 = 2*NOBR - 1
      IWARN  = 0
      INFO   = 0
      IF( FIRST ) THEN
         ICYCLE = 1
         MAXWRK = 1
         NSMPSM = 0
      ELSE IF( .NOT.ONEBCH ) THEN
         ICYCLE = IWORK(1)
         MAXWRK = IWORK(2)
         NSMPSM = IWORK(3)
      END IF
      NSMPSM = NSMPSM + NSMP
C
C     Check the scalar input parameters.
C
      IF( .NOT.( MOESP .OR. N4SID ) ) THEN
         INFO = -1
      ELSE IF( .NOT.( FQRALG .OR. QRALG .OR. CHALG ) ) THEN
         INFO = -2
      ELSE IF( MOESP .AND. .NOT.( JOBDM .OR. LSAME( JOBD, 'N' ) ) ) THEN
         INFO = -3
      ELSE IF( .NOT.( FIRST .OR. INTERM .OR. LAST ) ) THEN
         INFO = -4
      ELSE IF( .NOT. ONEBCH ) THEN
         IF( .NOT.( CONNEC .OR. LSAME( CONCT, 'N' ) ) )
     $      INFO = -5
      END IF
      IF( INFO.EQ.0 ) THEN
         IF( .NOT.( CONTRL .OR. LSAME( CTRL, 'N' ) ) ) THEN
            INFO = -6
         ELSE IF( NOBR.LE.0 ) THEN
            INFO = -7
         ELSE IF( M.LT.0 ) THEN
            INFO = -8
         ELSE IF( L.LE.0 ) THEN
            INFO = -9
         ELSE IF( NSMP.LT.2*NOBR .OR.
     $            ( LAST .AND. NSMPSM.LT.NR+NOBR21 ) ) THEN
            INFO = -10
         ELSE IF( LDU.LT.1 .OR. ( M.GT.0 .AND. LDU.LT.NSMP ) ) THEN
            INFO = -12
         ELSE IF( LDY.LT.NSMP ) THEN
            INFO = -14
         ELSE IF( LDR.LT.NR .OR. ( MOESP .AND. JOBDM .AND.
     $            LDR.LT.3*MNOBR ) ) THEN
            INFO = -17
         ELSE
C
C           Compute workspace.
C           (Note: Comments in the code beginning "Workspace:" describe
C           the minimal amount of workspace needed at that point in the
C           code, as well as the preferred amount for good performance.)
C
            NS = NSMP - NOBR21
            IF ( CHALG ) THEN
               IF ( .NOT.LAST ) THEN
                  IF ( CONNEC ) THEN
                     MINWRK = 2*( NR - M - L )
                  ELSE
                     MINWRK = 1
                  END IF
               ELSE IF ( MOESP ) THEN
                  IF ( CONNEC .AND. .NOT.ONEBCH ) THEN
                     MINWRK = MAX( 2*( NR - M - L ), 5*LNOBR )
                  ELSE
                     MINWRK = 5*LNOBR
                     IF ( JOBDM )
     $                  MINWRK = MAX( 2*MNOBR - NOBR, LMNOBR, MINWRK )
                  END IF
               ELSE
                  MINWRK = 5*LMNOBR + 1
               END IF
            ELSE IF ( FQRALG ) THEN
               IF ( .NOT.ONEBCH .AND. CONNEC ) THEN
                  MINWRK = NR*( M + L + 3 )
               ELSE IF ( FIRST .OR. INTERM ) THEN
                  MINWRK = NR*( M + L + 1 )
               ELSE
                  MINWRK = 2*NR*( M + L + 1 ) + NR
               END IF
            ELSE
               MINWRK = 2*NR
               IF ( ONEBCH .AND. LDR.GE.NS ) THEN
                  IF ( MOESP ) THEN
                     MINWRK = MAX( MINWRK, 5*LNOBR )
                  ELSE
                     MINWRK = 5*LMNOBR + 1
                  END IF
               END IF
               IF ( FIRST ) THEN
                  IF ( LDR.LT.NS ) THEN
                     MINWRK = MINWRK + NR
                  END IF
               ELSE
                  IF ( CONNEC ) THEN
                     MINWRK = MINWRK*( NOBR + 1 )
                  ELSE
                     MINWRK = MINWRK + NR
                  END IF
               END IF
            END IF
C
            MAXWRK = MINWRK
C
            IF( LDWORK.LT.MINWRK ) THEN
               INFO = -23
               DWORK( 1 ) = MINWRK
            END IF
         END IF
      END IF
C
C     Return if there are illegal arguments.
C
      IF( INFO.NE.0 ) THEN
         IF( .NOT.ONEBCH ) THEN
            IWORK(1) = 1
            IWORK(2) = MAXWRK
            IWORK(3) = 0
         END IF
         CALL XERBLA( 'IB01AD', -INFO )
         RETURN
      END IF
C
C     Compress the input-output data.
C     Workspace: need   c*(M+L)*NOBR, where c is a constant depending
C                       on the algorithm and the options used
C                       (see SLICOT Library routine IB01MD);
C                prefer larger.
C
      CALL IB01MD( METH, ALG, BATCH, CONCT, NOBR, M, L, NSMP, U, LDU, Y,
     $             LDY, R, LDR, IWORK, DWORK, LDWORK, IWARN, INFO )
C
      IF ( INFO.EQ.1 ) THEN
C
C        Error return: A fast algorithm was requested (ALG = 'C', 'F')
C        in sequential data processing, but it failed.
C
         RETURN
      END IF
C
      MAXWRK = MAX( MAXWRK, INT( DWORK( 1 ) ) )
C
      IF ( .NOT.LAST ) THEN
C
C        Return to get new data.
C
         ICYCLE = ICYCLE + 1
         IWORK(1) = ICYCLE
         IWORK(2) = MAXWRK
         IWORK(3) = NSMPSM
         RETURN
      END IF
C
C     Find the singular value decomposition (SVD) giving the system
C     order, and perform related preliminary calculations needed for
C     computing the system matrices.
C     Workspace: need   max( (2*M-1)*NOBR, (M+L)*NOBR, 5*L*NOBR ),
C                                            if METH = 'M';
C                            5*(M+L)*NOBR+1, if METH = 'N';
C                prefer larger.
C
      CALL IB01ND( METH, JOBD, NOBR, M, L, R, LDR, SV, RCOND, IWORK,
     $             DWORK, LDWORK, IWARNL, INFO )
      IWARN = MAX( IWARN, IWARNL )
C
      IF ( INFO.EQ.2 ) THEN
C
C        Error return: the singular value decomposition (SVD) algorithm
C        did not converge.
C
         RETURN
      END IF
C
C     Estimate the system order.
C
      CALL IB01OD( CTRL, NOBR, L, SV, N, TOL, IWARNL, INFO )
      IWARN = MAX( IWARN, IWARNL )
C
C     Return optimal workspace in  DWORK(1).
C
      DWORK( 1 ) = MAX( MAXWRK,  INT( DWORK( 1 ) ) )
      IF( .NOT.ONEBCH ) THEN
         IWORK(1) = ICYCLE
         IWORK(2) = MAXWRK
         IWORK(3) = NSMPSM
      END IF
      RETURN
C
C *** Last line of IB01AD ***
      END


c Convert latitude and longitude to kilometers relative
c to center of coordinates by short distance conversion.

	subroutine dist(xlat, xlon, xkm, ykm)

	implicit none

c	Parameters:
	doubleprecision	xlat, xlon	! (input)
	real		xkm, ykm	! (output)

c	Local variables:
	doubleprecision lat1, lat2, lat3
	real	q
	real	xx
	real	yp

	include "geocoord.inc"

c Set up short distance conversion by subr. SETORG
      q=60*xlat-olat
      yp=q+olat
      lat1=datan(rlatc*dtan(RAD*yp/60.0))
      lat2=datan(rlatc*dtan(RAD*OLAT/60.0))
      LAT3=(LAT2+LAT1)/2.
      xx=60*xlon-olon  !  - wegen LON E
      q=q*aa
      xx = xx*bb*dcos(LAT3)
      IF(rotate.ne.0.) then
c** rotate coordinate system anticlockwise
        yp=cost*q+sint*xx
        xx=cost*xx-sint*q
        q=yp
      ENDIF

      xkm=xx
      ykm=q

      return
      end


SUBROUTINE Calculate_Width
    USE FloatPrecision
    USE ArraySize
    USE Parameters
    USE grids
    USE hydro
    USE Topography
    IMPLICIT NONE

    INTEGER :: i , j
    REAL(fp), DIMENSION(NL:NU) :: darea
    REAL(fp) :: c1 , c2 , maxdd

    c1 = 1.3D0
    c2 = 0.9D0
    DO i = ML , MU
        maxdd = c1*TDAMP + dmin1(maxval(DEP0(i,:)),c2*TDAMP)
        IF(maxdd > 0.D0) THEN
            DO j = NL , NU
                darea(j) = dmax1(0.D0,(c1*TDAMP + dmin1(DEP0(i,j),c2*TDAMP)))
            END DO
            B1(i) = (2.D0*sum(darea(:))-darea(NL)-darea(NU))*dx/2.D0/maxdd
        ELSE
            B1(i) = 0.D0 !
        END IF
    END DO

END SUBROUTINE Calculate_Width


C    Copyright(C) 1999-2020 National Technology & Engineering Solutions
C    of Sandia, LLC (NTESS).  Under the terms of Contract DE-NA0003525 with
C    NTESS, the U.S. Government retains certain rights in this software.
C
C    See packages/seacas/LICENSE for details

      subroutine jacob(x1,x2,x3,x4,x5,x6,x7,x8,
     *                 y1,y2,y3,y4,y5,y6,y7,y8,
     *                 z1,z2,z3,z4,z5,z6,z7,z8, JACMN)
      REAL JACOBI, JACMN
      REAL XXI(3), XET(3), XZE(3)

      JACMN = 1.0e38

C... Jacobian at mid-point:

      xxi(1) = x2 + x3 + x6 + x7 - x1 - x4 - x5 - x8
      xet(1) = x3 + x4 + x7 + x8 - x1 - x2 - x5 - x6
      xze(1) = x5 + x6 + x7 + x8 - x1 - x2 - x3 - x4

      xxi(2) = y2 + y3 + y6 + y7 - y1 - y4 - y5 - y8
      xet(2) = y3 + y4 + y7 + y8 - y1 - y2 - y5 - y6
      xze(2) = y5 + y6 + y7 + y8 - y1 - y2 - y3 - y4

      xxi(3) = z2 + z3 + z6 + z7 - z1 - z4 - z5 - z8
      xet(3) = z3 + z4 + z7 + z8 - z1 - z2 - z5 - z6
      xze(3) = z5 + z6 + z7 + z8 - z1 - z2 - z3 - z4

      jacobi = CRSDOT(xxi,xet,xze)/64.0
      jacmn = min(jacobi, jacmn)
C... J(0,0,0):

      xxi(1) = x2 - x1
      xet(1) = x4 - x1
      xze(1) = x5 - x1

      xxi(2) = y2 - y1
      xet(2) = y4 - y1
      xze(2) = y5 - y1

      xxi(3) = z2 - z1
      xet(3) = z4 - z1
      xze(3) = z5 - z1

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,0,0):

      xxi(1) = x2 - x1
      xet(1) = x3 - x2
      xze(1) = x6 - x2

      xxi(2) = y2 - y1
      xet(2) = y3 - y2
      xze(2) = y6 - y2

      xxi(3) = z2 - z1
      xet(3) = z3 - z2
      xze(3) = z6 - z2

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(0,1,0):

      xxi(1) = x3 - x4
      xet(1) = x4 - x1
      xze(1) = x8 - x4

      xxi(2) = y3 - y4
      xet(2) = y4 - y1
      xze(2) = y8 - y4

      xxi(3) = z3 - z4
      xet(3) = z4 - z1
      xze(3) = z8 - z4

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(0,0,1):

      xxi(1) = x6 - x5
      xet(1) = x8 - x5
      xze(1) = x5 - x1

      xxi(2) = y6 - y5
      xet(2) = y8 - y5
      xze(2) = y5 - y1

      xxi(3) = z6 - z5
      xet(3) = z8 - z5
      xze(3) = z5 - z1

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,1,0):

      xxi(1) = x3 - x4
      xet(1) = x3 - x2
      xze(1) = x7 - x3

      xxi(2) = y3 - y4
      xet(2) = y3 - y2
      xze(2) = y7 - y3

      xxi(3) = z3 - z4
      xet(3) = z3 - z2
      xze(3) = z7 - z3

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,0,1):

      xxi(1) = x6 - x5
      xet(1) = x7 - x6
      xze(1) = x6 - x2

      xxi(2) = y6 - y5
      xet(2) = y7 - y6
      xze(2) = y6 - y2

      xxi(3) = z6 - z5
      xet(3) = z7 - z6
      xze(3) = z6 - z2

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(0,1,1):

      xxi(1) = x7 - x8
      xet(1) = x8 - x5
      xze(1) = x8 - x4

      xxi(2) = y7 - y8
      xet(2) = y8 - y5
      xze(2) = y8 - y4

      xxi(3) = z7 - z8
      xet(3) = z8 - z5
      xze(3) = z8 - z4

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

C... J(1,1,1):

      xxi(1) = x7 - x8
      xet(1) = x7 - x6
      xze(1) = x7 - x3

      xxi(2) = y7 - y8
      xet(2) = y7 - y6
      xze(2) = y7 - y3

      xxi(3) = z7 - z8
      xet(3) = z7 - z6
      xze(3) = z7 - z3

      jacobi = CRSDOT(xxi,xet,xze)
      jacmn = min(jacobi, jacmn)

      return
      end

      REAL FUNCTION CRSDOT(a, b, c)
      REAL a(3), b(3), c(3)
C ... Compute d = a dot (b cross c)

      REAL xcross, ycross, zcross

      xcross = b(2) * c(3) - b(3) * c(2)
      ycross = b(3) * c(1) - b(1) * c(3)
      zcross = b(1) * c(2) - b(2) * c(1)

      crsdot = (a(1) * xcross + a(2) * ycross + a(3) * zcross)
      return
      end


!
!     -------------------------------------------------------------
!      N I N E 1 2
!     -------------------------------------------------------------
!
!                                                                  *
!     THIS PACKAGE DETERMINES THE VALUES OF 9j COEFFICIENT         *
!                                                                  *
!     |  J1/2      J2/2  J3/2 |                                    *
!     |  L1/2      L2/2  J3/2 |                                    *
!     |  K1/2 + 1  K1/2    1  |                                    *
!                                                                  *
!     Written by G. Gaigalas,                                      *
!     Vanderbilt University,  Nashville             October 1996   *
!
      SUBROUTINE NINE12(J1, J2, J3, L1, L2, K1, A)
!-----------------------------------------------
!   M o d u l e s
!-----------------------------------------------
      USE vast_kind_param, ONLY:  DOUBLE
      USE CONSTS_C
!...Translated by Pacific-Sierra Research 77to90  4.3E  10:09:06  11/16/01
!...Switches:
!-----------------------------------------------
!   I n t e r f a c e   B l o c k s
!-----------------------------------------------
      USE sixj_I
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER  :: J1
      INTEGER  :: J2
      INTEGER  :: J3
      INTEGER  :: L1
      INTEGER  :: L2
      INTEGER  :: K1
      REAL(DOUBLE) , INTENT(OUT) :: A
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: K2
      REAL(DOUBLE) :: S1, SKAI1, S2, SKAI2, S, VARD
!-----------------------------------------------
      K2 = K1 - 2
      CALL SIXJ (J1, L1, K1, L2, J2, J3, 0, S1)
      SKAI1 = DBLE(J2 - L2 + K1)*DBLE(L2 - J2 + K1)*DBLE(J2 + L2 + K2 + 4)*&
         DBLE(J2 + L2 - K2)
      S1 = S1*DSQRT(SKAI1)
      CALL SIXJ (J1, L1, K2, L2, J2, J3, 0, S2)
      SKAI2 = DBLE(J1 - L1 + K1)*DBLE(L1 - J1 + K1)*DBLE(J1 + L1 + K2 + 4)*&
         DBLE(J1 + L1 - K2)
      S2 = S2*DSQRT(SKAI2)
      S = S1 + S2
!      VARD=DSQRT(DBLE(8*(K2+3)*(K2+2)*(K2+1)*J3*(J3+2)*(J3+1)))
      VARD = DSQRT(DBLE(8*(K2 + 3))*DBLE(K2 + 2)*DBLE(K2 + 1)*DBLE(J3)*DBLE(J3&
          + 2)*DBLE(J3 + 1))
      A = S/VARD
      IF (MOD(L1 + J2 + K2 + J3,4) /= 0) A = -A
      RETURN
      END SUBROUTINE NINE12


! This is a conversion file from FORTRAN77 to Fortran90
! The original source is available online:
!   http://www.bosai.go.jp/study/application/dc3d/download/DC3Dmanual.pdf
program test
    implicit none

    real(8) :: X, Y, Z, DEPTH, DIP, AL1, AL2, AW1, AW2, DISL1, DISL2, DISL3, ALPHA
    real(8) :: UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ
    integer :: IRET

    real(8) :: POT1, POT2, POT3, POT4

    !----- Check DC3D
    X=10.0d0
    Y=20.0d0
    Z=-30.0d0
    !Z=30.0d0
    DEPTH=50.0d0
    DIP=70.0d0
    AL1=-80.0d0
    AL2=120.0d0
    AW1=-30.0d0
    AW2=25.0d0
    DISL1=200.0d0
    DISL2=-150.0d0
    DISL3=100.0d0
    !-----
    write(*,*) '*** OUTPUT OF DC3D ***'
    write(*,'(a,2(f8.2,","))') 'DEPTH, DIP =',DEPTH,DIP
    write(*,'(a,4(f8.2,","))') 'AL1, AL2, AW1, AW2 =',AL1,AL2,AW1,AW2
    write(*,'(a,4(f8.2,","))') 'DISL1, DISL2, DISL3 =',DISL1,DISL2,DISL3
    write(*,'(3(a,f8.2,","))') 'X =',X,' Y =',Y,' Z =',Z
    !-----
    ALPHA=2.0d0/3.0d0
    call DC3D(ALPHA,X,Y,Z,DEPTH,DIP, &
              AL1,AL2,AW1,AW2,DISL1,DISL2,DISL3, &
              UX,UY,UZ,UXX,UYX,UZX,UXY,UYY,UZY,UXZ,UYZ,UZZ,IRET)
    write(*,*)
    write(*,'(a,I1)') 'IRET = ',IRET
    write(*,'(a,3(f11.6,","))') 'UX, UY, UZ =',UX,UY,UZ
    write(*,*) '   ANSWER = -37.8981,    63.1789,    14.9607'
    stop
end program test


!*==sgetf2.f90  processed by SPAG 7.51RB at 20:08 on  3 Mar 2022
!> \brief \b SGETF2 computes the LU factorization of a general m-by-n matrix using partial pivoting with row interchanges (unblocked algorithm).
!
!  =========== DOCUMENTATION ===========
!
! Online html documentation available at
!            http://www.netlib.org/lapack/explore-html/
!
!> \htmlonly
!> Download SGETF2 + dependencies
!>
!> [TGZ]
!>
!> [ZIP]
!>
!> [TXT]
!> \endhtmlonly
!
!  Definition:
!  ===========
!
!       SUBROUTINE SGETF2( M, N, A, LDA, IPIV, INFO )
!
!       .. Scalar Arguments ..
!       INTEGER            INFO, LDA, M, N
!       ..
!       .. Array Arguments ..
!       INTEGER            IPIV( * )
!       REAL               A( LDA, * )
!       ..
!
!
!> \par Purpose:
!  =============
!>
!> \verbatim
!>
!> SGETF2 computes an LU factorization of a general m-by-n matrix A
!> using partial pivoting with row interchanges.
!>
!> The factorization has the form
!>    A = P * L * U
!> where P is a permutation matrix, L is lower triangular with unit
!> diagonal elements (lower trapezoidal if m > n), and U is upper
!> triangular (upper trapezoidal if m < n).
!>
!> This is the right-looking Level 2 BLAS version of the algorithm.
!> \endverbatim
!
!  Arguments:
!  ==========
!
!> \param[in] M
!> \verbatim
!>          M is INTEGER
!>          The number of rows of the matrix A.  M >= 0.
!> \endverbatim
!>
!> \param[in] N
!> \verbatim
!>          N is INTEGER
!>          The number of columns of the matrix A.  N >= 0.
!> \endverbatim
!>
!> \param[in,out] A
!> \verbatim
!>          A is REAL array, dimension (LDA,N)
!>          On entry, the m by n matrix to be factored.
!>          On exit, the factors L and U from the factorization
!>          A = P*L*U; the unit diagonal elements of L are not stored.
!> \endverbatim
!>
!> \param[in] LDA
!> \verbatim
!>          LDA is INTEGER
!>          The leading dimension of the array A.  LDA >= max(1,M).
!> \endverbatim
!>
!> \param[out] IPIV
!> \verbatim
!>          IPIV is INTEGER array, dimension (min(M,N))
!>          The pivot indices; for 1 <= i <= min(M,N), row i of the
!>          matrix was interchanged with row IPIV(i).
!> \endverbatim
!>
!> \param[out] INFO
!> \verbatim
!>          INFO is INTEGER
!>          = 0: successful exit
!>          < 0: if INFO = -k, the k-th argument had an illegal value
!>          > 0: if INFO = k, U(k,k) is exactly zero. The factorization
!>               has been completed, but the factor U is exactly
!>               singular, and division by zero will occur if it is used
!>               to solve a system of equations.
!> \endverbatim
!
!  Authors:
!  ========
!
!> \author Univ. of Tennessee
!> \author Univ. of California Berkeley
!> \author Univ. of Colorado Denver
!> \author NAG Ltd.
!
!> \date December 2016
!
!> \ingroup realGEcomputational
!
!  =====================================================================
      SUBROUTINE SGETF2(M,N,A,Lda,Ipiv,Info)
      IMPLICIT NONE
!*--SGETF2112
!
!  -- LAPACK computational routine (version 3.7.0) --
!  -- LAPACK is a software package provided by Univ. of Tennessee,    --
!  -- Univ. of California Berkeley, Univ. of Colorado Denver and NAG Ltd..--
!     December 2016
!
!     .. Scalar Arguments ..
      INTEGER Info , Lda , M , N
!     ..
!     .. Array Arguments ..
      INTEGER Ipiv(*)
      REAL A(Lda,*)
!     ..
!
!  =====================================================================
!
!     .. Parameters ..
      REAL ONE , ZERO
      PARAMETER (ONE=1.0E+0,ZERO=0.0E+0)
!     ..
!     .. Local Scalars ..
      REAL sfmin
      INTEGER i , j , jp
!     ..
!     .. External Functions ..
      REAL SLAMCH
      INTEGER ISAMAX
      EXTERNAL SLAMCH , ISAMAX
!     ..
!     .. External Subroutines ..
      EXTERNAL SGER , SSCAL , SSWAP , XERBLA
!     ..
!     .. Intrinsic Functions ..
      INTRINSIC MAX , MIN
!     ..
!     .. Executable Statements ..
!
!     Test the input parameters.
!
      Info = 0
      IF ( M<0 ) THEN
         Info = -1
      ELSEIF ( N<0 ) THEN
         Info = -2
      ELSEIF ( Lda<MAX(1,M) ) THEN
         Info = -4
      ENDIF
      IF ( Info/=0 ) THEN
         CALL XERBLA('SGETF2',-Info)
         RETURN
      ENDIF
!
!     Quick return if possible
!
      IF ( M==0 .OR. N==0 ) RETURN
!
!     Compute machine safe minimum
!
      sfmin = SLAMCH('S')
!
      DO j = 1 , MIN(M,N)
!
!        Find pivot and test for singularity.
!
         jp = j - 1 + ISAMAX(M-j+1,A(j,j),1)
         Ipiv(j) = jp
         IF ( A(jp,j)/=ZERO ) THEN
!
!           Apply the interchange to columns 1:N.
!
            IF ( jp/=j ) CALL SSWAP(N,A(j,1),Lda,A(jp,1),Lda)
!
!           Compute elements J+1:M of J-th column.
!
            IF ( j<M ) THEN
               IF ( ABS(A(j,j))>=sfmin ) THEN
                  CALL SSCAL(M-j,ONE/A(j,j),A(j+1,j),1)
               ELSE
                  DO i = 1 , M - j
                     A(j+i,j) = A(j+i,j)/A(j,j)
                  ENDDO
               ENDIF
            ENDIF
!
         ELSEIF ( Info==0 ) THEN
!
            Info = j
         ENDIF
!
!
!           Update trailing submatrix.
!
         IF ( j<MIN(M,N) ) CALL SGER(M-j,N-j,-ONE,A(j+1,j),1,A(j,j+1),  &
     &                               Lda,A(j+1,j+1),Lda)
      ENDDO
!
!     End of SGETF2
!
      END SUBROUTINE SGETF2


c
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c     *                                                               *
c     *                  copyright (c) 1998 by UCAR                   *
c     *                                                               *
c     *       University Corporation for Atmospheric Research         *
c     *                                                               *
c     *                      all rights reserved                      *
c     *                                                               *
c     *                      SPHEREPACK version 3.2                   *
c     *                                                               *
c     *       A Package of Fortran77 Subroutines and Programs         *
c     *                                                               *
c     *              for Modeling Geophysical Processes               *
c     *                                                               *
c     *                             by                                *
c     *                                                               *
c     *                  John Adams and Paul Swarztrauber             *
c     *                                                               *
c     *                             of                                *
c     *                                                               *
c     *         the National Center for Atmospheric Research          *
c     *                                                               *
c     *                Boulder, Colorado  (80307)  U.S.A.             *
c     *                                                               *
c     *                   which is sponsored by                       *
c     *                                                               *
c     *              the National Science Foundation                  *
c     *                                                               *
c     * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * * *
c
c
c
c
c     3/97
c
c     a program for testing all divergence,vorticity and idvt(ec,es,gc,gs) routines
c
c     (1) first set a valid vector field by setting a stream function sf and velocity
c         potential function sv as polys in x,y,z restricted to the sphere.  Then
c         derive (v,w) and dv,vt from sf and sv analytically by differentiation.
c         (see tvha.f)
c
c     (2) compute the coefficients br,bi,cr,ci of (v,w) using vector analysis
c
c     (3) compute the divergence and vorticity of (v,w) using div,vrt (es,ec,gc,gs)
c
c     (4) compare with divergence and vorticity from (1)
c
c     (5) invert dv,vt with idvt(ec,es,gc,gs) and compare with vector field from (1)
c
      program tidvt
c
c     set dimensions with parameter statements
c
      parameter(nnlat= 25,nnlon= 16, nnt = 3)
      parameter(mmdab = (nnlon+2)/2, mmdb = (nnlon+1)/2)
      parameter (lleng= 5*nnlat*nnlat*nnlon,llsav=15*nnlat*nnlat*nnlon)
      dimension work(lleng),wsave(llsav)
      parameter (lldwork = 4*nnlat*nnlat )
      double precision dwork(lldwork)
      dimension br(mmdb,nnlat,nnt),bi(mmdb,nnlat,nnt)
      dimension cr(mmdb,nnlat,nnt),ci(mmdb,nnlat,nnt)
      dimension ad(mmdab,nnlat,nnt),bd(mmdab,nnlat,nnt)
      dimension av(mmdab,nnlat,nnt),bv(mmdab,nnlat,nnt)
      dimension dv(nnlat,nnlon,nnt),vt(nnlat,nnlon,nnt)
      dimension dvsav(nnlat,nnlon,nnt),vtsav(nnlat,nnlon,nnt)
      dimension thetag(nnlat),dtheta(nnlat),dwts(nnlat)
      dimension v(nnlat,nnlon,nnt),w(nnlat,nnlon,nnt)
      dimension vsav(nnlat,nnlon,nnt),wsav(nnlat,nnlon,nnt)
      dimension ptrbd(nnt),ptrbv(nnt)
      double precision dtheta, dwts
c
c     set dimension variables
c
      nlat = nnlat
      nlon = nnlon
      mdab = mmdab
      mdb = mmdb
      nmax = max0(nlat,nlon)

      lwork = lleng
      lsave = llsav
      nt = nnt
      call iout(nlat,"nlat")
      call iout(nlon,"nlon")
      call iout(nt,"  nt")
      isym = 0
      ityp = 0
c
c     set equally spaced colatitude and longitude increments
c
      pi = 4.0*atan(1.0)
      dphi = (pi+pi)/nlon
      dlat = pi/(nlat-1)
c
c     compute nlat gaussian points in thetag
c
      ldwork = lldwork
      call gaqd(nlat,dtheta,dwts,dwork,ldwork,ier)
      do  i=1,nlat
	thetag(i) = dtheta(i)
      end do
      call name("gaqd")
      call iout(ier," ier")
      call vecout(thetag,"thtg",nlat)
c
c     test all divergence and inverse divergence subroutines
c
      do icase=1,4
c
c     icase=1 corresponds to "ec"
c     icase=2 corresponds to "es"
c     icase=3 corresponds to "gc"
c     icase=4 corresponds to "gs"

      call name("****")
      call name("****")
      call iout(icase,"icas")
c
c     set vector field v,w
c
      do k=1,nt
	do j=1,nlon
	  phi = (j-1)*dphi
	  sinp = sin(phi)
	  cosp = cos(phi)
	  do i=1,nlat
	    theta = (i-1)*dlat
	    if (icase.gt.2) theta=thetag(i)
	    cost = cos(theta)
	    sint = sin(theta)
	    x = sint*cosp
	    y = sint*sinp
	    z = cost
	    if (k .eq.1) then
c              sf = x
c              sv = y
c
c          v = -1/sint*dstdp + dsvdt
c
c          w =  1/sint*dsvdp + dstdt
c
c          dv = 1/sint*[d(sint*v)/dt + dwdp]  = dvdt + ct/st*v + 1/st*dwdp
c
c          vt = 1/sint*[-dv/dp + d(sint*w)/dt) = dwdt + ct/st*w - 1/st*dvdp

	       v(i,j,k) = sinp + cost*sinp
	       w(i,j,k) = cosp + cost*cosp
	       dv(i,j,k) = -2.0*sint*sinp
	       vt(i,j,k) = -2.0*sint*cosp
	    else if (k.eq.2) then
C              sf = y
c              sv = z
	       v(i,j,k) = -cosp-sint
	       w(i,j,k) = cost*sinp
	       vt(i,j,k) = -2.*sint*sinp
	       dv(i,j,k) = -2.*cost
	    else if (k.eq.3) then
c              st = x
c              sv = z
	       v(i,j,k) = sinp - sint
	       w(i,j,k) = cost*cosp
	       vt(i,j,k) = -2.*sint*cosp
	       dv(i,j,k) = -2.*cost
	    end if
c
c      save derived vector field,vorticity,divergence for latter comparison
c
	    vtsav(i,j,k) = vt(i,j,k)
	    dvsav(i,j,k) = dv(i,j,k)
	    vsav(i,j,k) = v(i,j,k)
	    wsav(i,j,k) = w(i,j,k)
	  end do
	end do
      end do

      if (icase.eq.1) then

      call name("**ec")
c
c     analyze vector field
c
      call vhaeci(nlat,nlon,wsave,lsave,work,lwork,dwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")

      call vhaec(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdb,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")
c
c     compute divergence,vorticity of (v,w) in dv,vt
c

      call shseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call divec(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("div ")
      call iout(ierror,"ierr")

      call vrtec(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("vrt ")
      call iout(ierror,"ierr")

      else if (icase.eq.2) then

      call name("**es")
c
c     analyze vector field
c
      call vhaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")
      call vhaes(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdb,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call shsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call dives(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("div ")
      call iout(ierror,"ierr")
      call vrtes(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("vrt ")
      call iout(ierror,"ierr")

      else if (icase .eq. 3) then

      call name("**gc")
c
c     analyze vector field
c
      call vhagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")
      call vhagc(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdb,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call shsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call divgc(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("div ")
      call iout(ierror,"ierr")
      call vrtgc(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("vrt ")
      call iout(ierror,"ierr")

      else if (icase .eq. 4) then

      call name("**gs")
c
c     analyze vector field
c
      call vhagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("vhai")
      call iout(ierror,"ierr")
      call vhags(nlat,nlon,isym,nt,v,w,nlat,nlon,br,bi,cr,ci,mdb,
     +nlat,wsave,lsave,work,lwork,ierror)
      call name("vha ")
      call iout(ierror,"ierr")

      call shsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shsi")
      call iout(ierror,"ierr")

      call divgs(nlat,nlon,isym,nt,dv,nlat,nlon,br,bi,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("div ")
      call iout(ierror,"ierr")
      call vrtgs(nlat,nlon,isym,nt,vt,nlat,nlon,cr,ci,mdb,nlat,
     +wsave,lsave,work,lwork,ierror)
      call name("vrt ")
      call iout(ierror,"ierr")

      end if
c
c     compute "error" in dv,vt
c
      err2d = 0.0
      err2v = 0.0
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	      err2d = err2d + (dv(i,j,k)-dvsav(i,j,k))**2
	      err2v = err2v + (vt(i,j,k)-vtsav(i,j,k))**2
	  end do
	end do
      end do
c
c     set and print least squares error in dv
c
      err2d = sqrt(err2d/(nt*nlat*nlon))
      call vout(err2d,"errd")
      err2v = sqrt(err2v/(nt*nlat*nlon))
      call vout(err2v,"errv")
c
c     now recompute (v,w) inverting dv,vt using idvt(ec,es,gc,gs)
c
      do kk=1,nt
      do j=1,nlon
      do i=1,nlat
      v(i,j,kk) = 0.0
      w(i,j,kk) = 0.0
      end do
      end do
      end do

      if (icase.eq.1) then

      call name("**ec")

      call shaeci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaec(nlat,nlon,isym,nt,dv,nlat,nlon,ad,bd,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call shaec(nlat,nlon,isym,nt,vt,nlat,nlon,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhseci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idvtec(nlat,nlon,isym,nt,v,w,nlat,nlon,ad,bd,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ptrbd,ptrbv,ierror)
      call name("idvt")
      call iout(ierror,"ierr")
      call vecout(prtbd,"prtd",nt)
      call vecout(prtbv,"prtv",nt)

      else if (icase.eq.2) then

      call name("**es")

      call shaesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shaes(nlat,nlon,isym,nt,dv,nlat,nlon,ad,bd,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call shaes(nlat,nlon,isym,nt,vt,nlat,nlon,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)

      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsesi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idvtes(nlat,nlon,isym,nt,v,w,nlat,nlon,ad,bd,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ptrbd,ptrbv,ierror)
      call name("idvt")
      call iout(ierror,"ierr")
      call vecout(prtbd,"prtd",nt)
      call vecout(prtbv,"prtv",nt)

      else if (icase.eq.3) then

      call name("**gc")

      call shagci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shagc(nlat,nlon,isym,nt,dv,nlat,nlon,ad,bd,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call shagc(nlat,nlon,isym,nt,vt,nlat,nlon,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)

      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsgci(nlat,nlon,wsave,lsave,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idvtgc(nlat,nlon,isym,nt,v,w,nlat,nlon,ad,bd,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ptrbd,ptrbv,ierror)
      call name("idvt")
      call iout(ierror,"ierr")
      call vecout(prtbd,"prtd",nt)
      call vecout(prtbv,"prtv",nt)

      else if (icase.eq.4) then

      call name("**gs")

      call shagsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("shai")
      call iout(ierror,"ierr")

      call shags(nlat,nlon,isym,nt,dv,nlat,nlon,ad,bd,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)
      call shags(nlat,nlon,isym,nt,vt,nlat,nlon,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ierror)

      call name("sha ")
      call iout(ierror,"ierr")
      call iout(lsave,"lsav")
      call iout(lwork,"lwrk")

      call vhsgsi(nlat,nlon,wsave,lsave,work,lwork,dwork,ldwork,ierror)
      call name("idvi")
      call iout(ierror,"ierr")

      call idvtgs(nlat,nlon,isym,nt,v,w,nlat,nlon,ad,bd,av,bv,
     +mdab,nlat,wsave,lsave,work,lwork,ptrbd,ptrbv,ierror)
      call name("idvt")
      call iout(ierror,"ierr")
      call vecout(prtbd,"prtd",nt)
      call vecout(prtbv,"prtv",nt)

      end if

c
c     compare this v,w with original derived from sf,sv
c
      err2v = 0.0
      err2w = 0.0
      do k=1,nt
	do j=1,nlon
	  do i=1,nlat
	    err2v = err2v + (v(i,j,k)-vsav(i,j,k))**2
	    err2w = err2w + (w(i,j,k)-wsav(i,j,k))**2
	  end do
	end do
      end do
      err2v = sqrt(err2v/(nlat*nlon*nt))
      err2w = sqrt(err2w/(nlat*nlon*nt))
      call vout(err2v,"errv")
      call vout(err2w,"errw")
c
c     end of icase loop
c
      end do
      end
c
      subroutine iout(ivar,nam)
      real nam
      write(6,10) nam , ivar
   10 format(1h a4, 3h = ,i8)
      return
      end
c
      subroutine vout(var,nam)
      real nam
      write(6,10) nam , var
   10 format(1h a4,3h = ,e12.5)
      return
      end
c
      subroutine name(nam)
      real nam
      write(6,100) nam
  100 format(1h a8)
      return
      end
c
      subroutine vecout(vec,nam,len)
      dimension vec(len)
      real nam
      write(6,109) nam, (vec(l),l=1,len)
  109 format(1h a4,/(1h 8e11.4))
      return
      end


      SUBROUTINE chstwo(bins1,bins2,nbins,knstrn,df,chsq,prob)
      INTEGER knstrn,nbins
      REAL chsq,df,prob,bins1(nbins),bins2(nbins)
CU    USES gammq
      INTEGER j
      REAL gammq
      df=nbins-knstrn
      chsq=0.
      do 11 j=1,nbins
        if(bins1(j).eq.0..and.bins2(j).eq.0.)then
          df=df-1.
        else
          chsq=chsq+(bins1(j)-bins2(j))**2/(bins1(j)+bins2(j))
        endif
11    continue
      prob=gammq(0.5*df,0.5*chsq)
      return
      END

NR-Functions/Numerical Recipes- Example & Functions/Functions/chstwo.for


subroutine integrated_temperature(input_array,lon,lat,time,output_array)
	implicit none
	integer, intent(in) :: lon,lat,time
	integer :: x,y,t,mone,none
	double precision, intent(in) :: input_array(lon,lat,time)
	double precision, intent(out) :: output_array(lon,lat,time)
        double precision ::a
	a =0.02040816
	mone=lon - 3
	none=lat - 3
	do 20,t=1,time
	  do 10, x=4,mone
	   do 5, y=4,none
	   output_array(x,y,t) = ((input_array(x-3,y-3,t)+input_array(x-3,y-2,t)+input_array(x-3,y-1,t) &
		                + input_array(x-3,y,t)  +input_array(x-3,y+1,t)+input_array(x-3,y+2,t) &
				+ input_array(x-3,y+3,t) &
                                + input_array(x-2,y-3,t)+input_array(x-2,y-2,t)+input_array(x-2,y-1,t) &
		                + input_array(x-2,y,t)  +input_array(x-2,y+1,t)+input_array(x-2,y+2,t) &
				+ input_array(x-2,y+3,t) &
                                + input_array(x-1,y-3,t)+input_array(x-1,y-2,t)+input_array(x-1,y-1,t) &
		                + input_array(x-1,y,t)  +input_array(x-1,y+1,t)+input_array(x-1,y+2,t) &
				+ input_array(x-1,y+3,t) &
			        + input_array(x,y-3,t)+input_array(x,y-2,t)+input_array(x,y-1,t) &
		                + input_array(x,y,t)  +input_array(x,y+1,t)+input_array(x,y+2,t) &
				+ input_array(x,y+3,t) &
                                + input_array(x+1,y-3,t)+input_array(x+1,y-2,t)+input_array(x+1,y-1,t) &
		                + input_array(x+1,y,t)  +input_array(x+1,y+1,t)+input_array(x+1,y+2,t) &
				+ input_array(x+1,y+3,t) &
                                + input_array(x+2,y-3,t)+input_array(x+2,y-2,t)+input_array(x+2,y-1,t) &
		                + input_array(x+2,y,t)  +input_array(x+2,y+1,t)+input_array(x+2,y+2,t) &
				+ input_array(x+2,y+3,t) &
                                + input_array(x+3,y-3,t)+input_array(x+3,y-2,t)+input_array(x+3,y-1,t) &
		                + input_array(x+3,y,t)  +input_array(x+3,y+1,t)+input_array(x+3,y+2,t) &
				+ input_array(x+3,y+3,t))/49)

5          end do
10         end do
20	end do
	end subroutine integrated_temperature


program test_sto_he
use types, only: dp
use sto, only: stoints2, get_basis2
use utils, only: assert
use radialscf, only: doscf, kinetic_energy
use hfprint, only: printall, printlam
implicit none

integer, allocatable :: nl(:, :), nbfl(:)
real(dp), allocatable :: zl(:, :), focc(:, :)

real(dp), allocatable :: S(:, :, :), T(:, :, :), V(:, :, :), slater(:, :)
integer :: n, Z, m, Nscf, Lmax, ndof
real(dp) :: alpha, Etot, tolE, tolP, Ekin
real(dp), allocatable :: H(:, :, :), P_(:, :, :), C(:, :, :), lam(:, :)

allocate(nbfl(0:0), nl(5, 0:0), zl(5, 0:0), focc(1, 0:0))
nbfl = 0
focc = 0
focc(:1, 0) = [2]
nbfl(0) = 5
nl(:5, 0) = [1, 1, 1, 1, 1]
zl(:5, 0) = [1.41714_dp, 2.37682_dp, 4.39628_dp, 6.52699_dp, 7.94252_dp]

Z = 2
tolE = 1e-10_dp
tolP = 1e-4_dp
alpha = 0.6_dp
Nscf = 100

n = maxval(nbfl)
Lmax = ubound(nbfl, 1)
ndof = sum(nbfl)
print *, "total  DOFs =", ndof
allocate(H(n, n, 0:Lmax), S(n, n, 0:Lmax), T(n, n, 0:Lmax), V(n, n, 0:Lmax))
m = ndof*(ndof+1)/2
allocate(slater(m*(m+1)/2, 0:2*Lmax))
call stoints2(Z, nbfl, nl, zl, S, T, V, slater)

allocate(P_(n, n, 0:Lmax), C(n, n, 0:Lmax), lam(n, 0:Lmax))

H = T + V

print *, "SCF cycle:"
call doscf(nbfl, H, slater, S, focc, Nscf, tolE, tolP, alpha, C, P_, lam, Etot)
Ekin = kinetic_energy(nbfl, P_, T)
call printall(nbfl, nl, zl, lam, C, Ekin, Etot)
call printlam(nbfl, lam, Ekin, Etot)

call assert(abs(Etot - (-0.28616799E+01_dp)) < 1e-7_dp)
call assert(abs(lam(1, 0) - (-0.917948_dp)) < 1e-6_dp)

end program


	! integrates hmf model by rk4 method and finds the variation of temperature and order parameter (magnetization) with energy per particle

	implicit none

	integer, parameter :: mm=100, nn=2*mm
	integer, parameter :: nh=50, tran=10000, iter=20000
	double precision   :: xx(nn), yy(nn), dy(nn)
	double precision   :: tau, dtau, amp, omega, r, phi
 	double precision   :: pi, pi2, grnd, omega_span(5)
	integer            :: i,j,k,l,m,n,tran1,itlen
	double precision   :: KE, PE, H, U, a, Tavg, Ravg, Uavg

	common amp, omega

	pi   = 4.0d0*datan(1.0d0); pi2 = 2.0d0*pi!defining paramter values
	tau  = 0.0d0; dtau = 0.01d0
	tran1=tran+1; itlen=iter-tran

	amp=1.0d0
	omega_span(1)=5.0d0; omega_span(2)=10.0d0; omega_span(3)=50.0d0;!diff combination of frequency w
	omega_span(4)=1.0d0; omega_span(5)=100.0d0;

	call sgrnd(148)

	open (unit=1,file='Khmfsmall.dat',status='unknown')!opening a file to write

	do l = 1, 5	! omega

	omega = omega_span(l)

	do i = 1, 50	! energy per particle

	U = i*0.1d0; H = U*mm
	Tavg=0.0d0; Ravg=0.0d0; Uavg=0.0d0

	do j = 1, nh	! history

	do n = 1, mm
	yy(n) = 0.1*(grnd()-0.5d0)
	end do

	PE = 0.0d0
	do m = 2, mm
	do n = 1, mm
	PE = PE + dcos(yy(m)-yy(n))
	end do
	PE=PE+abs(amp*cos(omega*tau))*dcos(yy(1)-yy(n))
	end do
	PE = (1/nn)*(mm**2-PE)

	a = 2.0d0*sqrt((12.0d0/nn)*(H-PE))

	do n = mm+1, nn
        yy(n) = a*(grnd()-0.5d0)
        end do

	do k = 1, tran	! transients

	call derivs(tau,yy,dy)
        call rk4(yy,dy,nn,tau,dtau,xx,derivs)

	yy = xx

	end do	! transients

	do k = tran1, iter	! iterations

	call derivs(tau,yy,dy)
        call rk4(yy,dy,nn,tau,dtau,xx,derivs)

	yy = xx

	call order_parameter(xx,r,phi)!calling order paramater

	KE = 0.0d0
	do n = mm+1, nn
	KE = KE + yy(n)**2
	end do
	KE = KE/2.0d0

        PE = 0.0d0
	do m = 2, mm
	do n = 1, mm
	PE = PE + dcos(yy(m)-yy(n))
	end do
	PE=PE+abs(amp*cos(omega*tau))*dcos(yy(1)-yy(n))
	end do
	PE = (1/nn)*(mm**2-PE)

	H = PE + KE

	!write(1,'(41(xf12.6))') H/mm, 2*KE/mm, r

	Uavg = Uavg + H/mm
	Tavg = Tavg + 2*KE/mm
	Ravg = Ravg + r

	end do	! iterations

        end do	! history

	Uavg = Uavg/(nh*itlen)
	Tavg = Tavg/(nh*itlen)
	Ravg = Ravg/(nh*itlen)

	write(1,'(41(xf10.6))') omega, Uavg, Tavg, Ravg!writing average values to datafile

	end do	! energy per particle

	write(1,'(41(xf10.6))')

	end do	! amplitude

	end program

!----------------------------------------------------------------------------- calculates the time derivative ------------------------------------------

        subroutine derivs(tau,yy,dy)

        integer, parameter :: mm=100, nn=2*mm
	double precision   :: yy(nn), dy(nn)
	double precision   :: pi, tau, dtau
	integer            :: i, j, k, l, m, n
        double precision   :: kk, amp, omega, r, phi

	common amp, omega

	call order_parameter(yy,r,phi)

	kk = abs(amp*dcos(omega*tau))

        do i = 1, mm
        dy(i) = yy(mm+i)
        end do

	do i = mm+2, nn
        dy(i) = r*dsin(phi-yy(i-mm))
	dy(mm+1) = kk*r*dsin(phi-yy(i-mm))
        end do

        return
        end subroutine

!---------------------------------------------------------------- finds the magnitude and phase of the order parameter--------------------------------------

	subroutine order_parameter(theta,r,phi)

        integer, parameter :: mm=100, nn=2*mm
        double precision   :: theta(nn)
        double precision   :: r, phi, real_sum, imag_sum

        real_sum = 0.0d0
        imag_sum = 0.0d0

        do j=1,mm
        real_sum = real_sum + dcos(theta(j))
        imag_sum = imag_sum + dsin(theta(j))
        enddo

        real_sum = real_sum/mm
        imag_sum = imag_sum/mm
        r = dsqrt((real_sum)**2 + (imag_sum)**2)
        phi = dacos(real_sum/r)

        return
        end

!---------------------------------------------------------------------------Subroutine for RK$ algorithm---------------------------------------------------------

	SUBROUTINE rk4(y,dydx,n,x,h,yout,derivs)

	INTEGER n,NMAX
	REAL*8 h,x,dydx(n),y(n),yout(n)
	EXTERNAL derivs
	PARAMETER (NMAX=200)
	INTEGER i
	REAL*8 h6,hh,xh,dym(NMAX),dyt(NMAX),yt(NMAX)

	hh=h*0.5
	h6=h/6.
	xh=x+hh

	do i=1,n
        yt(i)=y(i)+hh*dydx(i)
	end do

	call derivs(xh,yt,dyt)
	do i=1,n
        yt(i)=y(i)+hh*dyt(i)
	end do

	call derivs(xh,yt,dym)
	do i=1,n
        yt(i)=y(i)+h*dym(i)
        dym(i)=dyt(i)+dym(i)
	end do

	call derivs(x+h,yt,dyt)
	do i=1,n
        yout(i)=y(i)+h6*(dydx(i)+dyt(i)+2.*dym(i))
	end do

	return
	END

	include 'mt.f'