C SCIENTIFIC FUNCTION CALLER
C This version is a dummy placeholder.
C The SCIFCT subroutine exists to allow AnalytiCalc to call just
C about *ANY* Fortran callable routine.
C   The operation is to use a formula in AnalytiCalc which includes
c a call of form:
c  *U STxxxxxx range;range;range;range;range;...;range>outrange;outrange;outrange
c so that the "xxxxxx" part is the function name to be called.
c  input ranges are the parts of the sheet for input to the function; these
c are internally copied to a large array (defined here) which is a normal
c Fortran array. They are converted to integer*4 as needed if the function
c being called needs this. Once all conversion is done, the subroutine is
c called using an argument list built up by this call list. At the end,
c the output ranges are filled in from the internal Fortran array.
c   Because Fortran callable subroutines (e.g. those in the SSP) may pass
c their return arguments in ANY of their arguments, seeing a ; will increment
c the output range counter.
c
c To add more:
c  * Select desired sizes for work area (must be big enough to hold ALL
c  arguments used), max number of arguments per function, etc.
c  * Add new function name and characteristics to tables. Note that the
c  name, integer/float stuff for all args, which arg is first OUTPUT arg,
c  and map of output args, all are needed. Don't make first output arg
c  bigger than the max. number of args.
c  * Add another call and element in the computed GOTO for each function
c  desired.
c  * Build and enjoy.
c
c   Internally we need tables of
c      * Function names (up to 6 characters long per classical Fortran rules)
c      * Number of arguments needed per function
c      * Integer/real flags for arguments' data types
c      * First output argument number (user convenience and less error
c           prone than having to have a bunch of ;;;;'s to force the
c           outputrange to come from the right area
c      * Length of the Fortran array used for each input argument
c Note: Provision is made for "scratch array" arguments, but is a bit
c  crude. However, if extra space is needed, user can specify a larger
c  input area and the larger chunk of scratch space will be present.
c  Unused argument areas will generally be zeroed on each call.
c   It is perfectly reasonable to have input-only functions (e.g. plots)
c   or several subroutines called in sequence for a function.
c
	SUBROUTINE SCIFCT(LINE,RETCD)
	Integer BigSpc
	Parameter (BigSpc=1024)
	Parameter (MaxArgs=10)
	Parameter (NFCT=5)
c NFCT is number of functions included in the list. Update the parameter
c and the tables together (please!)
	InTEgeR*4 RETCD
	LOGICAL*1 LINE(80)
	Real*8 ArgAry(BigSpc)
	INTEGER*4 IARGAR(2,BIGSPC)
	EQUIVALENCE(IARGAR(1,1),ARGARY(1))
	Integer*4 ArgCtr,IntPar
	Integer*4 ArgPtr(MaxArgs)
	Integer*4 NARGin(NFct)
c nargin is number input args needed.
	Integer*4 OutArg(MaxArgs,NFct)
	Integer*4 RevStr(MaxArgs,NFct)
c RevStr will be nonzero to reverse storage of arrays
c from normal row-first to column-first order.
	Integer*4 OutBgn(NFct)
c OutArg is 0 for no output, 1 for output area
	Integer*4 IsReal(MaxArgs,NFCT)
c
C Since there are some subs that need dummy argument scratch
c areas, encode IsReal as follows:
c  0 = Real
c  -1 = Integer
c  +nn = Use argument nn's VALUE (after grabbing it) for
c        size of area to allocate. Always allocate floats
c        since they're longer.
c
c Note: Due to the way the program allocates scratch array, the
c  arguments with size info for dummy arrays must be present
c  ahead of the scratch space arguments.
c
C Argument coordinate lists
	Integer*4 InCord(4,MaxArgs)
	InTEgeR*4 InType(MaxArgs)
	Integer*4 OutCor(4,MaxArgs)
	REAL*8 R8WRK,R8WRK2
	INTEGER*4 I4WRK,I4WRK2
	InTEgeR*4 OutTyp(MaxArgs)
c
	Character*6 WrkFnm
	Logical*1 WFNm(6)
	Equivalence(WFNm(1),WrkFnm)
	Integer*4 IniOut(NFCT)
	Integer*4 AryPtr
	Character*6 FName(NFCT)
	Logical*1 FNameB(6,NFCT)
	Equivalence(Fname(1),FNameB(1,1))
c allows access of function names by byte, but data stmts to set up
c as full names...
c    This example has only 2 functions:
c  *U STDLLSQ   and
c  *U STCHISQ
c        from the Scientific Subroutine Package library...
	Data FnameB/
     1  'D','L','L','S','Q',0,
     2  'C','H','I','S','Q',0,
     3  'V','E','C','N','O','R',
     4  'A','S','Y','M', 0 ,0,
     4  'A','S','U','M', 0 ,0 /
	DATA IsReal/
     1  0,0,-1,-1,-1,0,5,0,-1,0,
     2  0,-1,-1,0,-1,-1,2,3,0,0,
     3  0,-1,0,0,0,0,0,0,0,0,
     4  0,-1,-1,0,0,0,0,0,0,0,
     5  0,-1,-1,0,-1,0,0,0,0,0  /
	DATA OutBgn/
     1  6,4,3,4,4 /
	DATA OutArg/
     1  0,0,0,0,0,1,0,0,1,1,
     2  0,0,0,1,1,1,0,0,0,0,
     3  0,0,1,0,0,0,0,0,0,0,
     4  0,0,0,1,0,0,0,0,0,0,
     5  0,0,0,1,1,0,0,0,0,0 /
c Note OutArg is just which output arguments are really
c output data. 1 means they are, 0 means they're not.
c
C NARGIN is min number input arguments that must be present.
	Data NARGin/10,8,3,4,5/
	Data RevStr/
     1  0,0,0,0,0,0,0,0,0,0,
     2  0,0,0,0,0,0,0,0,0,0,
     3  0,0,0,0,0,0,0,0,0,0,
     4  0,0,0,0,0,0,0,0,0,0,
     5  0,0,0,0,0,0,0,0,0,0 /

C
C FIRST, before we spend a lot of effort grabbing arguments, make
c  sure we know about the function to be called. If we don't, just
c  return an error.
	KK=0
	DO 101 N=1,NFCT
	DO 110 NN=1,6
	IF(FNAMEB(NN,N).LE.0)GOTO 110
	IF(LINE(NN).NE.FNAMEB(NN,N)) GOTO 112
110	CONTINUE
C WE FELL THRU AND FOUND THE NAME. SAVE ITS' INDEX.
	KK=N
112	CONTINUE
101	CONTINUE
	IF(KK.GT.0)GOTO 115
114	RETCD=3
	RETURN
115	CONTINUE
	NFUNCT=KK
c A little setup...
	ArgCtr=1
	IntPar=1
c integer "parity", used to pack integer args in work array
	Aryptr=1
	Do 1 n=1,MaxArgs
	Argptr(n)=1
	Do 11 nn=1,4
	InCord(nn,n)=0
	OutCor(nn,n)=0
11	Continue
1	CONTINUE
	DO 2 N=1,BigSpc
	ArgAry(N)=0.0D0
2	Continue
C arrange for all uninitialized numbers to contain zeroes
	RETCD=1
C HANDLE *U STXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
C STARTS AFTER THE "ST" SO WE CAN DECODE IT.
c if we can't get the function, return RETCD=3...
c
c Now grab the arguments and store them in InCord, Intype, OutCor, OutTyp
	K=INDEX(LINE,32)
C FIND STUFF AFTER SPACE
	K=K+1
	NArg=1
	IBGN=1
100	Continue
	LEND=IBGN+20
C GET LOC OF MATRIX A (MUST BE SQUARE)
	ID1B=0
	ID2B=0
	ID1A=0
	ID2A=0
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 300
	IF(LINE(K+LSTCHR-1).NE.':')GOTO 1000
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 300
1000	CONTINUE
C GMTX GETS ARGS FOR ONE RANGE
	InCord(1,NArg)=ID1A
	InCord(2,NArg)=ID2A
	INCord(3,NARG)=ID1B
	INCORD(4,NARG)=ID2B
	IBGN=LSTCHR+1
	NARG=NARG+1
	IF(LINE(K+LSTCHR-1).EQ.';')GOTO 100
C
300	CONTINUE
C NOW HAVE ALL ARGS FOR INPUT COLLECTED
	INARGS=NARG
	If(INargs.lt.NARGin(NFunct)) GOTO 114
c Flag error if not enough input args presented.
	K=INDEX(LINE,62)
C FIND STUFF AFTER > CHARACTER
	IF(K.EQ.0.OR.K.GT.70)GOTO 500
C MUST HAVE A > OR no outputs are present.
C This is perfectly legal; outputs like graphs or auxiliary
C files (unknown to rest of program) are possible too.
	K=K+1
	NArg=1
	IBGN=1
400	Continue
	LEND=IBGN+20
C GET LOC OF MATRIX A (MUST BE SQUARE)
	ID1B=0
	ID2B=0
	ID1A=0
	ID2A=0
C TEST FOR NULL ARGUMENT (;; PAIR)
	IF(LINE(K+IBGN-1).EQ.';')GOTO 450
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
	IF(IVALID.EQ.0)GOTO 500
	IF(LINE(K+LSTCHR-1).NE.':')GOTO 1500
	IBGN=LSTCHR+1
	LEND=IBGN+20
	CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
	IF(IVALID.EQ.0)GOTO 500
1500	CONTINUE
	IBGN=LSTCHR+1
	GOTO 455
450	CONTINUE
	IBGN=IBGN+1
	LSTCHR=IBGN
C PASS ;
455	CONTINUE
C GMTX GETS ARGS FOR ONE RANGE
	OUTCor(1,NArg)=ID1A
	OUTCor(2,NArg)=ID2A
	OUTCor(3,NARG)=ID1B
	OUTCor(4,NARG)=ID2B
	NARG=NARG+1
	IF(LINE(K+LSTCHR-1).EQ.';')GOTO 400
C	GOTO 500
C
500	CONTINUE
C NOW HAVE OUTPUT ARGUMENT LIST COLLECTED
C BEGIN COLLECTING DATA
	NARG=1
	IntPar=1
2000	CONTINUE
	IACNTR=ARGCTR
C  GET INPUT DATA INTO OUR BIG ARRAY
	IF(INCORD(1,NARG).LE.0)GOTO 3000
	ARGPTR(NARG)=ARGCTR
	IF(INCORD(3,NARG).NE.0)GOTO 2011
C SINGLE ARGUMENT; GRAB IT
	nn=incord(1,narg)
	mm=incord(2,narg)
	call typget(nn,mm,itype)
	If(Itype.ne.4) then
	  CALL XVBLGT(NN,MM,R8WRK)
	Else
	  Call JVBLGT(NN,MM,I4wrk)
	  R8WRK=I4WRK
	End If
c	CALL XVBLGT(INCORD(1,NARG),INCORD(2,NARG),R8WRK)
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  INTPAR=1
	  I4WRK=R8WRK
	  IARGAR(IntPar,ARGCTR)=I4WRK
	ELSE
	  If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
	  IntPar=1
C if we last packed the second word of an integer, bump to next
	  ARGARY(ARGCTR)=R8WRK
	END IF
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
	NARG=NARG+1
	GOTO 2000
2011	CONTINUE
C 2-D AREA
	IntPar=1
	DO 2020 LNN=INCORD(1,NARG),INCORD(3,NARG)
	DO 2020 LMM=INCORD(2,NARG),INCORD(4,NARG)
	NN=LNN
	IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
	MM=LMM
	IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
	call typget(nn,mm,itype)
	If(Itype.ne.4) then
	  CALL XVBLGT(NN,MM,R8WRK)
	Else
	  Call JVBLGT(NN,MM,I4wrk)
	  R8WRK=I4WRK
	End If
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  I4WRK=R8WRK
	  IARGAR(IntPar,ARGCTR)=I4WRK
	  IntPar=3-IntPar
c if IntPar is 1 make it 2; if it's 2, make it 1
	ELSE
	  If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
	  IntPar=1
C if we last packed the second word of an integer, bump to next
	  ARGARY(ARGCTR)=R8WRK
	END IF
	If(IntPar.eq.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
2020	CONTINUE
	NARG=NARG+1
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
	IntPar=1
C
C FIX UP DUMMY ARGUMENTS
C
	IF(ISREAL(NARG,NFUNCT).GT.0.AND.ISREAL(NARG,NFUNCT)
     1  .LE.MAXARGS) THEN
c If user allocated more space than the dummy calc, use bigger
c allocation. However, add a little more and check for array
c overflow.
	  ARGCTR=MAX0(ARGCTR,IACNTR+IARGAR(1,ISREAL(NARG,NFUNCT)))
	  ARGCTR=ARGCTR+30
	  ARGCTR=MIN0(ARGCTR+1,BigSpc)
C ADD A LITTLE FOR GOOD LUCK
	END IF
	GOTO 2000
3000	CONTINUE
C NOW SHOULD BE READY TO CALL THIS STUFF...
C GENERATE CALLS LIKE THE TEMPLATES BELOW. NO NEED TO MODIFY
C THE FUNCTIONS, BUT WE DO NEED TO MESS WITH THIS STUFF BECAUSE
C I DON'T KNOW OFFHAND HOW TO DO A DYNAMIC CALLING LIST IN FORTRAN
C THAT'LL WORK ON STACK IMPLEMENTATIONS.
c
c Add more numbers to the list here to get more function calls.
c
	GOTO (4001,4002,4003,4004,4005),NFUNCT
	RETCD=3
	RETURN
c *************** BEGINNING OF CALLS ****************
4001	CONTINUE
C DLLSQ FUNCTION.... 10 ARGS
	CALL DLLSQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
     2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)),
     3  ARGARY(ARGPTR(9)),ARGARY(ARGPTR(10)))
	GOTO 5000
