module ms_mm_multiply
  use MatrixSwitch_ops

  implicit none

contains

  !================================================!
  ! implementation: reference                      !
  !================================================!

  subroutine mm_multiply_sddenref(A,trA,B,trB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    logical, intent(in) :: trA
    logical, intent(in) :: trB

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k

    !**********************************************!

    C%dval=beta*C%dval

    if ((.not. trA) .and. (.not. trB)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(i,k)*B%dval(k,j)
             end do
          end do
       end do
    else if (trA .and. (.not. trB)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(k,i)*B%dval(k,j)
             end do
          end do
       end do
    else if ((.not. trA) .and. trB) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(i,k)*B%dval(j,k)
             end do
          end do
       end do
    else if (trA .and. trB) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(k,i)*B%dval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_sddenref

  subroutine mm_multiply_szdenref(A,tcA,B,tcB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    integer, intent(in) :: tcA
    integer, intent(in) :: tcB

    complex(dp), intent(in) :: alpha
    complex(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k

    !**********************************************!

    C%zval=beta*C%zval

    if ((tcA==0) .and. (tcB==0)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==0)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==0)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==1)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==1)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==1)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==2)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==2)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==2)) then
       do i=1,C%dim1
          do j=1,C%dim2
             do k=1,A%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*B%zval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_szdenref

  subroutine mm_multiply_sdcscsddensddenref(A,trA,B,trB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    logical, intent(in) :: trA
    logical, intent(in) :: trB

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%dval=beta*C%dval

    if ((.not. trA) .and. (.not. trB)) then
       do k=1,A%dim2
          do l=A%iaux4(k)+1,A%iaux4(k+1)
             i=A%iaux3(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(k,j)
             end do
          end do
       end do
    else if (trA .and. (.not. trB)) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(k,j)
             end do
          end do
       end do
    else if ((.not. trA) .and. trB) then
       do k=1,A%dim2
          do l=A%iaux4(k)+1,A%iaux4(k+1)
             i=A%iaux3(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(j,k)
             end do
          end do
       end do
    else if (trA .and. trB) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_sdcscsddensddenref

  subroutine mm_multiply_sddensdcscsddenref(A,trA,B,trB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    logical, intent(in) :: trA
    logical, intent(in) :: trB

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%dval=beta*C%dval

    if ((.not. trA) .and. (.not. trB)) then
       do j=1,C%dim2
          do l=B%iaux4(j)+1,B%iaux4(j+1)
             k=B%iaux3(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(i,k)*B%dval(l,1)
             end do
          end do
       end do
    else if (trA .and. (.not. trB)) then
       do j=1,C%dim2
          do l=B%iaux4(j)+1,B%iaux4(j+1)
             k=B%iaux3(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(k,i)*B%dval(l,1)
             end do
          end do
       end do
    else if ((.not. trA) .and. trB) then
       do k=1,A%dim2
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(i,k)*B%dval(l,1)
             end do
          end do
       end do
    else if (trA .and. trB) then
       do k=1,A%dim1
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(k,i)*B%dval(l,1)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_sddensdcscsddenref

  subroutine mm_multiply_sddensddensdcscref(A,trA,B,trB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    logical, intent(in) :: trA
    logical, intent(in) :: trB

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%dval=beta*C%dval

    if ((.not. trA) .and. (.not. trB)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim2
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(i,k)*B%dval(k,j)
             end do
          end do
       end do
    else if (trA .and. (.not. trB)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(k,i)*B%dval(k,j)
             end do
          end do
       end do
    else if ((.not. trA) .and. trB) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim2
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(i,k)*B%dval(j,k)
             end do
          end do
       end do
    else if (trA .and. trB) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(k,i)*B%dval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_sddensddensdcscref

  subroutine mm_multiply_sdcsrsddensddenref(A,trA,B,trB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    logical, intent(in) :: trA
    logical, intent(in) :: trB

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%dval=beta*C%dval

    if ((.not. trA) .and. (.not. trB)) then
       do i=1,C%dim1
          do l=A%iaux3(i)+1,A%iaux3(i+1)
             k=A%iaux4(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(k,j)
             end do
          end do
       end do
    else if (trA .and. (.not. trB)) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(k,j)
             end do
          end do
       end do
    else if ((.not. trA) .and. trB) then
       do i=1,C%dim1
          do l=A%iaux3(i)+1,A%iaux3(i+1)
             k=A%iaux4(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(j,k)
             end do
          end do
       end do
    else if (trA .and. trB) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(l,1)*B%dval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_sdcsrsddensddenref

  subroutine mm_multiply_sddensdcsrsddenref(A,trA,B,trB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    logical, intent(in) :: trA
    logical, intent(in) :: trB

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%dval=beta*C%dval

    if ((.not. trA) .and. (.not. trB)) then
       do k=1,A%dim2
          do l=B%iaux3(k)+1,B%iaux3(k+1)
             j=B%iaux4(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(i,k)*B%dval(l,1)
             end do
          end do
       end do
    else if (trA .and. (.not. trB)) then
       do k=1,A%dim1
          do l=B%iaux3(k)+1,B%iaux3(k+1)
             j=B%iaux4(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(k,i)*B%dval(l,1)
             end do
          end do
       end do
    else if ((.not. trA) .and. trB) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(i,k)*B%dval(l,1)
             end do
          end do
       end do
    else if (trA .and. trB) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%dval(i,j)=C%dval(i,j)+alpha*A%dval(k,i)*B%dval(l,1)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_sddensdcsrsddenref

  subroutine mm_multiply_sddensddensdcsrref(A,trA,B,trB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    logical, intent(in) :: trA
    logical, intent(in) :: trB

    real(dp), intent(in) :: alpha
    real(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%dval=beta*C%dval

    if ((.not. trA) .and. (.not. trB)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim2
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(i,k)*B%dval(k,j)
             end do
          end do
       end do
    else if (trA .and. (.not. trB)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(k,i)*B%dval(k,j)
             end do
          end do
       end do
    else if ((.not. trA) .and. trB) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim2
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(i,k)*B%dval(j,k)
             end do
          end do
       end do
    else if (trA .and. trB) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%dval(l,1)=C%dval(l,1)+alpha*A%dval(k,i)*B%dval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_sddensddensdcsrref

  subroutine mm_multiply_szcscszdenszdenref(A,tcA,B,tcB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    integer, intent(in) :: tcA
    integer, intent(in) :: tcB

    complex(dp), intent(in) :: alpha
    complex(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%zval=beta*C%zval

    if ((tcA==0) .and. (tcB==0)) then
       do k=1,A%dim2
          do l=A%iaux4(k)+1,A%iaux4(k+1)
             i=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==0)) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(l,1))*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==0)) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==1)) then
       do k=1,A%dim2
          do l=A%iaux4(k)+1,A%iaux4(k+1)
             i=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==1)) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(l,1))*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==1)) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==2)) then
       do k=1,A%dim2
          do l=A%iaux4(k)+1,A%iaux4(k+1)
             i=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==2)) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(l,1))*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==2)) then
       do i=1,C%dim1
          do l=A%iaux4(i)+1,A%iaux4(i+1)
             k=A%iaux3(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_szcscszdenszdenref

  subroutine mm_multiply_szdenszcscszdenref(A,tcA,B,tcB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    integer, intent(in) :: tcA
    integer, intent(in) :: tcB

    complex(dp), intent(in) :: alpha
    complex(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%zval=beta*C%zval

    if ((tcA==0) .and. (tcB==0)) then
       do j=1,C%dim2
          do l=B%iaux4(j)+1,B%iaux4(j+1)
             k=B%iaux3(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==0)) then
       do j=1,C%dim2
          do l=B%iaux4(j)+1,B%iaux4(j+1)
             k=B%iaux3(l)
             do i=1,C%dim1
               C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==0)) then
       do j=1,C%dim2
          do l=B%iaux4(j)+1,B%iaux4(j+1)
             k=B%iaux3(l)
             do i=1,C%dim1
               C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==1)) then
       do k=1,A%dim2
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*conjg(B%zval(l,1))
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==1)) then
       do k=1,A%dim1
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*conjg(B%zval(l,1))
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==1)) then
       do k=1,A%dim1
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*conjg(B%zval(l,1))
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==2)) then
       do k=1,A%dim2
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==2)) then
       do k=1,A%dim1
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==2)) then
       do k=1,A%dim1
          do l=B%iaux4(k)+1,B%iaux4(k+1)
             j=B%iaux3(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*B%zval(l,1)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_szdenszcscszdenref

  subroutine mm_multiply_szdenszdenszcscref(A,tcA,B,tcB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    integer, intent(in) :: tcA
    integer, intent(in) :: tcB

    complex(dp), intent(in) :: alpha
    complex(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%zval=beta*C%zval

    if ((tcA==0) .and. (tcB==0)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim2
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(i,k)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==0)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*conjg(A%zval(k,i))*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==0)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(k,i)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==1)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim2
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(i,k)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==1)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*conjg(A%zval(k,i))*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==1)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(k,i)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==2)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim2
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(i,k)*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==2)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*conjg(A%zval(k,i))*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==2)) then
       do j=1,C%dim2
          do l=C%iaux4(j)+1,C%iaux4(j+1)
             i=C%iaux3(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(k,i)*B%zval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_szdenszdenszcscref

  subroutine mm_multiply_szcsrszdenszdenref(A,tcA,B,tcB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    integer, intent(in) :: tcA
    integer, intent(in) :: tcB

    complex(dp), intent(in) :: alpha
    complex(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%zval=beta*C%zval

    if ((tcA==0) .and. (tcB==0)) then
       do i=1,C%dim1
          do l=A%iaux3(i)+1,A%iaux3(i+1)
             k=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==0)) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(l,1))*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==0)) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==1)) then
       do i=1,C%dim1
          do l=A%iaux3(i)+1,A%iaux3(i+1)
             k=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==1)) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(l,1))*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==1)) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==2)) then
       do i=1,C%dim1
          do l=A%iaux3(i)+1,A%iaux3(i+1)
             k=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==2)) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(l,1))*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==2)) then
       do k=1,A%dim1
          do l=A%iaux3(k)+1,A%iaux3(k+1)
             i=A%iaux4(l)
             do j=1,C%dim2
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(l,1)*B%zval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_szcsrszdenszdenref

  subroutine mm_multiply_szdenszcsrszdenref(A,tcA,B,tcB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    integer, intent(in) :: tcA
    integer, intent(in) :: tcB

    complex(dp), intent(in) :: alpha
    complex(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%zval=beta*C%zval

    if ((tcA==0) .and. (tcB==0)) then
       do k=1,A%dim2
          do l=B%iaux3(k)+1,B%iaux3(k+1)
             j=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==0)) then
       do k=1,A%dim1
          do l=B%iaux3(k)+1,B%iaux3(k+1)
             j=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==0)) then
       do k=1,A%dim1
          do l=B%iaux3(k)+1,B%iaux3(k+1)
             j=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==1)) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*conjg(B%zval(l,1))
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==1)) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*conjg(B%zval(l,1))
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==1)) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*conjg(B%zval(l,1))
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==2)) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(i,k)*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==2)) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*conjg(A%zval(k,i))*B%zval(l,1)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==2)) then
       do j=1,C%dim2
          do l=B%iaux3(j)+1,B%iaux3(j+1)
             k=B%iaux4(l)
             do i=1,C%dim1
                C%zval(i,j)=C%zval(i,j)+alpha*A%zval(k,i)*B%zval(l,1)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_szdenszcsrszdenref

  subroutine mm_multiply_szdenszdenszcsrref(A,tcA,B,tcB,C,alpha,beta)
    implicit none

    !**** INPUT ***********************************!

    integer, intent(in) :: tcA
    integer, intent(in) :: tcB

    complex(dp), intent(in) :: alpha
    complex(dp), intent(in) :: beta

    type(matrix), intent(in) :: A
    type(matrix), intent(in) :: B

    !**** INOUT ***********************************!

    type(matrix), intent(inout) :: C

    !**** INTERNAL ********************************!

    integer :: i, j, k, l

    !**********************************************!

    C%zval=beta*C%zval

    if ((tcA==0) .and. (tcB==0)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim2
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(i,k)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==0)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*conjg(A%zval(k,i))*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==0)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(k,i)*B%zval(k,j)
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==1)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim2
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(i,k)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==1)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*conjg(A%zval(k,i))*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==1)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(k,i)*conjg(B%zval(j,k))
             end do
          end do
       end do
    else if ((tcA==0) .and. (tcB==2)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim2
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(i,k)*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==1) .and. (tcB==2)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*conjg(A%zval(k,i))*B%zval(j,k)
             end do
          end do
       end do
    else if ((tcA==2) .and. (tcB==2)) then
       do i=1,C%dim1
          do l=C%iaux3(i)+1,C%iaux3(i+1)
             j=C%iaux4(l)
             do k=1,A%dim1
                C%zval(l,1)=C%zval(l,1)+alpha*A%zval(k,i)*B%zval(j,k)
             end do
          end do
       end do
    end if

  end subroutine mm_multiply_szdenszdenszcsrref

