    MODULE blas_extended_mat_mat_op

      ! Fortran 95 Bindings Generic Interface Blocks
      ! .  for section 4.?.? -- Matrix-Matrix Operations
      ! .  using external procedures.
      ! Written on 18 December 2000
      ! .  Susan Blackford, UT-ICL

      PRIVATE
      PUBLIC :: gemm, symm, hemm, trmm, trsm, syrk, herk, syr2k, her2k

      INTERFACE gemm
        ! gemm  a, b and c rank 2
        ! gemv  a rank 2; b and c rank 1
        ! ger,geru,gerc   a and b rank 1; c rank 2 (called ger)
        ! For c, rank 2, c has shape (m,n)
        ! .   a has shape (m,k) if transa = blas_no_trans (the default)
        ! .               (k,m) if transa /= blas_no_trans
        ! .               (m) if rank 1
        ! .   b has shape (k,n) if transb = blas_no_trans (the default)
        ! .               (n,k) if transb /= blas_no_trans
        ! .               (n) if rank 1
        ! For c, rank 1, c has shape (m)
        ! .   a has shape (m,n) if transa = blas_no_trans (the default)
        ! .               (n,m) if transa /= blas_no_trans
        ! .   b has shape (n)
        SUBROUTINE gemm_d(a,b,c,transa,transb,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa, transb
        END SUBROUTINE gemm_d
        SUBROUTINE gemv_d(a,b,c,transa,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa
        END SUBROUTINE gemv_d
        SUBROUTINE ger_d(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ger_d
        SUBROUTINE gemm_z(a,b,c,transa,transb,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa, transb
        END SUBROUTINE gemm_z
        SUBROUTINE gemv_z(a,b,c,transa,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa
        END SUBROUTINE gemv_z
        SUBROUTINE ger_z(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ger_z
        SUBROUTINE gemm_s(a,b,c,transa,transb,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa, transb
        END SUBROUTINE gemm_s
        SUBROUTINE gemv_s(a,b,c,transa,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa
        END SUBROUTINE gemv_s
        SUBROUTINE ger_s(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ger_s
        SUBROUTINE gemm_c(a,b,c,transa,transb,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa, transb
        END SUBROUTINE gemm_c
        SUBROUTINE gemv_c(a,b,c,transa,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_side_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: transa
        END SUBROUTINE gemv_c
        SUBROUTINE ger_c(a,b,c,alpha,beta)
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
        END SUBROUTINE ger_c
      END INTERFACE

      INTERFACE symm
        ! symm  a, b and c rank 2
        ! symv  a rank 2; b and c rank 1
        ! For c, rank 2, c has shape (m,n)
        ! .   b has same shape as c
        ! .   a has shape (m,m) if  side = blas_left_side (the default)
        ! .     has shape (n,n) if  side /= blas_left_side
        ! For c, rank 1, c has shape (m)
        ! .   b has same shape as c
        ! .   a has shape (m,m)
        SUBROUTINE symm_d(a,b,c,side,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symm_d
        SUBROUTINE symv_d(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symv_d
        SUBROUTINE symm_z(a,b,c,side,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symm_z
        SUBROUTINE symv_z(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symv_z
        SUBROUTINE symm_s(a,b,c,side,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symm_s
        SUBROUTINE symv_s(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symv_s
        SUBROUTINE symm_c(a,b,c,side,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symm_c
        SUBROUTINE symv_c(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE symv_c
      END INTERFACE

      INTERFACE hemm
        ! hemm  a, b and c rank 2
        ! hemv  a rank 2; b and c rank 1
        ! For c, rank 2, c has shape (m,n)
        ! .   b has same shape as c
        ! .   a has shape (m,m) if  side = blas_left_side (the default)
        ! .     has shape (n,n) if  side /= blas_left_side
        ! For c, rank 1, c has shape (m)
        ! .   b has same shape as c
        ! .   a has shape (m,m)
        SUBROUTINE hemm_z(a,b,c,side,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hemm_z
        SUBROUTINE hemv_z(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hemv_z
        SUBROUTINE hemm_c(a,b,c,side,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hemm_c
        SUBROUTINE hemv_c(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE hemv_c
      END INTERFACE

      INTERFACE trmm
        ! trsm  t and b rank 2
        ! trmv  t rank 2; b rank 1
        ! For b, rank 2, b has shape (m,n)
        ! .   t has shape (m,m) if  side = blas_left_side (the default)
        ! .     has shape (n,n) if  side /= blas_left_side
        ! For b, rank 1, b has shape (m)
        ! .   t has shape (m,m)
        SUBROUTINE trmm_d(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmm_d
        SUBROUTINE trmv_d(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmv_d
        SUBROUTINE trmm_z(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmm_z
        SUBROUTINE trmv_z(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmv_z
        SUBROUTINE trmm_s(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmm_s
        SUBROUTINE trmv_s(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmv_s
        SUBROUTINE trmm_c(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmm_c
        SUBROUTINE trmv_c(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trmv_c
      END INTERFACE

      INTERFACE trsm
        ! trsm  t and b rank 2
        ! trsv  t rank 2; b rank 1
        ! For b, rank 2, b has shape (m,n)
        ! .   t has shape (m,m) if  side = blas_left_side (the default)
        ! .     has shape (n,n) if  side /= blas_left_side
        ! For b, rank 1, b has shape (m)
        ! .   t has shape (m,m)
        SUBROUTINE trsm_d(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsm_d
        SUBROUTINE trsv_d(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsv_d
        SUBROUTINE trsm_z(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsm_z
        SUBROUTINE trsv_z(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsv_z
        SUBROUTINE trsm_s(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsm_s
        SUBROUTINE trsv_s(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: t(:,:)
          REAL (wp), INTENT (INOUT) :: b(:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsv_s
        SUBROUTINE trsm_c(t,b,side,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_side_type, &
           blas_trans_type, blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_side_type), INTENT (IN), OPTIONAL :: side
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsm_c
        SUBROUTINE trsv_c(t,b,uplo,trans,diag,alpha)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type, &
           blas_diag_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: t(:,:)
          COMPLEX (wp), INTENT (INOUT) :: b(:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
          TYPE (blas_diag_type), INTENT (IN), OPTIONAL :: diag
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
        END SUBROUTINE trsv_c
      END INTERFACE

      INTERFACE syrk
        ! syrk  a and c rank 2
        ! syr  c rank 2; a rank 1
        ! c has shape (n,n)
        ! . For a, rank 2
        ! .   a has shape (n,k) if  trans = blas_no_trans (the default)
        ! .     has shape (k,n) if  trans /= blas_no_trans
        ! . For a, rank 1
        ! .   a has shape (n)
        SUBROUTINE syrk_d(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syrk_d
        SUBROUTINE syr_d(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr_d
        SUBROUTINE syrk_z(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syrk_z
        SUBROUTINE syr_z(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr_z
        SUBROUTINE syrk_s(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syrk_s
        SUBROUTINE syr_s(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr_s
        SUBROUTINE syrk_c(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syrk_c
        SUBROUTINE syr_c(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr_c
      END INTERFACE

      INTERFACE herk
        ! herk  a and c rank 2
        ! her  c rank 2; a rank 1
        ! c has shape (n,n)
        ! . For a, rank 2
        ! .   a has shape (n,k) if  trans = blas_no_trans (the default)
        ! .     has shape (k,n) if  trans /= blas_no_trans
        ! . For a, rank 1
        ! .   a has shape (n)
        SUBROUTINE herk_z(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE herk_z
        SUBROUTINE her_z(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE her_z
        SUBROUTINE herk_c(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE herk_c
        SUBROUTINE her_c(a,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE her_c
      END INTERFACE

      INTERFACE syr2k
        ! syr2k  a, b and c rank 2
        ! syr2  c rank 2; a and b rank 1
        ! c has shape (n,n)
        ! . For a, rank 2
        ! .   a has shape (n,k) if  trans = blas_no_trans (the default)
        ! .     has shape (k,n) if  trans /= blas_no_trans
        ! .   b has same shape as a
        ! . For a, rank 1
        ! .   a has shape (n)
        ! .   b has same shape as a
        SUBROUTINE syr2k_d(a,b,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2k_d
        SUBROUTINE syr2_d(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          REAL (wp), INTENT (IN) :: a(:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2_d
        SUBROUTINE syr2k_z(a,b,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2k_z
        SUBROUTINE syr2_z(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2_z
        SUBROUTINE syr2k_s(a,b,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:,:), b(:,:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2k_s
        SUBROUTINE syr2_s(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          REAL (wp), INTENT (IN) :: a(:), b(:)
          REAL (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2_s
        SUBROUTINE syr2k_c(a,b,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2k_c
        SUBROUTINE syr2_c(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha, beta
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE syr2_c
      END INTERFACE

      INTERFACE her2k
        ! her2k  a, b and c rank 2
        ! her2  c rank 2; a and b rank 1
        ! c has shape (n,n)
        ! . For a, rank 2
        ! .   a has shape (n,k) if  trans = blas_no_trans (the default)
        ! .     has shape (k,n) if  trans /= blas_no_trans
        ! .   b has same shape as a
        ! . For a, rank 1
        ! .   a has shape (n)
        ! .   b has same shape as a
        SUBROUTINE her2k_z(a,b,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: beta
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE her2k_z
        SUBROUTINE her2_z(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => dp
          COMPLEX (wp), INTENT (IN) :: a(:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: beta
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE her2_z
        SUBROUTINE her2k_c(a,b,c,uplo,trans,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type, blas_trans_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:,:), b(:,:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: beta
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_trans_type), INTENT (IN), OPTIONAL :: trans
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE her2k_c
        SUBROUTINE her2_c(a,b,c,uplo,alpha,beta)
          USE blas_operator_arguments, ONLY : blas_uplo_type
          USE blas_precision, ONLY : wp => sp
          COMPLEX (wp), INTENT (IN) :: a(:), b(:)
          COMPLEX (wp), INTENT (INOUT) :: c(:,:)
          REAL (wp), INTENT (IN), OPTIONAL :: beta
          COMPLEX (wp), INTENT (IN), OPTIONAL :: alpha
          TYPE (blas_uplo_type), INTENT (IN), OPTIONAL :: uplo
        END SUBROUTINE her2_c
      END INTERFACE

    END MODULE blas_extended_mat_mat_op


C * * * * * * * * * * * * * * *
C --- DRIVER FOR RADAR5
C * * * * * * * * * * * * * * *
C       Use make command (relevant to Makefile)

        IMPLICIT REAL*8 (A-H,O-Z)

        REAL*4 TARRAY(2)
        INTEGER, PARAMETER :: DP=kind(1D0)
C --->  PARAMETERS FOR RADAR5 (FULL JACOBIAN) <---
        INTEGER, PARAMETER :: ND=3
        INTEGER, PARAMETER :: NRDENS=2
        INTEGER, PARAMETER :: NGRID=0
        INTEGER, PARAMETER :: NLAGS=1
        INTEGER, PARAMETER :: NJACL=4
        INTEGER, PARAMETER :: MXST=4000
        INTEGER, PARAMETER :: LWORK=30
        INTEGER, PARAMETER :: LIWORK=30
        REAL(kind=DP), dimension(ND) :: Y
        REAL(kind=DP), dimension(NGRID+1) :: GRID
        REAL(kind=DP), dimension(LWORK) :: WORK
        INTEGER, dimension(LIWORK) :: IWORK
        INTEGER, dimension(NRDENS+2) :: IPAST
        REAL(kind=DP), dimension(3) :: RPAR
        REAL(kind=DP), dimension(1) :: Y1
        REAL(kind=DP), dimension(1) :: Y2
        REAL(kind=DP), dimension(1) :: Y3
        REAL(kind=DP), dimension(3) :: RTOL
        REAL(kind=DP), dimension(3) :: ATOL
        INTEGER, dimension(23) :: ISTAT
        EXTERNAL  FCN,PHI,ARGLAG,JFCN,JACLAG,QFUN,SOLOUT

C ------ FILE TO OPEN ----------
        OPEN(9,FILE='sol.out')
        OPEN(10,FILE='cont.out')
        REWIND 9
        REWIND 10

        TOL=1.D-9

C       PARAMETERS IN THE DIFFERENTIAL EQUATION
C ---   rho
        RPAR(1)=2.9D0
C ---   tau
        RPAR(2)=21.D0/50.D0
C ---   alpha
        RPAR(3)=0.1D0

C -----------------------------------------------------------------------
C
C --- DIMENSION OF THE SYSTEM
        N=ND
C --- COMPUTE THE JACOBIAN ANALYTICALLY
        IJAC=1
C --- JACOBIAN IS A FULL MATRIX
        MLJAC=N
C --- DIFFERENTIAL EQUATION IS IN IMPLICIT FORM
        IMAS=2
	  MLMAS=N
C --- OUTPUT ROUTINE IS USED DURING INTEGRATION
        IOUT=1
C --- INITIAL VALUES
        X=0.0D0
        Y(1)=33.D-2
        Y(2)=222.D-2
        Y(3)=-0.1D0
C       Consistent with initial function
C --- DELAY
        TAU=RPAR(2)
C --- ENDPOINT OF INTEGRATION
        XEND=30.0D0
C       XEND=6.D0
C --- REQUIRED (RELATIVE AND ABSOLUTE) TOLERANCE
        ITOL=1
C       TOL=1.D-6
        TFAC=1.D-3
C       TFAC=1.D0
        RTOL(1)=TOL
        RTOL(2)=TOL
        RTOL(3)=TOL
        ATOL(1)=RTOL(1)
        ATOL(2)=RTOL(2)
        ATOL(3)=RTOL(3)*TFAC
C --- INITIAL STEP SIZE
        H=1.0D-6
C --- DEFAULT VALUES FOR PARAMETERS
        DO 10 I=1,20
        IWORK(I)=0
  10    WORK(I)=0.0D0
C       IWORK(3)=50
C --- MAX NUMBER OF STEPS
        IWORK(2)=100000
C --- ERROR CONTROL
        IWORK(8)=1
        IWORK(11)=0
C     BREAKING POINTS SEARCH
        WORK(11)=2.D0
C --- WORKSPACE FOR PAST
        IWORK(12)=MXST
C --- THE SECOND COMPONENT USES RETARDED ARGUMENT
        IWORK(15)=NRDENS
        IPAST(1)=1
        IPAST(2)=3
C --- SET THE PRESCRIBED GRID-POINTS
       DO I=1,NGRID
        GRID(I)=I*TAU
       END DO
C --- WORKSPACE FOR GRID
       IWORK(13)=NGRID
C --- CONTROL OF NEWTON ITERATION
       IWORK(14)=1
C --- NEUTRAL PROBLEM
C --- DERIVATIVE COMPONENTS
       IWORK(16)=1
       IPAST(NRDENS+1)=1
C _____________________________________________________________________
C --- CALL OF THE SUBROUTINE RADAR5
        CALL DTIME(TARRAY)
        CALL RADAR5(N,FCN,PHI,ARGLAG,X,Y,XEND,H,
     &                  RTOL,ATOL,ITOL,
     &                  JFCN,IJAC,MLJAC,MUJAC,
     &                  JACLAG,NLAGS,NJACL,
     &                  IMAS,SOLOUT,IOUT,
     &                  WORK,IWORK,RPAR,IPAR,IDID,
     &                  GRID,IPAST,QFUN,MLMAS,MUMAS)
        CALL DTIME(TARRAY)

C --- PRINT FINAL SOLUTION SOLUTION
        WRITE (6,*) X,Y(1),Y(2),Y(3)
C --- PRINT STATISTICS
         DO J=14,20
            ISTAT(J)=IWORK(J)
         END DO
        WRITE(6,*)' ***** TOL=',TOL,'  ELAPSED TIME=',TARRAY(1),' ****'
        WRITE (6,91) (ISTAT(J),J=14,20)
        WRITE (6,92) ISTAT(23)

 90     FORMAT(1X,'X =',F8.2,'    Y =',3E20.12)
 91     FORMAT(' fcn=',I5,' jac=',I5,' step=',I5,
     &        ' accpt=',I5,' rejct=',I5,' dec=',I5,
     &        ' sol=',I5)
 92     FORMAT(' full Newt. its =',I7)
        WRITE(6,*) 'SOLUTION IS TABULATED IN FILES: sol.out & cont.out'

        CLOSE(9)
        CLOSE(10)

        STOP
        END
C
C
        SUBROUTINE SOLOUT (NR,XOLD,X,HSOL,Y,CONT,LRC,N,
     &                     RPAR,IPAR,IRTRN)
C ----- PRINTS THE DISCRETE OUTPUT AND THE CONTINUOUS OUTPUT
C       AT EQUIDISTANT OUTPUT-POINTS
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), PARAMETER :: XSTEP=0.001D0
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LRC) :: CONT
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI
C       XOUT IS USED FOR THE DENSE OUTPUT
        COMMON /INTERN/XOUT

        WRITE (9,99) X,Y(1),Y(2),Y(3)

        IF (NR.EQ.1) THEN
           WRITE (10,99) X,Y(1),Y(2),Y(3)
           XOUT=XSTEP
        ELSE
 10        CONTINUE
           IF (X.GE.XOUT) THEN
C ---   CONTINUOUS OUTPUT FOR RADAU5
              WRITE (10,99) XOUT,
     &         CONTR5(1,N,XOUT,CONT,X,HSOL),
     &         CONTR5(2,N,XOUT,CONT,X,HSOL),
     &         CONTR5(3,N,XOUT,CONT,X,HSOL)
              XOUT=XOUT+XSTEP
              GOTO 10
           END IF
        END IF
  99     FORMAT(1X,'X =',F12.6,'    Y =',3F12.6)
C 99     FORMAT(1X,'X =',F12.6,'    Y =',3E23.15)

        RETURN
        END
C
        FUNCTION ARGLAG(IL,X,Y,RPAR,IPAR,
     &                  PHI,PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: Y
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        INTEGER, dimension(1) :: IPAR
        REAL(kind=DP), dimension(1) :: RPAR

        ARGLAG=X-RPAR(2)

        RETURN
        END
C
        SUBROUTINE FCN(N,X,Y,F,ARGLAG,PHI,RPAR,IPAR,
     &                  PAST,IPAST,NRDS)
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(N) :: F
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        rho=RPAR(1)
        tau=RPAR(2)
        alpha=RPAR(3)

        Y12=Y(1)*Y(1)
        CALL LAGR5(1,X,Y,ARGLAG,PAST,THETA,IPOS,RPAR,IPAR,
     &             PHI,IPAST,NRDS)
        Y1L1=YLAGR5(1,THETA,IPOS,PHI,RPAR,IPAR,PAST,IPAST,NRDS)
        Y3L1=YLAGR5(3,THETA,IPOS,PHI,RPAR,IPAR,PAST,IPAST,NRDS)

        F1=Y(1)*(1.D0-Y1L1-rho*Y3L1) - Y(2)*Y12/(1.D0+Y12)
        F(1)=F1
        F(2)=Y(2)*(Y12/(1.D0+Y12)-alpha)
        F(3)=F1 - Y(3)

        RETURN
        END
C
        SUBROUTINE JFCN(N,X,Y,DFY,LDFY,ARGLAG,PHI,RPAR,IPAR,
     &                  PAST,IPAST,NRDS)
C ----- STANDARD JACOBIAN OF THE EQUATION
        IMPLICIT REAL*8 (A-H,K,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(LDFY,N) :: DFY
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        EXTERNAL PHI

        rho=RPAR(1)
        tau=RPAR(2)
        alpha=RPAR(3)

        Y12=Y(1)*Y(1)
        CALL LAGR5(1,X,Y,ARGLAG,PAST,THETA,IPOS,RPAR,IPAR,
     &             PHI,IPAST,NRDS)
        Y1L1=YLAGR5(1,THETA,IPOS,PHI,RPAR,IPAR,PAST,IPAST,NRDS)
        Y3L1=YLAGR5(3,THETA,IPOS,PHI,RPAR,IPAR,PAST,IPAST,NRDS)

        DFY(1,1)=1.D0-Y1L1+(2.D0*Y12*Y(1)*Y(2))/((1.D0+Y12)*(1.D0+Y12))
     1          -(2.D0*Y(1)*Y(2))/(1.D0+Y12)-rho*Y3L1
        DFY(1,2)=-Y12/(1.D0+Y12)
        DFY(1,3)=0.D0
        DFY(2,1)=2.D0*Y(1)*Y(2)/((1.D0+Y12)**2)
        DFY(2,2)=Y12/(1.D0+Y12)-alpha
        DFY(2,3)=0.D0
        DFY(3,1)=DFY(1,1)
        DFY(3,2)=DFY(1,2)
        DFY(3,3)=-1.D0

        RETURN
        END
C
        SUBROUTINE JACLAG(N,X,Y,DFYL,ARGLAG,PHI,IVE,IVC,IVL,
     &                    RPAR,IPAR,PAST,IPAST,NRDS)
C ----- JACOBIAN OF DELAY TERMS IN THE EQUATION
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(N) :: Y
        REAL(kind=DP), dimension(1) :: DFYL
        REAL(kind=DP), dimension(1) :: PAST
        INTEGER, dimension(1) :: IPAST
        REAL(kind=DP), dimension(1) :: RPAR
        INTEGER, dimension(1) :: IVE,IVC,IVL
        EXTERNAL PHI

        rho=RPAR(1)
        tau=RPAR(2)
        alpha=RPAR(3)

        IVL(1)=1
        IVE(1)=1
        IVC(1)=1
        IVL(2)=1
        IVE(2)=1
        IVC(2)=3
        DFYL(1)=-Y(1)
        DFYL(2)=-rho*Y(1)
        IVL(3)=1
        IVE(3)=3
        IVC(3)=1
        IVL(4)=1
        IVE(4)=3
        IVC(4)=3
        DFYL(3)=DFYL(2)
        DFYL(4)=DFYL(1)

        RETURN
        END

C
        FUNCTION PHI(I,X,RPAR,IPAR)
        IMPLICIT REAL*8 (A-H,O-Z)
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR
        SELECT CASE (I)
        CASE (1)
            PHI= 33.D-2-X/10.D0
        CASE (2)
            PHI= 222.D-2+X/10.D0
        CASE (3)
            PHI=-0.1D0
        END SELECT
        RETURN
        END

        SUBROUTINE QFUN(N,Q,LQ,RPAR,IPAR)
C --- MATRIX "M" FOR THE TEST PROBLEM
        INTEGER, PARAMETER :: DP=kind(1D0)
        REAL(kind=DP), dimension(1) :: RPAR
        REAL(kind=DP), dimension(LQ,N) :: Q

        Q(1,1)=1.D0
        Q(1,2)=0.D0
        Q(1,3)=0.D0
        Q(2,1)=0.D0
        Q(2,2)=1.D0
        Q(2,3)=0.D0
        Q(3,1)=0.D0
        Q(3,2)=0.D0
        Q(3,3)=0.D0
        RETURN
        END


C
C***********************************************************************
C                                                                      *
C            NACHOS II - A Finite Element Computer Program             *
C                        for Incompressible Flow Problems              *
C                                                                      *
C     Copyright (c) 1986,2019   National Technology & Engineering      *
C                               Solutions of Sandia, LLC (NTESS)       *
C                                                                      *
C                            All rights reserved.                      *
C                                                                      *
C     This software is distributed under the BSD 3-Clause License.     *
C                                                                      *
C***********************************************************************
C
      SUBROUTINE COORD8 (XB,YB,XX,YY,S,T,INODE,ICONV)
C
C     ******************************************************************
C
C     SUBROUTINE TO LOCATE NORMALIZED COORDINATES S,T IN PARENT ELEMENT
C     ISOPARAMETRIC EIGHT-NODE QUADRILATERAL
C
C     ******************************************************************
C
      DIMENSION XX(*), YY(*)
      DIMENSION SS(8), TT(8)
C
      DATA SS/-1.,1.,1.,-1.,0.,1.,0.,-1./
      DATA TT/-1.,-1.,1.,1.,-1.,0.,1.,0./
      DATA TOL/.005/,IMAX/20/
C
C     STATEMENT FUNCTIONS FOR SHAPE FUNCTIONS AND DERIVATIVES
C
      FX(SP,TP)=.25*XX(1)*(1.-SP)*(1.-TP)*(-SP-TP-1.)+.25*XX(2)*(1.+SP)*
     1(1.-TP)*(SP-TP-1.)+.25*XX(3)*(1.+SP)*(1.+TP)*(SP+TP-1.)+.25*XX(4)*
     2(1.-SP)*(1.+TP)*(-SP+TP-1.)+.50*XX(5)*(1.-SP*SP)*(1.-TP)+.50*XX(6)
     3*(1.+SP)*(1.-TP*TP)+.50*XX(7)*(1.-SP*SP)*(1.+TP)+.50*XX(8)*(1.-SP)
     4*(1.-TP*TP)
C
      FY(SP,TP)=.25*YY(1)*(1.-SP)*(1.-TP)*(-SP-TP-1.)+.25*YY(2)*(1.+SP)*
     1(1.-TP)*(SP-TP-1.)+.25*YY(3)*(1.+SP)*(1.+TP)*(SP+TP-1.)+.25*YY(4)*
     2(1.-SP)*(1.+TP)*(-SP+TP-1.)+.50*YY(5)*(1.-SP*SP)*(1.-TP)+.50*YY(6)
     3*(1.+SP)*(1.-TP*TP)+.50*YY(7)*(1.-SP*SP)*(1.+TP)+.50*YY(8)*(1.-SP)
     4*(1.-TP*TP)
C
      DFXDS(SP,TP)=.25*XX(1)*(1.-TP)*(TP+2.*SP)+.25*XX(2)*(1.-TP)*(-TP+2
     1.*SP)+.25*XX(3)*(1.+TP)*(TP+2.*SP)+.25*XX(4)*(1.+TP)*(-TP+2.*SP)+.
     250*XX(5)*(1.-TP)*(-2.*SP)+.50*XX(6)*(1.-TP*TP)+.50*XX(7)*(1.+TP)*(
     3-2.*SP)+.50*XX(8)*(1.-TP*TP)*(-1.)
C
      DFYDS(SP,TP)=.25*YY(1)*(1.-TP)*(TP+2.*SP)+.25*YY(2)*(1.-TP)*(-TP+2
     1.*SP)+.25*YY(3)*(1.+TP)*(TP+2.*SP)+.25*YY(4)*(1.+TP)*(-TP+2.*SP)+.
     250*YY(5)*(1.-TP)*(-2.*SP)+.50*YY(6)*(1.-TP*TP)+.50*YY(7)*(1.+TP)*(
     3-2.*SP)+.50*YY(8)*(1.-TP*TP)*(-1.)
C
      DFXDT(SP,TP)=.25*XX(1)*(1.-SP)*(SP+2.*TP)+.25*XX(2)*(1.+SP)*(-SP+2
     1.*TP)+.25*XX(3)*(1.+SP)*(SP+2.*TP)+.25*XX(4)*(1.-SP)*(-SP+2.*TP)+.
     250*XX(5)*(1.-SP*SP)*(-1.)+.50*XX(6)*(1.+SP)*(-2.*TP)+.50*XX(7)*(1.
     3-SP*SP)+.50*XX(8)*(1.-SP)*(-2.*TP)
C
      DFYDT(SP,TP)=.25*YY(1)*(1.-SP)*(SP+2.*TP)+.25*YY(2)*(1.+SP)*(-SP+2
     1.*TP)+.25*YY(3)*(1.+SP)*(SP+2.*TP)+.25*YY(4)*(1.-SP)*(-SP+2.*TP)+.
     250*YY(5)*(1.-SP*SP)*(-1.)+.50*YY(6)*(1.+SP)*(-2.*TP)+.50*YY(7)*(1.
     3-SP*SP)+.50*YY(8)*(1.-SP)*(-2.*TP)
C
C     ******************************************************************
C
C     CHECK FOR COINCIDENT NODE
C
      IF (INODE.EQ.0) GO TO 10
C
      S=SS(INODE)
      T=TT(INODE)
      RETURN
C
C     USE NEWTON RAPHSON PROCEDURE TO COMPUTE S,T COORDINATES
C
   10 CONTINUE
      SG=0.
      TG=0.
      ICOUNT=0
   20 CONTINUE
C
C     BUILD JACOBIAN AND INVERT
C
      A11=DFXDS(SG,TG)
      A12=DFYDS(SG,TG)
      A21=DFXDT(SG,TG)
      A22=DFYDT(SG,TG)
      F1=FX(SG,TG)-XB
      F2=FY(SG,TG)-YB
      DETA=A11*A22-A12*A21
      SNEW=SG-(A22*F1-A21*F2)/DETA
      TNEW=TG-(-A12*F1+A11*F2)/DETA
C
C     CHECK CONVERGENCE
C
      ICOUNT=ICOUNT+1
      DS=ABS(SNEW-SG)
      DT=ABS(TNEW-TG)
      IF (DS.LT.TOL.AND.DT.LT.TOL) GO TO 30
      SG=SNEW
      TG=TNEW
      IF (ICOUNT.EQ.IMAX) GO TO 40
      GO TO 20
C
   30 CONTINUE
      S=SNEW
      T=TNEW
      RETURN
C
   40 CONTINUE
      ICONV=1
C
      RETURN
      END


      SUBROUTINE SAMLMR(X,N,XMOM,NMOM,A,B)
C***********************************************************************
C*                                                                     *
C*  FORTRAN CODE WRITTEN FOR INCLUSION IN IBM RESEARCH REPORT RC20525, *
C*  'FORTRAN ROUTINES FOR USE WITH THE METHOD OF L-MOMENTS, VERSION 3' *
C*                                                                     *
C*  J. R. M. HOSKING                                                   *
C*  IBM RESEARCH DIVISION                                              *
C*  T. J. WATSON RESEARCH CENTER                                       *
C*  YORKTOWN HEIGHTS                                                   *
C*  NEW YORK 10598, U.S.A.                                             *
C*                                                                     *
C*  VERSION 3     AUGUST 1996                                          *
C*                                                                     *
C***********************************************************************
C
C  SAMPLE L-MOMENTS OF A DATA ARRAY
C
C  PARAMETERS OF ROUTINE:
C  X      * INPUT* ARRAY OF LENGTH N. CONTAINS THE DATA, IN ASCENDING
C                  ORDER.
C  N      * INPUT* NUMBER OF DATA VALUES
C  XMOM   *OUTPUT* ARRAY OF LENGTH NMOM. ON EXIT, CONTAINS THE SAMPLE
C                  L-MOMENTS L-1, L-2, T-3, T-4, ... .
C  NMOM   * INPUT* NUMBER OF L-MOMENTS TO BE FOUND. AT MOST MAX(N,20).
C  A      * INPUT* ) PARAMETERS OF PLOTTING
C  B      * INPUT* ) POSITION (SEE BELOW)
C
C  FOR UNBIASED ESTIMATES (OF THE LAMBDA'S) SET A=B=ZERO. OTHERWISE,
C  PLOTTING-POSITION ESTIMATORS ARE USED, BASED ON THE PLOTTING POSITION
C  (J+A)/(N+B)  FOR THE J'TH SMALLEST OF N OBSERVATIONS. FOR EXAMPLE,
C  A=-0.35D0 AND B=0.0D0 YIELDS THE ESTIMATORS RECOMMENDED BY
C  HOSKING ET AL. (1985, TECHNOMETRICS) FOR THE GEV DISTRIBUTION.
C
      IMPLICIT DOUBLE PRECISION (A-H,O-Z)
      DOUBLE PRECISION X(N),XMOM(NMOM),SUM(20)
      DATA ZERO/0D0/,ONE/1D0/
      IF(NMOM.GT.20.OR.NMOM.GT.N)GOTO 1000
      DO 10 J=1,NMOM
   10 SUM(J)=ZERO
      IF(A.EQ.ZERO.AND.B.EQ.ZERO)GOTO 50
      IF(A.LE.-ONE.OR.A.GE.B)GOTO 1010
C
C         PLOTTING-POSITION ESTIMATES OF PWM'S
C
      DO 30 I=1,N
      PPOS=(I+A)/(N+B)
      TERM=X(I)
      SUM(1)=SUM(1)+TERM
      DO 20 J=2,NMOM
      TERM=TERM*PPOS
   20 SUM(J)=SUM(J)+TERM
   30 CONTINUE
      DO 40 J=1,NMOM
   40 SUM(J)=SUM(J)/N
      GOTO 100
C
C         UNBIASED ESTIMATES OF PWM'S
C
   50 DO 70 I=1,N
      Z=I
      TERM=X(I)
      SUM(1)=SUM(1)+TERM
      DO 60 J=2,NMOM
      Z=Z-ONE
      TERM=TERM*Z
   60 SUM(J)=SUM(J)+TERM
   70 CONTINUE
      Y=N
      Z=N
      SUM(1)=SUM(1)/Z
      DO 80 J=2,NMOM
      Y=Y-ONE
      Z=Z*Y
   80 SUM(J)=SUM(J)/Z
C
C         L-MOMENTS
C
  100 K=NMOM
      P0=ONE
      IF(NMOM-NMOM/2*2.EQ.1)P0=-ONE
      DO 120 KK=2,NMOM
      AK=K
      P0=-P0
      P=P0
      TEMP=P*SUM(1)
      DO 110 I=1,K-1
      AI=I
      P=-P*(AK+AI-ONE)*(AK-AI)/(AI*AI)
  110 TEMP=TEMP+P*SUM(I+1)
      SUM(K)=TEMP
  120 K=K-1
      XMOM(1)=SUM(1)
      IF(NMOM.EQ.1)RETURN
      XMOM(2)=SUM(2)
      IF(SUM(2).EQ.ZERO)GOTO 1020
      IF(NMOM.EQ.2)RETURN
      DO 130 K=3,NMOM
  130 XMOM(K)=SUM(K)/SUM(2)
      RETURN
C
 1000 WRITE(6,7000)
      RETURN
 1010 WRITE(6,7010)
      RETURN
 1020 WRITE(6,7020)
      RETURN
C
 7000 FORMAT(' *** ERROR *** ROUTINE SAMLMR : PARAMETER NMOM INVALID')
 7010 FORMAT(' *** ERROR *** ROUTINE SAMLMR :',
     *  ' PLOTTING-POSITION PARAMETERS INVALID')
 7020 FORMAT(' *** ERROR *** ROUTINE SAMLMR : ALL DATA VALUES EQUAL')
      END


! RUN: %python %S/test_folding.py %s %flang_fc1
! Test folding of array constructors with constant implied DO bounds;
! their indices are constant expressions and can be used as such.
module m1
  integer, parameter :: kinds(*) = [1, 2, 4, 8]
  integer(kind=8), parameter :: clipping(*) = [integer(kind=8) :: &
    (int(z'100010101', kind=kinds(j)), j=1,4)]
  integer(kind=8), parameter :: expected(*) = [ &
    int(z'01',8), int(z'0101',8), int(z'00010101',8), int(z'100010101',8)]
  logical, parameter :: test_clipping = all(clipping == expected)
end module


      subroutine n_rbst(xr,xc,xp,nd,nt,n_grp,ih_grp,nch_grp,
     &   sndiag,s,period,itmax_stk,itmax_ln,itmax_cln,r0,ioux,
     &   iocm,iotf)

ccc    NEW ROBUST VERSION OF INCOHERENT NOISE VARIANCE ESTIMATION
ccc      ROUTINE
ccc     estimates of "noise" in each channel, using methods of
ccc     Egbert, 1996  ;  Channels are divided into n_grp groups;
ccc      group i contatins nch_grp(i) consecutive channels beginnig
ccc      with channel ih_grp(i)
ccc     Noise estimates are based on fitting all channels in a group
ccc      to PCs constructed from all channels in the other groups.
ccc     After computation of raw residual variances, a linear system
ccc       is solved (in the call to var_adj) to compute approximately
ccc       unbiased estimates of incoherent noise variances for each
ccc       channel

ccc      VARIOUS FLAGS WHICH CONTROL OPTIONS:
ccc      iocm is output unit for correlation matrix output (if > 0 ...
ccc        otherwise this is not output)
ccc      iotf gives output unit for prediction TF (if > 0 ...
ccc        otherwise this is not output)
ccc      ioux gives output unit for residuals (if >0 )

      include 'iosize.inc'
      parameter (ns1mx=(nchmx*(nchmx+1))/2,nwork=ntmx*ntmx*3)
      parameter (ntmx_sq = ntmx*ntmx)

      integer ih_grp(ntmx),nch_grp(ntmx),n_grp
      complex xr(nd,nt),xc(nd,nt),xp(nd,nt),s(*)
      real sndiag(ntmx),tf_se(ntmx,ntmx),sumSndiag
      complex sn(ntmx_sq),tf(ntmx,ntmx),work(nwork)
      integer iotf
      character*80 comment

ccc   imxc1 is # of iterations for robust regression on PCs estimate
      imxc1 = itmax_cln
      do i = 1,nt
         sndiag(i) = 0.0
      enddo

ccc   copy raw data (xr) into cleaned data array (xc)
      call datawt(0,nd,nt,xr,xc,xc,sn,r0)
      if(ioux.gt.0) then
ccc      output raw input data
         write(comment,*) 'Raw data in n_rbst'
         call wrtx(ioux,xc,nt,nd,1,sndiag,comment)
      endif

ccc   initial estimate of noise in each data channel
      call ln_rbst(xr,xc,xp,sndiag,s,nt,nd,n_grp,ih_grp,sn,tf,tf_se,
     &  nch_grp,itmax_stk,itmax_ln)

ccc   copy raw data (xr) into cleaned data array (xc)
      call datawt(0,nd,nt,xr,xc,xc,sn,r0)
ccc   extract diagonal of residual covariance estiamte
c       write(*,*) 'n_grp',n_grp
c       write(*,*) 'ih_grp',(ih_grp(i),i=1,n_grp)
      do i=1,n_grp
         isn = ipt_sn(nch_grp,i)
         call diag(sn(isn),nch_grp(i),sndiag(ih_grp(i)))
      enddo
      sumSndiag = 0.
      do i = 1,nt
         sumSndiag = sumSndiag+abs(sndiag(i))
      enddo
      do i = 1,nt
         if (sndiag(i) .eq. 0) then
            sndiag(i) = sumSndiag/(100*nt)
         endif
      enddo

c      write(*,*) 'sndiag',(sndiag(l),l=1,14)

ccc   iterative refinement
      do iter=1,imxc1
         call ln_rbst(xr,xc,xp,sndiag,s,nt,nd,n_grp,ih_grp,sn,tf,tf_se,
     &     nch_grp,itmax_stk,itmax_ln)
         do i=1,n_grp
            isn = ipt_sn(nch_grp,i)
            call diag(sn(isn),nch_grp(i),sndiag(ih_grp(i)))
         enddo
         sumSndiag = 0.
         do i = 1,nt
            sumSndiag = sumSndiag+abs(sndiag(i))
         enddo
         do i = 1,nt
            if (sndiag(i) .eq. 0) then
               sndiag(i) = sumSndiag/(100*nt)
            endif
         enddo
c         write(*,*) 'iter = ',iter
c         write(*,*) 'sndiag',(sndiag(l),l=1,14)
ccc      using raw data (XR) + predictions (XP) form cleaned data (XC)
         call datawt(iter,nd,nt,xr,xp,xc,sndiag,r0)
      enddo ! iter

ccc   optional output of estimated TF
      if(iotf.gt.0) call wrt_tf(iotf,period,tf,tf_se,nt,nd)

ccc   variance adjustment (see Appendix A in Egbert, 1996)
      call var_adj(nt,tf,sndiag,work)

ccc   recompute SDM (no iterations, use cleanded data...
ccc           ... appropriate for comparison with noise estimates
      call rbstk2(xc,nt,nd,s,xp,0)

ccc   optional output of correlation matrix, group residual correlation
ccc   matrices
      if(iocm .gt. 0) then
        write(iocm,*) '************  PERIOD = ',period,'  ************'
        write(iocm,*) '************* # of Data = ',nd,'   *************'
        call wrt_cormat(iocm,s,nt)
        call wrt_sn(iocm,sn,nch_grp,n_grp)
      endif
      return
      end
c______________________________________________________________________
c
      subroutine wrt_tf(iotf,period,tf,tf_se,nt,nd)
      complex tf(nt,nt)
      real tf_se(nt,nt),period
      integer iotf
      write(iotf,'(e12.4,i12)') 1./period,nd
      do i = 1,nt
         do j=1,nt
            write(iotf,'(3e12.4)') tf(i,j),tf_se(i,j)
         enddo
      enddo
      return
      end
c_____________________________________________________________________
c
      subroutine mkgrp(option_grp,ih,ie,nsta,nt,ih_grp,n_grp,nch_grp)

ccc   makes arrays ih_grp,n_grp,nch_grp for call to n_rbst based
ccc   on value of character variable

      character*1 option_grp
      integer ih(*),ie(*),nsta,nt,ih_grp(*),n_grp,nch_grp(*)

      if(option_grp.eq.'S') then
ccc      groups are all channels at each site
         n_grp = nsta
         do ista = 1,nsta
            nch_grp(ista) = ih(ista+1) - ih(ista)
            ih_grp(ista) = ih(ista)
         enddo
         ih_grp(nsta+1) = nt+1
      else if(option_grp.eq.'A') then
ccc      each channel is a group by itself
         n_grp = nt
         do i = 1,nt+1
            nch_grp(i) = 1
            ih_grp(i) = i
          enddo
      else
ccc      use all channels of a component type at a fixed site as a group
ccc      (default option)
         ii = 1
         do ista = 1,nsta
            nch_grp(ii) = ie(ista)-ih(ista)
            if(nch_grp(ii).gt.0) then
               ih_grp(ii) = ih(ista)
               ii = ii + 1
             endif
             nch_grp(ii) = ih(ista+1)-ie(ista)
             if(nch_grp(ii).gt.0) then
                ih_grp(ii) = ie(ista)
                ii = ii + 1
             endif
          enddo
          ih_grp(ii) = nt+1
          n_grp= ii - 1
       endif
       return
       end


MODULE Leafnumber_mod
    IMPLICIT NONE
CONTAINS
    SUBROUTINE leafnumber_(deltaTT, &
        phyllochron, &
        hasFlagLeafLiguleAppeared, &
        leafNumber, &
        phase)
        REAL:: phyllochron_
        REAL, INTENT(IN) :: deltaTT
        REAL, INTENT(IN) :: phyllochron
        INTEGER, INTENT(IN) :: hasFlagLeafLiguleAppeared
        REAL, INTENT(INOUT) :: leafNumber
        REAL, INTENT(IN) :: phase
        !- Description:
    !            - Model Name: CalculateLeafNumber Model
    !            - Author: Pierre MARTRE
    !            - Reference: Modeling development phase in the
    !                Wheat Simulation Model SiriusQuality.
    !                See documentation at http://www1.clermont.inra.fr/siriusquality/?page_id=427
    !            - Institution: INRA Montpellier
    !            - Abstract: calculate leaf number. LeafNumber increase is caped at one more leaf per day
        !- inputs:
    !            - name: deltaTT
    !                          - description : daily delta TT
    !                          - variablecategory : auxiliary
    !                          - datatype : DOUBLE
    !                          - min : -20
    !                          - max : 100
    !                          - default : 23.5895677277199
    !                          - unit : °C d
    !                          - inputtype : variable
    !            - name: phyllochron
    !                          - description : phyllochron
    !                          - variablecategory : state
    !                          - inputtype : variable
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 1000
    !                          - default : 0
    !                          - unit : °C d leaf-1
    !            - name: hasFlagLeafLiguleAppeared
    !                          - description : true if flag leaf has appeared (leafnumber reached finalLeafNumber)
    !                          - variablecategory : state
    !                          - datatype : INT
    !                          - min : 0
    !                          - max : 1
    !                          - default : 0
    !                          - unit :
    !                          - inputtype : variable
    !            - name: leafNumber
    !                          - description :  Actual number of phytomers
    !                          - variablecategory : state
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 25
    !                          - default : 0
    !                          - unit : leaf
    !                          - inputtype : variable
    !            - name: phase
    !                          - description :  the name of the phase
    !                          - variablecategory : state
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 7
    !                          - default : 1
    !                          - unit :
    !                          - uri : some url
    !                          - inputtype : variable
        !- outputs:
    !            - name: leafNumber
    !                          - description : Actual number of phytomers
    !                          - datatype : DOUBLE
    !                          - min : 0
    !                          - max : 10000
    !                          - unit : leaf
    !                          - uri : some url
        IF(phase .GE. 1.0) .AND. phase .LT. 4.0))) THEN
            IF(hasFlagLeafLiguleAppeared .EQ. 0)) THEN
                IF(phyllochron .EQ. 0.0)) THEN
                    phyllochron_ = 0.0000001
                ELSE
                    phyllochron_ = phyllochron
                END IF
                leafNumber = leafNumber + MIN(deltaTT / phyllochron_), 0.999))
            END IF
        END IF
    END SUBROUTINE leafnumber_
END MODULE


*********************************************************************
* statistical analysis of the raw data
*********************************************************************

      program dataAnal
	use constantClass, only : LDIM, TAU
	use dataProcClass, only : getDataFile, getStatisticsFile
	implicit none

	integer :: lSze, lVol, evalStp, dataID, statID, ioSt, i
	double precision :: temp
	real :: ergAvg, ergVar, ergDens, heatDens, mgntAvg, mgntVar,
     $	        mgntDens, suscept, mgntSqr, mgntQud, binder,
     $	        helix, helix4th, corrRate
	real, dimension(:) :: lkErgAvg(1:LDIM), lkErgSqr(1:LDIM),
     $	                      h(1:LDIM), h4(1:LDIM), corr(1:LDIM)
	real, dimension(:), allocatable :: erg(:), mgnt(:)
	real, dimension(:,:), allocatable :: lkErg(:,:), kMgnt(:,:)
	character(len=64) :: arg

*********************************************************************
c	Get command-line argument
*********************************************************************
	i = iargc()
	if(i .ne. 3) then
	  call commandError()
	end if

	call getarg(1, arg)
	read(arg, *) lSze
	if(lSze .lt. 1) then
	  call commandError()
	end if

	call getarg(2, arg)
	read(arg, *) temp
	if(temp .le. 0.0) then
	  call commandError()
	end if

	call getarg(3, arg)
	read(arg, *) evalStp
	if(evalStp .lt. 1) then
	  call commandError()
	end if

*********************************************************************
c	Initialization
*********************************************************************
	dataID = 31
	statID = 30
	lVol = lSze ** 2

	allocate(erg(1:evalStp))
	allocate(mgnt(1:evalStp))
	allocate(lkErg(1:evalStp,1:LDIM))
	allocate(kMgnt(1:evalStp,1:LDIM))
*********************************************************************
c	Get data from file
*********************************************************************
	call getDataFile(lSze, temp, dataID)
	call getStatisticsFile(statID)

	do i = 1, evalStp
	  read(dataID, *), erg(i), mgnt(i), lkErg(i,1:LDIM),
     $	                   kMgnt(i,1:LDIM)
	end do

	ergAvg = real(sum(erg)) / evalStp
	ergVar = sum((erg - ergAvg) ** 2) / evalStp
	heatDens = ergVar / ((temp ** 2) * lVol)
	ergDens = ergAvg / lVol

	mgntAvg = real(sum(abs(mgnt))) / evalStp
	mgntVar = sum((abs(mgnt) - mgntAvg) ** 2) / evalStp
	suscept = mgntVar / (temp * lVol)
	mgntDens = mgntAvg / lVol

c	mgntAbs = sum(abs(mgnt(1:evalStp))) / evalStp

	mgntSqr = real(sum(mgnt ** 2)) / evalStp
	mgntQud = real(sum(mgnt ** 4)) / evalStp
	binder = 1 - mgntQud / (3 * (mgntSqr ** 2))

	lkErgAvg = sum(lkErg, dim=1) / evalStp
	lkErgSqr = sum(lkErg ** 2, dim=1) / evalStp
	corr = sum(kMgnt, dim=1) / evalStp

	do i = 1, LDIM
	  h(i) = lkErgAvg(i) / lVol
          h4(i) = (3 * ((lkErgAvg(i) ** 2) - lkErgSqr(i)) / temp +
     $	           lkErgAvg(i)) / (lVol ** 2)
	  corr(i) = sqrt((mgntSqr / corr(i)) - 1) /
     $	            (2 * sin(TAU / (2 * lSze)) * lSze)
	enddo
	helix = sum(h) / LDIM
	helix4th = sum(h4) / LDIM
	corrRate = sum(corr) / LDIM
	write(statID, *), lSze, temp, evalStp, ergDens, heatDens,
     $	                  mgntDens, suscept, binder, helix, helix4th,
     $	                  corrRate

	deallocate(erg)
	deallocate(mgnt)
	close(dataID)
	close(statID)

      contains
c	subroutine listFile(dir, lsFl)
c	  character(len=64) :: dir, lsFl
c	  lsFl = trim(dir) // 'ls.txt'
c	  call system('ls ' // dir // ' > ' // lsFl)
c	end subroutine
	subroutine commandError()
	  write(*,*) 'Invalid command-line arguments'
	  write(*,*) 'Usage:'
	  write(*,*) './(programName) (latticeSize) (temperature)',
     $	             '(stepNumber)'
	  write(*,*) '(latticeSize) must be even'
	  write(*,*) '(temperature) must be positive'
	  write(*,*) '(stepNumber) must be positive'
	  call exit(1)
	end subroutine
      end program


subroutine norm1(a,p,nm)
USE variables
implicit none
integer a(3),p(3)
real*8 nm
! this subroutine computes the overlap <123|456>
nm=S(a(1),p(1))*S(a(2),p(2))*S(a(3),p(3));
!write(6,*) a,p,S(1,2)
!stop
end subroutine norm1


      SUBROUTINE obtain_field_line(zetacn, thetacn, iotac,
     1    nsurf, alpha)
      USE stel_kinds
      USE normalize_data, ONLY: lasym_v                                   ! 110909 RS: logical for asymmetric input (if True)
      USE ballooning_data
      USE general_dimensions
      USE fmesh_quantities
      IMPLICIT NONE
!-----------------------------------------------
!   D u m m y   A r g u m e n t s
!-----------------------------------------------
      INTEGER, INTENT(IN) :: nsurf
      REAL(rprec), INTENT(IN) :: zetacn, thetacn, iotac
      REAL(rprec), INTENT(OUT) :: alpha
!-----------------------------------------------
!   L o c a l   V a r i a b l e s
!-----------------------------------------------
      INTEGER :: j, lj
      REAL(rprec):: lambda0, ssine, arg, ccosi
!-----------------------------------------------

      lambda0 = 0
      fourier: DO j = 1, mnmax_v                                         ! Fourier invert lambda at initial point (thetacn, zetacn)
         arg = xm_v(j)*thetacn-xn_v(j)*zetacn
         ssine = SIN(arg); ccosi = COS(arg)
         lj = mnmax_v*(nsurf-1)+j
         lambda0 = lambda0 + lmnsf(lj)*ssine
         IF (lasym_v) lambda0 = lambda0 + lmncf(lj)*ccosi                ! 110909  RS: Asymmetric input
      ENDDO fourier

      alpha = thetacn + lambda0 - iotac*zetacn                           ! obtain field line label value

      END SUBROUTINE obtain_field_line


      PROGRAM FTEX07
C
C  This program illustrates the use of curvs1 and curvs2 to
C  interpolate a smoothing tension spline for data in the plane.
C
C  Numeber of input data points and interpolation points.
C
      PARAMETER(NUM_IN=4,NUM_OUT=101)
C
C  GKS parameters.
C
      PARAMETER(IERRF=6, LUNIT=2, IWTYPE=1, IWKID=1)
C
C  Declare arrays.
C
      DIMENSION X(NUM_IN),Y(NUM_IN)
      DIMENSION XS(NUM_IN),YS(NUM_IN),XSP(NUM_IN),YSP(NUM_IN)
      DIMENSION TEMP(NUM_IN,19),PARAM(NUM_IN),XL(2),YL(2)
      DIMENSION XO(NUM_OUT),YO(NUM_OUT),XOO(NUM_OUT),YOO(NUM_OUT)
C
C  Specify the original data points in the plane.
C
      DATA X/0.5, -1.5,  0.5,  1.5/
      DATA Y/1.5,  0.0, -2.5, -1.0/
C
C  Tension factor.
C
      SIGMA = 1.0
C
C  Specify a uniform observational weight (the interpolated
C  curve can be this far away from the original data points)..
C
      ISW   = 1
      D     = 0.2
C
C  Smoothing factor (larger values result in smoother curves).
C
      S     = REAL(NUM_IN)
C
C  Computational tolerance value.
C
      EPS   = SQRT(2./S)
C
C  Call CURVS1 and CURVS2 to calculate the smoothing spline.
C
      CALL CURVS1(NUM_IN,X,Y,D,ISW,S,EPS,PARAM,XS,YS,XSP,YSP,
     +            SIGMA,TEMP,IERR)
C
      XINC = 1./REAL(NUM_OUT-1)
      DO 10 I=1,NUM_OUT
        T = REAL(I-1)*XINC
        CALL CURVS2(T,NUM_IN,PARAM,XS,YS,XSP,YSP,SIGMA,XO(I),YO(I))
   10 CONTINUE
C
C  Not use CURVS1 and CURVS2 to compute an interpolating tension
C  spline by setting the smoothing parameter to zero.
C
      S   = 0.
      EPS = 0.
      CALL CURVS1(NUM_IN,X,Y,D,ISW,S,EPS,PARAM,XS,YS,XSP,YSP,
     +            SIGMA,TEMP,IERR)
C
      DO 20 I=1,NUM_OUT
        T = REAL(I-1)*XINC
        CALL CURVS2(T,NUM_IN,PARAM,XS,YS,XSP,YSP,SIGMA,XOO(I),YOO(I))
   20 CONTINUE
C
C  Plot the two curves.
C
      CALL GOPKS (6,IBUF)
      CALL GOPWK (IWKID, LUNIT, IWTYPE)
      CALL GACWK (IWKID)
C
C  Define colors.
C
      CALL GSCR(IWKID,0,1.,1.,1.)
      CALL GSCR(IWKID,1,0.,0.,0.)
      CALL GSCR(IWKID,2,1.,0.,0.)
      CALL GSCR(IWKID,3,0.,0.,1.)
C
C  Main title.
C
      CALL PCSETI('FN',25)
      CALL PLCHHQ(0.5,0.95,'Demo for CURVS1/CURVS2',25.,0.,0.)
      CALL SET(0.1, 0.95, 0.2, 0.90, -2., 3., -3., 2., 1)
C
C  Background grid.
C
      CALL GASETI('LTY',1)
      CALL PCSETI('FN',21)
      CALL GSPLCI(1)
      CALL LABMOD('(F4.1)','(F4.1)',4,4,20,20,0,0,0)
      CALL HALFAX(5, 4, 5, 4, -2., -3., 1,1)
C
C  Plot the smoothing spline in red, and its informational label.
C
      CALL GSLWSC(3.)
      CALL GSPLCI(2)
      CALL GPL(NUM_OUT,XO,YO)
      XL(1) = 0.250
      XL(2) = 0.750
      YL(1) = 0.625
      YL(2) = 0.625
      CALL GPL(2,XL,YL)
      CALL PLCHHQ(0.875,0.625,'Smoothing spline',24.,0.,-1.)
C
C  Plot the tension spline in blue, and its informational label.
C
      CALL GSPLCI(3)
      CALL GPL(NUM_OUT,XOO,YOO)
      XL(1) = 0.250
      XL(2) = 0.750
      YL(1) = 0.125
      YL(2) = 0.125
      CALL GPL(2,XL,YL)
      CALL PLCHHQ(0.875,0.125,'Tension spline',24.,0.,-1.)
C
C  Mark the original data with black dots, and label.
C
      CALL NGDOTS(X,Y,NUM_IN,0.13,1)
      CALL NGDOTS(0.500,-0.375,1,0.13,1)
      CALL PLCHHQ(0.875,-0.375,'Original data points',24.,0.,-1.)
C
      CALL FRAME()
C
      CALL GDAWK (IWKID)
      CALL GCLWK (IWKID)
      CALL GCLKS ()
C
      STOP
      END


!***********************************************************************************************************************************
! UNIT:
!
!  (MODULE) MR_DEF_MEANDER_PARS
!
! PURPOSE:
!
!   TO
!
! DEFINITION OF VARIABLES:
!
!
!
! RECORD OF REVISIONS:
!
!      DATE       |    PROGRAMMER    |    DESCRIPTION OF CHANGE
!      ====       |    ==========    |    =====================
!   20XX-XX-XX    |     DR. HYDE     |    ORIGINAL CODE.
!
!***********************************************************************************************************************************
  MODULE MR_DEF_MEANDER_PARS

    USE MR_KINDS

    IMPLICIT NONE

    REAL   (GJRD_KIND) :: THETA0

    REAL   (GJRD_KIND) :: BTH , LTH , LAMBTH
    REAL   (GJRD_KIND) :: LAMBTH2BTH , SINUOSITY

    INTEGER            :: NBENDS = 1

  END MODULE MR_DEF_MEANDER_PARS


subroutine griglia

!--------------------------------------------------- !
!  F. Califano, 2006                                 !
!--------------------------------------------------- !

use parameter_mod
use box_mod

IMPLICIT NONE

integer  :: ix, iy, iz

!------------------------------------------------------------------------!
!   Spatial grid -                                                       !
!------------------------------------------------------------------------!

 x   = (/(ix-1, ix = 1, nx)/) * dx
 y   = (/(iy-1, iy = 1, ny)/) * dy
 z   = (/(iz-1, iz = 1, nz)/) * dz

end subroutine


      REAL             FUNCTION SGAM1 (X)
c Copyright (c) 1996 California Institute of Technology, Pasadena, CA.
c ALL RIGHTS RESERVED.
c Based on Government Sponsored Research NAS7-03001.
C>> 1998-10-29 SGAM1 Krogh  Moved external statement up for mangle.
c>> 1994-10-20 SGAM1 Krogh  Changes to use M77CON
c>> 1994-05-18 SGAM1 WVS make DP and SP versions alike using CHGTYP
C>> 1993-08-04 SGAM1 CLL Add type stmt for SGAMMA.
C>> 1993-05-06 SGAM1 WVS JPL Convert from NSWC to Math 77
c--S replaces "?": ?GAM1, ?GAMMA
C ----------------------------------------------------------------------
C     EVALUATION OF 1/GAMMA(1 + X) - 1  FOR -0.5 .LE. X .LE. 1.5
C ----------------------------------------------------------------------
C
C     THE FOLLOWING ARE THE FIRST 49 COEFFICIENTS OF THE MACLAURIN
C     EXPANSION FOR 1/GAMMA(1 + X) - 1. THE COEFFICIENTS ARE
C     CORRECT TO 40 DIGITS. THE COEFFICIENTS WERE OBTAINED BY
C     ALFRED H. MORRIS JR. (NAVAL SURFACE WARFARE CENTER) AND ARE
C     GIVEN HERE FOR REFERENCE. ONLY THE FIRST 14 COEFFICIENTS ARE
C     USED IN THIS CODE.
C
C                           -----------
C
C     DATA A(1)  / .5772156649015328606065120900824024310422E+00/,
C    *     A(2)  /-.6558780715202538810770195151453904812798E+00/,
C    *     A(3)  /-.4200263503409523552900393487542981871139E-01/,
C    *     A(4)  / .1665386113822914895017007951021052357178E+00/,
C    *     A(5)  /-.4219773455554433674820830128918739130165E-01/,
C    *     A(6)  /-.9621971527876973562114921672348198975363E-02/,
C    *     A(7)  / .7218943246663099542395010340446572709905E-02/,
C    *     A(8)  /-.1165167591859065112113971084018388666809E-02/,
C    *     A(9)  /-.2152416741149509728157299630536478064782E-03/,
C    *     A(10) / .1280502823881161861531986263281643233949E-03/
C     DATA A(11) /-.2013485478078823865568939142102181838229E-04/,
C    *     A(12) /-.1250493482142670657345359473833092242323E-05/,
C    *     A(13) / .1133027231981695882374129620330744943324E-05/,
C    *     A(14) /-.2056338416977607103450154130020572836513E-06/,
C    *     A(15) / .6116095104481415817862498682855342867276E-08/,
C    *     A(16) / .5002007644469222930055665048059991303045E-08/,
C    *     A(17) /-.1181274570487020144588126565436505577739E-08/,
C    *     A(18) / .1043426711691100510491540332312250191401E-09/,
C    *     A(19) / .7782263439905071254049937311360777226068E-11/,
C    *     A(20) /-.3696805618642205708187815878085766236571E-11/
C     DATA A(21) / .5100370287454475979015481322863231802727E-12/,
C    *     A(22) /-.2058326053566506783222429544855237419746E-13/,
C    *     A(23) /-.5348122539423017982370017318727939948990E-14/,
C    *     A(24) / .1226778628238260790158893846622422428165E-14/,
C    *     A(25) /-.1181259301697458769513764586842297831212E-15/,
C    *     A(26) / .1186692254751600332579777242928674071088E-17/,
C    *     A(27) / .1412380655318031781555803947566709037086E-17/,
C    *     A(28) /-.2298745684435370206592478580633699260285E-18/,
C    *     A(29) / .1714406321927337433383963370267257066813E-19/,
C    *     A(30) / .1337351730493693114864781395122268022875E-21/
C     DATA A(31) /-.2054233551766672789325025351355733796682E-21/,
C    *     A(32) / .2736030048607999844831509904330982014865E-22/,
C    *     A(33) /-.1732356445910516639057428451564779799070E-23/,
C    *     A(34) /-.2360619024499287287343450735427531007926E-25/,
C    *     A(35) / .1864982941717294430718413161878666898946E-25/,
C    *     A(36) /-.2218095624207197204399716913626860379732E-26/,
C    *     A(37) / .1297781974947993668824414486330594165619E-27/,
C    *     A(38) / .1180697474966528406222745415509971518560E-29/,
C    *     A(39) /-.1124584349277088090293654674261439512119E-29/,
C    *     A(40) / .1277085175140866203990206677751124647749E-30/
C     DATA A(41) /-.7391451169615140823461289330108552823711E-32/,
C    *     A(42) / .1134750257554215760954165259469306393009E-34/,
C    *     A(43) / .4639134641058722029944804907952228463058E-34/,
C    *     A(44) /-.5347336818439198875077418196709893320905E-35/,
C    *     A(45) / .3207995923613352622861237279082794391090E-36/,
C    *     A(46) /-.4445829736550756882101590352124643637401E-38/,
C    *     A(47) /-.1311174518881988712901058494389922190237E-38/,
C    *     A(48) / .1647033352543813886818259327906394145400E-39/,
C    *     A(49) /-.1056233178503581218600561071538285049997E-40/
C
C                           -----------
C
C     C = A(1) - 1 IS ALSO FREQUENTLY NEEDED. C HAS THE VALUE ...
C
C     DATA C /-.4227843350984671393934879099175975689578E+00/
C
C ----------------------------------------------------------------------
      EXTERNAL R1MACH, SGAMMA
      REAL             R1MACH, SGAMMA
      REAL             D, ROUND, T, W, X, XMAX, Z
      SAVE ROUND, XMAX
      REAL             A0, A1, B1, B2, B3, B4, B5, B6, B7, B8
      REAL             C, C0, C1, C2, C3, C4, C5, C6, C7, C8, C9,
     *                 C10, C11, C12, C13
      REAL             F0, F1, F2, F3, F4, F5, F6, G1, G2, G3, G4
      REAL             P1, P2, P3, P4, P5, P6, P7
      REAL             Q2, Q3, Q4, Q5
      REAL             R1, R2, R3, R4, R5, R6, R7, R8, R9
      REAL             S1, S2
C ---------------------------
      DATA XMAX /-1.0E0/
C ---------------------------
      DATA A0 / .611609510448141581788E-08/,
     *     A1 / .624730830116465516210E-08/
      DATA B1 / .203610414066806987300E+00/,
     *     B2 / .266205348428949217746E-01/,
     *     B3 / .493944979382446875238E-03/,
     *     B4 /-.851419432440314906588E-05/,
     *     B5 /-.643045481779353022248E-05/,
     *     B6 / .992641840672773722196E-06/,
     *     B7 /-.607761895722825260739E-07/,
     *     B8 / .195755836614639731882E-09/
C ---------------------------
      DATA F0 /.6116095104481415817861E-08/,
     *     F1 /.6871674113067198736152E-08/,
     *     F2 /.6820161668496170657918E-09/,
     *     F3 /.4686843322948848031080E-10/,
     *     F4 /.1572833027710446286995E-11/,
     *     F5/-.1249441572276366213222E-12/,
     *     F6 /.4343529937408594255178E-14/
      DATA G1 /.3056961078365221025009E+00/,
     *     G2 /.5464213086042296536016E-01/,
     *     G3 /.4956830093825887312020E-02/,
     *     G4 /.2692369466186361192876E-03/
C ---------------------------
C     C = C0 - 1
C ---------------------------
      DATA C /-.422784335098467139393487909917598E+00/
C ---------------------------
      DATA C0  / .577215664901532860606512090082402E+00/,
     *     C1  /-.655878071520253881077019515145390E+00/,
     *     C2  /-.420026350340952355290039348754298E-01/,
     *     C3  / .166538611382291489501700795102105E+00/,
     *     C4  /-.421977345555443367482083012891874E-01/,
     *     C5  /-.962197152787697356211492167234820E-02/,
     *     C6  / .721894324666309954239501034044657E-02/,
     *     C7  /-.116516759185906511211397108401839E-02/,
     *     C8  /-.215241674114950972815729963053648E-03/,
     *     C9  / .128050282388116186153198626328164E-03/
      DATA C10 /-.201348547807882386556893914210218E-04/,
     *     C11 /-.125049348214267065734535947383309E-05/,
     *     C12 / .113302723198169588237412962033074E-05/,
     *     C13 /-.205633841697760710345015413002057E-06/
C --------------------------
      DATA P1/ .577215664901533E+00/, P2/-.409078193005776E+00/,
     *     P3/-.230975380857675E+00/, P4/ .597275330452234E-01/,
     *     P5/ .766968181649490E-02/, P6/-.514889771323592E-02/,
     *     P7/ .589597428611429E-03/
C --------------------------
      DATA Q2/ .427569613095214E+00/,
     *     Q3/ .158451672430138E+00/, Q4/ .261132021441447E-01/,
     *     Q5/ .423244297896961E-02/
C --------------------------
      DATA R1/-.422784335098468E+00/, R2/-.771330383816272E+00/,
     *     R3/-.244757765222226E+00/, R4/ .118378989872749E+00/,
     *     R5/ .930357293360349E-03/, R6/-.118290993445146E-01/,
     *     R7/ .223047661158249E-02/, R8/ .266505979058923E-03/,
     *     R9/-.132674909766242E-03/
C --------------------------
      DATA S1/ .273076135303957E+00/, S2/ .559398236957378E-01/
C ---------------------------
      IF (XMAX .LT. 0.0E0) THEN
         ROUND = R1MACH(4)
         XMAX = 1.0E0 / ROUND
      END IF
      T = X
      D = X - 0.5E0
      IF (D .GT. 0.E0) T = D - 0.5E0
      IF (ROUND .LT. 1.0E-14) THEN
C
C        CASE WHEN PRECISION IS GREATER THAN 14 DIGITS:
C
         IF (T) 30,10,20
C
   10    SGAM1 = 0.E0
         RETURN
C -----------
C
C                CASE WHEN 0 .LT. T .LE. 0.5
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
   20    IF (T .GT. 0.5) THEN
            IF (X .GT. XMAX) THEN
               SGAM1 = -1.0E0
               RETURN
            END IF
            SGAM1 = 1.0E0 / SGAMMA(1.0E0 + X) - 1.0E0
            RETURN
         END IF
         W = ((((((F6*T + F5)*T + F4)*T + F3)*T + F2)*T + F1)*T + F0)/
     *         ((((G4*T + G3)*T + G2)*T + G1)*T + 1.E0)
         Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T +
     *            C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T +
     *            C3)*T + C2)*T + C1)*T + C0
C
         IF (D .LE. 0.E0) THEN
            SGAM1 = X*Z
            RETURN
         END IF
         SGAM1 = (T/X)*((Z - 0.5E0) - 0.5E0)
         RETURN
C -----------
C
C                CASE WHEN -0.5 .LE. T .LT. 0
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
   30    IF (T .LT. -0.5) THEN
            IF (X .GT. XMAX) THEN
               SGAM1 = -1.0E0
               RETURN
            END IF
            SGAM1 = 1.0E0 / SGAMMA(1.0E0 + X) - 1.0E0
            RETURN
         END IF
         W = (A1*T + A0)/((((((((B8*T + B7)*T + B6)*T + B5)*T +
     *          B4)*T + B3)*T + B2)*T + B1)*T + 1.E0)
         Z = (((((((((((((W*T + C13)*T + C12)*T + C11)*T + C10)*T +
     *            C9)*T + C8)*T + C7)*T + C6)*T + C5)*T + C4)*T +
     *            C3)*T + C2)*T + C1)*T + C
C
         IF (D .LE. 0.E0) THEN
            SGAM1 = X*((Z + 0.5E0) + 0.5E0)
            RETURN
         END IF
         SGAM1 = T*Z/X
         RETURN
      ELSE
C
C        CASE WHEN PRECISION IS LESS THAN 14 DIGITS
C
         IF (T) 300,100,200
C
  100    SGAM1 = 0.0
         RETURN
C -----------
C
C                CASE WHEN 0 .LT. T .LE. 0.5
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
  200    IF (T .GT. 0.5E0) THEN
            IF (X .GT. XMAX) THEN
               SGAM1 = -1.0E0
               RETURN
            END IF
            SGAM1 = 1.0E0 / SGAMMA(1.0E0 + X) - 1.0E0
            RETURN
         END IF
         Z = ((((((P7*T + P6)*T + P5)*T + P4)*T + P3)*T + P2)*T + P1) /
     *       ((((Q5*T + Q4)*T + Q3)*T + Q2)*T + 1.0)
         IF (D .LE. 0.0) THEN
            SGAM1 = X*Z
            RETURN
         END IF
         SGAM1 = (T/X)*((Z - 0.5) - 0.5)
         RETURN
C
C -----------
C
C                CASE WHEN -0.5 .LE. T .LT. 0
C
C              W IS A MINIMAX APPROXIMATION FOR
C              THE SERIES A(15) + A(16)*T + ...
C
C -----------
  300    IF (T .LT. -0.5E0) THEN
            IF (X .GT. XMAX) THEN
               SGAM1 = -1.0E0
               RETURN
            END IF
            SGAM1 = 1.0E0 / SGAMMA(1.0E0 + X) - 1.0E0
            RETURN
         END IF
         Z = ((((((((R9*T + R8)*T + R7)*T + R6)*T + R5)*T
     *                       + R4)*T + R3)*T + R2)*T + R1) /
     *       ((S2*T + S1)*T + 1.0)
         IF (D .LE. 0.0) THEN
            SGAM1 = X*((Z + 0.5) + 0.5)
            RETURN
         END IF
         SGAM1 = T*Z/X
         RETURN
      END IF
      END


      SUBROUTINE SEMST(ISTK,ISEM,ANS,IDIV,N,N2,NDOWS,char,IFMT)
C      TRACE SEMBL,TEMP,K
C    SEMST IS THE VERSION OF SEMSTK THAT RUNS IN HOST MEMORY RATHER THAN IN THE AP.
C  SEMST PERFORMS THE FOLLOWING TASKS: 1) COMPUTES THE ENERGY OF THE STACKED
C TRACE (THE ENERGY WINDOWS ARE N TRACE SAMPLES LONG AND ARE COMPUTED EVERY
C N2 TRACE SAMPLES).  2) DIVIDES THE STACKED TRACE ENERGY BY THE NUMBER OF
C WINDOWS THAT WENT INTO THE STACKED TRACE, FOR EACH WINDOW.  THIS IS THE MEAN
C ENERGY OF THE STACKED TRACE.  3) DIVIDES THE STACKED TRACE MEAN ENERGY BY THE
C MEAN ENERGY OF THE INPUT WINDOWS.  4) MULTIPLIES THIS SEMBLANCE BY char (9).
C
C ARGUMENTS:
C ISTK - THE APMEM INDEX OF THE STACKED TRACE.
C ISEM - THE APMEM INDEX OF THE MEAN ENERGY OF THE INPUT TRACES.
C ANS  - THE ARRAY TO RECEIVE THE REAL SEMBLANCE VALUES.
C IDIV - THE APMEM INDEX OF THE NUMBER OF WINDOWS FORMING THE STACK.
C N    - THE NUMBER OF SAMPLES IN EACH WINDOW.
C N2   - THE DISTANCE BETWEEN WINDOWS (USUALLY N/2).
C NDOWS - THE NUMBER OF WINDOWS.
C IFMT - THE OUTPUT FORMAT - BETTER BE 1 - INCLUDED FOR COMPATIBILITY WITH SEMSTK
C
C COPYRIGHTED BY PAUL HENKART, 23 JANUARY 1983
C
      COMMON /APMEM/ A(32766)
      DIMENSION ans(1)
C
      IF(IFMT.EQ.1) GO TO 2
      PRINT 1
1     FORMAT(' ***  ERROR  ***  SEMST CAN NOT DO A FORMAT ',
     *  'OTHER THAN 1.')
      STOP
2     CONTINUE
      IDIV1=IDIV
      ISEM1=ISEM
      K=ISTK-1
      DO 20 I=1,NDOWS
         ENERGY=0.
         IF(A(IDIV1).LE.0.) A(IDIV1)=1.
         DO 10 J=1,N                                                    ! DO A WINDOW LENGTH
            IF(A(K+J).EQ.0.) GO TO 10                                   ! NO SENSE IN PLAYING WITH ZEROES!
            TEMP=A(K+J)/A(IDIV1)                                        !  THE STACKED TRACE HAS NOT BEEN DIVIDED YET!!!
            ENERGY=ENERGY+TEMP*TEMP                                     !  SUM OF THE SQUARES!
10       CONTINUE
c         PRINT 111,I,IDIV1,ISEM1,A(IDIV1),A(ISEM1),ENERGY
c  111    FORMAT(1X,3I10,3F12.5)
         IF(A(ISEM1).EQ.0.) A(ISEM1)=1.
         SEMBL=(ENERGY/(A(ISEM1)/A(IDIV1))) * char
         ANS(I)=SEMBL
C         IDIV1=IDIV1+1
         ISEM1=ISEM1+1
         K=K+N                                                          ! FIND THE BEGINNING OF THE NEXT WINDOW
   20 CONTINUE
      RETURN
      END


SUBROUTINE UpdateGhostLayerNCurvilinear(var,Sx,Sy,NNx,NNy,NNz,CompGrid,alpha,beta,GhostGridX,GhostGridY)
USE Precision
USE DataTypes
IMPLICIT NONE
TYPE (Level_def) :: CompGrid
INTEGER :: NNx, NNy, NNz, rank, alpha, beta, i,j,k, GhostGridX, GhostGridY, diffb
REAL(KIND=long), DIMENSION(NNx,NNy) :: var, Sx, Sy
REAL(KIND=long), DIMENSION(2*alpha+1) :: Stenciln
REAL(KIND=long) :: xn, yn, Source, NormalX, NormalY, nx, ny
INTEGER, DIMENSION(2*beta+1) :: idx
IF (alpha/=beta) THEN
	print*,'ERROR: alpha/=beta. (UpdateGhostLayerECurvilinear)'
	STOP
END IF
rank = 2*beta+1
! On the free surface
k = NNz
! two boundaries
j=1
DO i = 1+GhostGridX, NNx-GhostGridX
  	Stenciln = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,1+GhostGridY,1)
    !! Source terms on the boundary ! FIXME: check the formula...
    !xn = CompGrid%CurvilinearStuff%xn(i,j+GhostGridY)
    !yn = CompGrid%CurvilinearStuff%yn(i,j+GhostGridY)
    !Source = xn*Sx(i,j+GhostGridY) + yn*Sy(i,j+GhostGridY)
    ! use geometric factors for wall boundary
	nx = CompGrid%CurvilinearStuff%nx(i,j+GhostGridY)
	ny = CompGrid%CurvilinearStuff%ny(i,j+GhostGridY)
   	! Normal vectors are defined at the ghost points used to impose the kinematic boundary conditions
	NormalX = CompGrid%CurvilinearStuff%NormalX(k,i,j)
	NormalY = CompGrid%CurvilinearStuff%NormalY(k,i,j)
    Source = (NormalX*Sx(i,j+GhostGridY) + NormalY*Sy(i,j+GhostGridY))/(NormalX*nx+NormalY*ny)
    !
    var(i,j) = (Source-DOT_PRODUCT(Stenciln(2:rank),var(i,2:rank))) / Stenciln(1)
END DO
j = NNy
DO i = 1+GhostGridX, NNx-GhostGridX
   	Stenciln = CompGrid%CurvilinearStuff%DiffStencils%StencilG(1:rank,rank-GhostGridY,1)
    !! Source terms on the boundary! FIXME: check the formula...
    !xn = CompGrid%CurvilinearStuff%xn(i,j-GhostGridY)
    !yn = CompGrid%CurvilinearStuff%yn(i,j-GhostGridY)
    !Source = xn*Sx(i,j-GhostGridY) + yn*Sy(i,j-GhostGridY)
    ! use geometric factors for wall boundary
	nx = CompGrid%CurvilinearStuff%nx(i,j-GhostGridY)
	ny = CompGrid%CurvilinearStuff%ny(i,j-GhostGridY)
    NormalX = CompGrid%CurvilinearStuff%NormalX(k,i,j)
	NormalY = CompGrid%CurvilinearStuff%NormalY(k,i,j)
    Source = (NormalX*Sx(i,j-GhostGridY) + NormalY*Sy(i,j-GhostGridY))/(NormalX*nx+NormalY*ny)
    !
    var(i,j) = (Source-DOT_PRODUCT(Stenciln(1:rank-1),var(i,j-rank+1:j-1))) / Stenciln(rank)
END DO

END SUBROUTINE UpdateGhostLayerNCurvilinear