4002	CONTINUE
C CHISQ FUNCTION.... 8 ARGS
	CALL CHISQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
     2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)))
	GOTO 5000
4003	CONTINUE
C Vector Norm function
	CALL VECNOR(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)))
	GOTO 5000
4004	CONTINUE
C ASYMMETRY
	CALL ASYM(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)))
	GOTO 5000
4005	CONTINUE
C ARRAY SUM
	CALL ASUM(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
     1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)))
	GOTO 5000
C Use this for debugging too...
c
c insert more function calls here... they all look alike except for
c function name.
c
c  It's also completely permissible to call several Fortran subroutines
c  in sequence here if it makes sense; it's up to the user. This code
c  just gives a way to call unmodified Fortran callable code and have
c  it make sense in the AnalytiCalc context. ANY Fortran callable code
c  is OK.
c
c *****************end of calls *****************
c
5000	CONTINUE
C NOW GET ARGUMENTS BACK TO DUMP TO SHEET
	KARG=0
	DO 5100 NARG=OUTBGN(NFUNCT),MAXARGS
	KARG=KARG+1
	IF(OUTARG(NARG,NFUNCT).LE.0)GOTO 5100
	IF(OUTCOR(1,KARG).EQ.0)GOTO 5100
C +++
	ARGCTR=ARGPTR(NARG)
	IF(OUTCOR(3,KARG).NE.0)GOTO 6014
