home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d1xx / d144 / analyticalc.lha / AnalytiCalc / AnalySources.Arc / Scifct.fam < prev    next >
Text File  |  1988-03-16  |  13KB  |  446 lines
  1. C SCIENTIFIC FUNCTION CALLER
  2. C This version is a dummy placeholder.
  3. C The SCIFCT subroutine exists to allow AnalytiCalc to call just
  4. C about *ANY* Fortran callable routine.
  5. C   The operation is to use a formula in AnalytiCalc which includes
  6. c a call of form:
  7. c  *U STxxxxxx range;range;range;range;range;...;range>outrange;outrange;outrange
  8. c so that the "xxxxxx" part is the function name to be called.
  9. c  input ranges are the parts of the sheet for input to the function; these
  10. c are internally copied to a large array (defined here) which is a normal
  11. c Fortran array. They are converted to integer*4 as needed if the function
  12. c being called needs this. Once all conversion is done, the subroutine is
  13. c called using an argument list built up by this call list. At the end,
  14. c the output ranges are filled in from the internal Fortran array.
  15. c   Because Fortran callable subroutines (e.g. those in the SSP) may pass
  16. c their return arguments in ANY of their arguments, seeing a ; will increment
  17. c the output range counter.
  18. c
  19. c To add more:
  20. c  * Select desired sizes for work area (must be big enough to hold ALL
  21. c  arguments used), max number of arguments per function, etc.
  22. c  * Add new function name and characteristics to tables. Note that the
  23. c  name, integer/float stuff for all args, which arg is first OUTPUT arg,
  24. c  and map of output args, all are needed. Don't make first output arg
  25. c  bigger than the max. number of args.
  26. c  * Add another call and element in the computed GOTO for each function
  27. c  desired.
  28. c  * Build and enjoy.
  29. c
  30. c   Internally we need tables of
  31. c      * Function names (up to 6 characters long per classical Fortran rules)
  32. c      * Number of arguments needed per function
  33. c      * Integer/real flags for arguments' data types
  34. c      * First output argument number (user convenience and less error
  35. c           prone than having to have a bunch of ;;;;'s to force the
  36. c           outputrange to come from the right area
  37. c      * Length of the Fortran array used for each input argument
  38. c Note: Provision is made for "scratch array" arguments, but is a bit
  39. c  crude. However, if extra space is needed, user can specify a larger
  40. c  input area and the larger chunk of scratch space will be present.
  41. c  Unused argument areas will generally be zeroed on each call.
  42. c   It is perfectly reasonable to have input-only functions (e.g. plots)
  43. c   or several subroutines called in sequence for a function.
  44. c
  45.     SUBROUTINE SCIFCT(LINE,RETCD)
  46.     Integer BigSpc
  47.     Parameter (BigSpc=256)
  48.     Parameter (MaxArgs=10)
  49.     Parameter (NFCT=3)
  50. c NFCT is number of functions included in the list. Update the parameter
  51. c and the tables together (please!)
  52.     INTEGER RETCD
  53.     Character*1 LINE(80)
  54.     Real*8 ArgAry(BigSpc)
  55.     INTEGER*4 IARGAR(2,BIGSPC)
  56.     EQUIVALENCE(IARGAR(1,1),ARGARY(1))
  57.     Integer*4 ArgCtr,IntPar
  58.     Integer*4 ArgPtr(MaxArgs)
  59.     Integer*4 NARGin(NFct)
  60. c nargin is number input args needed.
  61.     Integer*4 OutArg(MaxArgs,NFct)
  62.     Integer*4 OutBgn(NFct)
  63. c OutArg is 0 for no output, 1 for output area
  64.     Integer*4 RevStr(MaxArgs,NFct)
  65. c RevStr will be nonzero to reverse storage of arrays
  66. c from normal row-first to column-first order.
  67.     Integer*4 IsReal(MaxArgs,NFCT)
  68. c
  69. C Since there are some subs that need dummy argument scratch
  70. c areas, encode IsReal as follows:
  71. c  0 = Real
  72. c  -1 = Integer
  73. c  +nn = Use argument nn's VALUE (after grabbing it) for
  74. c        size of area to allocate. Always allocate floats
  75. c        since they're longer.
  76. c
  77. c Note: Due to the way the program allocates scratch array, the
  78. c  arguments with size info for dummy arrays must be present
  79. c  ahead of the scratch space arguments.
  80. c
  81. C Argument coordinate lists
  82.     Integer*4 InCord(4,MaxArgs)
  83.     Integer*4 InType(MaxArgs)
  84.     Integer*4 OutCor(4,MaxArgs)
  85.     REAL*8 R8WRK,R8WRK2
  86.     INTEGER*4 I4WRK,I4WRK2
  87.     Integer*4 OutTyp(MaxArgs)
  88. c
  89.     Character*6 WrkFnm
  90.     Character*1 WFNm(6)
  91.     Equivalence(WFNm(1),WrkFnm)
  92.     Integer*4 IniOut(NFCT)
  93.     Integer*4 AryPtr
  94.     Character*6 FName(NFCT)
  95.     Character*1 FNameB(6,NFCT)
  96.     Equivalence(Fname(1),FNameB(1,1))
  97. c allows access of function names by byte, but data stmts to set up
  98. c as full names...
  99. c    This example has only 2 functions:
  100. c  *U STDLLSQ   and
  101. c  *U STCHISQ
  102. c        from the Scientific Subroutine Package library...
  103.     Data FnameB/
  104.      1  'D','L','L','S','Q',0,
  105.      2  'C','H','I','S','Q',0,
  106.      3  'V','E','C','N','O','R' /
  107.     DATA IsReal/
  108.      1  0,0,-1,-1,-1,0,5,0,-1,0,
  109.      2  0,-1,-1,0,-1,-1,2,3,0,0,
  110.      3  0,-1,0,0,0,0,0,0,0,0  /
  111.     DATA OutBgn/
  112.      1  6,4,3 /
  113.     DATA OutArg/
  114.      1  0,0,0,0,0,1,0,0,1,1,
  115.      2  0,0,0,1,1,1,0,0,0,0,
  116.      3  0,0,1,0,0,0,0,0,0,0 /
  117. c Note OutArg is just which output arguments are really
  118. c output data. 1 means they are, 0 means they're not.
  119. c
  120. C NARGIN is min number input arguments that must be present.
  121.     Data NARGin/10,8,3/
  122.     Data RevStr/
  123.      1  0,0,0,0,0,0,0,0,0,0,
  124.      2  0,0,0,0,0,0,0,0,0,0,
  125.      3  0,0,0,0,0,0,0,0,0,0,
  126.      4  0,0,0,0,0,0,0,0,0,0,
  127.      5  0,0,0,0,0,0,0,0,0,0 /
  128. C
  129. C FIRST, before we spend a lot of effort grabbing arguments, make
  130. c  sure we know about the function to be called. If we don't, just
  131. c  return an error.
  132.     KK=0
  133.     DO 101 N=1,NFCT
  134.     DO 110 NN=1,6
  135.     IF(Ichar(FNAMEB(NN,N)).LE.0)GOTO 110
  136.     IF(LINE(NN).NE.FNAMEB(NN,N)) GOTO 112
  137. 110    CONTINUE
  138. C WE FELL THRU AND FOUND THE NAME. SAVE ITS' INDEX.
  139.     KK=N
  140. 112    CONTINUE
  141. 101    CONTINUE
  142.     IF(KK.GT.0)GOTO 115
  143. 114    RETCD=3
  144.     RETURN
  145. 115    CONTINUE
  146.     NFUNCT=KK
  147. c A little setup...
  148.     ArgCtr=1
  149.     IntPar=1
  150. c integer "parity", used to pack integer args in work array
  151.     Aryptr=1
  152.     Do 1 n=1,MaxArgs
  153.     Argptr(n)=1
  154.     Do 11 nn=1,4
  155.     InCord(nn,n)=0
  156.     OutCor(nn,n)=0
  157. 11    Continue
  158. 1    CONTINUE
  159.     DO 2 N=1,BigSpc
  160.     ArgAry(N)=0.0D0
  161. 2    Continue
  162. C arrange for all uninitialized numbers to contain zeroes
  163.     RETCD=1
  164. C HANDLE *U STXXXX FUNCTIONS. LINE ARRAY PASSED IN HERE
  165. C STARTS AFTER THE "ST" SO WE CAN DECODE IT.
  166. c if we can't get the function, return RETCD=3...
  167. c
  168. c Now grab the arguments and store them in InCord, Intype, OutCor, OutTyp
  169.     K=INDEXQ(LINE,32)
  170. C FIND STUFF AFTER SPACE
  171.     K=K+1
  172.     NArg=1
  173.     IBGN=1
  174. 100    Continue
  175.     LEND=IBGN+20
  176. C GET LOC OF MATRIX A (MUST BE SQUARE)
  177.     ID1B=0
  178.     ID2B=0
  179.     ID1A=0
  180.     ID2A=0
  181.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  182.     IF(IVALID.EQ.0)GOTO 300
  183.     IF(LINE(K+LSTCHR-1).NE.':')GOTO 1000
  184.     IBGN=LSTCHR+1
  185.     LEND=IBGN+20
  186.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  187.     IF(IVALID.EQ.0)GOTO 300
  188. 1000    CONTINUE
  189. C GMTX GETS ARGS FOR ONE RANGE
  190.     InCord(1,NArg)=ID1A
  191.     InCord(2,NArg)=ID2A
  192.     INCord(3,NARG)=ID1B
  193.     INCORD(4,NARG)=ID2B
  194.     IBGN=LSTCHR+1
  195.     NARG=NARG+1
  196.     IF(LINE(K+LSTCHR-1).EQ.';')GOTO 100
  197. C
  198. 300    CONTINUE
  199. C NOW HAVE ALL ARGS FOR INPUT COLLECTED
  200.     INARGS=NARG
  201.     If(INargs.lt.NARGin(NFunct)) GOTO 114
  202. c Flag error if not enough input args presented.
  203.     K=INDEXQ(LINE,62)
  204. C FIND STUFF AFTER > CHARACTER
  205.     IF(K.EQ.0.OR.K.GT.70)GOTO 500
  206. C MUST HAVE A > OR no outputs are present.
  207. C This is perfectly legal; outputs like graphs or auxiliary
  208. C files (unknown to rest of program) are possible too.
  209.     K=K+1
  210.     NArg=1
  211.     IBGN=1
  212. 400    Continue
  213.     LEND=IBGN+20
  214. C GET LOC OF MATRIX A (MUST BE SQUARE)
  215.     ID1B=0
  216.     ID2B=0
  217.     ID1A=0
  218.     ID2A=0
  219. C TEST FOR NULL ARGUMENT (;; PAIR)
  220.     IF(LINE(K+IBGN-1).EQ.';')GOTO 450
  221.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1A,ID2A,IVALID)
  222.     IF(IVALID.EQ.0)GOTO 500
  223.     IF(LINE(K+LSTCHR-1).NE.':')GOTO 1500
  224.     IBGN=LSTCHR+1
  225.     LEND=IBGN+20
  226.     CALL VARSCN(LINE(K),IBGN,LEND,LSTCHR,ID1B,ID2B,IVALID)
  227.     IF(IVALID.EQ.0)GOTO 500
  228. 1500    CONTINUE
  229.     IBGN=LSTCHR+1
  230.     GOTO 455
  231. 450    CONTINUE
  232.     IBGN=IBGN+1
  233.     LSTCHR=IBGN
  234. C PASS ;
  235. 455    CONTINUE
  236. C GMTX GETS ARGS FOR ONE RANGE
  237.     OUTCor(1,NArg)=ID1A
  238.     OUTCor(2,NArg)=ID2A
  239.     OUTCor(3,NARG)=ID1B
  240.     OUTCor(4,NARG)=ID2B
  241.     NARG=NARG+1
  242.     IF(LINE(K+LSTCHR-1).EQ.';')GOTO 400
  243. C    GOTO 500
  244. C
  245. 500    CONTINUE
  246. C NOW HAVE OUTPUT ARGUMENT LIST COLLECTED
  247. C BEGIN COLLECTING DATA
  248.     NARG=1
  249.     IntPar=1
  250. 2000    CONTINUE
  251.     IACNTR=ARGCTR
  252. C  GET INPUT DATA INTO OUR BIG ARRAY
  253.     IF(INCORD(1,NARG).LE.0)GOTO 3000
  254.     ARGPTR(NARG)=ARGCTR
  255.     IF(INCORD(3,NARG).NE.0)GOTO 2011
  256. C SINGLE ARGUMENT; GRAB IT
  257.     nn=incord(1,narg)
  258.     mm=incord(2,narg)
  259.     call typget(nn,mm,itype)
  260.     If(Itype.ne.4) then
  261.       CALL XVBLGT(NN,MM,R8WRK)
  262.     Else
  263.       Call JVBLGT(NN,MM,I4wrk)
  264.       R8WRK=I4WRK
  265.     End If
  266. c    CALL XVBLGT(INCORD(1,NARG),INCORD(2,NARG),R8WRK)
  267.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  268.       INTPAR=1
  269.       I4WRK=R8WRK
  270.       IARGAR(IntPar,ARGCTR)=I4WRK
  271.     ELSE
  272.       If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  273.       IntPar=1
  274. C if we last packed the second word of an integer, bump to next
  275.       ARGARY(ARGCTR)=R8WRK
  276.     END IF
  277.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  278.     NARG=NARG+1
  279.     GOTO 2000
  280. 2011    CONTINUE
  281. C 2-D AREA
  282.     IntPar=1
  283.     DO 2020 LNN=INCORD(1,NARG),INCORD(3,NARG)
  284.     DO 2020 LMM=INCORD(2,NARG),INCORD(4,NARG)
  285.     NN=LNN
  286.     IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
  287.     MM=LMM
  288.     IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
  289.     call typget(nn,mm,itype)
  290.     If(Itype.ne.4) then
  291.       CALL XVBLGT(NN,MM,R8WRK)
  292.     Else
  293.       Call JVBLGT(NN,MM,I4wrk)
  294.       R8WRK=I4WRK
  295.     End If
  296.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  297.       I4WRK=R8WRK
  298.       IARGAR(IntPar,ARGCTR)=I4WRK
  299.       IntPar=3-IntPar
  300. c if IntPar is 1 make it 2; if it's 2, make it 1
  301.     ELSE
  302.       If(IntPar.ne.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  303.       IntPar=1
  304. C if we last packed the second word of an integer, bump to next
  305.       ARGARY(ARGCTR)=R8WRK
  306.     END IF
  307.     If(IntPar.eq.1)ARGCTR=MIN0(ARGCTR+1,BigSpc)
  308. 2020    CONTINUE
  309.     NARG=NARG+1
  310.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  311.     IntPar=1
  312. C
  313. C FIX UP DUMMY ARGUMENTS
  314. C
  315.     IF(ISREAL(NARG,NFUNCT).GT.0.AND.ISREAL(NARG,NFUNCT)
  316.      1  .LE.MAXARGS) THEN
  317. c If user allocated more space than the dummy calc, use bigger
  318. c allocation. However, add a little more and check for array
  319. c overflow.
  320.       ARGCTR=MAX0(ARGCTR,IACNTR+IARGAR(1,ISREAL(NARG,NFUNCT)))
  321.       ARGCTR=ARGCTR+30
  322.       ARGCTR=MIN0(ARGCTR+1,BigSpc)
  323. C ADD A LITTLE FOR GOOD LUCK
  324.     END IF
  325.     GOTO 2000
  326. 3000    CONTINUE
  327. C NOW SHOULD BE READY TO CALL THIS STUFF...
  328. C GENERATE CALLS LIKE THE TEMPLATES BELOW. NO NEED TO MODIFY
  329. C THE FUNCTIONS, BUT WE DO NEED TO MESS WITH THIS STUFF BECAUSE
  330. C I DON'T KNOW OFFHAND HOW TO DO A DYNAMIC CALLING LIST IN FORTRAN
  331. C THAT'LL WORK ON STACK IMPLEMENTATIONS.
  332. c
  333. c Add more numbers to the list here to get more function calls.
  334. c
  335.     GOTO (4001,4002,4003),NFUNCT
  336.     RETCD=3
  337.     RETURN
  338. c *************** BEGINNING OF CALLS ****************
  339. 4001    CONTINUE
  340. C DLLSQ FUNCTION.... 10 ARGS
  341.     CALL DLLSQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  342.      1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
  343.      2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)),
  344.      3  ARGARY(ARGPTR(9)),ARGARY(ARGPTR(10)))
  345.     GOTO 5000
  346. 4002    CONTINUE
  347. C CHISQ FUNCTION.... 8 ARGS
  348.     CALL CHISQ(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  349.      1  ARGARY(ARGPTR(3)),ARGARY(ARGPTR(4)),ARGARY(ARGPTR(5)),
  350.      2  ARGARY(ARGPTR(6)),ARGARY(ARGPTR(7)),ARGARY(ARGPTR(8)))
  351.     GOTO 5000
  352. 4003    CONTINUE
  353. C Vector Norm function
  354.     CALL VECNOR(ARGARY(ARGPTR(1)),ARGARY(ARGPTR(2)),
  355.      1  ARGARY(ARGPTR(3)))
  356. C Use this for debugging too...
  357. c
  358. c insert more function calls here... they all look alike except for
  359. c function name.
  360. c
  361. c  It's also completely permissible to call several Fortran subroutines
  362. c  in sequence here if it makes sense; it's up to the user. This code
  363. c  just gives a way to call unmodified Fortran callable code and have
  364. c  it make sense in the AnalytiCalc context. ANY Fortran callable code
  365. c  is OK.
  366. c
  367. c *****************end of calls *****************
  368. c
  369. 5000    CONTINUE
  370. C NOW GET ARGUMENTS BACK TO DUMP TO SHEET
  371.     KARG=0
  372.     DO 5100 NARG=OUTBGN(NFUNCT),MAXARGS
  373.     KARG=KARG+1
  374.     IF(OUTARG(NARG,NFUNCT).LE.0)GOTO 5100
  375.     IF(OUTCOR(1,KARG).EQ.0)GOTO 5100
  376. C +++
  377.     ARGCTR=ARGPTR(NARG)
  378.     IF(OUTCOR(3,KARG).NE.0)GOTO 6014
  379. C SINGLE ARGUMENT; GRAB IT
  380.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  381.       I4WRK=IARGAR(1,ARGCTR)
  382.       R8WRK=I4WRK
  383.     ELSE
  384.       R8WRK=ARGARY(ARGCTR)
  385.     END IF
  386.     nn=outcor(1,karg)
  387.     mm=outcor(2,karg)
  388.     Call typget(nn,mm,itype)
  389.     If (Itype.ne.4) then
  390.       CALL XVBLST(NN,MM,R8WRK)
  391.     Else
  392.       I4WRK=R8WRK
  393.       CALL JVBLST(nn,mm,I4WRK)
  394.     End If
  395.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  396.     GOTO 5100
  397. 6014    CONTINUE
  398. C 2-D AREA
  399.     DO 6020 LNN=OUTCOR(1,KARG),OUTCOR(3,KARG)
  400.     DO 6020 LMM=OUTCOR(2,KARG),OUTCOR(4,KARG)
  401.     NN=LNN
  402.     IF(REVSTR(NARG,NFUNCT).NE.0)NN=LMM
  403.     MM=LMM
  404.     IF(REVSTR(NARG,NFUNCT).NE.0)MM=LNN
  405.     IF(ISREAL(NARG,NFUNCT).LT.0) THEN
  406.       I4WRK=IARGAR(1,ARGCTR)
  407.       R8WRK=I4WRK
  408.     ELSE
  409.       R8WRK=ARGARY(ARGCTR)
  410.     END IF
  411.     Call typget(nn,mm,itype)
  412.     If (Itype.ne.4) then
  413.       CALL XVBLST(NN,MM,R8WRK)
  414.     Else
  415.       I4WRK=R8WRK
  416.       CALL JVBLST(nn,mm,I4WRK)
  417.     End If
  418. c    CALL XVBLST(NN,MM,R8WRK)
  419.     ARGCTR=MIN0(ARGCTR+1,BigSpc)
  420. 6020    CONTINUE
  421. C +++
  422. 5100    CONTINUE
  423. C AT LAST, DONE
  424.     RETURN
  425.     END
  426.     Subroutine VecNor(InRng,NVEC,Val)
  427. C test subroutine
  428. c Computes norm of input range, where NVEC is number of
  429. c elements in the INRNG array.
  430.     REAL*8 InRng
  431.     Dimension InRng(1)
  432.     Integer*4 NVEC
  433.     Real*8 Val,X
  434. C    VAL=0.0d0
  435.     If(NVEC.LE.0)val=-1.0
  436.     If(NVEC.LE.0)return
  437. c return -1 if bad dimensions.
  438.     X=0.0D0
  439.     Do 1 n=1,nvec
  440.     x=x+InRng(n)*InRng(n)
  441. 1    Continue
  442.     x=dsqrt(x)
  443.     Val=X
  444.     Return
  445.     End
  446.