C COPYRIGHT (C) 1983 GLENN EVERHART
C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS
C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.
C USER FUNCTION ROUTINE
C GENERATES PARSING AND EXECUTION OF ROUTINE CALLS OF FORM
C  *U FNAME (ARGUMENTS)
C WHERE LINE (80 BYTES) CONTAINS COMMAND LINE AND ALL
C ARGUMENTS MAY BE PARSED.
C CALLED FROM CMND
c available parsing aid:
c call varscn(line,ibgn,lend,lstchr,id1,id2,ivalid)
c where line(ibgn... lend) is scanned. If variable found
c ivalid=1 else ivalid=0. id1,id2 are dims in xvbls for
c variable found if any. lstchr is last char found+1...
C OTHER USEFUL ROUTINES IN THE SHEET:
C GN(LAST,LEND,NUMBER,LINE)
C  LOOKS FROM LINE(LAST) THRU LINE(LEND) FOR A NUMBER AND
C  RETURNS ANY NUMBER IN "NUMBER" ARG. ASSUMES "LINE" IS A
C  BYTE ARRAY. (NO INDICATION OF WHERE THE NUMBER WAS FOUND
C  HOWEVER). THROWS OUT LEADING SPACES, TERMINATES ON A NON
C  NUMERIC.
C INDEX(LINE,CHAR)
C  EXPECTS LINE TO BE NULL TERMINATED AND RETURNS EITHER
C  THE SUBSCRIPT (COUNTING FROM 1) OF CHAR IN LINE OR THE
C  MAX SUBSCRIPT IN LINE (I.E., WHERE IT HIT THE NULL TERMINATOR).
C  NOTE THIS DIFFERS FROM THE "STANDARD" VERSION OF INDEX WHICH
C  RETURNS 0 FOR "NOT FOUND" -- THIS VERSION RETURNS MAX LENGTH
C  FOR "NOT FOUND". STOPS AT 512 BYTES HOWEVER...
C  PARSING IS UP TO USER. NOTE VARSCN MAY BE CALLED TO PARSE
C VARIABLE NAMES. SUPPLIED VERSION CALLS IDATE WHICH RETURNS
C SYSTEM DATE IN RSX OR VMS AS INTEGER DAY, MONTH, AND YEAR.
C  THIS RETURNS HERE IN AC T, U, AND V
	SUBROUTINE USRFCT(LINE,RETCD)
	INCLUDE 'VKLUGPRM.FTN'
	BYTE LINE(80)
	INTEGER RETCD
	LOGICAL*1 AVBLS(100,27),WRK(128),VBLS(8,RRW,RCL)
	INTEGER*2 TYPE(RRW,RCL),VLEN(9)
	REAL*8 XAC,XVBLS(RRW,RCL)
	REAL*8 TAC,UAC,VAC
	INTEGER*4 JVBLS(2,RRW,RCL)
	EQUIVALENCE(XAC,AVBLS(1,27))
	EQUIVALENCE(TAC,AVBLS(1,20))
	EQUIVALENCE(UAC,AVBLS(1,21))
	EQUIVALENCE(VAC,AVBLS(1,22))
	EQUIVALENCE(VBLS(1,1,1),JVBLS(1,1,1))
	EQUIVALENCE(VBLS(1,1,1),XVBLS(1,1))
	COMMON/V/TYPE,AVBLS,VBLS,VLEN
C ARGUMENTS COME IN IN ARGUMENTS IN LINE
C RESULTS GO INTO PERCENT (XAC) AND WHEREVER ELSE DESIRED...
	LOGICAL*1 FNAMS(6,4)
C FNAMS IS NAME OF FUNCTION CALLED.
	DATA FNAMS /'I','D','A','T','E',0,
     1  'M','T','X','E','Q',0,
     2  'M','O','V','E','V',0,
     3  'M','D','E','T',0,0
     9  /
C NULL TERMINATE ANY NAMES (ALLOWS 5 CHARACTERS)
C START LOOKING PAST THE *U
C  GET FUNCTION NAME AND GO TO PROCESS EACH FUNCTION SEPARATELY
C GET NONBLANK CHAR FOR FUNCTION NAME START
	K=3
30	IF(LINE(K).NE.' ')GOTO 40
	K=K+1
	IF(K.LT.60)GOTO 30