end module ms_mm_multiply


CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC
C
C   FFTPACK 5.0
C
C   Authors:  Paul N. Swarztrauber and Richard A. Valent
C
C   $Id$
C
CCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCCC

      SUBROUTINE MRFTI1 (N,WA,FAC)
      REAL       WA(N)      ,FAC(15)
      INTEGER    NTRYH(4)
      DOUBLE PRECISION TPI,ARGH,ARGLD,ARG
      DATA NTRYH(1),NTRYH(2),NTRYH(3),NTRYH(4)/4,2,3,5/
C
      NL = N
      NF = 0
      J = 0
  101 J = J+1
      IF (J-4) 102,102,103
  102 NTRY = NTRYH(J)
      GO TO 104
  103 NTRY = NTRY+2
  104 NQ = NL/NTRY
      NR = NL-NTRY*NQ
      IF (NR) 101,105,101
  105 NF = NF+1
      FAC(NF+2) = NTRY
      NL = NQ
      IF (NTRY .NE. 2) GO TO 107
      IF (NF .EQ. 1) GO TO 107
      DO 106 I=2,NF
         IB = NF-I+2
         FAC(IB+2) = FAC(IB+1)
  106 CONTINUE
      FAC(3) = 2
  107 IF (NL .NE. 1) GO TO 104
      FAC(1) = N
      FAC(2) = NF
      TPI = 8.D0*DATAN(1.D0)
      ARGH = TPI/FLOAT(N)
      IS = 0
      NFM1 = NF-1
      L1 = 1
      IF (NFM1 .EQ. 0) RETURN
      DO 110 K1=1,NFM1
         IP = FAC(K1+2)
         LD = 0
         L2 = L1*IP
         IDO = N/L2
         IPM = IP-1
         DO 109 J=1,IPM
            LD = LD+L1
            I = IS
            ARGLD = FLOAT(LD)*ARGH
            FI = 0.
            DO 108 II=3,IDO,2
               I = I+2
               FI = FI+1.
               ARG = FI*ARGLD
	       WA(I-1) = DCOS(ARG)
	       WA(I) = DSIN(ARG)
  108       CONTINUE
            IS = IS+IDO
  109    CONTINUE
         L1 = L2
  110 CONTINUE
      RETURN
      END


