← Back to branch summary

~ubuntu-branches/ubuntu/dapper/fpc/dapper

« back to all changes in this revision

Viewing changes to packages/numlib/omv.pas

  • Committer: Bazaar Package Importer
  • Author(s): Carlos Laviola
  • Date: 2004-08-12 16:29:37 UTC
  • mfrom: (1.2.1 upstream) (2.1.1 warty)
  • Revision ID: james.westby@ubuntu.com-20040812162937-moo8ulvysp1ln771
Tags: 1.9.4-5
http://bugs.debian.org/265265
fp-compiler: needs ld, adding dependency on binutils.  (Closes: #265265)

Show diffs side-by-side

added added

removed removed

Lines of Context:
packages/numlib/omv.pas
1
 
{
2
 
    $Id: omv.pas,v 1.1 2000/07/13 06:34:15 michael Exp $
3
 
    This file is part of the Numlib package.
4
 
    Copyright (c) 1986-2000 by
5
 
     Kees van Ginneken, Wil Kortsmit and Loek van Reij of the
6
 
     Computational centre of the Eindhoven University of Technology
7
 
 
8
 
    FPC port Code          by Marco van de Voort (marco@freepascal.org)
9
 
             documentation by Michael van Canneyt (Michael@freepascal.org)
10
 
 
11
 
    This unit contains some basic matrix operations.
12
 
 
13
 
    See the file COPYING.FPC, included in this distribution,
14
 
    for details about the copyright.
15
 
 
16
 
    This program is distributed in the hope that it will be useful,
17
 
    but WITHOUT ANY WARRANTY; without even the implied warranty of
18
 
    MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.
19
 
 
20
 
 **********************************************************************}
21
 
 
22
 
Unit omv;
23
 
{$I direct.inc}
24
 
 
25
 
interface
26
 
 
27
 
uses typ;
28
 
 
29
 
{Calculates inproduct of vectors a and b which have N elements. The first
30
 
element is passed in a and b}
31
 
Function omvinp(Var a, b: ArbFloat; n: ArbInt): ArbFloat;
32
 
 
33
 
{Multiplication of two matrices C=AxB }
34
 
Procedure omvmmm(Var a: ArbFloat; m, n, rwa: ArbInt;
35
 
                 Var b: ArbFloat; k, rwb: ArbInt;
36
 
                 Var c: ArbFloat; rwc: ArbInt);
37
 
 
38
 
{Multiplication of a matrix(A) with a vector(B), C=A x B}
39
 
Procedure omvmmv(Var a: ArbFloat; m, n, rwidth: ArbInt; Var b, c: ArbFloat);
40
 
 
41
 
{Calculate 1-Norm of matrix A}
42
 
Function omvn1m(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
43
 
 
44
 
{Calculate 1-Norm of vector A}
45
 
Function omvn1v(Var a: ArbFloat; n: ArbInt): ArbFloat;
46
 
 
47
 
{Calculate 2-Norm of vector A}
48
 
Function omvn2v(Var a: ArbFloat; n: ArbInt): ArbFloat;
49
 
 
50
 
{Calculate Frobenius-Norm of mxn matrix A}
51
 
Function omvnfm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
52
 
 
53
 
{Calculates maximum (infinite) norm of mxn matrix a}
54
 
Function omvnmm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
55
 
 
56
 
{Calculates maximum (infinite) norm of n-Vector }
57
 
Function omvnmv(Var a: ArbFloat; n: ArbInt): ArbFloat;
58
 
 
59
 
{Transponate mxn matrix A  (which was declared rwa bytes wide), put
60
 
it to C (rwc was declared elements wide)}
61
 
Procedure omvtrm(Var a: ArbFloat; m, n, rwa: ArbInt; Var c: ArbFloat;
62
 
                        rwc: ArbInt);
63
 
 
64
 
IMPLEMENTATION
65
 
 
66
 
Function omvinp(Var a, b: ArbFloat; n: ArbInt): ArbFloat;
67
 
 
68
 
Var        pa, pb : ^arfloat1;
69
 
                i : ArbInt;
70
 
                s : ArbFloat;
71
 
Begin
72
 
  If n<1 Then
73
 
    exit(0);
74
 
  pa := @a;
75
 
 pb := @b;
76
 
 s := 0;
77
 
  For i:=1 To n Do
78
 
    Begin
79
 
      s := s+pa^[i]*pb^[i]
80
 
    End; {i}
81
 
  omvinp := s
82
 
End; {omvinp}
83
 
 
84
 
Procedure omvmmm(Var a: ArbFloat; m, n, rwa: ArbInt;
85
 
                 Var b: ArbFloat; k, rwb: ArbInt;
86
 
                 Var c: ArbFloat; rwc: ArbInt);
87
 
 
88
 
Var           pa, pb, pc : ^arfloat1;
89
 
     i, j, l, inda, indc : ArbInt;
90
 
                       s : ArbFloat;
91
 
Begin
92
 
  If (m<1) Or (n<1) Or (k<1) Then
93
 
   exit;
94
 
  pa := @a;
95
 
 pb := @b;
96
 
 pc := @c;
97
 
  For i:=1 To m Do
98
 
    Begin
99
 
      inda := (i-1)*rwa;
100
 
      indc := (i-1)*rwc;
101
 
      For j:=1 To k Do
102
 
        Begin
103
 
          s := 0;
104
 
          For l:=1 To n Do
105
 
            s := s+pa^[inda+l]*pb^[(l-1)*rwb+j];
106
 
          pc^[indc+j] := s
107
 
        End {j}
108
 
    End; {i}
109
 
End; {omvmmm}
110
 
 
111
 
Procedure omvmmv(Var a: ArbFloat; m, n, rwidth: ArbInt; Var b, c: ArbFloat);
112
 
 
113
 
Var     pa, pb, pc : ^arfloat1;
114
 
         i, j, ind : ArbInt;
115
 
Begin
116
 
  If (m<1) Or (n<1) Then
117
 
    exit;
118
 
  pa := @a;
119
 
 pb := @b;
120
 
 pc := @c;
121
 
 ind := 0;
122
 
  For i:=1 To m Do
123
 
    Begin
124
 
      pc^[i] := omvinp(pa^[ind+1], pb^[1], n);
125
 
      ind := ind+rwidth
126
 
    End; {i}
127
 
End; {omvmmv}
128
 
 
129
 
Function omvn1m(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
130
 
 
131
 
Var           pa : ^arfloat1;
132
 
            i, j : ArbInt;
133
 
     norm, normc : ArbFloat;
134
 
 
135
 
Begin
136
 
  If (m<1) Or (n<1) Then
137
 
    exit;
138
 
  pa := @a;
139
 
 norm := 0;
140
 
  For j:=1 To n Do
141
 
    Begin
142
 
      normc := 0;
143
 
      For i:=1 To m Do
144
 
        normc := normc+abs(pa^[j+(i-1)*rwidth]);
145
 
      If norm<normc Then
146
 
        norm := normc
147
 
    End;
148
 
  omvn1m := norm
149
 
End {omvn1m};
150
 
 
151
 
Function omvn1v(Var a: ArbFloat; n: ArbInt): ArbFloat;
152
 
 
153
 
Var   pa : ^arfloat1;
154
 
       i : ArbInt;
155
 
    norm : ArbFloat;
156
 
 
157
 
Begin
158
 
  If n<1 Then
159
 
    exit;
160
 
  pa := @a;
161
 
  norm := 0;
162
 
  For i:=1 To n Do
163
 
    norm := norm+abs(pa^[i]);
164
 
  omvn1v := norm
165
 
End {omvn1v};
166
 
 
167
 
Function omvn2v(Var a: ArbFloat; n: ArbInt): ArbFloat;
168
 
 
169
 
Var   pa : ^arfloat1;
170
 
       i : ArbInt;
171
 
    norm : ArbFloat;
172
 
 
173
 
Begin
174
 
  If n<1 Then
175
 
    exit;
176
 
  pa := @a;
177
 
  norm := 0;
178
 
  For i:=1 To n Do
179
 
    norm := norm+sqr(pa^[i]);
180
 
  omvn2v := sqrt(norm)
181
 
End {omvn2v};
182
 
 
183
 
Function omvnfm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
184
 
 
185
 
Var      pa : ^arfloat1;
186
 
    i, j, k : ArbInt;
187
 
       norm : ArbFloat;
188
 
 
189
 
Begin
190
 
  If (m<1) Or (n<1) Then
191
 
    exit;
192
 
  pa := @a;
193
 
 norm := 0;
194
 
 k := 0;
195
 
  For i:=1 To m Do
196
 
    Begin
197
 
      For j:=1 To n Do
198
 
        norm := norm+sqr(pa^[j+k]);
199
 
      k := k+rwidth
200
 
    End;
201
 
  omvnfm := sqrt(norm)
202
 
End {omvnfm};
203
 
 
204
 
Function omvnmm(Var a: ArbFloat; m, n, rwidth: ArbInt): ArbFloat;
205
 
 
206
 
Var          pa : ^arfloat1;
207
 
           i, k : ArbInt;
208
 
    normr, norm : ArbFloat;
209
 
 
210
 
Begin
211
 
  If (m<1) Or (n<1) Then
212
 
    exit;
213
 
  pa := @a;
214
 
 norm := 0;
215
 
 k := 0;
216
 
  For i:=1 To m Do
217
 
    Begin
218
 
      normr := omvn1v(pa^[1+k], n);
219
 
      If norm<normr Then
220
 
        norm := normr;
221
 
      k := k+rwidth
222
 
    End;
223
 
  omvnmm := norm
224
 
End {omvnmm};
225
 
 
226
 
Function omvnmv(Var a: ArbFloat; n: ArbInt): ArbFloat;
227
 
 
228
 
Var       pa : ^arfloat1;
229
 
           i : ArbInt;
230
 
    norm, aa : ArbFloat;
231
 
 
232
 
Begin
233
 
  If (n<1) Then
234
 
    exit;
235
 
  pa := @a;
236
 
  norm := 0;
237
 
  For i:=1 To n Do
238
 
    Begin
239
 
      aa := abs(pa^[i]);
240
 
      If aa>norm Then
241
 
        norm := aa
242
 
    End;
243
 
  omvnmv := norm
244
 
End {omvnmv};
245
 
 
246
 
Procedure omvtrm(Var a: ArbFloat; m, n, rwa: ArbInt;
247
 
                 Var c: ArbFloat; rwc: ArbInt);
248
 
 
249
 
Var        pa, pc : ^arfloat1;
250
 
           ind, i, j : ArbInt;
251
 
 
252
 
Begin
253
 
  If (m<1) Or (n<1) Then
254
 
    exit;
255
 
  pa := @a;
256
 
 pc := @c;
257
 
 ind := 0;
258
 
  For i:=1 To m Do
259
 
    Begin
260
 
      For j:=1 To n Do
261
 
        pc^[(j-1)*rwc+i] := pa^[ind+j];
262
 
      ind := ind+rwa
263
 
    End; {i}
264
 
End; {omvtrm}
265
 
 
266
 
End.
267
 
{
268
 
  $Log: omv.pas,v $
269
 
  Revision 1.1  2000/07/13 06:34:15  michael
270
 
  + Initial import
271
 
 
272
 
  Revision 1.2  2000/01/25 20:21:42  marco
273
 
   * small updates, crlf fix, and RTE 207 problem
274
 
 
275
 
  Revision 1.1  2000/01/24 22:08:58  marco
276
 
   * initial version
277
 
 
278
 
 
279
 
}