blas.F90

Go to the documentation of this file.

!! Copyright (C) 2002-2006 M. Marques, A. Castro, A. Rubio, G. Bertsch
!!
!! This program is free software; you can redistribute it and/or modify
!! it under the terms of the GNU General Public License as published by
!! the Free Software Foundation; either version 2, or (at your option)
!! any later version.
!!
!! This program is distributed in the hope that it will be useful,
!! but WITHOUT ANY WARRANTY; without even the implied warranty of
!! MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
!! GNU General Public License for more details.
!!
!! You should have received a copy of the GNU General Public License
!! along with this program; if not, write to the Free Software
!! Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA
!! 02110-1301, USA.
!!
 
#include "global.h"
 
! -----------------------------------------------------------------------
! -----------------------------------------------------------------------
module blas_oct_m
 
  implicit none
 
  public ! interfaces, plus the wrappers below, in this module
 
  ! ---------------------------------------------------------------------
  ! BLAS level I
  ! ---------------------------------------------------------------------
 
  interface blas_swap
    subroutine dswap(n, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)    :: n, incx, incy
      real(real64),    intent(inout) :: dx, dy
    end subroutine dswap
 
    subroutine zswap(n, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)    :: n, incx, incy
      complex(real64), intent(inout) :: dx, dy
    end subroutine zswap
  end interface blas_swap
 
  interface blas_scal
    subroutine dscal(n, da, dx, incx)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)    :: n, incx
      real(real64),    intent(in)    :: da
      real(real64),    intent(inout) :: dx
    end subroutine dscal
 
    subroutine zscal(n, da, dx, incx)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)    :: n, incx
      complex(real64), intent(in)    :: da
      complex(real64), intent(inout) :: dx
    end subroutine zscal
 
    subroutine zdscal(n, da, dx, incx)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)    :: n, incx
      real(real64),    intent(in)    :: da
      complex(real64), intent(inout) :: dx
    end subroutine zdscal
  end interface blas_scal
 
  interface blas_axpy
    subroutine daxpy (n, da, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)    :: n, incx, incy
      real(real64),    intent(in)    :: da, dx
      real(real64),    intent(inout) :: dy
    end subroutine daxpy
 
    subroutine zaxpy (n, da, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)    :: n, incx, incy
      complex(real64), intent(in)    :: da, dx
      complex(real64), intent(inout) :: dy
    end subroutine zaxpy
 
    module procedure dazaxpy
  end interface blas_axpy
 
  interface blas_copy
    subroutine dcopy(n, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)  :: n, incx, incy
      real(real64),    intent(in)  :: dx
      real(real64),    intent(out) :: dy
    end subroutine dcopy
 
    subroutine zcopy(n, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in)  :: n, incx, incy
      complex(real64), intent(in)  :: dx
      complex(real64), intent(out) :: dy
    end subroutine zcopy
  end interface blas_copy
 
  interface blas_dot
    real(real64) function ddot(n, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in) :: n, incx, incy
      real(real64),    intent(in) :: dx, dy
    end function ddot
 
#if defined(HAVE_ACCELERATE)
    module procedure zdotc
#else
    complex(real64) function zdotc(n, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in) :: n, incx, incy
      complex(real64), intent(in) :: dx, dy
    end function zdotc
#endif
  end interface blas_dot
 
  interface blas_dotu
#if defined(HAVE_ACCELERATE)
    module procedure zdotu
#else
    complex(real64) function zdotu(n, dx, incx, dy, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in) :: n, incx, incy
      complex(real64), intent(in) :: dx, dy
    end function zdotu
