home *** CD-ROM | disk | FTP | other *** search
/ WinWares 1 / WINWARES.ISO / calc / tablecrv / fortran.tcl < prev    next >
Encoding:
Text File  |  1993-06-01  |  16.2 KB  |  563 lines
  1. ~~FORTRAN~~
  2. *----------------------------------------------------------*
  3. *          TableCurve FORTRAN Library Module
  4. *----------------------------------------------------------*
  5. * Although the full calling routine for the TableCode
  6. * subroutine is specific to the Lahey F77L Compilers, the
  7. * code has been written for portability using standard
  8. * FORTRAN 77. Only the system interrupt function INTRUP and
  9. * the system registers intreg(9) [INTEGER*2 AX,BX,CX,DX,DS,
  10. * ES,DI,SI,flags] are likely to be compiler-dependent.
  11. *----------------------------------------------------------*
  12. * Certain code lines use Lahey routines OVEFL, UNDFL, DVCHK,
  13. * and INVALOP to mask exceptions from arithmetic overflow,
  14. * underflow, divide-by-zero, and invalid operations. These
  15. * lines are commented out but can be activated if such
  16. * masking is desired on a Lahey compiler.
  17. *----------------------------------------------------------*
  18.  
  19. *----------------------------------------------------------*
  20.       PROGRAM main
  21. *----------------------------------------------------------*
  22.       INTEGER *2 irow,j,dataok
  23.       INTEGER *2 attr0,attr1,attr2,lenstr,idir
  24.       LOGICAL iscolor
  25.       DOUBLE PRECISION x(17),y(17)
  26.       CHARACTER tempstr*60,t2*80
  27.  
  28. ***** ----------- Lahey Exception Routines ----------- *****
  29. ***** LOGICAL*1 lflag(4)
  30. ***** CALL ovefl(lflag(1))
  31. ***** CALL dvchk(lflag(2))
  32. ***** CALL undfl(lflag(3))
  33. ***** CALL invalop(lflag(4))
  34. ***** ------------------------------------------------ *****
  35.  
  36. ***** Get DOS Attr, Assign 2 Window Attr, Clear Screen 
  37.       CALL getattr(attr0)
  38.       CALL getcolor(iscolor)
  39.       IF (iscolor) THEN
  40.         attr1= 1 + 7*16
  41.         attr2= 15+ 1*16
  42.       ELSE
  43.         attr1=15+ 0*16
  44.         attr2=0 + 7*16
  45.       ENDIF     
  46.       CALL cls(attr1)
  47.  
  48. ***** Main Screen Window Uses 1st Attr, Double Border 
  49.       CALL strclr(t2)
  50.       t2='TableCurve `FILE` `DATE` `TIME`'
  51.       CALL str0(t2,lenstr)
  52.       CALL window(0,1,24,78,attr1,2,t2)
  53.       CALL strclr(t2)
  54.  
  55. ***** X-Y Data Window Uses 2nd Attribute, Single Border 
  56.       CALL strclr(tempstr) 
  57.       tempstr=' `TITLE` '
  58.       CALL str0(tempstr,lenstr)
  59.       CALL window(4,32,23,76,attr2,1,tempstr)
  60.       CALL strclr(tempstr)
  61.       tempstr='`XTITLE`'
  62.       CALL strwrtmp(tempstr,attr2,5,34)
  63.       tempstr='`YTITLE`'
  64.       CALL strwrtmp(tempstr,attr2,5,56)
  65.  
  66. ***** Equation Data Summary 
  67.       tempstr='`EQSTR`'
  68.       CALL strwrtmp(tempstr,attr1,2,3)
  69.       tempstr='Eqn# `EQNO`'
  70.       CALL strwrtmp(tempstr,attr1,3,5)
  71.       tempstr='r2=`R2VAL`'
  72.       CALL strwrtmp(tempstr,attr1,4,5)
  73.       tempstr='a= `ASTR`'
  74.       CALL strwrtmp(tempstr,attr1,5,5)
  75.       tempstr='b= `BSTR`'
  76.       CALL strwrtmp(tempstr,attr1,6,5)
  77.       tempstr='c= `CSTR`'
  78.       CALL strwrtmp(tempstr,attr1,7,5)
  79.       tempstr='d= `DSTR`'
  80.       CALL strwrtmp(tempstr,attr1,8,5)
  81.       tempstr='e= `ESTR`'
  82.       CALL strwrtmp(tempstr,attr1,9,5)
  83.       tempstr='f= `FSTR`'
  84.       CALL strwrtmp(tempstr,attr1,10,5)
  85.       tempstr='g= `GSTR`'
  86.       CALL strwrtmp(tempstr,attr1,11,5)
  87.       tempstr='h= `HSTR`'
  88.       CALL strwrtmp(tempstr,attr1,12,5)
  89.       tempstr='i= `ISTR`'
  90.       CALL strwrtmp(tempstr,attr1,13,5)
  91.       tempstr='j= `JSTR`'
  92.       CALL strwrtmp(tempstr,attr1,14,5)
  93.       tempstr='k= `KSTR`'
  94.       CALL strwrtmp(tempstr,attr1,15,5)
  95.  
  96. ***** Data Entry Setup 
  97.       tempstr='X= `XTITLE`'
  98.       CALL strwrtmp(tempstr,attr1,17,3)
  99.       tempstr='Y= `YTITLE`'
  100.       CALL strwrtmp(tempstr,attr1,18,3) 
  101.       tempstr='Enter Value [x=,y=]'
  102.       CALL strwrtmp(tempstr,attr1,20,3)
  103.       tempstr='Press Esc to End Program'
  104.       CALL strwrtmp(tempstr,attr1,23,3)
  105.  
  106. ***** Data Entry Loop Rows 5-21 
  107.       irow=6 
  108.       idir=0
  109.   10  j=irow-5
  110.       dataok=1
  111.       IF (idir.EQ.1) THEN 
  112.         idir=0 
  113.       ELSE 
  114.         idir=1
  115.       ENDIF  
  116. ***** Data Entry Routine for X-Value 
  117.       CALL numfld(tempstr,21,3,25,attr2,dataok)
  118. ***** dataok=0 on ESCAPE -- This is only exit from loop 
  119.       IF (dataok.EQ.0) THEN
  120.         CALL cls(attr0)
  121.         GO TO 40
  122.       ENDIF
  123.       IF (dataok.GT.0) THEN 
  124.         READ(tempstr,20) x(j)
  125.   20    FORMAT(F25.0)    
  126.         CALL strclr(tempstr)
  127.         CALL `FNAME`(x(j),y(j))
  128.       ELSE
  129.         READ(tempstr,20) y(j)
  130.         CALL strclr(tempstr)
  131.         CALL rtbis(y(j),idir,x(j))
  132.       ENDIF
  133.  
  134. ***** ------ Check Exceptions Code ------------------- *****
  135. ***** CALL ovefl(lflag(1))
  136. ***** CALL dvchk(lflag(2))
  137. ***** CALL undfl(lflag(3))
  138. ***** CALL invalop(lflag(4))
  139. ***** IF (lflag(1).OR.lflag(2).OR.lflag(3).OR.lflag(4)) THEN
  140. *****   lflag(1)=.FALSE.
  141. *****    lflag(2)=.FALSE.
  142. *****   lflag(3)=.FALSE.
  143. *****   lflag(4)=.FALSE.
  144. *****   CALL clsblk(irow,34,irow,52,attr2)
  145. *****   GO TO 10
  146. *****  ENDIF
  147. ***** ------------------------------------------------ *****
  148.  
  149.       IF(irow.EQ.22) THEN
  150.         CALL clsblk(22,33,22,75,attr2)
  151.       ENDIF
  152. ***** Convert x,y to Formatted Strings For Output to Table *****
  153.       WRITE(tempstr,30) x(j)
  154.   30  FORMAT(G18.12)          
  155.       CALL strwrtmp(tempstr,attr2,irow,34)
  156.       WRITE(tempstr,30) y(j)
  157.       CALL strwrtmp(tempstr,attr2,irow,56)
  158.       irow=irow+1
  159.       IF (irow.GT.22) THEN 
  160.         irow=22
  161.       ENDIF  
  162.       GO TO 10
  163.  
  164. ***** End of Data Entry Loop *******************************
  165.   40  CALL cls(attr0)
  166.       END
  167.  
  168. *----------------------------------------------------------*
  169.       SUBROUTINE cursor(row,col)
  170. ***** Sets Cursor Position (0,0=Origin) 
  171. ***** AH=2,BH=0 DH,DL=row,col INT 10H 
  172. *----------------------------------------------------------*
  173.       INTEGER*2 row,col
  174.       INTEGER*2 intreg(9)
  175.       intreg(1)=2*256
  176.       intreg(2)=0
  177.       intreg(4)=row*256+col      
  178.       CALL INTRUP(intreg,16)
  179.       RETURN
  180.       END
  181.  
  182. *----------------------------------------------------------*
  183.       SUBROUTINE getattr(attr)
  184. ***** Retrieves Current Screen Attribute 
  185. ***** AH=8,BH=0,INT 10H  AH contains attribute 
  186. *----------------------------------------------------------*
  187.       INTEGER*2 attr
  188.       INTEGER*2 intreg(9)
  189.       intreg(1)=8*256
  190.       intreg(2)=0
  191.       CALL INTRUP(intreg,16)
  192.       attr=intreg(1)/256
  193.       RETURN
  194.       END
  195.  
  196. *----------------------------------------------------------*
  197.       SUBROUTINE getcolor(type)
  198. ***** Returns .TRUE. for color mode, .FALSE. for monochrome
  199. ***** AH=15 INT 10H  AL contains video mode
  200. *----------------------------------------------------------*
  201.       LOGICAL type
  202.       INTEGER*2 mode
  203.       INTEGER*2 intreg(9)
  204.       intreg(1)=15*256
  205.       CALL INTRUP(intreg,16)
  206.       mode=I2MOD(intreg(1),256)
  207.       type=.TRUE.
  208.       IF (mode.EQ.0 .OR. mode.EQ.2 .OR. mode.EQ.7) type=.FALSE.
  209.       RETURN
  210.       END
  211.  
  212. *----------------------------------------------------------*
  213.       SUBROUTINE cls(attr)
  214. ***** Clears Screen w/Attribute, Sets Cursor To Origin 
  215. ***** AH=6,BH=attribute CH,CL,DH,DL=coord(0,0,24,79) INT 10H
  216. *----------------------------------------------------------*
  217.       INTEGER*2 attr
  218.       INTEGER*2 intreg(9)
  219.       intreg(1)=6*256
  220.       intreg(2)=attr*256
  221.       intreg(3)=0
  222.       intreg(4)=24*256+79      
  223.       CALL INTRUP(intreg,16)
  224.       CALL cursor(0,0)
  225.       RETURN
  226.       END
  227.  
  228. *----------------------------------------------------------*
  229.       SUBROUTINE clsblk(top,left,btm,right,attr)
  230. ***** Clears Part of Screen w/Attribute, Cursor Inside 
  231. ***** AH=6,BH=attribute CH,CL,DH,DL=coord(t,l,b,r) INT 10H 
  232. *----------------------------------------------------------*
  233.       INTEGER*2 top,left,btm,right,attr
  234.       INTEGER*2 intreg(9)
  235.       intreg(1)=6*256
  236.       intreg(2)=attr*256
  237.       intreg(3)=top*256+left
  238.       intreg(4)=btm*256+right      
  239.       CALL INTRUP(intreg,16)
  240.       CALL cursor(top+1,left+1)
  241.       RETURN
  242.       END
  243.  
  244. *----------------------------------------------------------*
  245.       SUBROUTINE pca(c,attr,row,col)
  246. ***** Write Character w/Attribute at Row,Col
  247. ***** AH=9,AL=char BH=0 BL=attr CX=1 INT 10H
  248. *----------------------------------------------------------*
  249.       INTEGER*2 c,attr,row,col
  250.       INTEGER*2 intreg(9)
  251.       CALL cursor(row,col)
  252.       intreg(1)=9*256+c
  253.       intreg(2)=attr
  254.       intreg(3)=1
  255.       CALL INTRUP(intreg,16)
  256.       RETURN
  257.       END
  258.  
  259. *----------------------------------------------------------*
  260.       SUBROUTINE psa(str,attr,row,col)
  261. ***** Write String w/Attribute at Row,Col
  262. *----------------------------------------------------------*
  263.       CHARACTER str*80
  264.       INTEGER*2 attr,row,col
  265.       INTEGER*2 i,ci
  266.       INTEGER cint
  267.       DO 10 i=1,80
  268.       CALL cursor(row,col)
  269.       cint=ICHAR(str(i:i))
  270.       IF (cint.EQ.0) GO TO 20
  271.       ci=cint
  272.       CALL pca(ci,attr,row,col)
  273.       col=col+1
  274.   10  CONTINUE
  275.   20  RETURN
  276.       END
  277.  
  278. *----------------------------------------------------------*
  279.       SUBROUTINE str0(str,lenstr)
  280. ***** Null Terminate String, Return Length in len
  281. *----------------------------------------------------------*
  282.       CHARACTER str*(*)
  283.       INTEGER*2 lenstr
  284.       INTEGER i,ilen,j
  285.       ilen=LEN(str)
  286.       DO 10 i=ilen,1,-1
  287.       j=ICHAR(str(i:i))
  288.       IF (j .NE. 32 .AND. j .NE. 0) GO TO 20
  289.   10  CONTINUE
  290.   20  str(i+1:i+1)=CHAR(0)
  291.       lenstr=i
  292.       RETURN
  293.       END
  294.  
  295. *----------------------------------------------------------*
  296.       SUBROUTINE strclr(str)
  297. ***** Clear String to Blanks 
  298. *----------------------------------------------------------*
  299.       CHARACTER str*(*)
  300.       INTEGER i,ilen
  301.       ilen=LEN(str)
  302.       DO 10 i=1,ilen
  303.         str(i:i)=CHAR(32)
  304.   10  CONTINUE
  305.       RETURN
  306.       END
  307.  
  308. *----------------------------------------------------------*
  309.       SUBROUTINE strwrtmp(str,attr,row,col)
  310. ***** Prepare string, write @row,col, clear to blanks
  311. *----------------------------------------------------------*
  312.       CHARACTER str*(*)
  313.       INTEGER*2 lenstr
  314.       CALL str0(str,lenstr)
  315.       CALL psa(str,attr,row,col)
  316.       CALL strclr(str)
  317.       RETURN  
  318.       END
  319.  
  320. *----------------------------------------------------------*
  321.       SUBROUTINE getch(c)
  322. ***** DOS Get Character AX=700H, INT 21H, Char in AL 
  323. ***** Returns Character as INTEGER*2 [Fn Keys are +256] 
  324. *----------------------------------------------------------*
  325.       INTEGER*2 c
  326.       INTEGER*2 intreg(9)
  327.       intreg(1)=1792
  328.       CALL INTRUP(intreg,33)
  329.       c=I2MOD(intreg(1),256)
  330.       IF(c.EQ.0) THEN
  331.         intreg(1)=1792
  332.         CALL INTRUP(intreg,33)
  333.         c=256+I2MOD(intreg(1),256)
  334.       ENDIF
  335.       RETURN
  336.       END
  337.  
  338. *----------------------------------------------------------*
  339.       SUBROUTINE window(trow,lcol,brow,rcol,attr,border,title)
  340. ***** Simple Window, Border, Title 
  341. *----------------------------------------------------------*
  342.       INTEGER*2 trow,lcol,brow,rcol,attr,border
  343.       INTEGER*2 tl,tr,bl,br,lr,tb
  344.       INTEGER*2 i,lentitle
  345.       CHARACTER title*(*)
  346.  
  347.       CALL clsblk(trow,lcol,brow,rcol,attr)
  348.       IF(border.EQ.1) THEN
  349.         tl=218
  350.         tr=191
  351.         bl=192
  352.         br=217
  353.         lr=196
  354.         tb=179
  355.       ELSE
  356.         tl=201
  357.         tr=187
  358.         bl=200
  359.         br=188
  360.         lr=205
  361.         tb=186
  362.       ENDIF
  363.       CALL pca(tl,attr,trow,lcol)
  364.       CALL pca(bl,attr,brow,lcol)
  365.       CALL pca(tr,attr,trow,rcol)
  366.       CALL pca(br,attr,brow,rcol)
  367.       DO 10 i=lcol+1,rcol-1
  368.         CALL pca(lr,attr,trow,i) 
  369.         CALL pca(lr,attr,brow,i)
  370.   10  CONTINUE      
  371.       DO 20 i=trow+1,brow-1
  372.         CALL pca(tb,attr,i,lcol) 
  373.         CALL pca(tb,attr,i,rcol)
  374.   20  CONTINUE      
  375.       CALL str0(title,lentitle)
  376.       CALL psa(title,attr,trow,(rcol+lcol)/2-lentitle/2)   
  377.       RETURN
  378.       END
  379.       
  380. *----------------------------------------------------------*
  381.       SUBROUTINE numfld(fld,row,col,maxlen,attr,status)
  382. ***** Simple Numeric Field Input 
  383. ***** status is set to 0 on ESCAPE 
  384. *----------------------------------------------------------*
  385.       CHARACTER fld*(*)
  386.       INTEGER*2 row,col,maxlen,attr,status
  387.       INTEGER*2 i,j,c,yflag,expflag,pass
  388.       INTEGER ch
  389.  
  390.       CALL strclr(fld)
  391.       DO 10 j=0,maxlen-1
  392.         CALL pca(32,attr,row,col+j)
  393.   10  CONTINUE     
  394.       CALL cursor(row,col)
  395.       i=0
  396.       j=0
  397.       expflag=0
  398.       yflag=0
  399.   20  CALL getch(c)  
  400.       pass=0
  401.       IF(i.EQ.0 .AND. (c.EQ.89 .OR. c.EQ.121)) THEN
  402.         yflag=1
  403.         pass=1
  404.       ELSE IF(i.EQ.0 .AND. (c.EQ.88 .OR. c.EQ.120)) THEN 
  405.         pass=1
  406.       ELSE IF(i.EQ.1 .AND. c.EQ.61) THEN
  407.         pass=1 
  408.       ENDIF
  409.       IF((c.GE.48 .AND. c.LE.57) .OR. c.EQ.45 .OR. c.EQ.43 
  410.      1 .OR. c.EQ.46 .OR. ((c.EQ.69 .OR. c.EQ.101).AND.expflag.EQ.0)
  411.      2 .OR. pass.EQ.1) THEN
  412.         ch=c
  413.         CALL pca(c,attr,row,col+i)
  414.         CALL cursor(row,col+i+1)
  415.         i=i+1
  416.         IF (pass.EQ.0) THEN 
  417.           fld(j+1:j+1)=CHAR(ch)
  418.           j=j+1
  419.         ENDIF   
  420.         IF(c.EQ.69 .OR. c.EQ.101) THEN 
  421.           expflag=1
  422.         ENDIF  
  423.       ELSE IF((c.EQ.10 .OR. c.EQ.13 .OR. i.EQ.maxlen)
  424.      1 .AND. i.NE.0) THEN
  425.         GO TO 30
  426.       ELSE IF(c.EQ.8 .AND. i.GT.0) THEN
  427.         i=i-1
  428.         CALL pca(32,attr,row,col+i)
  429.         IF (i.EQ.0) THEN 
  430.           yflag=0
  431.         ENDIF  
  432.         IF (j.NE.0) THEN
  433.           j=j-1
  434.           fld(j+1:j+1)=CHAR(0)  
  435.         ENDIF  
  436.       ELSE IF(c.EQ.27) THEN
  437.         i=0
  438.         GO TO 30  
  439.       ENDIF
  440.       IF(i.LT.maxlen) GO TO 20
  441.   30  fld(j+1:j+1)=CHAR(0)
  442.       IF (yflag.EQ.1) THEN
  443.         status=-j
  444.       ELSE
  445.         status=j
  446.       ENDIF    
  447.   40  RETURN
  448.       END
  449.  
  450. *----------------------------------------------------------*
  451.       SUBROUTINE rtbis(y,dir,x)
  452. ***** root bisection routine
  453. ***** dir%=0 starts at lowest partition, =1 at highest
  454. ***** last chance is partition from XatYmin to XatYmax
  455. ***** returns 0 upon failure to find root
  456. *----------------------------------------------------------*
  457.       INTEGER*2 dir,i,j
  458.       DOUBLE PRECISION y,x,x1,x2,y2,xinc,dx,f,fmid,xmid,rtb,xacc
  459.       xacc=1E-6*`XMEAN`
  460.       xinc=`XRANGE`/4.0
  461.       DO 10 i=0,4
  462.       IF (i.EQ.4) THEN 
  463.         x1=`XATYMIN`
  464.         x2=`XATYMAX`
  465.       ELSE IF (dir.EQ.1) THEN 
  466.         x2=`XMAXIMUM`-xinc*i
  467.         x1=`XMAXIMUM`-xinc*(i+1)
  468.       ELSE 
  469.         x1=`XMINIMUM`+xinc*i
  470.         x2=`XMINIMUM`+xinc*(i+1)
  471.       ENDIF
  472.       CALL `FNAME`(x1,y2)
  473.       f=y-y2
  474.       CALL `FNAME`(x2,y2)
  475.       fmid=y-y2
  476.       IF ((f*fmid).LT.0) THEN
  477.         IF (f.LT.0.0) THEN 
  478.           dx=x2-x1
  479.           rtb=x1
  480.         ELSE 
  481.           dx=x1-x2
  482.           rtb=x2
  483.         END IF
  484.         DO 20 j=1,100
  485.           dx=dx*0.5
  486.           xmid=rtb+dx
  487.           CALL `FNAME`(xmid,y2)
  488.           fmid=y-y2
  489.           IF (fmid.LE.0) THEN 
  490.             rtb=xmid
  491.           ENDIF  
  492.           IF (DABS(dx).LT.xacc .OR. fmid.EQ.0) THEN 
  493.             x=rtb
  494.             GO TO 30
  495.           ENDIF
  496.   20    CONTINUE
  497.       END IF
  498.   10  CONTINUE
  499.       x=0.0
  500.   30  RETURN
  501.       END
  502.  
  503. !!FORTRAN!!
  504. *----------------------------------------------------------*`ERF`
  505.       REAL FUNCTION ERF(x)`ERF`
  506. *----------------------------------------------------------*`ERF`
  507.       DOUBLE PRECISION x`ERF`
  508.       REAL t,z,ans`ERF`        
  509.       z=DABS(x)`ERF`
  510.       t=1.0/(1.0+0.5*z)`ERF`
  511.       ans=(t*EXP(-z*z-1.26551223+t*(1.00002368+t*(0.37409196+`ERF`
  512.      1t*(0.09678418+t*(-0.18628806+t*(0.27886807+t*(-1.13520398+`ERF`
  513.      1t*(1.48851587+t*(-0.82215223+t*0.17087277))))))))))`ERF`
  514.       IF (x.GE.0.0) THEN`ERF` 
  515.         ERF=1.0-ans`ERF`
  516.       ELSE `ERF`
  517.         ERF=-1.0+ans`ERF`
  518.       END IF`ERF`
  519.       RETURN`ERF`
  520.       END`ERF`
  521.  
  522. *----------------------------------------------------------*
  523.       SUBROUTINE `FNAME`(x,y)
  524. *----------------------------------------------------------*
  525. ***** TableCurve `FILE` `DATE` `TIME`
  526. ***** `TITLE`
  527. ***** X= `XTITLE`
  528. ***** Y= `YTITLE`
  529. ***** Eqn# `EQNO`  `EQSTR`
  530. ***** r2=`R2VAL`
  531. ***** r2adj=`R2ADJ`
  532. ***** StdErr=`STDERR`
  533. ***** Fval=`FVAL`
  534. ***** a= `ASTR`
  535. ***** b= `BSTR`
  536. ***** c= `CSTR`
  537. ***** d= `DSTR`
  538. ***** e= `ESTR`
  539. ***** f= `FSTR`
  540. ***** g= `GSTR`
  541. ***** h= `HSTR`
  542. ***** i= `ISTR`
  543. ***** j= `JSTR`
  544. ***** k= `KSTR`
  545. *----------------------------------------------------------*
  546.       DOUBLE PRECISION x,y
  547.       DOUBLE PRECISION `FLIST`
  548.       DOUBLE PRECISION n`FDECLN`
  549.       x=`FX`
  550.       n=`FBAL2`
  551.       n=`FAUX`
  552.       x1=`F1`
  553.       x2=`F2`
  554.       x3=`F3`
  555.       x4=`F4`
  556.       y=`EQNCODE`
  557.       y=`FY`
  558.       RETURN
  559.       END
  560. !!FORTRAN!!
  561. ~~FORTRAN~~
  562.  
  563.