40	CONTINUE
C UNCOMMENT THE DO 100 STMT IF DIM 2 OF FNAMS > 1
	N=1
C **** BE SURE THE 2ND BOUND ON N IS THE SAME AS THE DIMENSION OF
C ****  FNAMS   **************************
	DO 100 N=1,4
	KF=N
	DO 110 NN=1,6
	IF(LINE(K+NN-1).NE.FNAMS(NN,N).AND.FNAMS(NN,N).GT.0)
     1  GOTO 100
110	CONTINUE
	GOTO 200
100	CONTINUE
C UNRECOGNIZED FUNCTION... IGNORE
300	RETCD=3
	RETURN
200	CONTINUE
C NOW HAVE FOUND FUNCTION IDENTIFIED BY KF. CALL IT AND ALLOW TO WORK
	GOTO (1100,1200,1300,1400),KF
	GOTO 300
1100	CONTINUE
C IDATE FUNCTION
C RETURNS MONTH, DAY, YEAR IN AC'S T,U,V
	CALL IDATE(IMO,IDA,IYR)
	TAC=IMO
	UAC=IDA
	VAC=IYR
C RETURN A FLOATING VALUE OF DATE FORM AS YYMMDD SO IT CAN BE
C USED FOR SORTING AND SIMILAR APPLICATIONS. COULD BE USED ALSO
C FOR INTERVALS IF A JULIAN DATE WERE RETURNED, BUT THIS WILL DO
C FOR COMPARISONS AND ORDERING.
	XAC=VAC*10000.+TAC*100.+UAC
	RETURN
