← Back to branch summary

~ubuntu-branches/ubuntu/karmic/scilab/karmic

« back to all changes in this revision

Viewing changes to examples/interface-lapack/intfdgemm.f

  • Committer: Bazaar Package Importer
  • Author(s): Torsten Werner
  • Date: 2002-03-21 16:57:43 UTC
  • Revision ID: james.westby@ubuntu.com-20020321165743-e9mv12c1tb1plztg
Tags: upstream-2.6
Import upstream version 2.6

Show diffs side-by-side

added added

removed removed

Lines of Context:
examples/interface-lapack/intfdgemm.f
 
1
      subroutine intfdgemm(fname)
 
2
c***************************************************************************
 
3
c     Example of interface: dgemm.f  (BLAS3)
 
4
c   usage: 
 
5
c   C=fdgemm(alfa,A,B,beta,C)
 
6
c
 
7
c************************************************************************
 
8
 
 
9
c     Copyright INRIA/ENPC
 
10
      include 'stack.h'
 
11
      logical getrhsvar
 
12
      logical checklhs,checkrhs
 
13
      character fname*(*)
 
14
c
 
15
c*****************************************************
 
16
c      0-Check number of rhs and lhs arguments
 
17
c*****************************************************       
 
18
       minrhs=5
 
19
       maxrhs=5
 
20
       minlhs=1
 
21
       maxlhs=1
 
22
c
 
23
       if(.not.checkrhs(fname,minrhs,maxrhs)) return
 
24
       if(.not.checklhs(fname,minlhs,maxlhs)) return
 
25
 
 
26
c*****************************************************
 
27
c      1-Get rhs parameters
 
28
c*****************************************************
 
29
c      alpha
 
30
       if(.not.getrhsvar(1,'d', m1,n1, lalfa))return
 
31
c      A
 
32
       if(.not.getrhsvar(2,'d', mA,nA, lA)) return
 
33
c      B
 
34
       if(.not.getrhsvar(3,'d', mB,nB, lB)) return
 
35
c      beta
 
36
       if(.not.getrhsvar(4,'d', m4,n4, lbeta)) return
 
37
c      C
 
38
       if(.not.getrhsvar(5,'d', mC,nC, lC)) return
 
39
       m=mA
 
40
       n=nB
 
41
       if((nA.ne.mB).or.((m1*n1*m4*n4).ne.1)) then
 
42
            call erro("Bad call to dgemm")
 
43
            return
 
44
       endif
 
45
       if((mA.ne.mC).or.(nB.ne.nC)) then
 
46
            call erro("invalid matrix dims in "//fname(1:6))
 
47
            return
 
48
       endif
 
49
c
 
50
       k=nA
 
51
       call dgemm('n','n',m ,n ,k,stk(lalfa),
 
52
     $      stk(lA),mA ,stk(lB),mB ,stk(lbeta) ,stk(lC),mC)
 
53
c      Return C (#5)
 
54
       lhsvar(1)=5
 
55
c
 
56
       end
 
57
 
 
58
 
 
59