!***** Double precision linear algebra *******************************

      subroutine loupd(x,n,nm,iperm,nperm)
! Lower-upper decomposition of matrix x, logical size n x n,
! stored as size nm x nm.  Returns matrix x(i,j),i<=j as upper
! triangular matrix and x(i,j),i>j as lower diagonal matrix with 1 on
! the diagonal.  The product of these two gives the original matrix x.
! Nperm is the order of the permutations of rows, either +1 or -1,
! unless the matrix is singular, in which case nperm is returned as 0
! and evaluation of the subroutine is stopped.
      implicit none
      integer n,nm,nperm
      integer iperm(nm)
      integer i,ii,j,jj,k,kk,im
      double precision x(nm,nm),temp
      double precision cmax,scl(nm),check
! scl(i) is scaling factor for row i, to normalize largest element to 1
      nperm=1
      do i=1,n
        cmax=0.d0
        do j=1,n
          if(abs(x(i,j)).gt.cmax) cmax=abs(x(i,j))
        enddo
        if (cmax.eq.0.d0) then
          nperm=0
          return
        endif
        scl(i)=1.d0/cmax
      enddo
      do j=1,n
        do i=1,j-1
          temp=x(i,j)
          do k=1,i-1
            temp=temp-x(i,k)*x(k,j)
          enddo
          x(i,j)=temp
        enddo
        cmax=0.d0
        do i=j,n
          temp=x(i,j)
          do k=1,j-1
            temp=temp-x(i,k)*x(k,j)
          enddo
          x(i,j)=temp
          check=scl(i)*abs(temp)
          if (check.ge.cmax) then
            im=i
            cmax=check
          endif
        enddo
        if (j.ne.im) then
          do k=1,n
            temp=x(im,k)
            x(im,k)=x(j,k)
            x(j,k)=temp
          enddo
          nperm=-nperm
          check=scl(j)
          scl(j)=scl(im)
          scl(im)=check
        endif
        iperm(j)=im
        if(j.ne.n) then
          if (x(j,j).ne.0) then
            temp=(1.d0,0.d0)/x(j,j)
            do i=j+1,n
              x(i,j)=x(i,j)*temp
            enddo
          else
            nperm=0
            return
          endif
        endif
      enddo
      return
      end

      subroutine baksublu(x,v,n,nm,iperm)
