Button for 1977 Button for 1984 Button for 1990 Button for 1995 Button for MDC Button for notes Button for examples

Appendix I

M[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

 ; ===

 ;

 ;

Button for 1977 Button for 1984 Button for 1990 Button for 1995 Button for MDC Button for notes Button for examples

Copyright © Standard Documents; 1977-2022 MUMPS Development Committee;
Copyright © Examples: 1995-2022 Ed de Moel;
Copyright © Annotations: 2003-2008 Jacquard Systems Research
Copyright © Annotations: 2008-2022 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 29-Nov-2011, 20:00:19 .

For comments, contact Ed de Moel (demoel@jacquardsystems.com)