1)abbrev package FCPAK1 FortranCodePackage1
2++ Author: Grant Keady and Godfrey Nolan
3++ Date Created: April 1993
4++ Basic Operations:
5++ Related Constructors:
6++ Also See:
7++ AMS Classifications:
8++ Keywords:
9++ References:
10++ Description:
11++  \spadtype{FortranCodePackage1} provides some utilities for
12++  producing useful objects in FortranCode domain.
13++  The Package may be used with the FortranCode domain and its
14++  \spad{printCode} or possibly via an outputAsFortran.
15++  (The package provides items of use in connection with ASPs
16++  in the AXIOM-NAG link and, where appropriate, naming accords
17++  with that in IRENA.)
18++  The easy-to-use functions use Fortran loop variables I1, I2,
19++  and it is users' responsibility to check that this is sensible.
20++  The advanced functions use SegmentBinding to allow users control
21++  over Fortran loop variable names.
22-- Later might add functions to build
23-- diagonalMatrix from List, i.e. the FC version of the corresponding
24-- FriCAS function from MatrixCategory;
25-- bandedMatrix, i.e. the full-matrix-FC version of the corresponding
26-- FriCAS function in BandedMatrix Domain
27-- bandedSymmetricMatrix, i.e. the full-matrix-FC version of the corresponding
28-- FriCAs function in BandedSymmetricMatrix Domain
29
30FortranCodePackage1 : Exports  == Implementation where
31
32  NNI    ==> NonNegativeInteger
33  PI     ==> PositiveInteger
34  PIN    ==> Polynomial(Integer)
35  SBINT  ==> SegmentBinding(Integer)
36  SEGINT ==> Segment(Integer)
37  LSBINT ==> List(SegmentBinding(Integer))
38  SBPIN  ==> SegmentBinding(Polynomial(Integer))
39  SEGPIN ==> Segment(Polynomial(Integer))
40  LSBPIN ==> List(SegmentBinding(Polynomial(Integer)))
41  FC     ==> FortranCode
42  EXPRESSION  ==> Union(Expression Integer, Expression Float, Expression Complex Integer, Expression Complex Float)
43
44  Exports == with
45
46    zeroVector : (Symbol, PIN) -> FC
47      ++ zeroVector(s, p) \undocumented{}
48
49    zeroMatrix : (Symbol, PIN, PIN) -> FC
50      ++ zeroMatrix(s, p, q) uses loop variables in the Fortran, I1 and I2
51
52    zeroMatrix : (Symbol, SBPIN, SBPIN) -> FC
53      ++ zeroMatrix(s, b, d) in this version gives the user control
54      ++ over names of Fortran variables used in loops.
55
56    zeroSquareMatrix : (Symbol, PIN) -> FC
57      ++ zeroSquareMatrix(s, p) \undocumented{}
58
59    identitySquareMatrix : (Symbol, PIN) -> FC
60      ++ identitySquareMatrix(s, p) \undocumented{}
61
62  Implementation ==> add
63    import from FC
64
65    zeroVector(fname : Symbol, n : PIN) : FC ==
66      ue : Expression(Integer) := 0
67      i1 : Symbol := 'I1
68      lp1 : PIN := 1::PIN
69      hp1 : PIN := n
70      segp1 : SEGPIN := segment(lp1, hp1)$SEGPIN
71      segbp1 : SBPIN := equation(i1, segp1)$SBPIN
72      ip1 : PIN := i1::PIN
73      indices : List(PIN) := [ip1]
74      fa : FC := forLoop(segbp1, assign(fname, indices, ue)$FC)$FC
75      fa
76
77    zeroMatrix(fname : Symbol, m : PIN, n : PIN) : FC ==
78      ue : Expression(Integer) := 0
79      i1 : Symbol := 'I1
80      lp1 : PIN := 1::PIN
81      hp1 : PIN := m
82      segp1 : SEGPIN := segment(lp1, hp1)$SEGPIN
83      segbp1 : SBPIN := equation(i1, segp1)$SBPIN
84      i2 : Symbol := 'I2
85      hp2 : PIN := n
86      segp2 : SEGPIN := segment(lp1, hp2)$SEGPIN
87      segbp2 : SBPIN := equation(i2, segp2)$SBPIN
88      ip1 : PIN := i1::PIN
89      ip2 : PIN := i2::PIN
90      indices : List(PIN) := [ip1, ip2]
91      fa : FC := forLoop(segbp1, forLoop(segbp2, assign(fname, indices, ue)$FC)$FC)$FC
92      fa
93
94    zeroMatrix(fname : Symbol, segbp1 : SBPIN, segbp2 : SBPIN) : FC ==
95      ue : Expression(Integer) := 0
96      i1 : Symbol := variable(segbp1)$SBPIN
97      i2 : Symbol := variable(segbp2)$SBPIN
98      ip1 : PIN := i1::PIN
99      ip2 : PIN := i2::PIN
100      indices : List(PIN) := [ip1, ip2]
101      fa : FC := forLoop(segbp1, forLoop(segbp2, assign(fname, indices, ue)$FC)$FC)$FC
102      fa
103
104    zeroSquareMatrix(fname : Symbol, n : PIN) : FC ==
105      ue : Expression(Integer) := 0
106      i1 : Symbol := 'I1
107      lp1 : PIN := 1::PIN
108      hp1 : PIN := n
109      segp1 : SEGPIN := segment(lp1, hp1)$SEGPIN
110      segbp1 : SBPIN := equation(i1, segp1)$SBPIN
111      i2 : Symbol := 'I2
112      segbp2 : SBPIN := equation(i2, segp1)$SBPIN
113      ip1 : PIN := i1::PIN
114      ip2 : PIN := i2::PIN
115      indices : List(PIN) := [ip1, ip2]
116      fa : FC := forLoop(segbp1, forLoop(segbp2, assign(fname, indices, ue)$FC)$FC)$FC
117      fa
118
119    identitySquareMatrix(fname : Symbol, n : PIN) : FC ==
120      ue : Expression(Integer) := 0
121      u1 : Expression(Integer) := 1
122      i1 : Symbol := 'I1
123      lp1 : PIN := 1::PIN
124      hp1 : PIN := n
125      segp1 : SEGPIN := segment(lp1, hp1)$SEGPIN
126      segbp1 : SBPIN := equation(i1, segp1)$SBPIN
127      i2 : Symbol := 'I2
128      segbp2 : SBPIN := equation(i2, segp1)$SBPIN
129      ip1 : PIN := i1::PIN
130      ip2 : PIN := i2::PIN
131      indice1 : List(PIN) := [ip1, ip1]
132      indices : List(PIN) := [ip1, ip2]
133      fc : FC := forLoop(segbp2, assign(fname, indices, ue)$FC)$FC
134      f1 : FC := assign(fname, indice1, u1)$FC
135      fl : List(FC) := [fc, f1]
136      fa : FC := forLoop(segbp1, block(fl)$FC)$FC
137      fa
138
139)abbrev package FOP FortranOutputStackPackage
140
141++ Author: Mike Dewar
142++ Date Created:  October 1992
143++ Basic Operations:
144++ Related Domains:
145++ Also See:
146++ AMS Classifications:
147++ Keywords:
148++ Examples:
149++ References:
150++ Description: Code to manipulate Fortran Output Stack
151FortranOutputStackPackage() : specification == implementation where
152
153  specification == with
154
155    clearFortranOutputStack : () -> Stack String
156      ++ clearFortranOutputStack() clears the Fortran output stack
157    showFortranOutputStack : () -> Stack String
158      ++ showFortranOutputStack() returns the Fortran output stack
159    popFortranOutputStack : () -> Void
160      ++ popFortranOutputStack() pops the Fortran output stack
161    pushFortranOutputStack : FileName -> Void
162      ++ pushFortranOutputStack(f) pushes f onto the Fortran output stack
163    pushFortranOutputStack : String -> Void
164      ++ pushFortranOutputStack(f) pushes f onto the Fortran output stack
165    topFortranOutputStack : () -> String
166      ++ topFortranOutputStack() returns the top element of the Fortran
167      ++ output stack
168
169  implementation == add
170
171    import from MoreSystemCommands
172
173    -- A stack of filenames for Fortran output.  We are sharing this with
174    -- the standard Fortran output code, so want to be a bit careful about
175    -- how we interact with what the user does independently.  We get round
176    -- potential problems by always examining the top element of the stack
177    -- before we push.  If the user has redirected output then we alter our
178    -- top value accordingly.
179    fortranOutputStack : Stack String := empty()@(Stack String)
180
181    topFortranOutputStack() : String == string(_$fortranOutputFile$Lisp)
182
183    pushFortranOutputStack(fn : FileName) : Void ==
184        pushFortranOutputStack(fn::String)
185
186    pushFortranOutputStack(fn : String) : Void ==
187      if empty? fortranOutputStack then
188        push!(string(_$fortranOutputFile$Lisp), fortranOutputStack)
189      else if not(top(fortranOutputStack)=string(_$fortranOutputFile$Lisp)) then
190        pop! fortranOutputStack
191        push!(string(_$fortranOutputFile$Lisp), fortranOutputStack)
192      push!( fn, fortranOutputStack)
193      systemCommand concat(["set output fortran quiet ", fn])$String
194      void()
195
196    popFortranOutputStack() : Void ==
197      if not empty? fortranOutputStack then pop! fortranOutputStack
198      if empty? fortranOutputStack then push!("CONSOLE",fortranOutputStack)
199      systemCommand concat(["set output fortran quiet append ",_
200                           top fortranOutputStack])$String
201      void()
202
203    clearFortranOutputStack() : Stack String ==
204      fortranOutputStack := empty()@(Stack String)
205
206    showFortranOutputStack() : Stack String ==
207      fortranOutputStack
208
209)abbrev package TEMUTL TemplateUtilities
210++ Author: Mike Dewar
211++ Date Created:  October 1992
212++ Basic Operations:
213++ Related Domains:
214++ Also See:
215++ AMS Classifications:
216++ Keywords:
217++ Examples:
218++ References:
219++ Description: This package provides functions for template manipulation
220TemplateUtilities() : Exports == Implementation where
221
222  Exports == with
223    interpretString : String -> Any
224      ++ interpretString(s) treats a string as a piece of FriCAS input, by
225      ++ parsing and interpreting it.
226    stripCommentsAndBlanks : String -> String
227      ++ stripCommentsAndBlanks(s) treats s as a piece of FriCAS input, and
228      ++ removes comments, and leading and trailing blanks.
229
230  Implementation == add
231
232    import from InputForm
233
234    stripC(s : String, u : String) : String ==
235      i : Integer := position(u, s, 1)
236      i = 0 => s
237      delete(s, i..)
238
239    stripCommentsAndBlanks(s : String) : String ==
240      trim(stripC(stripC(s,"++"),"--"),char " ")
241
242    interpretString(s : String) : Any ==
243      interpret parse s
244
245)abbrev package MCALCFN MultiVariableCalculusFunctions
246++ Author: Themos Tsikas, Grant Keady
247++ Date Created: December 1992
248++ Basic Operations:
249++ Related Constructors:
250++ Also See:
251++ AMS Classifications:
252++ Keywords:
253++ References:
254++ Description:
255++  \spadtype{MultiVariableCalculusFunctions} Package provides several
256++  functions for multivariable calculus.
257++ These include gradient, hessian and jacobian,
258++ divergence and laplacian.
259++ Various forms for banded and sparse storage of matrices are
260++ included.
261MultiVariableCalculusFunctions(S, F, FLAF, FLAS) : Exports == Implementation where
262  PI ==> PositiveInteger
263  NNI ==> NonNegativeInteger
264
265  S : SetCategory
266  F : PartialDifferentialRing(S)
267  FLAS : FiniteLinearAggregate(S)
268  FLAF : FiniteLinearAggregate(F)
269
270  Exports ==> with
271    gradient : (F, FLAS) -> Vector F
272     ++ \spad{gradient(v, xlist)}
273     ++ computes the gradient, the vector of first partial derivatives,
274     ++ of the scalar field v,
275     ++ v a function of the variables listed in xlist.
276    divergence : (FLAF, FLAS) ->  F
277     ++ \spad{divergence(vf, xlist)}
278     ++ computes the divergence of the vector field vf,
279     ++ vf a vector function of the variables listed in xlist.
280    laplacian : (F, FLAS) -> F
281     ++ \spad{laplacian(v, xlist)}
282     ++ computes the laplacian of the scalar field v,
283     ++ v a function of the variables listed in xlist.
284    hessian : (F, FLAS) -> Matrix F
285     ++ \spad{hessian(v, xlist)}
286     ++ computes the hessian, the matrix of second partial derivatives,
287     ++ of the scalar field v,
288     ++ v a function of the variables listed in xlist.
289    bandedHessian : (F, FLAS, NNI) -> Matrix F
290     ++ \spad{bandedHessian(v, xlist, k)}
291     ++ computes the hessian, the matrix of second partial derivatives,
292     ++ of the scalar field v,
293     ++ v a function of the variables listed in xlist,
294     ++ k is the semi-bandwidth, the number of nonzero subdiagonals,
295     ++ 2*k+1 being actual bandwidth.
296     ++ Stores the nonzero band in lower triangle in a matrix,
297     ++ dimensions k+1 by #xlist,
298     ++ whose rows are the vectors formed by diagonal, subdiagonal, etc.
299     ++ of the real, full-matrix, hessian.
300     ++ (The notation conforms to LAPACK/NAG-F07 conventions.)
301    -- At one stage it seemed a good idea to help the ASP<n> domains
302    -- with the types of their input arguments and this led to the
303    -- standard Gradient|Hessian|Jacobian functions.
304    --standardJacobian: (Vector(F), List(S)) -> Matrix F
305    -- ++ \spad{jacobian(vf, xlist)}
306    -- ++ computes the jacobian, the matrix of first partial derivatives,
307    -- ++ of the vector field vf,
308    -- ++ vf a vector function of the variables listed in xlist.
309    jacobian : (FLAF, FLAS) -> Matrix F
310     ++ \spad{jacobian(vf, xlist)}
311     ++ computes the jacobian, the matrix of first partial derivatives,
312     ++ of the vector field vf,
313     ++ vf a vector function of the variables listed in xlist.
314    bandedJacobian : (FLAF, FLAS, NNI, NNI) -> Matrix F
315     ++ \spad{bandedJacobian(vf, xlist, kl, ku)}
316     ++ computes the jacobian, the matrix of first partial derivatives,
317     ++ of the vector field vf,
318     ++ vf a vector function of the variables listed in xlist,
319     ++ kl is the number of nonzero subdiagonals,
320     ++ ku is the number of nonzero superdiagonals,
321     ++ kl+ku+1 being actual bandwidth.
322     ++ Stores the nonzero band in a matrix,
323     ++ dimensions kl+ku+1 by #xlist.
324     ++ The upper triangle is in the top ku rows,
325     ++ the diagonal is in row ku+1,
326     ++ the lower triangle in the last kl rows.
327     ++ Entries in a column in the band store correspond to entries
328     ++ in same column of full store.
329     ++ (The notation conforms to LAPACK/NAG-F07 conventions.)
330
331  Implementation ==> add
332    localGradient(v : F, xlist : List(S)) : Vector(F) ==
333       vector([D(v, x) for x in xlist])
334    gradient(v, xflas) ==
335       --xlist: List(S) := [xflas(i) for i in 1 .. maxIndex(xflas)]
336       xlist : List(S) := parts(xflas)
337       localGradient(v, xlist)
338    localDivergence(vf : Vector(F), xlist : List(S)) : F ==
339       i : PI
340       n : NNI
341       ans : F
342       -- Perhaps should report error if two args of min different
343       n := min(#(xlist), ((maxIndex(vf))::NNI))$NNI
344       ans := 0
345       for i in 1 .. n repeat ans := ans + D(vf(i), xlist(i))
346       ans
347    divergence(vf, xflas) ==
348       xlist : List(S) := parts(xflas)
349       i : PI
350       n : NNI
351       ans : F
352       -- Perhaps should report error if two args of min different
353       n := min(#(xlist), ((maxIndex(vf))::NNI))$NNI
354       ans := 0
355       for i in 1 .. n repeat ans := ans + D(vf(i), xlist(i))
356       ans
357    laplacian(v, xflas) ==
358       xlist : List(S) := parts(xflas)
359       gv : Vector(F) := localGradient(v, xlist)
360       localDivergence(gv, xlist)
361    hessian(v, xflas) ==
362       xlist : List(S) := parts(xflas)
363       matrix([[D(v, [x, y]) for x in xlist] for y in xlist])
364    --standardJacobian(vf, xlist) ==
365    --   i: PI
366    --   matrix([[D(vf(i), x) for x in xlist] for i in 1 .. maxIndex(vf)])
367    jacobian(vf, xflas) ==
368       xlist : List(S) := parts(xflas)
369       i : PI
370       matrix([[D(vf(i), x) for x in xlist] for i in 1 .. maxIndex(vf)])
371    bandedHessian(v, xflas, k) ==
372       xlist : List(S) := parts(xflas)
373       j, iw : PI
374       n : NNI
375       bandM : Matrix F
376       n := #(xlist)
377       bandM := new(k+1, n, 0)
378       for j in 1 .. n repeat setelt!(bandM, 1, j, D(v, xlist(j), 2))
379       for iw in 2 .. (k+1) repeat (_
380         for j in 1 .. (n-iw+1) repeat (_
381           setelt!(bandM, iw, j, D(v, [xlist(j), xlist(j + iw - 1)])) ) )
382       bandM
383    jacobian(vf, xflas) ==
384       xlist : List(S) := parts(xflas)
385       i : PI
386       matrix([[D(vf(i), x) for x in xlist] for i in 1 .. maxIndex(vf)])
387    bandedJacobian(vf, xflas, kl, ku) ==
388       xlist : List(S) := parts(xflas)
389       j, iw : PI
390       n : NNI
391       bandM : Matrix F
392       n := #(xlist)
393       bandM := new(kl+ku+1, n, 0)
394       for j in 1 .. n repeat setelt!(bandM, ku + 1, j, D(vf(j), xlist(j)))
395       for iw in (ku+2) .. (ku+kl+1) repeat (_
396         for j in 1 .. (n-iw+ku+1) repeat (_
397           setelt!(bandM, iw, j, D(vf(j + iw - 1 - ku), xlist(j))) ) )
398       for iw in 1 .. ku repeat (_
399         for j in (ku+2-iw) .. n repeat (_
400           setelt!(bandM, iw, j, D(vf(j + iw - 1 - ku), xlist(j))) ) )
401       bandM
402
403--Copyright (c) 1991-2002, The Numerical ALgorithms Group Ltd.
404--All rights reserved.
405--
406--Redistribution and use in source and binary forms, with or without
407--modification, are permitted provided that the following conditions are
408--met:
409--
410--    - Redistributions of source code must retain the above copyright
411--      notice, this list of conditions and the following disclaimer.
412--
413--    - Redistributions in binary form must reproduce the above copyright
414--      notice, this list of conditions and the following disclaimer in
415--      the documentation and/or other materials provided with the
416--      distribution.
417--
418--    - Neither the name of The Numerical ALgorithms Group Ltd. nor the
419--      names of its contributors may be used to endorse or promote products
420--      derived from this software without specific prior written permission.
421--
422--THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS
423--IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED
424--TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A
425--PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER
426--OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL,
427--EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO,
428--PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR
429--PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF
430--LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING
431--NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS
432--SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
433