! Solves a linear equation x'*w=v for w.  X is the lower-upper
! decomposition of x' from subroutine loupd.  Vector v is replaced by
! the solutions w as output.
      implicit none
      integer n,nm,iperm(nm),i,j,ii,jj
      double precision x(nm,nm),v(nm),temp
      ii=0
      do i=1,n
        temp=v(iperm(i))
        v(iperm(i))=v(i)
        if (ii.ne.0) then
          do j=ii,i-1
            temp=temp-x(i,j)*v(j)
          enddo
        elseif (temp.ne.0.d0) then
          ii=i
        endif
        v(i)=temp
      enddo
      do i=n,1,-1
        temp=v(i)
        do j=i+1,n
          temp=temp-x(i,j)*v(j)
        enddo
        v(i)=temp/x(i,i)
      enddo
      return
      end

      subroutine inverse(x,y,n,nm)
! Returns matrix y as the inverse of matrix x, both
! of dimension n x n.
      implicit none
      integer n,nm
      double precision x(nm,nm),y(nm,nm),v(nm)
      integer i,j,k,ii,jj,kk
      integer iperm(nm),nperm
      do i=1,n
        do j=1,n
          if (i.eq.j) then
            y(i,j)=1.d0
          else
            y(i,j)=0.d0
          endif
        enddo
      enddo
      call loupd(x,n,nm,iperm,nperm)
      do j=1,n
        call baksublu(x,y(1,j),n,nm,iperm)
      enddo
      return
      end

!***** Complex linear algebra *********************************************

      subroutine loupdc(x,n,nm,iperm,nperm)
! Lower-upper decomposition of matrix x, logical size n x n,
! stored as size nm x nm.  Returns matrix x(i,j),i<=j as upper
! triangular matrix and x(i,j),i>j as lower diagonal matrix with 1 on
! the diagonal.  The product of these two gives the original matrix x.
! Nperm is the order of the permutations of rows, either +1 or -1,
! unless the matrix is singular, in which case nperm is returned as 0
! and evaluation of the subroutine is stopped.
      implicit none
      integer n,nm,nperm
      integer iperm(nm)
      integer i,ii,j,jj,k,kk,im
      double complex x(nm,nm),temp
      double precision cmax,scl(nm),check
