irpjast/qmckl_dgemm.org

#+TITLE: QMCkl dgemm

#+NAME: header
#+BEGIN_SRC text
Generated from qmckl_dgemm.org
#+END_SRC

* Fortran interface

#+BEGIN_SRC f90 :noweb yes :tangle qmckl_blas_f.f90
! <<header>>

module qmckl_blas
  use :: iso_c_binding

  interface
     subroutine qmckl_dgemm(transa, transb, m, n, k, &
          alpha, A, lda, B, ldb, beta, C, ldc) bind(C)
       use :: iso_c_binding
       implicit none
       character(kind=c_char  ), value :: transa, transb
       integer  (kind=c_int   ), value :: m, n, k, lda, ldb, ldc
       real     (kind=c_double), value :: alpha, beta
       real     (kind=c_double)        :: A(lda,*), B(ldb,*), C(ldc,*)
     end subroutine qmckl_dgemm
  end interface

end module qmckl_blas
#+END_SRC

* C code
  To avoid passing too many arguments to recursive subroutines, we put
  all the arguments in a struct.

  #+NAME: dgemm_args
  #+BEGIN_SRC c
struct dgemm_args {
  double alpha; 
  double beta;
  double* A;
  double* B;
  double* C;
  int m;
  int n;
  int k;
  int lda;
  int ldb;
  int ldc;
  CBLAS_LAYOUT transa;
  CBLAS_LAYOUT transb;
}; 
  
  #+END_SRC

  The driver routine packs the arguments in the struct and calls the
  recursive routine.

  #+NAME: dgemm
  #+BEGIN_SRC c 
void qmckl_dgemm(char transa, char transb,
                 int m, int n, int k,
                 double alpha, 
                 double* A, int lda,
                 double* B, int ldb,
                 double beta,
                 double* C, int ldc)
{
  struct dgemm_args args; 

  args.alpha = alpha;
  args.beta  = beta ;
  args.A = A;
  args.B = B;
  args.C = C;
  args.m = m;
  args.n = n;
  args.k = k;
  args.lda = lda;
  args.ldb = ldb;
  args.ldc = ldc;

  if (transa == 'T' || transa == 't') {
    args.transa = CblasTrans; 
  } else {
    args.transa = CblasNoTrans; 
  }

  CBLAS_LAYOUT tb;
  if (transa == 'T' || transa == 't') {
    args.transb = CblasTrans; 
  } else {
    args.transb = CblasNoTrans; 
  }

  qmckl_dgemm_rec(args);
}

  #+END_SRC


  #+NAME: dgemm_rec
  #+BEGIN_SRC c 
static void qmckl_dgemm_rec(struct dgemm_args args) {

  cblas_dgemm(CblasColMajor, args.transa, args.transb, 
              args.m, args.n, args.k, args.alpha,
              args.A, args.lda, args.B, args.ldb,
              args.beta, args.C, args.ldc);

}
  #+END_SRC

  #+BEGIN_SRC c :noweb yes :tangle qmckl_dgemm.c
/* <<header>> */

#include <cblas.h>

<<dgemm_args>>

<<dgemm_rec>>

<<dgemm>>
  #+END_SRC