#endif
  end interface blas_dotu
 
  interface blas_nrm2
    real(real64) function dnrm2(n, dx, incx)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in) :: n, incx
      real(real64),    intent(in) :: dx
    end function dnrm2
 
    real(real64) function dznrm2(n, dx, incx)
      use, intrinsic :: iso_fortran_env
      implicit none
      integer,         intent(in) :: n, incx
      complex(real64), intent(in) :: dx
    end function dznrm2
  end interface blas_nrm2
 
 
  ! ------------------------------------------------------------------
  ! BLAS level II
  ! ------------------------------------------------------------------
 
  interface blas_symv
    subroutine dsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: uplo
      integer,           intent(in)    :: n, lda, incx, incy
      real(real64),      intent(in)    :: alpha, beta
      real(real64),      intent(in)    :: a
      real(real64),      intent(in)    :: x
      real(real64),      intent(inout) :: y
    end subroutine dsymv
 
    subroutine zsymv(uplo, n, alpha, a, lda, x, incx, beta, y, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: uplo
      integer,           intent(in)    :: n, lda, incx, incy
      complex(real64),   intent(in)    :: alpha, beta
      complex(real64),   intent(in)    :: a
      complex(real64),   intent(in)    :: x
      complex(real64),   intent(inout) :: y
    end subroutine zsymv
  end interface blas_symv
 
  interface blas_gemv
    subroutine dgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: trans
      integer,           intent(in)    :: m, n, lda, incx, incy
      real(real64),      intent(in)    :: alpha, beta
      real(real64),      intent(in)    :: a
      real(real64),      intent(in)    :: x
      real(real64),      intent(inout) :: y
    end subroutine dgemv
 
    subroutine zgemv(trans, m, n, alpha, a, lda, x, incx, beta, y, incy)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: trans
      integer,           intent(in)    :: m, n, lda, incx, incy
      complex(real64),   intent(in)    :: alpha, beta
      complex(real64),   intent(in)    :: a
      complex(real64),   intent(in)    :: x
      complex(real64),   intent(inout) :: y
    end subroutine zgemv
  end interface blas_gemv
 
 
  ! ------------------------------------------------------------------
  ! BLAS level III
  ! ------------------------------------------------------------------
 
  interface blas_gemm
    subroutine dgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: transa, transb
      integer,           intent(in)    :: m, n, k, lda, ldb, ldc
      real(real64),      intent(in)    :: alpha, beta
      real(real64),      intent(in)    :: a
      real(real64),      intent(in)    :: b
      real(real64),      intent(inout) :: c
    end subroutine dgemm
 
    subroutine zgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: transa, transb
      integer,           intent(in)    :: m, n, k, lda, ldb, ldc
      complex(real64),   intent(in)    :: alpha, beta
      complex(real64),   intent(in)    :: a
      complex(real64),   intent(in)    :: b
      complex(real64),   intent(inout) :: c
    end subroutine zgemm
 
    module procedure zdgemm
  end interface
 
  interface blas_trmm
    subroutine dtrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: side, uplo, transa, diag
      integer,           intent(in)    :: m, n, lda, ldb
      real(real64),      intent(in)    :: a, alpha
      real(real64),      intent(inout) :: b
    end subroutine dtrmm
 
    subroutine ztrmm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: side, uplo, transa, diag
      integer,           intent(in)    :: m, n, lda, ldb
      complex(real64),   intent(in)    :: a, alpha
      complex(real64),   intent(inout) :: b
    end subroutine ztrmm
  end interface blas_trmm
 
  interface blas_symm
    subroutine dsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1), intent(in)    :: side, uplo
      integer,      intent(in)    :: m, n, lda, ldb, ldc
      real(real64), intent(in)    :: alpha, beta, a, b
      real(real64), intent(inout) :: c
    end subroutine dsymm
 
    subroutine zsymm(side, uplo, m, n, alpha, a, lda, b, ldb, beta, c, ldc)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: side, uplo
      integer,           intent(in)    :: m, n, lda, ldb, ldc
      complex(real64),   intent(in)    :: alpha, beta, a, b
      complex(real64),   intent(inout) :: c
    end subroutine zsymm
  end interface blas_symm
 
  interface blas_herk
    subroutine dsyrk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: uplo, trans
      integer,           intent(in)    :: n, k, lda, ldc
      real(real64),      intent(in)    :: alpha, beta, a
      real(real64),      intent(inout) :: c
    end subroutine dsyrk
 
    subroutine zherk(uplo, trans, n, k, alpha, a, lda, beta, c, ldc)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: uplo, trans
      integer,           intent(in)    :: n, k, lda, ldc
      real(real64),      intent(in)    :: alpha, beta
      complex(real64),   intent(in)    :: a
      complex(real64),   intent(inout) :: c
    end subroutine zherk
  end interface blas_herk
 
  interface blas_trsm
    subroutine dtrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1), intent(in)    :: side
      character(1), intent(in)    :: uplo
      character(1), intent(in)    :: transa
      character(1), intent(in)    :: diag
      integer,      intent(in)    :: m
      integer,      intent(in)    :: n
      real(real64), intent(in)    :: alpha
      real(real64), intent(in)    :: a
      integer,      intent(in)    :: lda
      real(real64), intent(inout) :: b
      integer,      intent(in)    :: ldb
    end subroutine dtrsm
 
    subroutine ztrsm(side, uplo, transa, diag, m, n, alpha, a, lda, b, ldb)
      use, intrinsic :: iso_fortran_env
      implicit none
      character(1),      intent(in)    :: side
      character(1),      intent(in)    :: uplo
      character(1),      intent(in)    :: transa
      character(1),      intent(in)    :: diag
      integer,           intent(in)    :: m
      integer,           intent(in)    :: n
      complex(real64),   intent(in)    :: alpha
      complex(real64),   intent(in)    :: a
      integer,           intent(in)    :: lda
      complex(real64),   intent(inout) :: b
      integer,           intent(in)    :: ldb
    end subroutine ztrsm
  end interface blas_trsm
 