C SINGLE ARGUMENT; GRAB IT
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  I4WRK=IARGAR(1,ARGCTR)
	  R8WRK=I4WRK
	ELSE
	  R8WRK=ARGARY(ARGCTR)
	END IF
	nn=outcor(1,karg)
	mm=outcor(2,karg)
	Call typget(nn,mm,itype)
	If (Itype.ne.4) then
	  CALL XVBLST(NN,MM,R8WRK)
	Else
	  I4WRK=R8WRK
	  CALL JVBLST(nn,mm,I4WRK)
	End If
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
	GOTO 5100
6014	CONTINUE
C 2-D AREA
	DO 6020 LNN=OUTCOR(1,KARG),OUTCOR(3,KARG)
	DO 6020 LMM=OUTCOR(2,KARG),OUTCOR(4,KARG)
	NN=LNN
	IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
	MM=LMM
	IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
	IF(ISREAL(NARG,NFUNCT).LT.0) THEN
	  I4WRK=IARGAR(1,ARGCTR)
	  R8WRK=I4WRK
	ELSE
	  R8WRK=ARGARY(ARGCTR)
	END IF
	Call typget(nn,mm,itype)
	If (Itype.ne.4) then
	  CALL XVBLST(NN,MM,R8WRK)
	Else
	  I4WRK=R8WRK
	  CALL JVBLST(nn,mm,I4WRK)
	End If