! scl(i) is scaling factor for row i, to normalize largest element to 1
      nperm=1
      do i=1,n
        cmax=0.d0
        do j=1,n
          if(abs(x(i,j)).gt.cmax) cmax=abs(x(i,j))
        enddo
        if (cmax.eq.0.d0) then
          nperm=0
          return
        endif
        scl(i)=1.d0/cmax
      enddo
      do j=1,n
        do i=1,j-1
          temp=x(i,j)
          do k=1,i-1
            temp=temp-x(i,k)*x(k,j)
          enddo
          x(i,j)=temp
        enddo
        cmax=0.d0
        do i=j,n
          temp=x(i,j)
          do k=1,j-1
            temp=temp-x(i,k)*x(k,j)
          enddo
          x(i,j)=temp
          check=scl(i)*abs(temp)
          if (check.ge.cmax) then
            im=i
            cmax=check
          endif
        enddo
        if (j.ne.im) then
          do k=1,n
            temp=x(im,k)
            x(im,k)=x(j,k)
            x(j,k)=temp
          enddo
          nperm=-nperm
          check=scl(j)
          scl(j)=scl(im)
          scl(im)=check
        endif
        iperm(j)=im
        if(j.ne.n) then
          if (x(j,j).ne.0) then
            temp=(1.d0,0.d0)/x(j,j)
            do i=j+1,n
              x(i,j)=x(i,j)*temp
            enddo
          else
            nperm=0
            return
          endif
        endif
      enddo
      return
      end

      subroutine baksubluc(x,v,n,nm,iperm)
! Solves a linear equation x'*w=v for w.  X is the lower-upper
! decomposition of x' from subroutine loupdc.  Vector v is replaced by
! the solutions w as output.
      implicit none
      integer n,nm,iperm(nm),i,j,ii,jj
      double complex x(nm,nm),v(nm),temp
      ii=0
      do i=1,n
        temp=v(iperm(i))
        v(iperm(i))=v(i)
        if (ii.ne.0) then
          do j=ii,i-1
            temp=temp-x(i,j)*v(j)
          enddo
        elseif (temp.ne.0.d0) then
          ii=i
        endif
        v(i)=temp
      enddo
      do i=n,1,-1
        temp=v(i)
        do j=i+1,n
          temp=temp-x(i,j)*v(j)
        enddo
        v(i)=temp/x(i,i)
      enddo
      return
      end

      subroutine inversec(x,y,n,nm)
! Returns matrix y as the inverse of matrix x, both
! of dimension n x n.
      implicit none
      integer n,nm
      double complex x(nm,nm),y(nm,nm),v(nm)
      integer i,j,k,ii,jj,kk
      integer iperm(nm),nperm
!
      double complex ll(nm,nm),uu(nm,nm),AA(nm,nm)
      do i=1,n
        do j=1,n
          if (i.eq.j) then
            y(i,j)=1.d0
          else
            y(i,j)=0.d0
          endif
        enddo
      enddo
      call loupdc(x,n,nm,iperm,nperm)
      do j=1,n
        call baksubluc(x,y(1,j),n,nm,iperm)
      enddo
      return
      end


      SUBROUTINE DSCHUR( N, K, A, LDA, B, LDB, KDET, INFO )
      IMPLICIT NONE
*
*  -- modification of the LAPACK routine DGETF2 --
*
*
*
*
*     .. Scalar Arguments ..
      INTEGER            INFO, LDA, LDB, N, K
      DOUBLE PRECISION   KDET
*     ..
*     .. Array Arguments ..
      DOUBLE PRECISION   A( LDA, * ), B(LDB,*)
*     ..
*
*  Purpose
*  =======
*
*  DSCHUR computes the Schur complement of a general m-by-n matrix A
*  using Gaussian elimination.
*
*      [ A[K,K]   A[K,N-K]   ]
*  A = [                     ]
*      [ A[N-K,K] A[N-K,N-K] ]
*
*
*  B[K,N-K]=A[N-K,N-K]-A[N-K,K] * A[K,K]^-1 * A[K,N-K]
*
*  DSCHUR also computes the determinat of the matrix A[K,K].
*
*
*  Arguments
*  =========
*
*  N       (input) INTEGER
*          The number of columns of the matrix A.  N >= 0.
*
*  K       (input) INTEGER
*          The number of rows of the submatrix A[K,K].  0 <= K <= N
*
*
*  A       (input) DOUBLE PRECISION 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.
*
*  LDA     (input) INTEGER
*          The leading dimension of the array A.  LDA >= max(1,N).
*
*  B       (output) DOUBLE PRECISION array, dimension (LDB,N)
*          On exit, a N-K by N-K matrix that the elememts of the
*          Schur complement stored.
*
*
*  LDB     (output) INTEGER
*          The leading dimension of the array B.  0 <= LDB = N-K.
*
*
*  KDET    (output) DOUBLE PRECISION value
*          The determinant of the matrix A[K,K].
*
*  INFO    (output) 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.
*
*  =====================================================================
*
*     .. Parameters ..
      DOUBLE PRECISION   ONE, ZERO
      PARAMETER          ( ONE = 1.0D+0, ZERO= 0.0D+0 )