1200	CONTINUE
C MATRIX EQUATION. NOTE WE MUST NOW START SCAN FOR ARGUMENTS...
C K+5 IS START OF ARG LIST. START AT K+6 TO ALLOW ( TO BE THERE...
C FORMAT DESIRED:
C  *U MTXEQ(A1:A2,X1:X2,B1:B2) GENERATING SOLUTION MATRIX X1:X2
C  FROM MATRICES A,B AND SOLVING EQUATION AX=B WHERE A IS AN N BY
C  N SQUARE MATRIX, AND X AND B ARE N BY M MATRICES.
	RETCD=1
C COLLECT ARGUMENTS. NOTE THAT VARSCN AND GN TRASH POINTERS PASSED
C TO THEM IN IBGN, LEND, SO MAKE UP EVERY TIME. USE VARSCN TO
C COLLECT POINTERS TO THE SHEET ARRAY FIRST OFF COMMAND LINE,
C THEN PROCESS IN OUR MAGICAL MYSTICAL ROUTINE...
	IBGN=K+6
	LEND=IBGN+20
C GET LOCATIONS OF MATRICES A, X, AND B (FOR AX=B EQN)
C A MUST BER N BY N, SQUARE. X,B ARE N BY M.
	CALL PMTX2(RETCD,3,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1   IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	N=IABS(ID1B-ID1A)+1
C CHECK THAT MATRIX A IS SQUARE
	IF(N.NE.(IABS(ID2B-ID2A)+1))GOTO 300
C CHECK THAT MATRIX X AND B HAVE THE SAME DIMENSIONS
	IF((IDYA-IDXA).NE.(IDCA-IDBA))GOTO 300
	IF((IDYB-IDXB).NE.(IDCB-IDBB))GOTO 300
	M=IABS(IDYA-IDXA)+1
C CHECK THAT THE X AND B MATRIX DIMENSIONS ARE N BY M
C WHERE THE N IS THE SAME AS FOR THE A MATRIX
	NN=IABS(IDYB-IDXB)+1
	IF(NN.NE.N)GOTO 300
C NOW HAVE DIMENSIONS FOR ALL THIS STUFF...
C SINCE MTXEQU TRASHES ITS' B MATRIX, COPY IT INTO X MATRIX
C AND THEN CALL...
	DO 1210 NN=IDBA,IDCA
	DO 1210 MM=IDBB,IDCB
	XVBLS(NN-IDBA+IDXA,MM-IDBB+IDXB)=XVBLS(NN,MM)
1210	CONTINUE
C NOW ALL THE ARGUMENTS ARE SET UP... GO DO THE WORK.
C CALL UTILITY ROUTINE, THEN DONE...
	CALL MTXEQU(XVBLS(ID1A,ID2A),XVBLS(IDXA,IDXB),N,M,XAC)
	RETURN
1300	CONTINUE
C MOVEV  MTX1 MTX2  MOVE MTX1 VALUES TO MTX2
	RETCD=1
	IBGN=K+6
	CALL PMTX2(RETCD,2,LINE,IBGN,IR1T,IC1T,IR1B,IC1B,IR2T,IC2T,
     1  IR2B,IC2B)
C CHECK FOR SAME SIZE MATRICES
	IF((IC1T-IC1B).NE.(IC2T-IC2B))GOTO 300
	IF((IR1T-IR1B).NE.(IR2T-IR2B))GOTO 300
C DO THE COPY HERE (EASIER THAN CALLING SOMETHING...)
	DO 1301 NN=IR1T,IR1B
	DO 1301 MM=IC1T,IC1B
	XVBLS(NN-IR1T+IR2T,MM-IC1T+IC2T)=XVBLS(NN,MM)
1301	CONTINUE
	RETURN
1400	CONTINUE
C MDET  - DETERMINANT OF SQUARE MATRIX
C  1 ARGUMENT, VIZ., MATRIX COORDS
	RETCD=1
C ACCOUNT FOR "MDET" BEING 4 CHARS NOT 5
	IBGN=K+5
	CALL PMTX2(RETCD,1,LINE,IBGN,IR1T,IC1T,IR1B,IC1B)
C CALL A DETERMINANT ROUTINE TO DO THE WORK
C NOTE IT CHECKS FOR SQUARE MATRIX INTERNALLY AND RETURNS 0 IF NOT
C SQUARE...
	CALL MDET(XVBLS,IR1T,IC1T,IR1B,IC1B,XAC)
	RETURN
	END
C SPLIT OFF MATRIX PARSING LOGIC HERE TO PICK OFF UP TO 3 MATRICES
C COORDINATES
C THIS ALLOWS US TO CALL ONE ROUTINE TO LOCATE UP TO 3 MATRIX
C SPECIFICATIONS SEPARATED BY COMMAS.
	SUBROUTINE PMTX2(IRTCD,IMXX,LINE,IBGN,ID1A,ID2A,ID1B,ID2B,
     1  IDXA,IDXB,IDYA,IDYB,IDBA,IDBB,IDCA,IDCB)
	LOGICAL*1 LINE(80)
	CALL GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
     1  ID2B,RETCD)
C GET LOC OF MATRIX A (MUST BE SQUARE)
	IF(RETCD.NE.0.OR.IMXX.LE.1)GOTO 1000
	IF(LINE(LSTCHR).NE.',')GOTO 300
	IBGN=LSTCHR+1
	CALL GMTX(LINE,IBGN,LSTCHR,IDXA,IDXB,IDYA,
     1  IDYB,RETCD)
C GET LOC OF MATRIX X (RESULT).
	IF(RETCD.NE.0.OR.IMXX.LE.2)GOTO 1000
	IF(LINE(LSTCHR).NE.',')GOTO 300
	IBGN=LSTCHR+1
	CALL GMTX(LINE,IBGN,LSTCHR,IDBA,IDBB,IDCA,
     1  IDCB,RETCD)
C GET LOC OF MATRIX B (AX=B), THE OTHER HALF OF OUR GIVENS
C IF WE FALL TO HERE, ALL LOOKS OK, SO LEAVE RETCD ALONE.
C HOWEVER IF ANY ERRS HAVE OCCURRED, RETCD IS ALREADY SET TO 3
C FOR ERROR...
1000	RETURN
300	CONTINUE
	RETCD=3
	RETURN
	END
C GET SPECS FOR A MATRIX (2 VARS SEPARATED BY COLONS)
	SUBROUTINE GMTX(LINE,IBGN,LSTCHR,ID1A,ID2A,ID1B,
     1  ID2B,RETCD)
	LOGICAL*1 LINE(80)
C REQUIRE END OF MATRIX NAME WITHIN 20 CHARS OF START.
C SHOULD BE OK IN ALL REASONABLE CASES.
	LEND=IBGN+20
C GET LOC OF MATRIX A (MUST BE SQUARE)
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 300
	IF(LINE(LSTCHR).NE.':')GOTO 300
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE,IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 300
1000	RETURN
300	RETCD=3
	RETURN
	END