|
|
|
|
|
|
|
| ☜ | Appendix IM[UMPS] by Example | ☞ | ||||
16-Feb–1999, 16:54:35
Routine Save for all M[UMPS] Library Functions
;
; Unless otherwise noted, the code below
; was approved in document X11/95–11
;
; If corrections have been applied,
; first the original line appears,
; with three semicolons at the beginning of the line.
;
; Then the source of the correction is acknowledged,
; then the corrected line appears, followed by a
; line containing three semicolons.
;
ABS(X) Quit $Translate(+X,"-")
;===
;
;
ARCCOS(X) ;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Comment: This version of the function is
; optimized for speed, not for precision.
; The ‘precision’ parameter is not supported,
; and the precision is at best 2 in 10**–8.
;;;
;
New A,N,R,SIGN,XX
If X<–1 Set $Ecode=",M28,"
If X>1 Set $Ecode=",M28,"
Set SIGN=1 Set:X<0 X=-X,SIGN=–1
Set A(0)=1.5707963050,A(1)=–0.2145988016,A(2)=0.0889789874
Set A(3)=–0.0501743046,A(4)=0.0308918810,A(5)=–0.0170881256
Set A(6)=0.0066700901,A(7)=–0.0012624911
Set R=A(0),XX=1 For N=1:1:7 Set XX=XX*X,R=A(N)*XX+R
;
;;; Set R=$%SQRT^MATH(1-X)*R ; Number
; Winfried Gerum (8 June 1995)
Set R=$%SQRT^MATH(1-X,11)*R
;;;
;
Quit R*SIGN
;===
;
;
ARCCOS(X,PREC) ;
;
;;; New L,LIM,K,SIG,SIGS ; Number
; Winfried Gerum (8 June 1995)
New L,LIM,K,SIG,SIGS,VALUE
;;;
;
If X<–1 Set $Ecode=",M28,"
If X>1 Set $Ecode=",M28,"
Set PREC=$Get(PREC,11)
;
;;; If $Translate(X,"-")=1 Set VALUE=0 Quit ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
If $Translate(X,"-")=1 Quit 0
;;;
;
Set SIG=$Select(X<0:–1,1:1),VALUE=1-(X*X)
;
;;; Set X=$%SQRT^MATH(VALUE) ; Number
; Winfried Gerum (8 June 1995)
Set X=$%SQRT^MATH(VALUE,PREC)
;;;
;
;;; If $Translate(X,"-")=1 Do Quit ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
If $Translate(X,"-")=1 Do Quit VALUE
. ;;;
. ;
. Set VALUE=$%PI^MATH()/2*X
. Quit
;
;;; If X>0.9 Do Quit ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
If X>0.9 Do Quit VALUE
. ;;;
. ;
. Set SIGS=$Select(X<0:–1,1:1)
. Set VALUE=1/(1/X/X–1)
. ;
. ;;; Set X=$%SQRT^MATH(VALUE) ; Number
. ; Winfried Gerum (8 June 1995)
. Set X=$%SQRT^MATH(VALUE,PREC)
. ;;;
. ;
. ;
. ;;; Set VALUE=$%ARCTAN^MATH(X,10)*SIGS ; Number
. ; Winfried Gerum (8 June 1995)
. Set VALUE=$%ARCTAN^MATH(X,PREC)*SIGS
. ;;;
;
. Quit
Set (VALUE,L)=X
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Do Quit:($Translate(L,"-")<LIM)
. Set L=L*X*X*(K–2)/(K–1)*(K–2)/K,VALUE=VALUE+L
. Quit
Quit $Select(SIG<0:$%PI^MATH()-VALUE,1:VALUE)
;===
;
;
ARCCOSH(X,PREC) ;
If X<1 Set $Ecode=",M28,"
New SQ
;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set SQ=$%SQRT^MATH(X*X–1,PREC)
Quit $%LOG^MATH(X+SQ,PREC)
;===
;
;
ARCCOT(X,PREC) ;
Set PREC=$Get(PREC,11)
Set X=1/X
Quit $%ARCTAN^MATH(X,PREC)
;===
;
;
ARCCOTH(X,PREC) ;
New L1,L2
;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set L1=$%LOG^MATH(X+1,PREC)
Set L2=$%LOG^MATH(X–1,PREC)
Quit L1-L2/2
;===
;
;
ARCCSC(X,PREC) ;
Set PREC=$Get(PREC,11)
Set X=1/X
Quit $%ARCSIN^MATH(X,PREC)
;===
;
;
ARCSEC(X,PREC) ;
Set PREC=$Get(PREC,11)
Set X=1/X
Quit $%ARCCOS^MATH(X,PREC)
;===
;
;
ARCSIN(X) ;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Comment: This version of the function is
; optimized for speed, not for precision.
; The ‘precision’ parameter is not supported,
; and the precision is at best 2 in 10**–8.
;;;
;
New A,N,R,SIGN,XX
If X<–1 Set $Ecode=",M28,"
If X>1 Set $Ecode=",M28,"
Set SIGN=1 Set:X<0 X=-X,SIGN=–1
Set A(0)=1.5707963050,A(1)=–0.2145988016,A(2)=0.0889789874
Set A(3)=–0.0501743046,A(4)=0.0308918810,A(5)=–0.0170881256
Set A(6)=0.0066700901,A(7)=–0.0012624911
Set R=A(0),XX=1 For N=1:1:7 Set XX=XX*X,R=A(N)*XX+R
;
;;; Set R=$%SQRT^MATH(1-X)*R ; Number
; Winfried Gerum (8 June 1995)
Set R=$%SQRT^MATH(1-X,11)*R
;;;
;
Set R=$%PI^MATH()/2-R
Quit R*SIGN
;===
;
;
ARCSIN(X,PREC) ;
New L,LIM,K,SIGS,VALUE
Set PREC=$Get(PREC,11)
;
;;; If $Translate(X,"-")=1 Do Quit ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
If $Translate(X,"-")=1 Do Quit VALUE
. ;;;
. ;
. Set VALUE=$%PI^MATH()/2*X
. Quit
;
;;; If X>0.99999 Do Quit ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
If X>0.99999 Do Quit VALUE
. ;;;
. ;
. Set SIGS=$Select(X<0:–1,1:1)
. Set VALUE=1/(1/X/X–1)
. ;
. ;;; Set X=$%SQRT^MATH(VALUE) ; Number
. ; Winfried Gerum (8 June 1995)
. Set X=$%SQRT^MATH(VALUE,PREC)
. ;;;
. ;
. ;;; Set VALUE=$%ARCTAN^MATH(X,10)*SIGS ; Number
. ; Winfried Gerum (8 June 1995)
. Set VALUE=$%ARCTAN^MATH(X,PREC)*SIGS
. ;;;
. ;
. Quit
Set (VALUE,L)=X
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Do Quit:($Translate(L,"-")<LIM)
. Set L=L*X*X*(K–2)/(K–1)*(K–2)/K,VALUE=VALUE+L
. Quit
Quit VALUE
;===
;
;
ARCSINH(X,PREC) ;
If X<1 Set $Ecode=",M28,"
New SQ
;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set SQ=$%SQRT^MATH(X*X+1,PREC)
Quit $%LOG^MATH(X+SQ,PREC)
;===
;
;
ARCTAN(X,PREC) ;
New FOLD,HI,L,LIM,LO,K,SIGN,SIGS,SIGT,VALUE
Set PREC=$Get(PREC,11)
Set LO=0.0000000001,HI=9999999999
Set SIGT=$Select(X<0:–1,1:1),X=$Translate(X,"-")
Set X=$Select(X<LO:LO,X>HI:HI,1:X)
;
;;; Set FOLD=$Select(X'<1:0,1:1), ; Number
; Eli Reidler (28 June 1996)
Set FOLD=$Select(X'<1:0,1:1)
;;;
;
Set X=$Select(FOLD:1/X,1:X)
Set L=X,VALUE=$%PI^MATH()/2-(1/X),SIGN=1
;
;;; If X<1.3 Do Quit ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
If X<1.3 Do Quit VALUE
. ;;;
. ;
. Set X=$Select(FOLD:1/X,1:X),VALUE=1/((1/X/X)+1)
. ;
. ;;; Set $%SQRT^MATH(VALUE) ; Number
. ; Winfried Gerum (8 June 1995)
. ; Eli Reidler (28 June 1996)
. Set X=$%SQRT^MATH(VALUE,PREC)
. ;;;
. ;
. If $Translate(X,"-")=1 Do Quit
. . Set VALUE=$%PI^MATH()/2*X
. . Quit
. If X>0.9 Do Quit
. . Set SIGS=$Select(X<0:–1,1:1)
. . Set VALUE=1/(1/X/X–1)
. . Set X=$%SQRT^MATH(VALUE)
. . Set VALUE=$$ARCTAN(X,10)
. . Set VALUE=VALUE*SIGS
. . Quit
. Set (VALUE,L)=X
. Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
. For K=3:2 Do Quit:($Translate(L,"-")<LIM)
. . Set L=L*X*X*(K–2)/(K–1)*(K–2)/K,VALUE=VALUE+L
. . Quit
. Set VALUE=$Select(SIGT<1:-VALUE,1:VALUE)
. Quit
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Do Quit:($Translate(1/L,"-")<LIM)
. ;
. ;;; Set L=L*X*X,VALUE=VALUE+(1/(K*L)*SIGN), ; Number
. ; Eli Reidler (28 June 1996)
. Set L=L*X*X,VALUE=VALUE+(1/(K*L)*SIGN)
. ;;;
. ;
. Set SIGN=SIGN*–1
. Quit
Set VALUE=$Select(FOLD:$%PI^MATH()/2-VALUE,1:VALUE)
Set VALUE=$Select(SIGT<1:-VALUE,1:VALUE)
Quit VALUE
;===
;
;
ARCTANH(X,PREC) ;
If X<–1 Set $Ecode=",M28,"
If X>1 Set $Ecode=",M28,"
;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Quit $%LOG^MATH(1+X/(1-X),PREC)/2
;===
;
;
CABS(Z) ;
New ZRE,ZIM
Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
Quit $%SQRT^MATH(ZRE*ZRE+(ZIM*ZIM))
;===
;
;
CADD(X,Y) ;
New XRE,XIM,YRE,YIM
Set XRE=+X,XIM=+$Piece(X,"%",2)
Set YRE=+Y,YIM=+$Piece(Y,"%",2)
Quit XRE+YRE_"%"_(XIM+YIM)
;===
;
;
CCOS(Z,PREC) ;
New E1,E2,IA
;
;;; ; Number
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set IA=$%CMUL^MATH(Z,"0%1")
Set E1=$%CEXP^MATH(IA,PREC)
Set IA=-IA_"%"_(-$Piece(IA,"%",2))
Set E2=$%CEXP^MATH(IA,PREC)
Set IA=$%CADD^MATH(E1,E2)
Quit $%CMUL^MATH(IA,"0.5%0")
;===
;
;
CDIV(X,Y) ;
New D,IM,RE,XIM,XRE,YIM,YRE
Set XRE=+X,XIM=+$Piece(X,"%",2)
Set YRE=+Y,YIM=+$Piece(Y,"%",2)
Set D=YRE*YRE+(YIM*YIM)
Set RE=XRE*YRE+(XIM*YIM)/D
Set IM=XIM*YRE-(XRE*YIM)/D
Quit RE_"%"_IM
;===
;
;
CEXP(Z,PREC) ;
New R,ZIM,ZRE
;
;;; ; Number
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
Set R=$%EXP^MATH(ZRE,PREC)
Quit R*$%COS^MATH(ZIM,PREC)_"%"_(R*$%SIN^MATH(ZIM,PREC))
;===
;
;
CLOG(Z,PREC) ;
New ABS,ARG,ZIM,ZRE
;
;;; ; Number
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set ABS=$%CABS^MATH(Z)
Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
;
;;; Set ARG=$%ARCTAN^MATH(ZIM,ZRE,PREC) ; Number
; Alan Frank (October 1995)
Set ARG=$%ARCTAN^MATH(ZIM/ZRE,PREC)
;;;
;
Quit $%LOG^MATH(ABS,PREC)_"%"_ARG
;===
;
;
CMUL(X,Y) ;
New XIM,XRE,YIM,YRE
Set XRE=+X,XIM=+$Piece(X,"%",2)
Set YRE=+Y,YIM=+$Piece(Y,"%",2)
Quit XRE*YRE-(XIM*YIM)_"%"_(XRE*YIM+(XIM*YRE))
;===
;
;
COMPLEX(X) Quit +X_"%0"
;===
;
;
CONJUG(Z) ;
New ZIM,ZRE
Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
Quit ZRE_"%"_(-ZIM)
;===
;
;
COS(X,PREC) ;
New L,LIM,K,SIGN,VALUE
;
;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ; Number
; Winfried Gerum (8 June 1995)
; Comment: The official description does not mention than
; the function may also be called with the first
; parameter in degrees, minutes and seconds.
Set:X[":" X=$%DMSDEC^MATH(X)
;;;
;
Set PREC=$Get(PREC,11)
Set X=X#(2*$%PI^MATH())
Set (VALUE,L)=1,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=2:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
. Quit
Quit VALUE
;===
;
;
COS(X) ;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Comment: This version of the function is
; optimized for speed, not for precision.
; The ‘precision’ parameter is not supported,
; and the precision is at best 1 in 10**–9.
; Note that this function does not accept its
; parameter in degrees, minutes and seconds.
;;;
;
New A,N,PI,R,SIGN,XX
;
; This approximation only works for 0 <= x <= pi/2
; so reduce angle to correct quadrant.
;
Set PI=$%PI^MATH(),X=X#(PI*2),SIGN=1
Set:X>PI X=2*PI-X
Set:X*2>PI X=PI-X,SIGN=–1
;
Set XX=X*X,A(1)=–0.4999999963,A(2)=0.0416666418
Set A(3)=–0.0013888397,A(4)=0.0000247609,A(5)=–0.0000002605
Set (X,R)=1 For N=1:1:5 Set X=X*XX,R=A(N)*X+R
Quit R*SIGN
;===
;
;
COSH(X,PREC) ;
;
;;; New F,I,P,R,T,XX ; Number
; Winfried Gerum (8 June 1995)
New E,F,I,P,R,T,XX
;;;
;
Set PREC=$Get(PREC,11)+1
Set @("E=1E-"_PREC)
Set XX=X*X,F=1,(P,R,T)=1,I=1
For Set T=T*XX,F=I+1*I*F,R=T/F+R,P=P-R/R,I=I+2 If -E<P,P<E Quit
Quit R
;===
;
;
COT(X,PREC) ;
New C,L,LIM,K,SIGN,VALUE
;
;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ; Number
; Winfried Gerum (8 June 1995)
; Comment: The official description does not mention than
; the function may also be called with the first
; parameter in degrees, minutes and seconds.
Set:X[":" X=$%DMSDEC^MATH(X)
;;;
;
Set PREC=$Get(PREC,11)
Set (VALUE,L)=1,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=2:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
. Quit
Set C=VALUE
Set X=X#(2*$%PI^MATH())
Set (VALUE,L)=X,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
. Quit
If 'VALUE Quit "INFINITE"
Quit VALUE=C/VALUE
;===
;
;
COTH(X,PREC) ;
New SINH
If 'X Quit "INFINITE"
;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set SINH=$%SINH^MATH(X,PREC)
If 'SINH Quit "INFINITE"
Quit $%COSH^MATH(X,PREC)/SINH
;===
;
;
CPOWER(Z,N,PREC) ;
New AR,NIM,NRE,PHI,PI,R,RHO,TH,ZIM,ZRE
;
;;; ; Number
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set ZRE=+Z,ZIM=+$Piece(Z,"%",2)
Set NRE=+N,NIM=+$Piece(N,"%",2)
If 'ZRE,'ZIM,'NRE,'NIM Set $Ecode=",M28,"
;
;;; If 'ZRE,'ZIM Quit "0%0% ; Number
; Eli Reidler (28 June 1996)
If 'ZRE,'ZIM Quit "0%0"
;;;
;
Set PI=$%PI^MATH()
;
;;; Set R=$%SQRT^MATH(ZRE*ZRE+(ZIM*ZIM,PREC)) ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
Set R=$%SQRT^MATH(ZRE*ZRE+(ZIM*ZIM),PREC)
;;;
;
;
;;; If ZRE Set TH=$%ARCTAN^MATH(ZIM,ZRE,PREC) ; Number
; Alan Frank (October 1995)
If ZRE Set TH=$%ARCTAN^MATH(ZIM/ZRE,PREC)
;;;
;
;;; Else Set TH=$SELECT(ZRE>0:PI/2,1:-PI/2) ; Number
; Winfried Gerum (8 June 1995)
Else Set TH=$SELECT(ZIM>0:PI/2,1:-PI/2)
;;;
;
Set RHO=$%LOG^MATH(R,PREC)
Set AR=$%EXP^MATH(RHO*NRE-(TH*NIM),PREC)
Set PHI=RHO*NIM+(NRE*TH)
Quit AR*$%COS^MATH(PHI,PREC)_"%"_(AR*$%SIN^MATH(PHI,PREC))
;===
;
;
CSC(X,PREC) ;
New L,LIM,K,SIGN,VALUE
;
;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ; Number
; Winfried Gerum (8 June 1995)
; Comment: The official description does not mention than
; the function may also be called with the first
; parameter in degrees, minutes and seconds.
Set:X[":" X=$%DMSDEC^MATH(X)
;;;
;
;;; Set PREC=$Select($Data(PREC)#2:PREC,1:10) ; Number
; Winfried Gerum (8 June 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set X=X#(2*$%PI^MATH())
Set (VALUE,L)=X,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
. Quit
If 'VALUE Quit "INFINITE"
Quit 1/VALUE
;===
;
;
;
CSCH(X,PREC) ;;;Quit 1/$%SINH^MATH(X,PREC) ; Number
; Winfried Gerum (8 June 1995)
; Alan Frank (October 1995)
Quit 1/$%SINH^MATH(X,$Get(PREC,11))
;;;
;
;===
;
;
CSIN(Z,PREC) ;
New IA,E1,E2
;
;;; ; Number
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Set IA=$%CMUL^MATH(Z,"0%1")
Set E1=$%CEXP^MATH(IA,PREC)
Set IA=-IA_"%"_(-$Piece(IA,"%",2))
Set E2=$%CEXP^MATH(IA,PREC)
Set IA=$%CSUB^MATH(E1,E2)
Set IA=$%CMUL^MATH(IA,"0.5%0")
Quit $%CMUL^MATH("0%–1",IA)
;===
;
;
CSUB(X,Y) ;
New XIM,XRE,YIM,YRE
Set XRE=+X,XIM=+$Piece(X,"%",2)
Set YRE=+Y,YIM=+$Piece(Y,"%",2)
Quit XRE-YRE_"%"_(XIM-YIM)
;===
;
;
DECDMS(X,PREC) ;
Set PREC=$Get(PREC,5)
Set X=X#360*3600
Set X=+$Justify(X,0,$Select((PREC-$Length(X\1))'<0:PREC-$Length(X\1),1:0))
Quit X\3600_":"_(X\60#60)_":"_(X#60)
;===
;
;
DEGRAD(X) Quit X*3.14159265358979/180
;===
;
;
DMSDEC(X) ;
Quit $Piece(X,":")+($Piece(X,":",2)/60)+($Piece(X,":",3)/3600)
;===
;
;
E() Quit 2.71828182845905
;===
;
;
EXP(X,PREC) ;
New L,LIM,K,VALUE
Set PREC=$Get(PREC,11)
Set L=X,VALUE=X+1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=2:1 Set L=L*X/K,VALUE=VALUE+L Quit:($Translate(L,"-")<LIM)
Quit VALUE
;===
;
;
LOG(X,PREC) ;
New L,LIM,M,N,K,VALUE
If X'>0 Set $Ecode=",M28,"
Set PREC=$Get(PREC,11)
Set M=1
;
;;; If X>0 For N=0:1 Quit:(X/M)<10 Set M=M*10 ; Number
; Winfried Gerum (8 June 1995)
For N=0:1 Quit:(X/M)<10 Set M=M*10
;;;
;
If X<1 For N=0:–1 Quit:(X/M)>0.1 Set M=M*0.1
Set X=X/M
Set X=(X–1)/(X+1),(VALUE,L)=X
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Set L=L*X*X,M=L/K,VALUE=M+VALUE Set:M<0 M=-M Quit:M<LIM
Set VALUE=VALUE*2+(N*2.30258509298749)
Quit VALUE
;===
;
;
LOG10(X,PREC) ;
New L,LIM,M,N,K,VALUE
If X'>0 Set $Ecode=",M28,"
Set PREC=$Get(PREC,11)
Set M=1
;
;;; If X>0 For N=0:1 Quit:(X/M)<10 Set M=M*10 ; Number
; Winfried Gerum (8 June 1995)
For N=0:1 Quit:(X/M)<10 Set M=M*10
;;;
;
If X<1 For N=0:–1 Quit:(X/M)>0.1 Set M=M*0.1
Set X=X/M
Set X=(X–1)/(X+1),(VALUE,L)=X
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Set L=L*X*X,M=L/K,VALUE=M+VALUE Set:M<0 M=-M Quit:M<LIM
Set VALUE=VALUE*2+(N*2.30258509298749)
Quit VALUE/2.30258509298749
;===
;
;
MTXADD(A,B,R,ROWS,COLS) ;
; Add A[ROWS,COLS] to B[ROWS,COLS],
; result goes to R[ROWS,COLS]
IF $DATA(A)<10 QUIT 0
IF $DATA(B)<10 QUIT 0
IF $GET(ROWS)<1 QUIT 0
IF $GET(COLS)<1 QUIT 0
;
NEW ROW,COL,ANY
FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
. KVALUE R(ROW,COL) SET ANY=0
. SET:$DATA(A(ROW,COL))#2 ANY=1
. SET:$DATA(B(ROW,COL))#2 ANY=1
. SET:ANY R(ROW,COL)=$GET(A(ROW,COL))+$GET(B(ROW,COL))
. QUIT
QUIT 1
;===
;
;
MTXCOF(A,I,K,N) ;
; Compute cofactor for element [i,k]
; in matrix A[N,N]
NEW T,R,C,RR,CC
SET CC=0 FOR C=1:1:N DO:C'=K
. SET CC=CC+1,RR=0
. FOR R=1:1:N SET:R'=I RR=RR+1,T(RR,CC)=$GET(A(R,C))
. QUIT
QUIT $%MTXDET^MATH(.T,N–1)
;===
;
;
MTXCOPY(A,R,ROWS,COLS) ;
; Copy A[ROWS,COLS] to R[ROWS,COLS]
IF $DATA(A)<10 QUIT 0
IF $GET(ROWS)<1 QUIT 0
IF $GET(COLS)<1 QUIT 0
;
NEW ROW,COL
FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
. KVALUE R(ROW,COL)
. SET:$DATA(A(ROW,COL))#2 R(ROW,COL)=A(ROW,COL)
. QUIT
QUIT 1
;===
;
;
MTXDET(A,N) ;
; Compute determinant of matrix A[N,N]
IF $DATA(A)<10 QUIT ""
IF $GET(N)<1 QUIT ""
;
; First the simple cases
;
IF N=1 QUIT $GET(A(1,1))
IF N=2 QUIT $GET(A(1,1))*$GET(A(2,2))-($GET(A(1,2))*$GET(A(2,1)))
;
NEW DET,I,SIGN
;
; Det A = sum (k=1:n) element (i,k) * cofactor [i,k]
;
SET DET=0,SIGN=1
FOR I=1:1:N DO
. SET DET=$GET(A(1,I))*$%MTXCOF^MATH(.A,1,I,N)*SIGN+DET
. SET SIGN=-SIGN
. QUIT
QUIT DET
;===
;
;
MTXEQU(A,B,R,N,M) ;
; Solve matrix equation A [M,M] * R [M,N] = B [M,N]
IF $GET(M)<1 QUIT ""
IF $GET(N)<1 QUIT ""
;;;IF '$%MTXDET^MATH(.A) QUIT 0
; Ed de Moel, 29 August 1999
IF '$%MTXDET^MATH(.A,M) QUIT 0
;;;
;
NEW I,I1,J,J1,J2,K,L,T,T1,T2,TEMP,X
;
SET X=$%MTXCOPY^MATH(.A,.T,N,N)
SET X=$%MTXCOPY^MATH(.B,.R,N,M)
;
; Reduction of matrix A
; Steps of reduction are counted by index K
;
FOR K=1:1:N–1 DO
. ;
. ; Search for largest coefficient of T
. ; (denoted by TEMP)
. ; in first column of reduced system
. ;
. SET TEMP=0,J2=K
. FOR J1=K:1:N DO
. . QUIT:$TRANSLATE($GET(T(J1,K)),"-")>$TRANSLATE(TEMP,"-")
. . SET TEMP=T(J1,K),J2=J1
. . QUIT
. ;
. ; Exchange row number K with row number J2,
. ; if necessary
. ;
. DO:J2'=K
. . ;
. . FOR J=K:1:N DO
. . . SET T1=$GET(T(K,J)),T2=$GET(T(J2,J))
. . . KILL T(K,J),T(J2,J)
. . . IF T1'="" SET T(J2,J)=T1
. . . IF T2'="" SET T(K,J)=T2
. . . QUIT
. . FOR J=1:1:M DO
. . . SET T1=$GET(R(K,J)),T2=$GET(R(J2,J))
. . . KILL R(K,J),R(J2,J)
. . . IF T1'="" SET R(J2,J)=T1
. . . IF T2'="" SET R(K,J)=T2
. . . QUIT
. . QUIT
. ;
. ; Actual reduction
. ;
. FOR I=K+1:1:N DO
. . FOR J=K+1:1:N DO
. . . QUIT:'$GET(T(K,K))
. . . SET T(I,J)=-$GET(T(K,J))*$GET(T(I,K))/T(K,K)+$GET(T(I,J))
. . . QUIT
. . FOR J=1:1:M DO
. . . QUIT:'$GET(T(K,K))
. . . SET R(I,J)=-$GET(R(K,J))*$GET(T(I,K))/T(K,K)+$GET(R(I,J))
. . . QUIT
. . QUIT
. QUIT
;
; Backsubstitution
;
FOR J=1:1:M DO
. IF $GET(T(N,N)) SET R(N,J)=$GET(R(N,J))/T(N,N)
. IF N–1>0 FOR I1=1:1:N–1 DO
. . SET I=N-I1
. . FOR L=I+1:1:N DO
. . . SET R(I,J)=-$GET(T(I,L))*$GET(R(L,J))+$GET(R(I,J))
. . . QUIT
. . IF $GET(T(I,I)) SET R(I,J)=$GET(R(I,J))/$GET(T(I,I))
. . QUIT
. QUIT
;;;QUIT $%MTXDET^MATH(.R)
; Ed de Moel, 29 Aug 1999
QUIT $SELECT(M=N:$%MTXDET^MATH(.R,M),1:1)
;;;
;===
;
MTXINV(A,R,N) ;
; Invert A[N,N], result goes to R[N,N]
IF $DATA(A)<10 QUIT 0
IF $GET(N)<1 QUIT 0
;
NEW T,X
SET X=$%MTXUNIT^MATH(.T,N)
QUIT $%MTXEQU^MATH(.A,.T,.R,N,N)
;===
;
;
MTXMUL(A,B,R,M,L,N) ;
; Multiply A[M,L] by B[L,N], result goes to R[M,N]
IF $DATA(A)<10 QUIT 0
IF $DATA(B)<10 QUIT 0
IF $GET(L)<1 QUIT 0
IF $GET(M)<1 QUIT 0
IF $GET(N)<1 QUIT 0
;
NEW I,J,K,SUM,ANY
FOR I=1:1:M FOR J=1:1:N DO
. SET (SUM,ANY)=0
. KVALUE R(I,J)
. FOR K=1:1:L DO
. . SET:$DATA(A(I,K))#2 ANY=1
. . SET:$DATA(B(K,J))#2 ANY=1
. . SET SUM=$GET(A(I,K))*$GET(B(K,J))+SUM
. . QUIT
. SET:ANY R(I,J)=SUM
. QUIT
QUIT 1
;===
;
;
MTXSCA(A,R,ROWS,COLS,S) ;
; Multiply A[ROWS,COLS] with the scalar S,
; result goes to R[ROWS,COLS]
IF $DATA(A)<10 QUIT 0
IF $GET(ROWS)<1 QUIT 0
IF $GET(COLS)<1 QUIT 0
IF '($DATA(S)#2) QUIT 0
;
NEW ROW,COL
FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
. KVALUE R(ROW,COL)
. SET:$DATA(A(ROW,COL))#2 R(ROW,COL)=A(ROW,COL)*S
. QUIT
QUIT 1
;===
;
;
MTXSUB(A,B,R,ROWS,COLS) ;
; Subtract B[ROWS,COLS] from A[ROWS,COLS],
; result goes to R[ROWS,COLS]
IF $DATA(A)<10 QUIT 0
IF $DATA(B)<10 QUIT 0
IF $GET(ROWS)<1 QUIT 0
IF $GET(COLS)<1 QUIT 0
;
NEW ROW,COL,ANY
FOR ROW=1:1:ROWS FOR COL=1:1:COLS DO
. KVALUE R(ROW,COL) SET ANY=0
. SET:$DATA(A(ROW,COL))#2 ANY=1
. SET:$DATA(B(ROW,COL))#2 ANY=1
. ;
. ;;; SET:ANY R(ROW,COL)=$GET(A(ROW,COL)-$GET(B(ROW,COL)) ; Number
. ; Eli Reidler (28 June 1996)
. SET:ANY R(ROW,COL)=$GET(A(ROW,COL))-$GET(B(ROW,COL))
. ;;;
. ;
. QUIT
QUIT 1
;===
;
;
MTXTRP(A,R,M,N) ;
; Transpose A[M,N], result goes to R[N,M]
IF $DATA(A)<10 QUIT 0
IF $GET(M)<1 QUIT 0
IF $GET(N)<1 QUIT 0
;
NEW I,J,K,D1,V1,D2,V2
FOR I=1:1:M+N–1 FOR J=1:1:I+1\2 DO
. SET K=I-J+1
. IF K=J DO QUIT
. . SET V1=$GET(A(J,J)),D1=$DATA(A(J,J))#2
. . IF J'>N,J'>M KVALUE R(J,J) SET:D1 R(J,J)=V1
. . QUIT
. ;
. SET V1=$GET(A(K,J)),D1=$DATA(A(K,J))#2
. SET V2=$GET(A(J,K)),D2=$DATA(A(J,K))#2
. IF K'>M,J'>N KVALUE R(K,J) SET:D2 R(K,J)=V2
. IF J'>M,K'>N KVALUE R(J,K) SET:D1 R(J,K)=V1
. QUIT
QUIT 1
;===
;
;
MTXUNIT(R,N,SPARSE) ;
; Create a unit matrix R[N,N]
IF $GET(N)<1 QUIT 0
;
NEW ROW,COL
FOR ROW=1:1:N FOR COL=1:1:N DO
. KVALUE R(ROW,COL)
. IF $GET(SPARSE) QUIT:ROW'=COL
. SET R(ROW,COL)=$SELECT(ROW=COL:1,1:0)
. QUIT
QUIT 1
;===
;
;
PI() Quit 3.14159265358979
;===
;
;
PRODUCE(IN,SPEC,MAX) ;
NEW VALUE,AGAIN,P1,P2,I,COUNT
SET VALUE=IN,COUNT=0
FOR DO QUIT:'AGAIN
. SET AGAIN=0
. SET I=""
. FOR SET I=$ORDER(SPEC(I)) QUIT:I="" DO QUIT:COUNT<0
. . QUIT:$GET(SPEC(I,1))=""
. . QUIT:'($DATA(SPEC(I,2))#2)
. . FOR QUIT:VALUE'[SPEC(I,1) DO QUIT:COUNT<0
. . . SET P1=$PIECE(VALUE,SPEC(I,1),1)
. . . SET P2=$PIECE(VALUE,SPEC(I,1),2,$LENGTH(VALUE))
. . . SET VALUE=P1_SPEC(I,2)_P2,AGAIN=1
. . . SET COUNT=COUNT+1
. . . IF $DATA(MAX),COUNT>MAX SET COUNT=–1,AGAIN=0
. . . QUIT
. . QUIT
. QUIT
QUIT VALUE
;===
;
;
RADDEG(X) Quit X*180/3.14159265358979
;===
;
;
REPLACE(IN,SPEC) ;
NEW L,MASK,K,I,LT,F,VALUE
SET L=$LENGTH(IN),MASK=$JUSTIFY("",L)
SET I="" FOR SET I=$ORDER(SPEC(I)) QUIT:I="" DO
. QUIT:'($DATA(SPEC(I,1))#2)
. QUIT:SPEC(I,1)=""
. QUIT:'($DATA(SPEC(I,2))#2)
. SET LT=$LENGTH(SPEC(I,1))
. SET F=0 FOR SET F=$FIND(IN,SPEC(I,1),F) QUIT:F<1 DO
. . QUIT:$EXTRACT(MASK,F-LT,F–1)["X"
. . SET VALUE(F-LT)=SPEC(I,2)
. . SET $EXTRACT(MASK,F-LT,F–1)=$TRANSLATE($JUSTIFY("",LT)," ","X")
. . QUIT
. QUIT
SET VALUE="" FOR K=1:1:L DO
. IF $EXTRACT(MASK,K)=" " SET VALUE=VALUE_$EXTRACT(IN,K) QUIT
. SET:$DATA(VALUE(K)) VALUE=VALUE_VALUE(K)
. QUIT
QUIT VALUE
;===
;
;
SEC(X,PREC) ;
New L,LIM,K,SIGN,VALUE
;
;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ; Number
; Winfried Gerum (8 June 1995)
; Comment: The official description does not mention than
; the function may also be called with the first
; parameter in degrees, minutes and seconds.
Set:X[":" X=$%DMSDEC^MATH(X)
;;;
;
Set PREC=$Get(PREC,11)
Set X=X#(2*$%PI^MATH())
Set (VALUE,L)=1,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=2:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
. Quit
If 'VALUE Quit "INFINITE"
Quit 1/VALUE
;===
;
;
SECH(X,PREC) ;;;Quit 1/$%COSH^MATH(X,PREC) ; Number
; Winfried Gerum (8 June 1995)
; Alan Frank (October 1995)
Quit 1/$%COSH^MATH(X,$Get(PREC,11))
;;;
;===
;
;
SIGN(X) Quit $SELECT(X<0:–1,X>0:1,1:0)
;===
;
;
SIN(X,PREC) ;
New L,LIM,K,SIGN,VALUE
;
;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ; Number
; Winfried Gerum (8 June 1995)
; Comment: The official description does not mention than
; the function may also be called with the first
; parameter in degrees, minutes and seconds.
Set:X[":" X=$%DMSDEC^MATH(X)
;;;
;
Set PREC=$Get(PREC,11)
Set X=X#(2*$%PI^MATH())
Set (VALUE,L)=X,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
. Quit
Quit VALUE
;===
;
;
SIN(X) ;
;;; ; Number
; Winfried Gerum (8 June 1995)
; Comment: This version of the function is
; optimized for speed, not for precision.
; The ‘precision’ parameter is not supported,
; and the precision is at best 1 in 10**–9.
; Note that this function does not accept its
; parameter in degrees, minutes and seconds.
;;;
;
New A,N,PI,R,SIGN,XX
;
; This approximation only works for 0 <= x <= pi/2
; so reduce angle to correct quadrant.
;
Set PI=$%PI^MATH(),X=X#(PI*2),SIGN=1
Set:X>PI X=2*PI-X,SIGN=–1
;
;;; Set:X*2<PI X=PI-X Set X=-PI/2+2 ; Number
; Winfried Gerum (8 June 1995)
Set:X*2<PI X=PI-X
;;;
;
;
Set XX=X*X,A(1)=–0.4999999963,A(2)=0.0416666418
Set A(3)=–0.0013888397,A(4)=0.0000247609,A(5)=–0.0000002605
Set (X,R)=1 For N=1:1:5 Set X=X*XX,R=A(N)*X+R
Quit R*SIGN
;===
;
;
SINH(X,PREC) ;
;
;;; New F,I,P,R,T,XX ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
New E,F,I,P,R,T,XX
;;;
;
Set PREC=$Get(PREC,11)+1
Set @("E=1E-"_PREC)
Set XX=X*X,F=1,I=2,(P,R,T)=X
For Set T=T*XX,F=I+1*I*F,R=T/F+R,P=P-R/R,I=I+2 If -E<P,P<E Quit
Quit R
;===
;
;
SQRT(X,PREC) ;
If X<0 Set $Ecode=",M28,"
If X=0 Quit 0
;
;;; ; Number
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
;
;;; If X<1 Quit 1/$%SQRT^MATH(1/X) ; Number
; Winfried Gerum (8 June 1995)
If X<1 Quit 1/$%SQRT^MATH(1/X,PREC)
;;;
;
New P,R,E
Set PREC=$Get(PREC,11)+1
;
;;; Set @(E="1E-"_PREC) ; Number
; Winfried Gerum (8 June 1995)
; Eli Reidler (28 June 1996)
Set @("E=1E-"_PREC)
;;;
;
Set R=X
For Set P=R,R=X/R+R/2,P=P-R/R If -E<P,P<E Quit
Quit R
;===
;
;
TAN(X,PREC) ;
New L,LIM,K,S,SIGN,VALUE
;
;;; Set:X[":" X=$%DMSDEC^MATH(X,12) ; Number
; Winfried Gerum (8 June 1995)
; Comment: The official description does not mention than
; the function may also be called with the first
; parameter in degrees, minutes and seconds.
Set:X[":" X=$%DMSDEC^MATH(X)
;;;
;
Set PREC=$Get(PREC,11)
Set X=X#(2*$%PI^MATH())
Set (VALUE,L)=X,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=3:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L/(K–1)*X/K*X,VALUE=VALUE+(SIGN*L)
. Quit
Set S=VALUE
Set X=X#(2*$%PI^MATH())
Set (VALUE,L)=1,SIGN=–1
Set LIM=$Select((PREC+3)'>11:PREC+3,1:11),@("LIM=1E-"_LIM)
For K=2:2 Do Quit:($Translate(L,"-")<LIM) Set SIGN=SIGN*–1
. Set L=L*X*X/(K–1*K),VALUE=VALUE+(SIGN*L)
. Quit
If 'VALUE Quit "INFINITE"
Quit S/VALUE
;===
;
;
TANH(X,PREC) ;
;
;;; ; Number
; Alan Frank (October 1995)
Set PREC=$Get(PREC,11)
;;;
;
Quit $%SINH^MATH(X,PREC)/$%COSH^MATH(X,PREC)
;===
;
;
FORMAT(V,S) ;
;
; The code below was approved in document X11/SC13/TG2/1999–1
;
New lo,mask,out,p,pos,spec,up,v1,v2,val,x
;
Set lo="abcdefghijklmnopqrstuvwxyz"
Set up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
;
; Array spec() contains the formatting directives
;
; First set defaults
;
Set spec("CS")="$" ; Currency symbol
Set spec("DC")="." ; Decimal separator
Set spec("EC")="*" ; Error character
Set spec("SL")="," ; Separator characters > 1
Set spec("FS")=" " ; Fill string
;
; Other specifiers may be
; FM = Format Mask
; FO = Fill On/Off
; SR = Separator characters < 1
;
; Then Inherit properties from System,
; overwriting the defaults
;
Set x="" For Set x=$Order(^$System($System,"FORMAT",x)) Quit:x="" Do
. Set spec(x)=^$System($System,"FORMAT",x)
. Quit
;
; Then Inherit properties from current process
; overwriting the system and the defaults
;
Set x="" For Set x=$Order(^$Job($Job,"FORMAT",x)) Quit:x="" Do
. Set spec(x)=^$Job($Job,"FORMAT",x)
. Quit
;
; Then look at actual parameters
; overwriting anything else
;
Set S=$Get(S) For Quit:S="" Do
. New e,i,str,v
. Set x=$Piece(S,"=",1)
. Set i=$Length(x)+2,str=0,v=""
. Set:x="" i=1
. For i=i:1:$Length(S)+1 Do Quit:'i
. . Set e=$Extract(S_":",i)
. . If 'str,e=":" Set S=$Extract(S,i+1,$Length(S)),i=0 Quit
. . Set v=v_e Quit:e'=""""
. . Set str=1-str
. . Quit
. If i>$Length(S) Set S=""
. If x'="",v'="" Set @("spec($Translate(x,lo,up))="_v) Quit
. Set $ECode=",M28,"
. Quit
;
; Make certain that DC and EC are non-empty
; and not longer than 1 character
;
Set spec("DC")=$Extract(spec("DC")_".",1)
Set spec("EC")=$Extract(spec("EC")_"*",1)
;
Set val=$Get(V),(mask,out)=$Get(spec("FM"))
If mask="" Quit val
;
; Currency string
;
Set x=spec("CS")
Set pos=0 For Set pos=$Find(mask,"c",pos) Quit:pos<1 Do
. Set $Extract(out,pos–1)=$Extract(x,1)
. Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
. Quit
;
; Sign
;
Set x=$Select(val>0:"+",val<0:"-",1:" ")
Set pos=0 For Set pos=$Find(mask,"+",pos) Quit:pos<1 Do
. Set $Extract(out,pos–1)=x
. Quit
Set pos=0 For Set pos=$Find(mask,"-",pos) Quit:pos<1 Do
. Set $Extract(out,pos–1)=$Select(x="-":x,1:" ")
. Quit
If x'="-" Set out=$Translate(out,"()"," ")
;
; Decimal separator
;
Set pos=$Find(mask,"d")
Do:pos'<1
. Set $Extract(out,pos–1)=spec("DC")
. For Set pos=$Find(mask,"d",pos) Quit:pos<1 Do
. . Set $Extract(out,pos–1)=spec("EC")
. . Quit
. Quit
;
; Right (default, format letter "n") or
; left (format letter "l") adjustment?
;
If mask["l",mask["n" Set $ECode=",M28,"
;
; Left and Right Separators
;
Set v1=$Piece(val,".",1),v2=$Piece(val,".",2)
Set v1=$Translate(v1,"-")
If mask'["l" Do
. Set x="" For p=1:1:$Length(v1) Set x=$Extract(v1,p)_x
. Set v1=x
. Quit
;
Set pos=$Find(mask,"d") Set:pos<1 pos=$Length(mask)+2
;
; Integer part and Left separators
;
Set x=spec("SL")
Set p(1)=pos–2,p(2)=–1,p(3)=1
Set:mask["l" p(1)=1,p(2)=1,p(3)=pos–2
For p=p(1):p(2):p(3) Do
. If "fln"[$Extract(mask,p) Do
. . Set $Extract(out,p)=$Extract(v1,1)
. . Set v1=$Extract(v1,2,$Length(v1))_spec("FS")
. . If $Translate(v1,spec("FS"))="" Set x=spec("FS")
. . Quit
. If $Extract(mask,p)="s" Do
. . Set $Extract(out,p)=$Extract(x,1)
. . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
. Quit
;
; Fractional part and Right separators
;
Set x=$Get(spec("SR"),spec("SL"))
Set:v2="" v2=0
For p=pos:1:$Length(mask) Do
. If "fn"[$Extract(mask,p) Do
. . Set $Extract(out,p)=$Extract(v2,1)
. . Set v2=$Extract(v2,2,$Length(v2))_"0"
. . Quit
. If $Extract(mask,p)="s" Do
. . Set $Extract(out,p)=$Extract(x,1)
. . Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
. . Quit
. Quit
;
; Fill String
;
Set x=$Get(spec("FS"))
For p=1:1:$l(mask) Do
. Quit:"nf"'[$Extract(mask,p)
. Quit:$Extract(out,p)'=" "
. Set $Extract(out,p)=$Extract(x,1)
. Set x=$Extract(x,2,$Length(x))_$Extract(x,1)
. Quit
;
; Justification
;
For x="+ | +","- | -","( | ("," )|) " Do
. New find,repl
. Set find=$Piece(x,"|",1),repl=$Piece(x,"|",2)
. For Quit:out'[find Do
. . Set out=$Piece(out,find,1)_repl_$Piece(out,find,2,$l(out)+2)
. . Quit
. Quit
;
Quit out
;
;===
;
;
CRC16(string,seed) ;
;
; The code below was approved in document X11/1998–32
;
; Polynomial x**16 + x**15 + x**2 + x**0
NEW I,J,R
IF '$DATA(seed) SET R=0
ELSE IF seed'<0,seed'>65535 SET R=seed\1
ELSE SET $ECODE=",M28,"
FOR I=1:1:$LENGTH(string) DO
. SET R=$$XOR($ASCII(string,I),R,8)
. FOR J=0:1:7 DO
. . IF R#2 SET R=$$XOR(R\2,40961,16)
. . ELSE SET R=R\2
. . QUIT
. QUIT
QUIT R
XOR(a,b,w) NEW I,M,R
SET R=b,M=1
FOR I=1:1:w DO
. SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
. SET M=M+M
. QUIT
QUIT R
;===
;
;
CRC32(string,seed) ;
;
; The code below was approved in document X11/1998–32
;
; Polynomial X**32 + X**26 + X**23 + X**22 +
; + X**16 + X**12 + X**11 + X**10 +
; + X**8 + X**7 + X**5 + X**4 +
; + X**2 + X + 1
NEW I,J,R
IF '$DATA(seed) SET R=4294967295
ELSE IF seed'<0,seed'>4294967295 SET R=4294967295-seed
ELSE SET $ECODE=",M28,"
FOR I=1:1:$LENGTH(string) DO
. SET R=$$XOR($ASCII(string,I),R,8)
. FOR J=0:1:7 DO
. . IF R#2 SET R=$$XOR(R\2,3988292384,32)
. . ELSE SET R=R\2
. . QUIT
. QUIT
QUIT 4294967295-R
XOR(a,b,w) NEW I,M,R
SET R=b,M=1
FOR I=1:1:w DO
. SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
. SET M=M+M
. QUIT
QUIT R
; ===
;
;
CRCCCITT(string,seed) ;
;
; The code below was approved in document X11/1998–32
;
; Polynomial x**16 + x**12 + x**5 + x**0
NEW I,J,R
IF '$DATA(seed) SET R=65535
ELSE IF seed'<0,seed'>65535 SET R=seed\1
ELSE SET $ECODE=",M28,"
FOR I=1:1:$LENGTH(string) DO
. SET R=$$XOR($ASCII(string,I)*256,R,16)
. FOR J=0:1:7 DO
. . SET R=R+R
. . QUIT:R<65536
. . SET R=$$XOR(4129,R–65536,13)
. . QUIT
. QUIT
QUIT R
XOR(a,b,w) NEW I,M,R
SET R=b,M=1
FOR I=1:1:w DO
. SET:a\M#2 R=R+$SELECT(R\M#2:-M,1:M)
. SET M=M+M
. QUIT
QUIT R
; ===
;
;
LOWER(A,CHARMOD) NEW lo,up,x,y
;
; The code below was approved in document X11/1998–21
;
SET x=$GET(CHARMOD)
SET lo="abcdefghijklmnopqrstuvwxyz"
SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
IF x?1"^"1E.E DO
. SET x=$EXTRACT(x,2,$LENGTH(x))
. IF x?1"|".E DO
. . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
. . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
. . SET x=$REVERSE($PIECE(x,"|",1))
. . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
. . QUIT
. ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
. QUIT
IF x="" SET x=^$JOB($JOB,"CHARACTER")
SET x=$GET(^$CHARACTER(x,"LOWER"))
IF x="" QUIT $TRANSLATE(A,up,lo)
SET @("x="_x_"(A)")
QUIT x
; ===
;
;
PATCODE(A,PAT,CHARMOD) NEW x,y
;
; The code below was approved in document X11/1998–21
;
SET x=$GET(CHARMOD)
IF x?1"^"1E.E DO
. SET x=$EXTRACT(x,2,$LENGTH(x))
. IF x?1"|".E DO
. . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
. . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
. . SET x=$REVERSE($PIECE(x,"|",1))
. . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
. . QUIT
. ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
. QUIT
IF x="" SET x=^$JOB($JOB,"CHARACTER")
SET x=$GET(^$CHARACTER(x,"PATCODE",PAT))
IF x="" QUIT 0
SET @("x="_x_"(A)")
QUIT x
; ===
;
;
UPPER(A,CHARMOD) NEW lo,up,x,y
;
; The code below was approved in document X11/1998–21
;
SET x=$GET(CHARMOD)
SET lo="abcdefghijklmnopqrstuvwxyz"
SET up="ABCDEFGHIJKLMNOPQRSTUVWXYZ"
IF x?1"^"1E.E DO
. SET x=$EXTRACT(x,2,$LENGTH(x))
. IF x?1"|".E DO
. . SET x=$REVERSE($EXTRACT(x,2,$LENGTH(x)))
. . SET y=$REVERSE($PIECE(x,"|",2,$LENGTH(x)+2))
. . SET x=$REVERSE($PIECE(x,"|",1))
. . SET x=$GET(^|y|$GLOBAL(x,"CHARACTER"))
. . QUIT
. ELSE SET x=$GET(^$GLOBAL(x,"CHARACTER"))
. QUIT
IF x="" SET x=^$JOB($JOB,"CHARACTER")
SET x=$GET(^$CHARACTER(x,"UPPER"))
IF x="" QUIT $TRANSLATE(A,lo,up)
SET @("x="_x_"(A)")
QUIT x
; ===
;
;
|
|
|
|
|
|
|
Copyright © Standard Documents; 1977-2024 MUMPS Development Committee;
Copyright © Examples: 1995-2024 Ed de Moel;
Copyright © Annotations: 2003-2008 Jacquard Systems Research
Copyright © Annotations: 2008-2024 Ed de Moel.
The information in this page is
NOT authoritative and subject to be modified
at any moment.
Please consult the
appropriate (draft) language standard for an
authoritative definition.
Some specifications are "approved for inclusion in a future standard". Note that the MUMPS Development Committee cannot guarantee that such future standards will indeed be published.
This page most recently updated on 14-Nov-2023, 21:20:14.
For comments, contact Ed de Moel (demoel@jacquardsystems.com)