*     ..
*     .. Local Scalars ..
      INTEGER            I, J
      DOUBLE PRECISION   TEN, DET(2)
*     ..
*     .. External Functions ..
*     ..
*     .. External Subroutines ..
      EXTERNAL           DGER, DSCAL, XERBLA
*     ..
*     .. Intrinsic Functions ..
      INTRINSIC          MAX, MIN, DABS
*     ..
*     .. Executable Statements ..
*
*     Test the input parameters.
*
      INFO = 0
      IF( N.LT.0 ) THEN
         INFO = -1
      ELSE IF( K.LT.0 .OR. K.GT.N-1) THEN
         INFO = -2
      ELSE IF( LDA.LT.MAX( 1, N ) ) THEN
         INFO = -4
      ELSE IF( LDB.LT.MAX( 1, N-K) ) THEN
         INFO = -6
      END IF
      IF( INFO.NE.0 ) THEN
         CALL XERBLA( 'DSCHUR', -INFO )
         RETURN
      END IF
*
*     Quick return if possible
*
      IF( N.EQ.0 .OR. K.EQ.0 .OR. K.EQ.N)
     $   RETURN
*
      DO 10 J = 1, K
*
*     Compute elements J+1:M of J-th column.
*
         IF( A( J, J ).NE.ZERO ) THEN

            CALL DSCAL( N-J, ONE / A( J, J ), A( J+1, J ), 1 )
*
         ELSE IF( INFO.EQ.0 ) THEN
*
            INFO = J

         END IF
*
*     Update trailing submatrix.
*
         CALL DGER( N-J, N-J, -ONE, A( J+1, J ), 1, A( J, J+1 ), LDA,
     $              A( J+1, J+1 ), LDA )

 10   CONTINUE

      DO 20 I = 1, N-K
         DO 30 J = 1, N-K
*
*     Store elements A( J, J ) of K+1:N rows and columns in matrix B.
*
            B( I, J )=A( K+I, K+J )

 30      CONTINUE
 20   CONTINUE

*
*     Determines the determinant of A[K,K].
*
      DET(1) = 1.0D0
      DET(2) = 0.0D0
      TEN = 10.0D0
      DO 80 I = 1, K
         DET(1) = A(I,I)*DET(1)
         IF (DET(1) .EQ. 0.0D0) GO TO 90
 40      IF (DABS(DET(1)) .GE. 1.0D0) GO TO 50
         DET(1) = TEN*DET(1)
         DET(2) = DET(2) - 1.0D0
         GO TO 40
 50      CONTINUE
 60      IF (DABS(DET(1)) .LT. TEN) GO TO 70
         DET(1) = DET(1)/TEN
         DET(2) = DET(2) + 1.0D0
         GO TO 60
 70      CONTINUE
 80   CONTINUE
 90   CONTINUE

      KDET=DET(1)*10**DET(2)

      RETURN
*
*     End of DSCHUR
*
      END


c $Id: polfit.f,v 1.1 1996/04/19 17:12:51 ty7777 Exp $
c $Log: polfit.f,v $
c Revision 1.1  1996/04/19  17:12:51  ty7777
c Initial revision
c
c
      SUBROUTINE POLFIT(X,Y,NPTS,A,ARRAY,NTERM,CHISQR)
