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
 ; ===
 ;
 ;