← Back to branch summary

~logan/ubuntu/trusty/suitesparse/4.2.1-3ubuntu1

« back to all changes in this revision

Viewing changes to RBio/RBtype_mex_64.f

  • Committer: Bazaar Package Importer
  • Author(s): Christophe Prud'homme
  • Date: 2007-05-29 09:36:29 UTC
  • mfrom: (1.1.1 upstream)
  • Revision ID: james.westby@ubuntu.com-20070529093629-zowquo0b7slkk6nc
Tags: 3.0.0-2
http://bugs.debian.org/426349
http://bugs.debian.org/426354
* suitesparse builds properly twice in a row
* Bug fix: "suitesparse - FTBFS: Broken build depens: libgfortran1-dev",
  thanks to Bastian Blank (Closes: #426349).
* Bug fix: "suitesparse_3.0.0-1: FTBFS: build-depends on
  libgfortran1-dev", thanks to Steve Langasek (Closes: #426354).

Show diffs side-by-side

added added

removed removed

Lines of Context:
RBio/RBtype_mex_64.f
 
1
c=======================================================================
 
2
c=== RBio/RBtype_mex_64 ================================================
 
3
c=======================================================================
 
4
 
 
5
c RBio: a MATLAB toolbox for reading and writing sparse matrices in
 
6
c Rutherford/Boeing format.
 
7
c Copyright (c) 2007, Timothy A. Davis, Univ. of Florida
 
8
 
 
9
 
 
10
c-----------------------------------------------------------------------
 
11
c RBtype mexFunction:
 
12
c-----------------------------------------------------------------------
 
13
c
 
14
c   [mtype mkind skind] = RBtype (A)
 
15
c
 
16
c   A: a sparse matrix.   Determines the Rutherford/Boeing type of the
 
17
c   matrix.  Very little memory is used (just size(A,2) integer
 
18
c   workspace), so this can succeed where a test such as nnz(A-A')==0
 
19
c   will fail.
 
20
c
 
21
c       mkind:  r: (0), A is real, and not binary
 
22
c               p: (1), A is binary
 
23
c               c: (2), A is complex
 
24
c               i: (3), A is integer
 
25
c
 
26
c       skind:  r: (-1), A is rectangular
 
27
c               u: (0), A is unsymmetric (not S, H, Z, below)
 
28
c               s: (1), A is symmetric (nnz(A-A.') is 0)
 
29
c               h: (2), A is Hermitian (nnz(A-A') is 0)
 
30
c               z: (3), A is skew symmetric (nnz(A+A.') is 0)
 
31
c
 
32
c   mtype is a 3-character string, where mtype(1) is the mkind
 
33
c   ('r', 'p', 'c', or 'i').  mtype(2) is the skind ('r', 'u', 's', 'h',
 
34
c   or 'z'), and mtype(3) is always 'a'.
 
35
c-----------------------------------------------------------------------
 
36
 
 
37
        subroutine mexfunction (nargout, pargout, nargin, pargin)
 
38
        integer*8
 
39
     $      pargout (*), pargin (*)
 
40
        integer*4 nargout, nargin
 
41
 
 
42
c       ----------------------------------------------------------------
 
43
c       MATLAB functions
 
44
c       ----------------------------------------------------------------
 
45
 
 
46
        integer*4 mxClassIDFromClassName,
 
47
     $      mxIsClass, mxIsSparse, mxIsComplex
 
48
 
 
49
        integer*8
 
50
     $      mxGetM, mxGetN, mxGetJc, mxGetIr, mxGetPr, mxGetPi,
 
51
     $      mxGetData, mxCreateNumericMatrix, mxCreateDoubleScalar,
 
52
     $      mxCreateString
 
53
 
 
54
c       ----------------------------------------------------------------
 
55
c       local variables
 
56
c       ----------------------------------------------------------------
 
57
 
 
58
        integer*8
 
59
     $      nrow, ncol, nnz, mkind, cp, skind, cmplex, cpmat,
 
60
     $      Ap, Ai, Ax, Az, kmin, kmax, one
 
61
        integer*4 iclass, wcmplex
 
62
        character mtype*3
 
63
        double precision t
 
64
 
 
65
c       ----------------------------------------------------------------
 
66
c       check inputs
 
67
c       ----------------------------------------------------------------
 
68
 
 
69
        if (nargin .ne. 1 .or. nargout .gt. 3) then
 
70
            call mexErrMsgTxt ('[mtype mkind skind] = RBtype (A)')
 
71
        endif
 
72
 
 
73
c       ----------------------------------------------------------------
 
74
c       get A
 
75
c       ----------------------------------------------------------------
 
76
 
 
77
        if (mxIsClass (pargin (1), 'double') .ne. 1 .or.
 
78
     $      mxIsSparse (pargin (1)) .ne. 1) then
 
79
            call mexErrMsgTxt ('A must be sparse and double')
 
80
        endif
 
81
        cmplex = mxIsComplex (pargin (1))
 
82
        Ap = mxGetJc (pargin (1))
 
83
        Ai = mxGetIr (pargin (1))
 
84
        Ax = mxGetPr (pargin (1))
 
85
        Az = mxGetPi (pargin (1))
 
86
        nrow = mxGetM (pargin (1))
 
87
        ncol = mxGetN (pargin (1))
 
88
 
 
89
c       ----------------------------------------------------------------
 
90
c       allocate workspace
 
91
c       ----------------------------------------------------------------
 
92
 
 
93
        iclass = mxClassIDFromClassName ('int64')
 
94
        one = 1
 
95
        wcmplex = 0
 
96
        cpmat = mxCreateNumericMatrix (ncol+1, one, iclass, wcmplex)
 
97
        cp = mxGetData (cpmat)
 
98
 
 
99
c       ----------------------------------------------------------------
 
100
c       determine the mtype of A
 
101
c       ----------------------------------------------------------------
 
102
 
 
103
        call RBkind (nrow, ncol, %val(Ap), %val(Ai), %val(Ax),
 
104
     $      %val(Az), cmplex, mkind, skind, mtype, nnz, %val(cp),
 
105
     $      kmin, kmax)
 
106
 
 
107
c       ----------------------------------------------------------------
 
108
c       return the result
 
109
c       ----------------------------------------------------------------
 
110
 
 
111
        pargout (1) = mxCreateString (mtype)
 
112
        if (nargout .ge. 2) then
 
113
            t = mkind
 
114
            pargout (2) = mxCreateDoubleScalar (t)
 
115
        endif
 
116
        if (nargout .ge. 3) then
 
117
            t = skind
 
118
            pargout (3) = mxCreateDoubleScalar (t)
 
119
        endif
 
120
 
 
121
c       ----------------------------------------------------------------
 
122
c       free workspace
 
123
c       ----------------------------------------------------------------
 
124
 
 
125
        call mxDestroyArray (%val (cpmat))
 
126
        return
 
127
        end
 
128