C     BEVINGTON p. 141
      character*256 rcsid /'$Header: /data/petsun4/src_solaris/librms/RCS/polfit.f,v 1.1 1996/04/19 17:12:51 ty7777 Exp $'/
      REAL*4 X(NPTS),Y(NPTS)
      REAL*4 A(NTERM),ARRAY(NTERM,NTERM)
      REAL*4 SUMX(19),SUMY(10)
      IF(NTERM.GT.10)STOP 'POLFIT NTERM TOO LARGE'
      NMAX=2*NTERM-1
      DO 13 N=1,NMAX
   13 SUMX(N)=0.
      DO 15 J=1,NTERM
   15 SUMY(J)=0.
      CHISQR=0.
      DO 50 I=1,NPTS
      XTERM=1.
      DO 44 N=1,NMAX
      SUMX(N)=SUMX(N)+XTERM
   44 XTERM=XTERM*X(I)
      YTERM=Y(I)
      DO 48 N=1,NTERM
      SUMY(N)=SUMY(N)+YTERM
   48 YTERM=YTERM*X(I)
      CHISQR=CHISQR+Y(I)**2
   50 CONTINUE
      DO 54 J=1,NTERM
      DO 54 K=1,NTERM
   54 ARRAY(J,K)=SUMX(J+K-1)
      if(.true.)then
      CALL MATINV(ARRAY,NTERM,DET)
      DO 61 L=1,NTERM
      A(L)=0.
      do 61 J=1,NTERM
   61 A(L)=A(L)+ARRAY(L,J)*SUMY(J)
      else
      DELTA=DETERM(ARRAY,NTERM)
      DO 70 L=1,NTERM
      DO 66 J=1,NTERM
      DO 65 K=1,NTERM
   65 ARRAY(J,K)=SUMX(J+K-1)
   66 ARRAY(J,L)=SUMY(J)
   70 A(L)=DETERM(ARRAY,NTERM)/DELTA
      endif
      DO 75 J=1,NTERM
      CHISQR=CHISQR-2.*A(J)*SUMY(J)
      DO 75 K=1,NTERM
   75 CHISQR=CHISQR+A(J)*A(K)*SUMX(J+K-1)
      CHISQR=CHISQR/FLOAT(NPTS-NTERM)
      RETURN
      END
      FUNCTION DETERM(ARRAY,NORDER)
      REAL*4 ARRAY(NORDER,NORDER)
      DETERM=1.
      DO 50 K=1,NORDER
      IF(ARRAY(K,K).NE.0.)GOTO 41
      DO 23 J=K,NORDER
      IF(ARRAY(J,K).NE.0.)GOTO 31
   23 CONTINUE
      DETERM=0.
      RETURN
   31 DO 34 I=K,NORDER
      SAVE=ARRAY(I,J)
      ARRAY(I,J)=ARRAY(I,K)
   34 ARRAY(I,K)=SAVE
      DETERM=-DETERM
   41 DETERM=DETERM*ARRAY(K,K)
      IF(K.GE.NORDER)GOTO 50
      DO 46 I=K+1,NORDER
      DO 46 J=K+1,NORDER
   46 ARRAY(I,J)=ARRAY(I,J)-ARRAY(I,K)*ARRAY(K,J)/ARRAY(K,K)
   50 CONTINUE
      RETURN
      END
      SUBROUTINE POLTST
      PARAMETER (NPTS=51)
      REAL*4 X(NPTS),Y(NPTS)
      PARAMETER (NORDER=10)
      REAL*4 A(NORDER),ARRAY(NORDER,NORDER),C(NORDER)
      write(*,"(' ENTER NTERM')")
      read(*,*)NTERM
      IF(NTERM.GT.NORDER)STOP 'POLTST NTERM TOO LARGE'
      write(*,"(' ENTER NTERM COEFFICIENTS')")
      read(*,*)(C(N),N=1,NTERM)
      DO 50 I=1,NPTS
      T=-1.+2.*FLOAT(I-1)/FLOAT(NPTS-1)
      X(I)=T
      Y(I)=C(1)
      DO 2 N=2,NTERM
      Y(I)=Y(I)+C(N)*T
    2 T=T*X(I)
   50 CONTINUE
      CALL POLFIT(X,Y,NPTS,A,ARRAY,NTERM,CHISQR)
      DO 10 N=1,NTERM
   10 write(*,101)N,C(N),A(N)
  101 FORMAT(I3,2F10.4)
      write(*,102)CHISQR
  102 FORMAT(' CHISQR',F10.4)
      STOP
      END


module volc_wrapper
  use iso_c_binding, only: c_double, c_int
  use volc, only: solve_gases
  implicit none
contains
  subroutine solve_gases_wrap(T,PP,f_O2,mCO2tot,mH2Otot, &
                             & P_H2O, P_H2, P_CO2, P_CO, &
                             & P_CH4, alphaG, x_CO2, x_H2O) bind(c)
    real(c_double), intent(in) :: T, PP, f_O2, mCO2tot, mH2Otot
    real(c_double), intent(out) :: P_H2O, P_H2, P_CO2, P_CO, P_CH4
    real(c_double), intent(out) :: alphaG, x_CO2, x_H2O
    call solve_gases(T,PP,f_O2,mCO2tot,mH2Otot, &
                   & P_H2O, P_H2, P_CO2, P_CO, &
                   & P_CH4, alphaG, x_CO2, x_H2O)
  end subroutine
