zOs/REXX/LA
/* rexx ***************************************************************
regression tool for reoTime Formula
fun = 'r': read in matrix and linear regression
fun = 'e': read in matrix and evualte different formulas
read in matrix: first line contains column names,
use a clustering algo to find filed widths
remove rows with negative values in it
put it to matrix rA
linear regressions:
iteratly remove columnn with smallest contribution
i.e. first big negative coefficients
evaluate: apply each formula defined in loadCols to each row
for each formula build a 2 dimensional table
range of calculatedTime/measuredTime
* for different minima of calculatedTime
these tables are concatented and written to the output file
la linear algebra
a matrix m, m.dim.0 = #dimension m.dim.1 = first dimension etc.
m.i.j (matrix element i, j9
linear regression: gesucht x mit
y=Ax bzw. t(y-Ax) * (a-Ax) minimal (t=transpose)
x = inverse(t(A) * A) * t(A) * y
tA = t(A) = transpose of A
ideas:
do a regression for predefined columns
remove the debug say
to regression in three steps:
regr2Square: (A, y) ==> (tA * A, tA * y)
or better, do that directly in input processing
remove unwanted rows/colums
solve y = tA*A * y or return matrixes for linear dep etc.
(simple linear equation| )
nice formatting
***********************************************************************/
call errReset 'h'
if 0 then exit eval()
if 0 then exit tstLa()
numeric digits 30
withConst = 1
fun = 'e'
ty = 'i' /* t=TS, i=index */
m.inDsn = 'A540769.WK.TEXW(CHECKRTi)'
m.outDsn = 'A540769.WK.TEXW(CHECKRTO)'
nms = 'Y XFI XLA'
if ty == 't' then
lbs = reotime tsParts I0SPCLOGMAX
else if ty == 'i' then
lbs = reotime Parts SPCLOGMAX
call readDsn m.inDsn, 'M.I.'
say m.i.0 'rows read from' m.inDsn
call findCols c, i
do cx = 1 to m.c.0 /*find col Indexes for y, xFi, xLa */
w1 = m.c.cx
wx = wordPos(w1, lbs)
if wx > 0 then do
n1 = word(nms, wx)
if symbol('m.cn.n1') == 'VAR' then
call err w1 c1 'duplicate' cx m.cn.n1
else
m.cn.n1 = cx
end
end
do nx=1 to words(nms) /*say limiting names */
n1 = word(nms, nx)
v1 = m.cn.n1
if symbol('m.cn.n1') == 'VAR' then
say n1 v1 m.c.v1 m.c.v1.fx'-'m.c.v1.tx
else
call err word(lbs, nx) 'not found for' n1
end
cY = m.cn.y
cFi = m.cn.xFi
cLa = m.cn.xLa
m.rY.dim.0 = 1
m.rA.dim.0 = 2
m.rA.dim.2 = cLa+1-cFi+withConst
m.rn.0 = cLa+1-cFi+withConst
do rx=1 to m.rn.0 /* ini the column info table */
cx = rx+cFi-1
m.rn.map.rx = rx
m.rn.rx.name = m.c.cx
call laInfo0 rn'.'rx
end
rLa = m.rn.0
if withConst then
m.rn.rLa.name = 'CONST'
cntNeg = 0
hx = 1
do ix=2 to m.i.0 /* load the good rows into rY and rA */
m.ry.hx = max(0, colVal(c, cy, m.i.ix))
hasNeg = m.ry.hx < 0
do cx=cFi to cLa+withConst
yy = cx + 1 - cFi
if cx > cLa then
m.rA.hx.yy = 1 /* constant */
else
m.rA.hx.yy = colVal(c, cx, m.i.ix)
if m.rA.hx.yy < 0 then
hasNeg = 1
else
call laInfo1 rn'.'yy, m.rA.hx.yy
end
if hasNeg then
cntNeg = cntNeg + 1
else
hx = hx+1
end
say (hx-1) 'good rows,' cntNeg 'rows with negatives removed'
m.rY.dim.1 = hx-1
m.rA.dim.1 = hx-1
do rx=1 to - m.rn.0
say 'rn.'rx m.rn.rx.name '0='m.rn.rx.cZero 'pos='m.rn.rx.cPos,
m.rn.rx.min '-' m.rn.rx.max
end
/* now, do the work */
if fun == 'e' then do
call eval ty, rn, ra, ry
end
else do
do while m.Ra.dim.2 > 0 /* regression loop */
dp = laRegression(rX, rA, rY)
pos = ''
mi = '?'
if dp \= rX then do
amb = -99
m.dp.amb.1 = 0
amx = 1
do dx=2 to m.dp.dim.1
if abs(m.dp.dx.1) > abs(m.dp.amx.1) then do
amb = amx
amx = dx
end
else if abs(m.dp.dx.1) > abs(m.dp.amb.1) then do
amb = dx
end
end
amy = m.rn.map.amx
amc = m.rn.map.amb
say 'linear dependent|||' m.rn.amy.name m.dp.amx.1 ,
'>' m.rn.amc.name m.dp.amb.1
end
else do
call laSayWithRN rn, 'found x',rX
mi = 999e999
mix = 0
do x=1 to m.rx.dim.1
y = m.rn.map.x
if m.rx.x * m.rn.y.max < mi then do
mix = x
mi = m.rx.x * m.rn.y.max
end
end
if mi >= 0 then
pos = 'nonNegative|||'
amx = mix
end
amy = m.rn.map.amx
say 'removing' m.rn.amy.name 'x.'amx'='mi pos
say ' max =' m.rn.amy.max '*x=' mi
call mCp rn'.'map, amx+1, m.rn.0, rn'.'map, -1
m.rn.0 = m.rn.0-1
call laRmR rA, amx
end
end
exit
tstLa: procedure expose m.
parse value '2 2 3' with m.a1.dim.0 m.a1.dim.1 m.a1.dim.2
parse value '1 2 3' with m.a1.1.1 m.a1.1.2 m.a1.1.3
parse value '4 5 6' with m.a1.2.1 m.a1.2.2 m.a1.2.3
if 0 then call laSay a1, 5
parse value '2 3 2' with m.a2.dim.0 m.a2.dim.1 m.a2.dim.2
parse value '4 5' with m.a2.1.1 m.a2.1.2
parse value '6 7' with m.a2.2.1 m.a2.2.2
parse value '8 9' with m.a2.3.1 m.a2.3.2
if 0 then call laSay a2, 5
call laMbyM a3, a1, a2
if 0 then call laSay a3, 5, 'a1 * a2'
call laMbyM a4, a2, a1
if 0 then call laSay a4, 5, 'a2 * a1'
call laSwapRow a4, 2, 3
if 0 then call laSay a4, 5, 'swap 2 3'
call laAdd2Row a4, 2, 3, -1
if 0 then call laSay a4, 5, 'add2row 2 3 -1'
call laUnit a5, 7
if 0 then call laSay a5, 5, 'unit 7'
if 1 then call laSay a3, 15, 'a3'
call laInvert a6, a3
if 1 then call laSay a6, 15, 'a6 = invert a3'
if 1 then call laSay laMbyM(a7, a6, a3), 15, 'a6*a3'
if 1 then call laSay laMbyM(a7, a3, a6), 15, 'a3*a6'
m.a4.3.3 = 0
if 0 then call laSay a4, 15, 'changed a4'
call laInvert a6, a4
if 0 then call laSay a6, 15, 'invert a4'
if 0 then call laSay laMbyM(a7, a6, a4), 15, 'a6*a4'
if 0 then call laSay laMbyM(a7, a4, a6), 15, 'a4*a6'
parse value '2 4 4' with m.b1.dim.0 m.b1.dim.1 m.b1.dim.2
parse value '1 2 3 4' with m.b1.1.1 m.b1.1.2 m.b1.1.3 m.b1.1.4
parse value '7 7 7 5' with m.b1.2.1 m.b1.2.2 m.b1.2.3 m.b1.2.4
parse value '0 0 1 3' with m.b1.3.1 m.b1.3.2 m.b1.3.3 m.b1.3.4
parse value '7 8 9 9' with m.b1.4.1 m.b1.4.2 m.b1.4.3 m.b1.4.4
if 1 then call laSay b1, 15, 'b1'
call laInvert bInv, b1
if 1 then call laSay bInv, 15, 'bInv inverse of b1'
if 1 then call laSay laMbyM(bT, bInv, b1), 15, 'bInv * b1'
if 1 then call laSay laMbyM(bT, b1, bInv), 15, 'b1 * bInv'
parse value '1 3 1 3 5' with m.v1.dim.0 m.v1.dim.1 m.v1.1 m.v1.2 m.v1.3
parse value '2 3 2' with m.r1.dim.0 m.r1.dim.1 m.r1.dim.2
parse value '0 1' with m.r1.1.1 m.r1.1.2
parse value '1 1' with m.r1.2.1 m.r1.2.2
parse value '2 1' with m.r1.3.1 m.r1.3.2
parse value '1 3 1 3 5' with m.v1.dim.0 m.v1.dim.1 m.v1.1 m.v1.2 m.v1.3
if 1 then call laSay r1, 15, 'r1'
if 1 then call laSay v1, 15, 'v1'
call laRegression v2, r1, v1
if 1 then call laSay v2, 15, 'regression r1 v1'
return
endProcedure laTest
eval: procedure expose m.
parse arg ty, rn, rA, rY
parse value '0.7 0.8 0.9 1 1.1 1.2 1.5' ,
with m.evS.97 m.evS.98 m.evS.99 ,
m.evS.100 m.evS.101 m.evS.102 m.evS.103
p = 1
f = 2
do i=104 to 199
m.evS.i = f * p
j = 200-i
m.evS.j = 1 / m.evS.i
f = translate(f, '251', '125')
if f = 1 then
p = p * 10
end
if ty == 'i' then
call loadColsIx d
else
call loadCols d
m.ev.0 = m.d.0
do dx=1 to m.d.0
ev = 'EV.'dx
parse value '5 0 1 60 600 3600' with m.ev.0 m.ev.1 m.ev.2,
m.ev.3 m.ev.4 m.ev.5
call evalZero ev
do cx=1 to m.d.dx.0
do rx=1 to m.rn.0
if m.rn.rx.name = m.d.dx.cx.name then
leave
end
if rx > m.rn.0 then
call err 'col' m.d.dx.cx.name 'notfound'
m.d.dx.cx.col = rx
end
m.d.dx.min = 999e999
m.d.dx.max = -999e999
m.d.dx.devSq = 0
m.d.dx.vSq = 0
m.d.dx.wSq = 0
end
do dx=1 to m.d.0
do cx=1 to m.d.dx.0
say 'd.'dx'.'cx m.d.dx.cx.name m.d.dx.cx.col ,
m.d.dx.cx.fact
end
end
do y=1 to m.Ra.dim.1
w = m.rY.y
do dx=1 to m.d.0
v = 0
do cx=1 to m.d.dx.0
ax = m.d.dx.cx.col
v = v + m.d.dx.cx.fact * m.rA.y.ax
end
call eval1 'EV.'dx, v, w
m.d.dx.min = min(m.d.dx.min, v)
m.d.dx.max = max(m.d.dx.max, v)
m.d.dx.devSq = m.d.dx.devSq + (v-w) * (v-w)
m.d.dx.vSq = m.d.dx.vSq + v * v
m.d.dx.wSq = m.d.dx.wSq + w * w
end
end
do dx=1 to m.d.0
ev = 'EV.'dx
m.ev.hdr.1 = m.d.dx
m.ev.hdr.2 = ' rng' format(m.d.dx.min , 2, 4, 2, 0),
'-' format(m.d.dx.max , 2, 4, 2, 0)
m.ev.hdr.3 = 'devSq' format(m.d.dx.devSq, 2, 4, 2, 0)
m.ev.hdr.4 = ' vSq' format(m.d.dx.vSq, 2, 4, 2, 0)
m.ev.hdr.5 = ' wSq' format(m.d.dx.wSq, 2, 4, 2, 0)
m.ev.hdr.0 = 5
end
call evalSay 1, 'EV'
call writeDsn m.outDsn, 'M.OO.', , 1
return
call evalZero ev
call eval1 ev, 0.1, 0.102
call eval1 ev, 1, 1.22
call eval1 ev, 12, 11
call eval1 ev, 66, 6600
call evalSay 0, ev
call evalSay 0, ev, ev
call loadCols d
return
endProcedure eval
loadCols: procedure expose m.
parse arg ed
a = ed'.1'
m.a = 'foAlt'
call loadC1 1 TSPARTS 2.22E+01
call loadC1 2 TSSPCLOGROWS 2.23E-08
call loadC1 3 TSROWSLOG 1.14E-07
call loadC1 4 IXENTLOG 2.66E-07
call loadC1 5 I0PARTS 4.94E+00
call loadC1 6 I0SPC 3.84E-08
call loadC1 7 I0ENTMAX 3.42E-06
a = ed'.2'
m.a = 'auf12k'
call loadC1 1 TSPARTS 2.7147881
call loadC1 2 TSROWS 1.4161175E-05
call loadC1 3 TSSPC 3.2655649E-08
call loadC1 4 TSUDS 5.5643292E-09
call loadC1 5 IXPARTS 8.3169080
call loadC1 6 IXSPC 9.1683081E-09
call loadC1 7 I0PARTS 1.9235028
call loadC1 8 I0SPCMAX 1.1758590E-07
call loadC1 9 I0SPCLOGMAX 4.6308572E-09
a = ed'.3'
m.a = 'aug1k'
call loadC1 1 TSROWSMAX 3.8142598E-06
call loadC1 2 TSSPCLOGROWS 1.0871730E-08
call loadC1 3 IXPARTS 1.0375221
call loadC1 4 IXENT 2.5437853E-06
call loadC1 5 I0PARTS 8.5882393E-01
call loadC1 6 I0SPCLOGMAX 2.2203412E-08
a = ed'.4'
m.a = 'sep6k8v'
call loadC1 1 TSROWS 6.6722887E-06
call loadC1 2 TSSPCLOGROWS 8.5027973E-09
call loadC1 3 TSUDSMAX 6.0607492E-09
call loadC1 4 IXENT 4.4905833E-07
call loadC1 5 I0PARTS 3.2896648
call loadC1 6 I0SPCMAX 2.6521501E-07
call loadC1 7 I0SPCLOGMAX 4.9577450E-10
call loadC1 8 CONST 9.5972874
a = ed'.5'
m.a = 'sep6k3v'
call loadC1 1 TSROWS 5.7890464E-06
call loadC1 2 TSSPCLOGROWS 1.1851404E-08
call loadC1 3 I0SPCMAX 2.7697702E-07
a = ed'.6'
m.a = 'sep6k2v'
call loadC1 1 TSSPCLOGROWS 1.7634377E-08
call loadC1 2 I0SPCMAX 2.8943198E-07
a = ed'.7'
m.a = 'sep16kFirstNNv10'
call loadC1 1 TSPARTS 2.2918106
call loadC1 2 TSROWS 1.1719944E-05
call loadC1 3 TSSPC 4.1178398E-08
call loadC1 4 TSUDS 4.7357392E-09
call loadC1 5 IXPARTS 5.9228624
call loadC1 6 IXSPC 1.1593550E-08
call loadC1 7 I0PARTS 2.8568338
call loadC1 8 I0SPCMAX 1.4917387E-07
call loadC1 9 I0SPCLOGMAX 3.4002310E-09
call loadC1 10 CONST 2.7397410
a = ed'.8'
m.a = 'sep16kv6'
call loadC1 1 TSROWS 1.2138081E-05
call loadC1 2 TSSPC 4.2093887E-08
call loadC1 3 TSUDS 5.0810006E-09
call loadC1 4 IXPARTS 9.5068747
call loadC1 5 I0SPCMAX 1.4627868E-07
call loadC1 6 I0SPCLOGMAX 3.4251123E-09
a = ed'.9'
m.a = 'sep16kv4'
call loadC1 1 TSROWS 1.3982363E-05
call loadC1 2 TSUDS 1.3126219E-08
call loadC1 3 I0SPCMAX 1.5430204E-07
call loadC1 4 I0SPCLOGMAX 3.4788130E-09
a = ed'.10'
m.a = 'sep16kv3'
call loadC1 1 TSROWS 1.6060241E-05
call loadC1 2 I0SPCMAX 1.4972364E-07
call loadC1 3 I0SPCLOGMAX 4.0276130E-09
a = ed'.11'
m.a = 'sep16kv2'
call loadC1 1 TSROWS 1.3603414E-05
call loadC1 2 I0SPCMAX 2.4771465E-07
m.ed.0 = 11
return
endProcedure loadCols
loadColsIx: procedure expose m.
parse arg ed
a = ed'.1'
m.a = 'ixAlt'
call loadC1 1 SPC 3.71E-08
call loadC1 2 ENT 3.42E-06
call loadC1 3 CONST 4.94E+00
/* max(coalesce(4.94E+00 + 3.8E-05 * space
+ 3.42E-06 * totalEntries, 5), 5) reo */
a = ed'.2'
m.a = 'ixAllv6'
call loadC1 1 ENTMAX 1.1831612E-05
call loadC1 '2 ENTLOGMAX -1.2913690E-06'
call loadC1 '3 SPCLOGENT -1.0056636E-07'
call loadC1 '4 SPCMAX -7.2703918E-09'
call loadC1 '5 SPCLOGMAX 9.4707207E-08'
call loadC1 '6 CONST -7.7846842'
a = ed'.3'
m.a = 'ixFirstNNv2'
call loadC1 1 SPCMAX 1.3558420E-07
call loadC1 2 CONST 1.8626988
m.ed.0 = 3
return
endProcedure loadColsIX
loadC1: procedure expose m. a
parse arg x m.a.x.name m.a.x.fact .
m.a.0 = x
return
eval1: procedure expose m.
parse arg ev, v, w
if v = 0 then
f = 999e999
else
f = w/v
if f >= 1 then do i=101 to 198 while f > m.evS.i
end
else do i=99 by -1 to 2 while f < m.evS.i
end
i = i - (f >= 1)
h = i-1
j = i+1
/* say 'v' v 'f' f 'i' i m.evS.h'-'m.evS.i'-'m.evS.j */
do ex=1 to m.ev.0 while m.ev.ex <= v
m.ev.ex.i = m.ev.ex.i + 1
end
return
endProcedure
evalZero: procedure expose m.
parse arg ev
do ex=1 to m.ev.0
do y=0 to 201
m.ev.ex.y = 0
end
end
return ev
endProcedure evalZero
evalSay: procedure expose m.
parse arg isSt, a2
aa = 'LA.SAY'
if isSt then do
do ax=1 to m.a2.0
m.aa.ax = a2'.'ax
end
m.aa.0 = m.a2.0
end
else do
do ax=1 to arg()-1
m.aa.ax = arg(ax-1)
end
m.aa.0 = arg()-1
end
call outPush oo
m.oo.0 = 0
sx=0
h = ''
do ax = 1 to m.aa.0
ev = m.aa.ax
if ax = 1 then
t = right('fact|ti', 9)
else
t = t || ' | '
do hx=1 to m.ev.hdr.0
if symbol('h.hx') \== 'VAR' then do
h.hx = ''
h.0 = m.ev.hdr.0
end
h.hx = left(h.hx, length(t))m.ev.hdr.hx
end
do y=1 to m.ev.0
t = t right(m.ev.y, 5)
tot.ev.y = 0
end
end
do hx=1 to h.0
call out h.hx
end
call out t
do i = 1 to 200
h = i-1
do ax = 1 to m.aa.0
ev = m.aa.ax
if m.ev.1.i \= 0 | m.ev.1.h \= 0 then
leave
end
if ax > m.aa.0 then
iterate
do ax = 1 to m.aa.0
if ax = 1 then
t = '>='right(m.evS.i, 7)
else
t = t || ' | '
ev = m.aa.ax
do y=1 to m.ev.0
t = t right(m.ev.y.i, 5)
tot.ev.y = tot.ev.y+ m.ev.y.i
end
end
call out t
end
do ax = 1 to m.aa.0
if ax = 1 then
t = left('total' , 9)
else
t = t || ' | '
ev = m.aa.ax
do y=1 to m.ev.0
t = t right(tot.ev.y, 5)
end
end
call out t
call outPush
do ox=1 to m.oo.0
say m.oo.ox
end
return
endProcedure evalSay
/*--- get the value of a column --------------------------------------*/
colVal: procedure expose m.
parse arg c, y, li
x = y - 1
z = y + 1
if y > 1 then
if substr(li, m.c.x.tx, m.c.y.fx-m.c.x.tx) \= '' then
call err 'before col' y m.c.y 'not empty:' li
if y < m.c.0 then
if substr(li, m.c.y.tx, m.c.z.fx-m.c.y.tx) \= '' then
call err 'after col' y m.c.y 'not empty:' li
if y = m.c.0 then
if substr(li, m.c.y.tx) \= '' then
call err 'after col' y m.c.y 'not empty:' li
v = substr(li, m.c.y.fx, m.c.y.tx-m.c.y.fx)
if datatype(v, 'n') then
return strip(v)
if words(v) = 2 & word(v, 1) = 0 & word(v, 2) = 'E+00' then
return 0
call err 'bad value' v 'in col' y m.c.y 'in line:' li
endProcedure colVal
/*--- find the columns width: incremently cluster --------------------*/
findCols: procedure expose m.
parse arg c, i
spc = ' '
m.c.0 = 0
ex = 1
do forever
bx = verify(m.i.1, spc, 'n', ex)
if bx < 1 then
leave
ex = verify(m.i.1, spc, 'm', bx)
if ex <= bx then
ex = length(m.i.1)+1
m.c.0 = m.c.0 + 1
r = c'.'m.c.0
m.r = substr(m.i.1, bx, ex-bx)
m.r.fx = bx
m.r.tx = ex
m.r.expLe = 0
m.r.expRi = 0
end
redo = ''
do ix=2 to m.i.0
r1 = findColsExp1(c, m.i.ix, spc)
again = pos('e', r1) > 0 & redo \== ''
if pos('o', r1) > 0 then
redo = redo ix
do while again
say 'redoing' redo
again = 0
rx = 1
do forever
ri = word(redo, rx)
if ri == '' then
leave
r2 = findColsExp1(c, m.i.ri, spc)
if pos('e', r2) > 0 then
again = 1
if pos('o', r2) > 0 then
rx = rx + 1
else
redo = subword(redo, 1, rx-1) subword(redo, rx+1)
end
end
end
say 'redo is' redo
do cx=1 to m.c.0
say cx m.c.cx.expLe m.c.cx.expRi m.c.cx.fx'-'m.c.cx.tx m.c.cx
end
return
endProcedure findCols
findColsExp1: procedure expose m.
parse arg c, li, spc
hasOut = ''
hasExp = ''
rx = 1
ex=1
do forever
bx = verify(li, spc, 'n', ex)
if bx < 1 then
leave
ex = verify(li, spc, 'm', bx)
if ex <= bx then
ex = length(li)+1
do rx=rx to m.c.0-1 while bx > m.c.rx.tx
end
rtx = rx m.c.rx.fx'-'m.c.rx.tx m.c.rx
if ex <= m.c.rx.fx | bx > m.c.rx.tx then do
/* say bx'-'ex 'outside ' rtx */
hasOut = 'o'
end
else do
if bx < m.c.rx.fx then do
ry = rx-1
if rx > 1 & bx < m.c.ry.tx then
say bx'-'ex 'leftConflict ' rtx
else do
say bx'-'ex 'extLeft ' rtx
m.c.rx.fx = bx
m.c.rx.expLe = 1
hasExp = 'e'
end
end
if ex > m.c.rx.tx then do
ry = rx+1
if rx < m.c.0 & tx > m.c.ry.fx then
say bx'-'ex 'rightConflict ' rtx
else do
say bx'-'ex 'extRight' rtx
m.c.rx.tx = ex
m.c.rx.expRi = 1
hasExp = 'e'
end
end
end
end
return hasOut || hasExp
endProcedure findColsExp1
laRegression: procedure expose m.
parse arg x, A, y
say 'regression' m.A.dim.0 m.A.dim.1 m.A.dim.2
say 'regression' m.A.1.1 m.A.2.2 m.A.3.3
call laSayInfos A, 'A'
call laSayInfos Y, 'Y'
tA = laTranspose(la'.'regr1, A)
tAA = laMbyM(la'.'regr2, tA, A)
call laSayInfos tAA, 'tA * A'
inv = laInvert(la'.'regr3, tAA, 1)
if m.inv.zero \== 0 then do
say 'linear dependency' m.inv.zero
call laSayInfos inv'.ZERO'
call laSayWithRN rn, 'depend r',inv'.ZERO'
tzz = laMbyM(la'.'regrZZ, tAA, inv'.ZERO')
call laSayInfos tzz, 'tAA * zero'
return inv'.ZERO'
end
call laSayInfos inv, 'inverse'
call laSayInfos laMbyM(la'.regTst', tAA, inv), 'tAA * inv'
/*call laSay y, 7, 'y' */
tAy = laMbyC(la'.'vect4, tA, y)
/* call laSay tAy, 7, 'tA * y' */
call laMbyC x, inv , tAy
call laSayInfos x, 'x = regression'
yy = laRbyC(y, y)
xtAAx = laRbyC(x, laMbyC(la'.retTs2', tAA, x))
xtAy = laRbyC(x, tAy)
say '***(y-Ax)**2='format(yy+xtAAx-2*xtAy, 2, 7, 2, 0),
'yy='format(yy , 2, 7, 2, 0)
return x
endProcedure laRegression
laTranspose: procedure expose m.
parse arg t, m
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laTranspose('t',' m')'
m.t.dim.0 = 2
m.t.dim.1 = m.m.dim.2
m.t.dim.2 = m.m.dim.1
do x=1 to m.m.dim.1
do y=1 to m.m.dim.2
m.t.y.x = m.m.x.y
end
end
return t
endProcedure laTranspose
laInvert: procedure expose m.
parse arg i, oo, absZero
/* idea: calculate L and R with LAR = 1
L exchanges rows or adds the f * row to another row
R exchanges cols or adds the f * col to another col
with the factor f having abs(f) <= 1
the diagonal elements are muliplied to 1 only at the end
a linear dependency is reported, if all remaining eles
have abs(e) absZero
******************************************/
m = laCopy(la'.'invert, oo)
if m.m.dim.0 <> 2 | m.m.dim.1 <> m.m.dim.2 then
call err 'not square' m.m.dim.0 m.m.dim.1 m.m.dim.2,
'in laInvert('i',' m')'
d = m.m.dim.1
l = laUnit(i'.lef', d)
r = laUnit(i'.rig', d)
do dx = 1 to d
am = 0
do y=dx to d
do x=dx to d
if abs(m.M.y.x) > am then do
am = abs(m.M.y.x)
amy = y
amx = x
end
end
end
if am <= absZero then do
m.i.zero = d + 1 - dx
m.i.zero.dim.0 = 2
m.i.zero.dim.1 = d
m.i.zero.dim.2 = d + 1 - dx
do y=dx to d
call laCopyCol i'.ZERO', y+1-dx, R, y, d
end
return i
end
else if am = 0 then do
trace ?r
say err 'rest of matrix 0'
say m m.m.dim.1 m.m.dim.2 d
say m.m.d.d
call err 'rest of matrix 0'
end
if abs(m.m.amy.amx) <> am then
call err 'mismatch'
am = m.m.amy.amx
call laSwapRow m, amy, dx
call laSwapRow l, amy, dx
call laSwapCol m, amx, dx
call laSwapCol r, amx, dx
if m.m.dx.dx <> am then
call err 'mismatch'
/* clean col below and row right of dx,dx */
do y=dx+1 to d
call laAdd2Row L, y, dx, -m.m.y.dx/am /* downwards */
call laAdd2Row M, y, dx, -m.m.y.dx/am
call laAdd2Col R, y, dx, -m.m.dx.y/am /* to the right */
call laAdd2Col M, y, dx, -m.m.dx.y/am
end
/* call laSay M, 15, 'M after clean row below' dx','dx */
end
do y = 1 to d /* make diag to 1 */
call laMultRow L, y, 1/m.M.y.y
end
m.i.zero = 0
return laMbyM(i, R, L)
endProcedure laInvert
laInvertV1: procedure expose m.
/* idea: calculate I with IA = 1 */
parse arg i, oo
m = laCopy(la'.'invert, oo)
if m.m.dim.0 <> 2 | m.m.dim.1 <> m.m.dim.2 then
call err 'not square' m.m.dim.0 m.m.dim.1 m.m.dim.2,
'in laInvert('i',' m')'
d = m.m.dim.1
call laUnit i, d
do x = 1 to d
/* call laSayInfos i, 'laRegr i before' x */
k = x
do y=x+1 to d
if abs(m.m.k.x) < abs(m.m.y.x) then
k = y
end
if k <> x then do
call laSwapRow m, k, x
call laSwapRow i, k, x
end
call laAdd2Row i, x, x, (1-m.m.x.x)/m.m.x.x
call laAdd2Row m, x, x, (1-m.m.x.x)/m.m.x.x
do y=1 to d
if x=y | m.m.y.x = 0 then
iterate
/* say y x m.m.y.x */
call laAdd2Row i, y, x, -m.m.y.x
call laAdd2Row m, y, x, -m.m.y.x
end
/* call laSay m, 15, 'm after' x 'of' d
call laSay laMbyM('x', i, oo), 15, 'i*oo after' x 'of' d */
end
return i
endProcedure laInvert
/*--- copy a matrix --------------------------------------------------*/
laCopy: procedure expose m.
parse arg c, m
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laCopy('c',' m')'
m.c.dim.0 = 2
m.c.dim.1 = m.m.dim.1
m.c.dim.2 = m.m.dim.2
do x=1 to m.m.dim.1
do y=1 to m.m.dim.2
m.c.x.y = m.m.x.y
end
end
return c
endProcedure laCopy
laCopyCol: procedure expose m.
parse arg c, cSuf, f, fSuf, d
do y=1 to d
m.c.y.cSuf = m.f.y.fSuf
end
return c
endProcedure laCopyCol
/*--- set m to a unit matrix of dimension d --------------------------*/
laUnit: procedure expose m.
parse arg m, d
m.m.dim.0 = 2
m.m.dim.1 = d
m.m.dim.2 = d
call laSetAll m, 0
do x=1 to d
m.m.x.x = 1
end
return m
endProcedure laUnit
laSetAll: procedure expose m.
parse arg m, v
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do x=1 to m.m.dim.1
do y=1 to m.m.dim.2
m.m.x.y = v
end
end
return m
endProcedure laSwapRow
laAdd2Row: procedure expose m.
parse arg m, i, k, f
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do x=1 to m.m.dim.2
m.m.i.x = m.m.i.x + m.m.k.x * f
end
return m
endProcedure laAdd2Row
laMultRow: procedure expose m.
parse arg m, i, f
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do x=1 to m.m.dim.2
m.m.i.x = m.m.i.x * f
end
return m
endProcedure laMultRow
laAdd2Col: procedure expose m.
parse arg m, i, k, f
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
do y=1 to m.m.dim.1
m.m.y.i = m.m.y.i + m.m.y.k * f
end
return m
endProcedure laAdd2Col
laSwapRow: procedure expose m.
parse arg m, i, k
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapRow('m',' i',' k')'
if i=k then
return m
do x=1 to m.m.dim.2
o = m.m.i.x
m.m.i.x = m.m.k.x
m.m.k.x = o
end
return m
endProcedure laSwapRow
laSwapCol: procedure expose m.
parse arg m, i, k
if m.m.dim.0 <> 2 then
call err 'bad dim.0' m.m.dim.0,
'in laSwapCol('m',' i',' k')'
if i=k then
return m
do y=1 to m.m.dim.1
o = m.m.y.i
m.m.y.i = m.m.y.k
m.m.y.k = o
end
return m
endProcedure laSwapCol
/*--- multiply the matrices L and R and put the result into P --------*/
laMbyM: procedure expose m.
parse arg p, l, r
if m.l.dim.0 <> 2 | m.r.dim.0 <> 2 then
call err 'bad dim.0' m.l.dim.0 m.r.dim.0 ,
'in laMbyM('p',' l',' r')'
if m.l.dim.2 <> m.r.dim.1 then
call err 'l.dim.2' m.l.dim.2 '<> r.dim.1' m.r.dim.1 ,
'in laMbyM('p',' l',' r')'
m.p.dim.0 = 2
m.p.dim.1 = m.l.dim.1
m.p.dim.2 = m.r.dim.2
do x=1 to m.p.dim.1
do y=1 to m.p.dim.2
q = 0
do z=1 to m.r.dim.1
q = q + m.l.x.z * m.r.z.y
end
m.p.x.y = q
end
end
return p
endProcedure laMbyM
/*--- multiply the matrix M by Column vector C into p ----------------*/
laMbyC: procedure expose m.
parse arg p, L, r
if m.L.dim.0 <> 2 | m.r.dim.0 <> 1 then
call err 'bad dim.0' m.L.dim.0 m.r.dim.0 ,
'in laMbyC('p',' L',' r')'
if m.L.dim.2 <> m.r.dim.1 then
call err 'L.dim.2' m.L.dim.2 '<> r.dim.1' m.r.dim.1 ,
'in laMbyC('p',' L',' r')'
m.p.dim.0 = 1
m.p.dim.1 = m.L.dim.1
do y=1 to m.p.dim.1
q = 0
do z=1 to m.r.dim.1
q = q + m.L.y.z * m.r.z
end
m.p.y = q
end
return p
endProcedure laMbyC
/*--- return scalar product of vectors r and c ----------------------*/
laRbyC: procedure expose m.
parse arg r, c
if m.r.dim.0 <> 1 | m.c.dim.0 <> 1 then
call err 'bad dim.0' m.L.dim.0 m.r.dim.0 ,
'in laRbyC(' r',' c')'
if m.r.dim.1 <> m.c.dim.1 then
call err 'L.dim.2' m.L.dim.2 '<> r.dim.1' m.r.dim.1 ,
'in laMbyC('p',' L',' r')'
p = 0
do x=1 to m.r.dim.1
p = p + m.r.x * m.c.x
end
return p
endProcedure laRbyC
/*--- remove row k from Matrx m -------------------------------------*/
laRmR: procedure expose m.
parse arg m, k
if m.m.dim.0 = 2 then do
do y=1 to m.m.dim.1
call mCp m'.'y, k+1, m.m.dim.2, m'.'y, -1
end
m.m.dim.2 = m.m.dim.2 - 1
end
else do
call err 'bad dim' m.m.dim.0
end
return
endProcedure laRmR
/*--- remove row k and column k from matrix M -----------------------*/
laRmRC: procedure expose m.
parse arg m, k
if m.m.dim.0 = 1 then do
call mCp m, k+1, m.m.dim.1, m, -1
m.m.dim.1 = m.m.dim.1 - 1
end
else if m.m.dim.0 = 2 then do
do y=1 to k-1
call mCp m'.'y, k+1, m.m.dim.2, m'.'y, -1
end
do y=k+1 to m.m.dim.1
z=y-1
call mCp m'.'y, 1, k-1, m'.'z, 0
call mCp m'.'y, k+1, m.m.dim.2, m'.'z, -1
end
m.m.dim.1 = m.m.dim.1 - 1
m.m.dim.2 = m.m.dim.2 - 1
end
else do
call err 'bad dim' m.m.dim.0
end
return
endProcedure laRmRC
mCp: procedure expose m.
parse arg src, xF, xT, dst, dlt
do x=xF to xT
y=x+dlt
m.dst.y = m.src.x
end
return
endProcedure mCp
/*--- say matrix m, with width w and message msg --------------------*/
laSay: procedure expose m.
parse arg m, w, msg
if m.m.dim.0 = 1 then do
say m':' m.m.dim.1':' msg
r = ''
do y= 1 to m.m.dim.1
r = r || right(m.m.y, w)
end
say r
end
else if m.m.dim.0 = 2 then do
say m':' m.m.dim.1 'x' m.m.dim.2':' msg
do x=1 to m.m.dim.1
r = ''
do y= 1 to m.m.dim.2
r = r || right(m.m.x.y, w)
end
say r
end
end
else
call err 'dim' m.m.dim.0 '<> 2 in laSay('m',' w',' msg')'
return
endProcedure laSay
laSayInfos: procedure expose m.
parse arg m, msg
say 'infos' m 'dim.0' m.m.dim.0':' m.m.dim.1'x'm.m.dim.2':' msg
call laInfo m
say ' counts 0='m.m.info.cZero', pos='m.m.info.cPos ,
|| ', neg='m.m.info.cNeg
say ' sum='m.m.info.sum', sumSquare='m.m.info.sq
say ' absolut min='m.m.info.absMin', max='m.m.info.absMax
return m
endProcedure laSysInfos
laSayWithRN: procedure expose m.
parse arg rn, txt
a1 = 3
say 'laSayWithCols' txt
rws = m.rn.0
do ax=a1 to arg()
a = arg(ax)
call laSayInfos a, 'arg' (ax+1-a1)
if \ (m.a.dim.0 == 1 | m.a.dim.0 == 2) then
call err 'dim not 1 or 2:' m.a.dim.0
if m.a.dim.1 <> rws then
call err 'rows not' rws':' m.a.dim.1
end
do rx=1 to rws
y = m.rn.map.rx
txt = right(rx, 3) left(m.rn.y.name, 15)
do ax=a1 to arg()
a = arg(ax)
if m.a.dim.0 = 1 then do
txt = txt format(m.a.rx, 2, 7, 2, 0)
end
else do cx=1 to m.a.dim.2
txt = txt format(m.a.rx.cx, 2, 7, 2, 0)
end
end
say txt
end
return
endProcedure laSayWithRN
laInfo: procedure expose m.
parse arg m
o = m'.INFO'
call laInfo0 o
if m.m.dim.0 = 1 then do
do y=1 to m.m.dim.1
call laInfo1 o, m.m.y
end
end
else if m.m.dim.0 = 2 then do
do y=1 to m.m.dim.1
do x=1 to m.m.dim.2
call laInfo1 o, m.m.y.x
end
end
end
else
call err 'laSayInfos bad dim' m.m.dim.0
return m
endProdcedure laInfo
laInfo0: procedure expose m.
parse arg o
m.o.cZero = 0
m.o.cPos = 0
m.o.cNeg = 0
m.o.sum = 0
m.o.sq = 0
m.o.min = 999e999
m.o.max = -999e999
m.o.absMin = 999e999
m.o.absMax = -999e999
return o
endProcedure laInfo0
laInfo1: procedure expose m.
parse arg o, v
m.o.min = min(m.o.min, v)
m.o.max = max(m.o.max, v)
if v = 0 then do
m.o.cZero = m.o.cZero + 1
return
end
if v > 0 then
m.o.cPos = m.o.cPos + 1
else
m.o.cNeg = m.o.cNeg + 1
m.o.sum = m.o.sum + v
m.o.sq = m.o.sq + v * v
m.o.absMin = min(m.o.absMin, abs(v))
m.o.absMax = max(m.o.absMax, abs(v))
return
endProdcedure laInfo1
/* copy adrTso begin *************************************************/
/*--- send ggTsoCmd to tso, fail if rc <> 0 or not listed in ggRet ---*/
adrTso:
parse arg ggTsoCmd, ggRet
address tso ggTsoCmd
if rc == 0 then return 0
else if ggRet == '*' then return rc
else if wordPos(rc, ggRet) > 0 then return rc
else
call err 'adrTso rc' rc 'for' ggTsoCmd
return /* end adrTso */
/*--- format dsn from tso format to jcl format -----------------------*/
dsn2jcl: procedure expose m.
parse upper arg dsn ., addPrefix
if left(dsn,1) = "'" then
return strip(dsn, 'b', "'")
sp = sysvar('SYSPREF')
if sp == '' then
sp = userid()
cx = pos('~', dsn)
if cx < 1 & addPrefix == 1 then
return sp'.'dsn
do while cx \== 0
le = left(dsn, cx-1)
ri = substr(dsn, cx+1)
if right(le, 1) == '.' | left(ri, 1) == '.' then
dsn = le || sp || ri
else
dsn = le || left('.', le \== '') || sp ,
|| left('.', ri \== '') || ri
cx = pos('~', spec, cx)
end
return dsn
endProcedure dsn2Jcl
/*--- format dsn from jcl format to tso format -----------------------*/
jcl2dsn: procedure expose m.
parse arg dsn .
return "'"dsn"'"
endProcedure jcl2dsn
dsnSetMbr: procedure expose m.
parse arg dsn, mbr
bx = pos('(', dsn)
if bx > 0 then
dsn = strip(left(dsn, bx-1))
if mbr <> '' then
dsn = dsn'('strip(mbr)')'
return dsn
endProcedure dsnSetMbr
dsnGetMbr: procedure expose m.
parse arg dsn
lx = pos('(', dsn)
rx = pos(')', dsn, lx+1)
if lx < 1 then
return ''
else if lx < rx then
return substr(dsn, lx+1, rx-lx-1)
else
return strip(substr(dsn,lx+1))
endProcedure dsnGetMbr
/**********************************************************************
io: read or write a dataset with the following callsequences:
read: readDDBegin, readDD*, readDDEnd
write: writeBegin, writeDD*, writeEnd
readDD returns true if data read, false at eof
***********************************************************************/
/*--- prepare reading from a DD --------------------------------------*/
readDDBegin: procedure expose m.
parse upper arg ggDD
call errAddCleanup 'call readDDEnd' ggDD', "*"'
return /* end readDDBegin */
/*--- read from DD ggDD into ggSt, return false at eof ---------------*/
readDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt = '' then
ggCnt = 100
call adrTso 'execio' ggCnt 'diskr' ggDD '(stem' ggSt')', 2
return (value(ggSt'0') > 0)
return /* end readDD */
/*--- finish reading DD ggDD ----------------------------------------*/
readDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call readDDEnd' ggDD', "*"'
return adrTso('execio 0 diskr' ggDD '(finis)', ggRet)
endProcedure readDDEnd
/*--- prepare writing to DD ggDD -------------------------------------*/
writeDDBegin: procedure expose m.
parse upper arg ggDD
/* ensure file is erased, if no records are written */
call adrTso 'execio' 0 'diskw' ggDD '(open)'
call errAddCleanup 'call writeDDEnd' ggDD', "*"'
return /* end writeDDBegin */
/*--- write to gg ggDD from stem ggSt, ggCnt records -----------------*/
writeDD:
parse arg ggDD, ggSt, ggCnt
if ggCnt == '' then
ggCnt = value(ggst'0')
call adrTso 'execio' ggCnt 'diskw' ggDD '(stem' ggSt')'
return
endSubroutine writeDD
/*--- end writing to dd ggDD (close) --------------------------------*/
writeDDEnd: procedure expose m.
parse upper arg ggDD, ggRet
call errRmCleanup 'call writeDDEnd' ggDD', "*"'
return adrTso('execio 0 diskw' ggDD '(finis)', ggRet)
endProcedure writeDDEnd
/*--- standardise a dsn spec
word1 dsName or -
word2 dd or -
word3 disp or -
word4 to first : attributes in tso format
after first : attributes for new allocation
----------------------------------------------------------------------*/
dsnSpec: procedure expose m.
parse upper arg spec
rr = '' /* put leading - in separate words */
do sx=1 while words(rr) < 3 & wx \= ''
wx = word(spec, sx)
do while abbrev(wx, '-') & words(rr) < 3
wx = substr(wx, 2)
rr = rr '-'
end
rr = rr wx
end
spec = rr subWord(spec, sx)
na = ''
dd = ''
di = ''
if left(spec, 1) = '&' then /* external spec is handled ok */
spec = strip(substr(spec, 2))
do wx=1 by 1
w = word(spec, wx)
if w = '' | abbrev(w, '.') | abbrev(w, ':') then
leave
else if wordPos(w, 'OLD SHR MOD NEW')>0 | abbrev(w, 'SYSO') then
di = w
else if w = 'CATALOG' then
di = di w
else if abbrev(w, 'DD(') then
dd = substr(w, 4, length(w)-4)
else if abbrev(w, 'DSN(') then
na = strip(substr(w, 5, length(w)-5))
else if na == '' then
na = dsn2jcl(w)
else if dd == '' then
dd = w
else if di == '' then
di = w
else
leave
end
if na == '' then
na = '-'
else if abbrev(na, "'") then
na = substr(na, 2, length(na)-2)
if dd == '' then dd = '-'
if di == '' then di = '-'
re = subword(spec, wx)
if abbrev(re, '.') then
re = substr(re, 2)
return na dd di re
endProcedure dsnSpec
/*--- alloc a dsn with dsnAlloc
if the dsn is inuse wait and retry
until either the allocation is successfull
or the timeout occurs --------------------------------------*/
dsnAllocWait: procedure expose m.
parse upper arg spec, pDi, pDD, timeOut
x = max(1, arg() - 1)
do rt=0
m.adrTsoAl.1 = ''
m.adrTsoAl.2 = ''
m.adrTsoAl.3 = ''
oldTrap = outtrap()
call outtrap m.adrTsoAl.
res = dsnAlloc(spec, pDi, pDD, '*')
if oldTrap = '' then
call outtrap off
else
call outtrap oldTrap append
if \ abbrev(res, ' ') then
return res
msg = m.adrTsoAl.1'\n'm.adrTsoAl.2'\n'm.adrTsoAl.3
if rt > timeOut & timeOut \== '' then
return err('timeout allocating' spec time() '\n'msg)
if pos('DATA SET IS ALLOCATED TO ANOTHER', msg) < 1 then
return err('allocating' spec'\n'msg)
say time() 'sleep and retry alloc' spec
call sleep 1, 0
end
endProcedure dsnAllocWait
/*--- alloc a dsn or a dd
spec '-'<ddName>
datasetName? disposition? '.'? attributes? (':' newAtts)?
disp default disposition
dd default dd name
retRc erlaubte ReturnCodes (leer = 0)
returns if ok then ddName <rexx for free> otherwise rc -----*/
dsnAlloc: procedure expose m.
parse upper arg spec, pDi, pDD, retRc
parse value dsnSpec(spec) with na dd di rest
if na = '-' then
m.dsnAlloc.dsn = ''
else
m.dsnAlloc.dsn = na
if na == '-' & dd \== '-' & di == '-' & rest = '' then
return dd
if dd == '-' & pDD \== '' then
dd = pDD
if dd == '-' then do
if symbol('m.adrTso.ddNum') = 'VAR' then
dd = m.adrTso.ddNum + 1
else
dd = 1
m.adrTso.ddNum = dd
dd = 'DD' || dd
end
if di = '-' & pDi \== '' then
di = pDi
if di = '-' then
di = 'SHR'
else if pos('(', na) < 1 then
nop
else if di = 'MOD' then
call err 'disp mod for' na
else
di = 'SHR'
if pos('/', na) > 0 then
return csmAlloc(na dd di rest, retRc)
else
return tsoAlloc(na dd di rest, retRc)
endProcedure dsnAlloc
tsoAlloc: procedure expose m.
parse arg na dd disp rest ':' nn, retRc
c = 'alloc dd('dd')' disp
if na \== '-' then
c = c "DSN('"na"')"
call outtrap m.adrTsoAl.
alRc = adrTso(c rest, '*')
call outtrap off
if alRc = 0 then do
call errAddCleanup 'call tsoFree' dd', "*"'
return dd 'call tsoFree' dd';'
end
if nn \= '' & wordPos(disp, 'OLD SHR') > 0 ,
& sysDsn("'"m.dsnAlloc.dsn"'") == 'DATASET NOT FOUND' then do
say 'tsoAlloc creating' c rest ':'nn
call adrTso 'alloc dd('dd') new catalog' dsnCreateAtts(na, nn)
call adrTso 'free dd('dd')'
return tsoAlloc(na dd disp rest, retRc)
end
do ax=1 to m.adrTsoAl.0
say m.adrTsoal.ax
end
if retRc = '*' | wordPos(alRc, retRc) > 0 then
return ' ' alRc
call err 'tsoAlloc rc' alRc 'for' c rest
endProcedure tsoAlloc
tsoFree: procedure expose m.
parse arg dd, ggRet
call adrTso 'free dd('dd')', ggRet
call errRmCleanup 'call tsoFree' dd', "*"'
return
endProcedure tsoFree
dsnCreateAtts: procedure expose m.
parse arg dsn, atts, forCsm
bl = 32760
if abbrev(atts, ':') then do
rl = substr(atts, 3)
if abbrev(atts, ':F') then do
if rl = '' then
rl = 80
recfm='f b'
bl = bl - (bl // rl)
end
else do
if rl = '' then
rl = bl-4
recfm = substr(atts, 2, 1) 'B'
end
end
if pos('(', dsn) > 0 then
po = 'dsntype(library) dsorg(po)'
else
po = ''
dsn = dsnSetMbr(dsn)
if forCsm == 1 then
return "dataset('"dsn"')" po,
"recfm("space(recfm, 0)") lrecl("rl") blkSize("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cylinder"
else
return "dsn('"dsn"')" po,
"recfm("recfm") lrecl("rl") block("bl")" ,
"mgmtclas(COM#A091) space(10, 1000) cyl"
endProcedure dsnCreateAtts
/*--- read the dataset specified in ggDsnSpec to stem ggSt -----------*/
readDSN:
parse arg ggDsnSpec, ggSt
ggAlloc = dsnAlloc(ggDsnSpec, 'SHR', 'readDsN')
call adrTso 'execio * diskr' word(ggAlloc, 1) '(stem' ggSt' finis)'
interpret subword(ggAlloc, 2)
return
endSubroutine readDsn
/*--- write the dataset specified in ggDsnSpec from stem ggSt
write ggCnt records if not empty otherwise ggst0
if ggSay 1 then say ... records written to ... -------------*/
writeDSN:
parse arg ggDsnSpec, ggSt, ggCnt, ggSay
if ggCnt == '' then
ggCnt = value(ggst'0')
ggAlloc = dsnAlloc(ggDsnSpec, 'OLD', 'readDsN')
call adrTso 'execio' ggCnt 'diskw' word(ggAlloc, 1) ,
'(stem' ggSt 'open finis)'
interpret subword(ggAlloc, 2)
if ggSay == 1 | m.debug == 1 then
say ggCnt 'records written to' ggDsnSpec
return
endSubroutine writeDsn
copyDSN: procedure expose m.
parse arg frSpec, toSpec, ggSay
frDD = dsnAlloc(frSpec, 'SHR', 'FRDD')
toDD = dsnAlloc(toSpec, 'OLD', 'TODD')
call readDDBegin word(frDD, 1)
call writeDDBegin word(toDD, 1)
cnt = 0
do while readDD(word(frDD, 1), r.)
call writeDD word(toDD, 1), r.
cnt = cnt + r.0
end
call readDDEnd word(frDD, 1)
call writeDDEnd word(toDD, 1)
interpret ';' subword(frDD, 2) '; ; ;' subword(toDD, 2)
if ggSay == 1 | m.debug == 1 then
say cnt 'records copied from' frSpec 'to' to toSpec
return
endSubroutine writeDsn
/* copy adrTso end ****************************************************/
/* copy err begin ******************************************************
messages, errorhandling,help
***********************************************************************/
errIni: procedure expose m.
if m.err.ini == 1 then
return
call outIni
m.err.ini = 1
m.err.handler = ''
m.err.cleanup = ';'
m.err.opt = ''
return
endProcedure errIni
/* configure err -----------------------------------------------------*/
errReset: procedure expose m.
call errIni
parse arg m.err.opt, m.err.handler
if pos('I', translate(m.err.opt)) > 0 then
if sysVar('sysISPF') = 'ACTIVE' then
call adrIsp 'control errors return'
return
endSubroutine errReset
/*--- error routine: abend with message ------------------------------*/
err:
parse arg ggTxt, ggOpt
call errIni
drop err handler cleanup opt call return
if ggOpt == '' & m.err.handler \== '' then do
if 1 then do /* no detection of recursive err call loop
--> will anyway fail by stack overflow */
interpret m.err.handler
end
else do
/* avoid recursive err call loop */
drop call return
if symbol('m.err.call') \== 'VAR' then
m.err.call = 1
else
m.err.call = m.err.call + 1
if m.err.call > 10 then do
say 'errHandler loop:' m.err.handler
end
else do
m.err.return = 1
call errInterpret m.err.handler
m.err.call = m.err.call - 1
if m.err.return then
return result
end
end
end
call outPush
call errSay ggTxt, 'e'
call errCleanup
if ggOpt == '' then
ggOpt = m.err.opt
ggOpt = translate(ggOpt)
if pos('T', ggOpt) > 0 then do
trace ?r
say 'trace ?r in err'
end
if pos('H', ggOpt) > 0 then do
call errSay 'divide by zero to show stackHistory', 'e'
x = 1 / 0
end
call errSay 'exit(12)', 'e'
exit errSetRc(12)
endSubroutine err
errAddCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
/* concatenate backwards, then it is executed also backwards */
m.err.cleanup = ';'code || m.err.cleanup
return
endProcedure errAddCleanup
errRmCleanup: procedure expose m.
parse arg code
if m.err.ini \== 1 then
call errIni
cx = pos(';'code';', m.err.cleanup)
if cx > 0 then
m.err.cleanup = left(m.err.cleanup, cx) ,
|| substr(m.err.cleanup, cx + length(code)+2)
return
endProcedure errRmCleanup
errCleanup: procedure expose m.
call errIni
cl = m.err.cleanup
if cl = ';' then
return
m.err.cleanup = ';'
call out 'err cleanup begin' cl
call errInterpret cl
call out 'err cleanup end' cl
return
endProcedure errCleanup
errInterpret: procedure expose m.
parse arg code
interpret code
m.err.return = 0
return
endProcedure errInterpret
/*--- assert that the passed rexx expression evaluates to true -------*/
assert:
interpret 'assertRes =' arg(1)
if \ assertRes then
call err 'assert failed' arg(1)':' arg(2)
return
endProcedure assert
/*--- output an errorMessage msg with pref pref
split message in lines at '/n' ---------------------------*/
errSay: procedure expose m.
parse arg msg, pref
parse source . . ggS3 . /* current rexx */
if pref == 'e' then
msg = 'fatal error in' ggS3':' msg
else if pref == 'w' then
msg = 'warning in' ggS3':' msg
else if pref \== '' then
msg = pref':' msg
return outNl(msg)
endProcedure errSay
/*--- abend with Message after displaying help -----------------------*/
errHelp: procedure expose m.
parse arg msg, op
call errSay msg, 'e'
call help
call err msg, op
endProcedure errHelp
/*--- return the Operating System we are running on: TSO or LINUX ---*/
errOS: procedure expose m.
parse source os .
return os
endProcedure errOS
/*--- set rc for ispf: -------------------------------------------------
if a cmd is run by ispStart, its RC is ignored,
but ISPF passes the value of the shared varible 3IspfRc
back as return code
----------------------------------------------------------------------*/
errSetRc: procedure expose m.
parse arg zIspfRc
if errOS() \== 'LINUX' then
if sysVar('sysISPF') = 'ACTIVE' then
address ispExec vput 'zIspfRc' shared
return zIspfRc
endProcedure errSetRc
/*--- output a trace message if m.tr is set -----------------------*/
trc: procedure expose m.
parse arg msg
if m.trace == 1 then
call out 'trc:' msg
return
endProcedure trc
debug: procedure expose m.
parse arg msg
if m.debug == 1 then
call out 'debug' msg
return
endProcedure debug
/*--- return current time and cpu usage ------------------------------*/
timing: procedure expose m.
return return time() 'ela='time('E') 'cpu='sysvar('syscpu'),
'su='sysvar('syssrv')
timingTest: procedure expose m.
say 'begin' timing() sysvar('sysnode')
do 30000000
end
say 'end ' timing()
return
/*--- display the first comment block of the source as help ----------*/
help: procedure expose m.
parse source . . s3 .
call out right(' help for rexx' s3, 79, '*')
do lx=1 by 1
if pos('/*', sourceLine(lx)) > 0 then
leave
else if lx > 10 then do
call out 'initial commentblock not found for help'
return
end
end
do lx=lx+1 by 1
li = strip(sourceLine(lx), 't', ' ')
if pos('*/', li) > 0 then
leave
call out li
end
call out right(' end help for rexx' s3, 79, '*')
return 4
endProcedure help
/*--- output all lines (separated by '\n') of all args --------------*/
outNl: procedure expose m.
do ax=1 to max(1, arg())
msg = arg(ax)
sx = 0
bx = -1
do lx=1 until bx >= length(msg)
ex = pos('\n', msg, bx+2)
if ex < 1 then
ex = length(msg)+1
call out substr(msg, bx+2, ex-bx-2)
bx = ex
end
end
return 0
endProcedure outNl
/*--- quote string txt using quoteChar qu ("""" ==> ") ---------------*/
quote: procedure expose m.
parse arg txt, qu
if qu = '' then
qu = '"'
res = qu
ix = 1
do forever
qx = pos(qu, txt, ix)
if qx = 0 then
return res || substr(txt, ix) || qu
res = res || substr(txt, ix, qx-ix) || qu || qu
ix = qx + length(qu)
end
endProcedure quote
/*--- if function ----------------------------------------------------*/
if: procedure expose m.
parse arg co, ifTrue, ifFalse
if co then
return ifTrue
else
return ifFalse
endProcedure if
/* copy err end *****************************************************/
/* copy out begin ******************************************************
out interface with simplistic implementation
***********************************************************************/
outIni: procedure expose m.
parse arg msg
if m.out.ini == 1 then
return
m.out.ini = 1
m.out.dst = ''
return
endProcedure outIni
/*--- output a message to the current destination -------------------*/
out: procedure expose m.
parse arg msg
if m.out.ini \== 1 then
call outIni
if m.out.dst == '' then do
say msg
end
else do
st = m.out.dst
sx = m.st.0 + 1
m.st.0 = sx
m.st.sx = msg
end
return 0
endProcedure out
/*--- push an out destination ---------------------------------------*/
outPush: procedure expose m.
parse arg m.out.dst
return
endProcedure outPush
/* copy out end *****************************************************/