stdlib_linalg_diag.fypp Source File

#:include "common.fypp"
#:set RCI_KINDS_TYPES = REAL_KINDS_TYPES + CMPLX_KINDS_TYPES + INT_KINDS_TYPES
submodule (stdlib_linalg) stdlib_linalg_diag

  implicit none

contains

    #:for k1, t1 in RCI_KINDS_TYPES
      module function diag_${t1[0]}$${k1}$(v) result(res)
        ${t1}$, intent(in) :: v(:)
        ${t1}$ :: res(size(v),size(v))
        integer :: i
        res = 0
        do i = 1, size(v)
          res(i,i) = v(i)
        end do
      end function diag_${t1[0]}$${k1}$
    #:endfor


    #:for k1, t1 in RCI_KINDS_TYPES
      module function diag_${t1[0]}$${k1}$_k(v,k) result(res)
        ${t1}$, intent(in) :: v(:)
        integer, intent(in) :: k
        ${t1}$ :: res(size(v)+abs(k),size(v)+abs(k))
        integer :: i, sz
        sz = size(v)
        res = 0
        if (k > 0) then
          do i = 1, sz
              res(i,k+i) = v(i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i+abs(k),i) = v(i)
          end do
        else
          do i = 1, sz
              res(i,i) = v(i)
          end do
        end if
      end function diag_${t1[0]}$${k1}$_k
    #:endfor

    #:for k1, t1 in RCI_KINDS_TYPES
      module function diag_${t1[0]}$${k1}$_mat(A) result(res)
        ${t1}$, intent(in) :: A(:,:)
        ${t1}$ :: res(minval(shape(A)))
        integer :: i
        do i = 1, minval(shape(A))
          res(i) = A(i,i)
        end do
      end function diag_${t1[0]}$${k1}$_mat
    #:endfor

    #:for k1, t1 in RCI_KINDS_TYPES
      module function diag_${t1[0]}$${k1}$_mat_k(A,k) result(res)
        ${t1}$, intent(in) :: A(:,:)
        integer, intent(in) :: k
        ${t1}$ :: res(minval(shape(A))-abs(k))
        integer :: i, sz
        sz = minval(shape(A))-abs(k)
        if (k > 0) then
          do i = 1, sz
              res(i) = A(i,k+i)
          end do
        else if (k < 0) then
          do i = 1, sz
              res(i) = A(i+abs(k),i)
          end do
        else
          do i = 1, sz
              res(i) = A(i,i)
          end do
        end if
      end function diag_${t1[0]}$${k1}$_mat_k
    #:endfor

end submodule