c	CALL XVBLST(NN,MM,R8WRK)
	ARGCTR=MIN0(ARGCTR+1,BigSpc)
6020	CONTINUE
C +++
5100	CONTINUE
C AT LAST, DONE
	RETURN
	END
	Subroutine VecNor(InRng,NVEC,Val)
C test subroutine
c Computes norm of input range, where NVEC is number of
c elements in the INRNG array.
	REAL*8 InRng
	Dimension InRng(1)
	Integer*4 NVEC
	Real*8 Val,X
C	VAL=0.0d0
	If(NVEC.LE.0)val=-1.0
	If(NVEC.LE.0)return
c return -1 if bad dimensions.
	X=0.0D0
	Do 1 n=1,nvec
	x=x+InRng(n)*InRng(n)
1	Continue
	x=dsqrt(x)
	Val=X
	Return
	End
c test subroutine
	Subroutine Asym(a,n,m,asymm)
	Real*8 a(n,m),asymm
	Integer*4 l
	asymm=0.0
	L=Min0(n,m)
	Do 1 k1=1,l
	Do 2 k2=1,l
	If(k2.ge.k1)goto 2
	asymm=asymm+a(k1,k2)-a(k2,k1)
2	Continue
1	Continue
	Return
	End
c test subroutine
c sums array values
	Subroutine Asum(a,n,m,asymm,icnt)
	Real*8 a(n,m),asymm
	Integer*4 icnt
	asymm=0.0
	Icnt=0
	Do 1 k1=1,n
	Do 2 k2=1,m
	If(a(k1,k2).ne.0.0)icnt=icnt+1
	asymm=asymm+a(k1,k2)
2	Continue
1	Continue
	Return
	End