end module


      subroutine pvvcalc(p2,p3,p4,p5,v2,v3,v4,v5)
      implicit none
      double precision p2(4),p3(4),p4(4),p5(4),v2(4),v3(4),v4(4),v5(4)
      double precision v2Dp2,v3Dp3,v4Dp4,v5Dp5
      integer j
      v2(1)=+(p3(2)*p4(3)*p5(4)+p3(4)*p4(2)*p5(3)+p3(3)*p4(4)*p5(2)
     .       -p3(2)*p4(4)*p5(3)-p3(3)*p4(2)*p5(4)-p3(4)*p4(3)*p5(2))
      v2(2)=-(p3(3)*p4(4)*p5(1)+p3(1)*p4(3)*p5(4)+p3(4)*p4(1)*p5(3)
     .       -p3(3)*p4(1)*p5(4)-p3(4)*p4(3)*p5(1)-p3(1)*p4(4)*p5(3))
      v2(3)=+(p3(4)*p4(1)*p5(2)+p3(2)*p4(4)*p5(1)+p3(1)*p4(2)*p5(4)
     .       -p3(4)*p4(2)*p5(1)-p3(1)*p4(4)*p5(2)-p3(2)*p4(1)*p5(4))
      v2(4)=+(p3(1)*p4(2)*p5(3)+p3(3)*p4(1)*p5(2)+p3(2)*p4(3)*p5(1)
     .       -p3(1)*p4(3)*p5(2)-p3(2)*p4(1)*p5(3)-p3(3)*p4(2)*p5(1))

      v3(1)=+(p2(2)*p4(3)*p5(4)+p2(4)*p4(2)*p5(3)+p2(3)*p4(4)*p5(2)
     .       -p2(2)*p4(4)*p5(3)-p2(3)*p4(2)*p5(4)-p2(4)*p4(3)*p5(2))
      v3(2)=-(p2(3)*p4(4)*p5(1)+p2(1)*p4(3)*p5(4)+p2(4)*p4(1)*p5(3)
     .       -p2(3)*p4(1)*p5(4)-p2(4)*p4(3)*p5(1)-p2(1)*p4(4)*p5(3))
      v3(3)=+(p2(4)*p4(1)*p5(2)+p2(2)*p4(4)*p5(1)+p2(1)*p4(2)*p5(4)
     .       -p2(4)*p4(2)*p5(1)-p2(1)*p4(4)*p5(2)-p2(2)*p4(1)*p5(4))
      v3(4)=+(p2(1)*p4(2)*p5(3)+p2(3)*p4(1)*p5(2)+p2(2)*p4(3)*p5(1)
     .       -p2(1)*p4(3)*p5(2)-p2(2)*p4(1)*p5(3)-p2(3)*p4(2)*p5(1))

      v4(1)=+(p2(2)*p3(3)*p5(4)+p2(4)*p3(2)*p5(3)+p2(3)*p3(4)*p5(2)
     .       -p2(2)*p3(4)*p5(3)-p2(3)*p3(2)*p5(4)-p2(4)*p3(3)*p5(2))
      v4(2)=-(p2(3)*p3(4)*p5(1)+p2(1)*p3(3)*p5(4)+p2(4)*p3(1)*p5(3)
     .       -p2(3)*p3(1)*p5(4)-p2(4)*p3(3)*p5(1)-p2(1)*p3(4)*p5(3))
      v4(3)=+(p2(4)*p3(1)*p5(2)+p2(2)*p3(4)*p5(1)+p2(1)*p3(2)*p5(4)
     .       -p2(4)*p3(2)*p5(1)-p2(1)*p3(4)*p5(2)-p2(2)*p3(1)*p5(4))
      v4(4)=+(p2(1)*p3(2)*p5(3)+p2(3)*p3(1)*p5(2)+p2(2)*p3(3)*p5(1)
     .       -p2(1)*p3(3)*p5(2)-p2(2)*p3(1)*p5(3)-p2(3)*p3(2)*p5(1))

      v5(1)=+(p2(2)*p3(3)*p4(4)+p2(4)*p3(2)*p4(3)+p2(3)*p3(4)*p4(2)
     .       -p2(2)*p3(4)*p4(3)-p2(3)*p3(2)*p4(4)-p2(4)*p3(3)*p4(2))
      v5(2)=-(p2(3)*p3(4)*p4(1)+p2(1)*p3(3)*p4(4)+p2(4)*p3(1)*p4(3)
     .       -p2(3)*p3(1)*p4(4)-p2(4)*p3(3)*p4(1)-p2(1)*p3(4)*p4(3))
      v5(3)=+(p2(4)*p3(1)*p4(2)+p2(2)*p3(4)*p4(1)+p2(1)*p3(2)*p4(4)
     .       -p2(4)*p3(2)*p4(1)-p2(1)*p3(4)*p4(2)-p2(2)*p3(1)*p4(4))
      v5(4)=+(p2(1)*p3(2)*p4(3)+p2(3)*p3(1)*p4(2)+p2(2)*p3(3)*p4(1)
     .       -p2(1)*p3(3)*p4(2)-p2(2)*p3(1)*p4(3)-p2(3)*p3(2)*p4(1))

      v2Dp2=v2(4)*p2(4)-v2(1)*p2(1)-v2(2)*p2(2)-v2(3)*p2(3)
      v3Dp3=v3(4)*p3(4)-v3(1)*p3(1)-v3(2)*p3(2)-v3(3)*p3(3)
      v4Dp4=v4(4)*p4(4)-v4(1)*p4(1)-v4(2)*p4(2)-v4(3)*p4(3)
      v5Dp5=v5(4)*p5(4)-v5(1)*p5(1)-v5(2)*p5(2)-v5(3)*p5(3)
      do j=1,4
      v2(j)=v2(j)/v2Dp2
      v3(j)=v3(j)/v3Dp3
      v4(j)=v4(j)/v4Dp4
      v5(j)=v5(j)/v5Dp5
      enddo
      return
      end