contains
 
#if defined(HAVE_ACCELERATE)
 
  complex(real64) function zdotc(n, dx, incx, dy, incy)
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env
    implicit none
    integer,         intent(in) :: n, incx, incy
    complex(real64), intent(in) :: dx, dy
 
    interface
      subroutine cblas_zdotc_sub(n, x, incx, y, incy, dotc) bind(c, name="cblas_zdotc_sub")
        use, intrinsic :: iso_c_binding
        implicit none
        integer(c_int),            intent(in), value :: n, incx, incy
        complex(c_double_complex), intent(in)        :: x, y
        complex(c_double_complex), intent(out)       :: dotc
      end subroutine cblas_zdotc_sub
    end interface
 
    ! no PUSH_SUB, called too often
 
    call cblas_zdotc_sub(n, dx, incx, dy, incy, zdotc)
 
  end function zdotc
 
  complex(real64) function zdotu(n, dx, incx, dy, incy)
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env
    implicit none
    integer,         intent(in) :: n, incx, incy
    complex(real64), intent(in) :: dx, dy
 
    interface
      subroutine cblas_zdotu_sub(n, x, incx, y, incy, dotu) bind(c, name="cblas_zdotu_sub")
        use, intrinsic :: iso_c_binding
        implicit none
        integer(c_int),            intent(in), value :: n, incx, incy
        complex(c_double_complex), intent(in)        :: x, y
        complex(c_double_complex), intent(out)       :: dotu
      end subroutine cblas_zdotu_sub
    end interface
 
    ! no PUSH_SUB, called too often
 
    call cblas_zdotu_sub(n, dx, incx, dy, incy, zdotu)
 
  end function zdotu
#endif
 
  subroutine dazaxpy(n, da, dx, dy)
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env
    implicit none
    integer,         intent(in)            :: n
    real(real64),    intent(in)            :: da
    complex(real64), intent(in),    target :: dx
    complex(real64), intent(inout), target :: dy
 
    real(real64), pointer :: rx, ry
 
    ! no PUSH_SUB, called too often
 
    call c_f_pointer(c_loc(dx), rx)
    call c_f_pointer(c_loc(dy), ry)
 
    call blas_axpy(2*n, da, rx, 1, ry, 1)
 
  end subroutine dazaxpy
 
  subroutine zdgemm(transa, transb, m, n, k, alpha, a, lda, b, ldb, beta, c, ldc)
    use, intrinsic :: iso_c_binding
    use, intrinsic :: iso_fortran_env
    implicit none
    character(1),    intent(in)            :: transa, transb
    integer,         intent(in)            :: m, n, k, lda, ldb, ldc
    real(real64),    intent(in)            :: alpha, beta
    complex(real64), intent(in),    target :: a
    real(real64),    intent(in)            :: b
    complex(real64), intent(inout), target :: c
 
    real(real64), pointer :: ra, rc
 
    ! no PUSH_SUB, called too often
 
    call c_f_pointer(c_loc(a), ra)
    call c_f_pointer(c_loc(c), rc)
 
    call blas_gemm(transa, transb, m, n, k, alpha, ra, lda, b, ldb, beta, rc, ldc)
 
  end subroutine zdgemm
 
end module blas_oct_m
 
 
!! Local Variables:
!! mode: f90
!! coding: utf-8
!! End: