home *** CD-ROM | disk | FTP | other *** search
/ Play and Learn 2 / 19941.ZIP / 19941 / EDUCMATH / STATS / FORTRANS.BAS (.txt) < prev    next >
Encoding:
GW-BASIC  |  1994-02-04  |  2.8 KB  |  51 lines
  1. 1  '                        FORTRAN DATA TRANSFER
  2. 2  '                   Copyright Tracy L. Gustafson, M.D.
  3. 3  '                  Round Rock, Texas. Version 3.2, 1985
  4. 4  ON ERROR GOTO 5000:CHAIN MERGE "EPIMRG",5
  5. 15  DIM D(1,1),CS(1,1),T(1),N$(1),X(1),X2(1),MD(1),SD(1)
  6. 22  DATA "FORTRAN DATA TRANSFER",29,23
  7. 30  PRINT:PRINT "Do you want to:    1.)  Create a new EPISTAT datafile.":PRINT
  8. 35  PRINT TAB(20);"2.)  Add a sample to an existing EPISTAT datafile."
  9. 40  BF=0:LOCATE 11,27:PRINT "Enter choice:":AR=11:AC=41:GOSUB 4800:ASUB=VAL(IP$):IF ABS(ASUB-1.5)>0.5 THEN BEEP:GOTO 40
  10. 45  CLS:PRINT TAB(29);DTTL:PRINT TAB(29);STRING$(21,205):PRINT
  11. 50  IF BF=0 THEN INPUT " Enter the name of the FORTRAN file you want to extract data from: ",FILEF$
  12. 55  FILE$=FILEF$:EF=1:ON ERROR GOTO 5020:OPEN FILE$ FOR INPUT AS #2
  13. 60  PRINT:AR=CSRLIN:PRINT TAB(10);"Enter the total length of each record or card image:"
  14. 65  PRINT TAB(11);"(Do not include the carriage return or line feed.)"
  15. 70  AC=64:GOSUB 4800:CJ=VAL(IP$)
  16. 75  PRINT:PRINT TAB(10);:INPUT "Enter the name of the variable you want to retrieve:  ",DN
  17. 80  LOCATE 9,14:PRINT "Enter the column number in which ";DN;" begins:":AR=9:AC=64:GOSUB 4800:C1=VAL(IP$)
  18. 85  PRINT TAB(14);"Enter the number of columns (digits) in ";DN;":":AR=10:GOSUB 4800:CW=VAL(IP$)
  19. 90  PRINT TAB(14);"Enter the number of (understood) decimal places:":AR=11:GOSUB 4800:CE=VAL(IP$)
  20. 95  PRINT TAB(33);:INPUT "Enter the missing value code:  ",DM
  21. 100  IF ASUB=1 THEN ERASE D,CS:DIM D(1,2000),CS(1,2000):A=1:GOTO 130
  22. 105  IF BF=0 THEN PRINT:INPUT "  What is the name of the EPISTAT datafile you want to ADD to?  ",FILE1$
  23. 110  FILE$=FILE1$:EF=2:OPEN FILE$ FOR INPUT AS #1:INPUT #1,A,C
  24. 115  ERASE D,CS,T,N$,X,X2,MD,SD:AA=A+1
  25. 120  DIM D(AA,C),CS(AA,C),T(AA),N$(AA),X(AA),X2(AA),MD(AA),SD(AA)
  26. 125  GOSUB 4040:A=AA
  27. 130  PRINT:PRINT:AR=CSRLIN:COLOR 23:PRINT TAB(32);"TRANSFERRING DATA":COLOR CLR1
  28. 135  CC=0:T(A)=0:X(A)=0:X2(A)=0:MD(A)=0:SD(A)=0:N$(A)=DN
  29. 140  CC=CC+1:LINE INPUT #2,DI:IF LEN(DI)<>CJ THEN CC=CC-1:GOTO 175 ELSE DJ=MID$(DI,C1,CW):IF DJ=DM THEN D(A,CC)="":GOTO 175
  30. 145  DK=MID$(DJ,1,CW-CE):IF CE>0 THEN DK=DK+"."+MID$(DJ,CW-CE+1,CE)
  31. 150  D(A,CC)=DK:VC=VAL(DK):T(A)=T(A)+1:X(A)=X(A)+VC:X2(A)=X2(A)+VC*VC
  32. 155  FOR Z=1 TO T(A)-1:VX=VAL(D(A,CS(A,Z))):IF VX<=VC THEN 165
  33. 160  FOR TZ=T(A) TO Z+1 STEP -1:CS(A,TZ)=CS(A,TZ-1):NEXT:GOTO 170
  34. 165  NEXT Z
  35. 170  CS(A,Z)=CC
  36. 175  IF NOT EOF(2) THEN 140 ELSE CLOSE #2
  37. 180  N=T(A):IF N>1 THEN IF X2(A)>X(A)*X(A)/N THEN SD(A)=SQR((X2(A)-X(A)*X(A)/N)/(N-1))
  38. 185  IF N>0 THEN IF N MOD 2=0 THEN MD(A)=(VAL(D(A,CS(A,N/2)))+VAL(D(A,CS(A,N/2+1))))*0.5 ELSE MD(A)=VAL(D(A,CS(A,N/2+0.5)))
  39. 190  IF CC>C THEN C=CC
  40. 195  IF ASUB=2 THEN LOCATE AR,32:PRINT TAB(55):FILE$=FILE1$:GOSUB 4110:GOTO 205
  41. 200  PRINT TAB(7);"(If you choose ";FILEF$;" you will write over your FORTRAN file.)":GOSUB 4100
  42. 205  FILE1$=FILE$:LOCATE 25,5:PRINT "Do you want to transfer another sample from ";FILEF$;" to ";FILE1$;:INPUT;A$
  43. 210  IF A$="y" OR A$="Y" THEN ASUB=2:BF=1:FILE$=FILEF$:GOTO 45 ELSE IF A$<>"N" AND A$<>"n" THEN BEEP:GOTO 205
  44. 215  GOTO 3000
  45. 4025  ERASE D,CS,T,N$,X,X2,MD,SD
  46. 4030  DIM D(A,C),CS(A,C),T(A),N$(A),X(A),X2(A),MD(A),SD(A)
  47. 5000  BEEP:IF ERR<>53 AND ERR<>71 THEN 5010 ELSE LOCATE 2,10:PRINT "Please place EPISTAT in drive A: (or other default).":PRINT TAB(25);"Press any key to continue:"
  48. 5005  A$=INKEY$:IF A$="" THEN 5005 ELSE RESUME
  49. 5010  ON ERROR GOTO 0:END
  50. 5032  IF EF=1 THEN RESUME 50 ELSE IF EF=2 THEN RESUME 105 ELSE 5010
  51.