home *** CD-ROM | disk | FTP | other *** search
/ Frozen Fish 1: Amiga / FrozenFish-Apr94.iso / bbs / alib / d4xx / d495 / analyticalc.lha / AnalytiCalc / SrcAndDocs / AnalyUtil.Lzh / DIFRdWrt.For < prev    next >
Encoding:
Text File  |  1987-10-15  |  11.3 KB  |  416 lines
  1. C PROGRAM TO READ/WRITE DIF FILES FROM .PCC FILES
  2.     CHARACTER*1 FORM,FVLD
  3.     INTEGER*4 VNLT
  4.     CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
  5.     CHARACTER*1 DIFHDR(10)
  6.     COMMON/NMSH/NMSH
  7.     INTEGER*4 IOLVL
  8.     DIMENSION FORM(128),FVLD(1,1)
  9.     CHARACTER*1 FVWRK,FVWRK2
  10. C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
  11. C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
  12. C SO INITIALLY IGNORE.
  13. C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
  14. C
  15. C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
  16. C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
  17.     CHARACTER*1 LETA
  18.     CHARACTER*127 CFORM,CFORM2
  19.     EQUIVALENCE(CFORM,FORM(1))
  20.     EQUIVALENCE(CFORM2,FORM2(1))
  21.     INTEGER*4 nrows,ncols
  22.     character*9 DFMT
  23. C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
  24. C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
  25. C
  26. C PUT NUMBERS OUT TO FILE
  27. C USES RELATIVE FORMS TO CURRENT POS.
  28. C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
  29. C ONLY WRITES PHYSICALLY PRESENT DATA.
  30. C P/D RRR,CCC,FORMULA,VALID,FORMAT
  31. C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
  32.     IOLVL=9
  33. C    OPEN(UNIT=5,FILE='CON:',STATUS='OLD')
  34. C    OPEN(UNIT=6,FILE='CON:',STATUS='NEW')
  35.     WRITE(*,101)
  36. 101    FORMAT('$Read DIF file to PCC or Write DIF file from'
  37.      1  ,' PCC [R/W]:')
  38.     READ(*,7953)FORM2
  39.     INDIF=1
  40.     IF(FORM2(1).EQ.'R'.or.form2(1).eq.'r')INDIF=0
  41.     WRITE(*,102)
  42. 102    FORMAT('$ Enter DIF filename>')
  43.     III=IOLVL
  44.     READ(*,7953,END=510,ERR=510)FORM2
  45. 7953    FORMAT(128A1)
  46.     DO 6940 II=1,128
  47.     ILN=129-II
  48.     IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
  49.     FORM2(ILN)=CHAR(0)
  50. 6940    CONTINUE
  51. 6941    CONTINUE
  52. C ILN IS LENGTH OFLINE NOW.
  53.     ILN=MIN0(ILN,127)
  54.     FORM2(ILN+1)=CHAR(0)
  55.     IF(INDIF.EQ.0)CALL RASSIG(3,FORM2)
  56.     IF(INDIF.NE.0)CALL WASSIG(4,FORM2)
  57. C LUN 3 IS INPUT, LUN 4 IS OUTPUT
  58. C NOW GET PCC FILENAME
  59.     WRITE(*,103)
  60. 103    FORMAT('$ Enter PCC filename>')
  61.     READ(*,7953,END=510,ERR=510)FORM2
  62.     DO 6340 II=1,128
  63.     ILN=129-II
  64.     IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6341
  65.     FORM2(ILN)=CHAR(0)
  66. 6340    CONTINUE
  67. 6341    CONTINUE
  68. C ILN IS LENGTH OFLINE NOW.
  69.     ILN=MIN0(ILN,127)
  70.     FORM2(ILN+1)=CHAR(0)
  71.     IF(INDIF.ne.0)CALL RASSIG(3,FORM2)
  72.     IF(INDIF.eq.0)CALL WASSIG(4,FORM2)
  73. c Now both files are opened and all set, and INDIF flag tells
  74. c whether the DIF file is the input or the output (0=input)
  75. c
  76. c Now since DIF files don't have a valid format, if we're reading
  77. c DIF and writing PCC files, ask for a display format.
  78.     IF (Indif.ne.0)goto 105
  79.     Write(*,106)
  80. 106    Format('$ Enter display format, no ().>')
  81.     Read(*,107)DFMT
  82. c may need to change format...
  83. 107    Format(A9)
  84.     GOTO 1000
  85. 105    Continue
  86.     WRITE(*,900)
  87. 900    FORMAT('$ Emit Values or Formulas [V/F]:')
  88.     Read(*,7953)let2
  89. C UPCASE V REPLY SINCE WE TEST EITHER 'V' OR NOT 'V' ONLY.
  90.     IF(LET2.EQ.'v')LET2='V'
  91. c LET2 tells us whether to emit Values or "Labels" in the DIF
  92. c file...
  93. C AT 1000 HANDLE READING DIF FILES TO PCC FILES
  94. C NEXT HANDLE READING PCC FILES TO DIF FILES.
  95. C
  96. C  PCC IN, DIF OUT
  97. C
  98. C FIRST PASS: READ IN PCC FILE TO SEE HOW MANY ROWS AND COLS
  99. C ARE THERE SINCE THAT'S NEEDED FOR DIF.
  100.     NCOLS=0
  101.     NROWS=0
  102.     READ(3,6951,END=9990,ERR=9990)NMSH,FORM
  103. 6951    FORMAT(100A1,100A1,100A1)
  104. 1107    CONTINUE
  105. C7955    FORMAT('P',I5,',',I5,',',128A1)
  106. C READ THE DATA AND KEEP MAXIMA FOR ROW, COL UNTIL EOF
  107. C    READ (3,108,END=109,ERR=109)LETR,ICOL,IROW,FORM
  108.     READ (3,108,END=109)LETR,ICOL,IROW,FORM
  109.     NCOL=ICOL
  110.     NROW=IROW
  111. 108    FORMAT(1A1,I5,1X,I5,1X,128A1)
  112. 7956    FORMAT(I3,1X,9A1,1X,I5)
  113. C    READ(3,7956,END=109,ERR=109)IVLD,(FORM2(IV),IV=120,
  114. C     1  128),ITYPE
  115.     READ(3,7956,END=109)IVLD,(FORM2(IV),IV=120,
  116.      1  128),ITYPE
  117.     IF(LETR.EQ.'M')GOTO 109
  118. C DON'T BOTHER WITH MAPPING RECORDS WHICH ARE AT END...
  119.     IF(LETR.NE.'P')GOTO 1107
  120.     IF(NCOL.GT.NCOLS)NCOLS=NCOL
  121.     IF(NROW.GT.NROWS)NROWS=NROW
  122.     GOTO 1107
  123. 109    CONTINUE
  124. C NOW HAVE DIMENSIONS...
  125.     REWIND 3
  126.     WRITE(6,5000)NCOLS,NROWS
  127. 5000    FORMAT(' NUMBER OF COLS FOUND=',I6,';NUMBER OF ROWS='
  128.      1  ,I6)
  129.     IF(NCOLS.LE.0.OR.NCOLS.GT.999)STOP 'COLS ERR'
  130.     IF(NROWS.LE.0.OR.NROWS.GT.999)STOP 'ROWS ERR'
  131.     READ(3,6951,END=9990,ERR=9990)NMSH,FORM
  132. C NOW EMIT TABLE RECORD USING TITLE OF SHEET AS STRING
  133.     WRITE(4,110)
  134. 110    FORMAT('TABLE',/,'0,1')
  135.     WRITE(4,111)(NMSH(IV),IV=1,75)
  136. 111    FORMAT('"',75A1,'"')
  137. C VECTORS IS DIF SLANG FOR COLUMNS. EMIT NUMBER OF VECTORS.
  138.     WRITE(4,112)NCOLS
  139. 112    FORMAT('VECTORS',/,'0,',I3,/,'""')
  140. C NEXT WRITE TUPLES RECORD WHICH IS BASICALLY NUMBER OF ROWS
  141.     WRITE(4,113)NROWS
  142. 113    FORMAT('TUPLES',/,'0,',I3,/,'""')
  143.     WRITE(4,114)
  144. 114    FORMAT('DATA',/,'0,0',/,'""')
  145. C WE ASKED EARLIER FOR LET2 TO BE V FOR VALUES OR F FOR FORMULAS
  146. C TO TELL WHICH TO EMIT.
  147. C NOW GO THROUGH AND HANDLE THE STUFF...
  148.     ICOLI=0
  149.     IROWI=1
  150.     ICOLS=NCOLS
  151.     IROWX=1
  152.     ICOLX=1
  153.     IROWS=NROWS
  154.     WRITE(4,121)
  155. 121    FORMAT('-1,0',/,'BOT')
  156. 118    CONTINUE
  157.     READ (3,108,END=119,ERR=119)LETR,ICOL,IROW,FORM
  158.     NCOL=ICOL
  159.     NROW=IROW
  160.     READ(3,7956,END=119,ERR=119)IVLD,(FORM2(IV),IV=120,
  161.      1  128),ITYPE
  162. C ONLY ACCEPT P OR p TYPE RECORDS (ONLY ONE, DEPENDING ON LET1)
  163.     IF(LETR.NE.'P'.AND.LET2.NE.'V')GOTO 118
  164.     IF(LETR.NE.'p'.AND.LET2.EQ.'V')GOTO 118
  165. C HERE WE KNOW WE'RE LEGAL
  166. C SINCE THE NEW VERSIONS OF ANALYTICALC GENERATE DATA ACROSS COLUMNS
  167. C FIRST (I.E., ALONG TUPLES), JUST KEEP TRACK OF LAST ONE
  168. C READ AND FILL IN NULLS IF WE MUST.
  169. C    ICOLX=ICOLX+1
  170. C    IF(ICOLX.LE.ICOLS)GOTO 120
  171. C    ICOLX=1
  172. C    IROWX=IROWX+1
  173. C120    CONTINUE
  174. C ICOLX AND IROWX ARE NEXT COL AND ROW EXPECTED IF WE READ A TOTALLY
  175. C FILLED TABLE AREA'S SAVED FILE.
  176. 122    CONTINUE
  177.     IF(ICOL.LE.ICOLX.AND.IROW.LE.IROWX)GOTO 123
  178. C NEED TO FILL IN EMPTIES...
  179.     WRITE(4,125)
  180. 125    FORMAT('0,0',/,'NA')
  181.     ICOLX=ICOLX+1
  182.     IF(ICOLX.LE.ICOLS)GOTO 124
  183.     ICOLX=1
  184.     IROWX=IROWX+1
  185. C WRITE ANOTHER BOT RECORD AS NEEDED HERE (IN CASE WHOLE ROW IS
  186. C EMPTY)
  187. C ONLY EMIT RECORD IF WE DIDN'T JUST FINISH THE LAST ROW.
  188.     IF(IROWX.LE.IROWS)WRITE(4,121)
  189. 124    CONTINUE
  190.     GOTO 122
  191. 123    CONTINUE
  192. C OK, NOW HAVE THIS FILLED IN...
  193.     IF(LET2.NE.'V')GOTO 128
  194. C MUST ENSURE THAT THE EXPONENT IS NN.NNNEXX RATHER THAN NN.NNNNDXX
  195. C I.E., D EXPONENTS AREN'T UNDERSTOOD. THEREFORE WRITE OUT E INSTEAD
  196. C OF D.
  197.     DO 200 IV=1,50
  198.     IF(FORM(IV).EQ.'D')FORM(IV)='E'
  199. 200    CONTINUE
  200. 128    CONTINUE
  201.     IF(LET2.EQ.'V')WRITE(4,126)(FORM(IV),IV=1,50)
  202. 126    FORMAT('0,',50A1,/,'V')
  203.     IF(LET2.NE.'V')WRITE(4,127)(FORM(IV),IV=1,109)
  204. 127    FORMAT('1,0',/,109A1)
  205. C GO BACK AND READ SOME MORE NOW
  206.     ICOLI=ICOL
  207.     IROWI=IROW
  208.     ICOLI=ICOLI+1
  209.     IF(ICOLI.LE.ICOLS)GOTO 2120
  210.     ICOLI=1
  211.     IROWI=IROWI+1
  212.     WRITE(4,121)
  213. 2120    CONTINUE
  214.     ICOLX=ICOLI
  215.     IROWX=IROWI
  216.     GOTO 118
  217. C
  218. 119    CONTINUE
  219. C ALL DONE, SO MARK END DATA AND GO HOME.
  220. C MUST BE SURE WE FILL OUT THE LAST TUPLE SO WRITE 'NA' RECORDS
  221. C IF IT'S NEEDED.
  222.     IF(IROWX.GT.IROWS.OR.ICOLX.GT.ICOLS)GOTO 9191
  223.     DO 9192 N=ICOLX,ICOLS
  224.     WRITE(4,125)
  225. C WRITE 'NA' RECORDS IN LOOP
  226. 9192    CONTINUE
  227. 9191    CONTINUE
  228.     WRITE(4,129)
  229. 129    FORMAT('-1,0'/,'EOD')
  230.     CLOSE(UNIT=4)
  231.     CLOSE(UNIT=3)
  232.     GOTO 9990
  233. 1000    CONTINUE
  234. C
  235. C DIF IN, PCC OUT
  236. C
  237. C ASSUME DIF FILE STARTS WITH TABLE, VECTORS, TUPLES RECORDS
  238.     READ(3,1001)DIFHDR
  239. 1001    FORMAT(10A1)
  240.     READ(3,1002)N1,N2
  241. 1002    FORMAT(I1,1X,I5)
  242.     READ(3,7953)FORM2
  243. C FORM2 GETS STRING OUT OF DIF RECORD
  244. C GET RID OF " CHARACTERS IN TITLE
  245. 3211    CONTINUE
  246.     N1=INDX(CFORM2,'"')
  247.     IF(N1.LE.0.OR.N1.GT.127)GOTO 3212
  248. C REPLACE " CHARACTERS WITH SPACES.
  249.     FORM2(N1)=' '
  250.     GOTO 3211
  251. 3212    CONTINUE
  252.     IF(DIFHDR(1).EQ.'T'.AND.DIFHDR(2).EQ.'A'.AND.DIFHDR(3)
  253.      1  .EQ.'B')WRITE(4,1003)(FORM2(IV),IV=2,81)
  254. C 2,81 LIMITS TO SKIP WRITING INITIAL " CHARACTER TO PCC FILE.
  255. C (OR SPACE IT GOT CHANGED TO)
  256. 1003    FORMAT(80A1)
  257.     IF(DIFHDR(1).EQ.'T'.AND.DIFHDR(2).EQ.'U'.AND.
  258.      1  DIFHDR(3).EQ.'P')NROWS=N2
  259.     IF(DIFHDR(1).EQ.'V'.AND.DIFHDR(2).EQ.'E'.AND.
  260.      1  DIFHDR(3).EQ.'C')NCOLS=N2
  261.     IF(DIFHDR(1).NE.'D'.OR.DIFHDR(2).NE.'A')GOTO 1000
  262. C FALL THROUGH AFTER READING DATA RECORD
  263. C HOPEFULLY WE NOW HAVE NUMBER OF ROWS AND COLUMNS EXPECTED
  264. C ALL STORED IN NROWS AND NCOLS.
  265.     IROW=0
  266.     ICOL=0
  267. 1010    CONTINUE
  268.     READ(3,7953,END=9900)FORM
  269.     N1=0
  270.     IX=INDX(CFORM,',')-1
  271.     IF(IX.LE.0)GOTO 8092
  272.     READ(CFORM,8090)N1
  273. 8090    FORMAT(I3)
  274.     DO 8091 N=1,123
  275. 8091    FORM(N)=FORM(N+IX+1)
  276. 8092    CONTINUE
  277. C READ NUMBER VALUE IN A STRING SO WE CAN DECODE IT AS
  278. C NEEDED.
  279.     READ(3,7961,END=9900)FORM2
  280. 7961    FORMAT(100A1,100A1)
  281. C READ A RECORD
  282. C N1 = -1 FLAGS SPECIAL RECORDS
  283.     IF(N1.GE.0)GOTO 1020
  284.     IF(FORM2(1).EQ.'B'.AND.FORM2(2).EQ.'O'
  285.      1  .AND.FORM2(3).EQ.'T')GOTO 1019
  286.     IF(FORM2(1).EQ.'E'.AND.FORM2(2).EQ.'O')GOTO 9900
  287.     GOTO 1010
  288. 1019    CONTINUE
  289. C AT START OF TUPLE RESET COL TO 1 AND ROW BUMPS...
  290.     IROW=IROW+1
  291.     ICOL=0
  292.     GOTO 1010
  293. C SKIP OVER NONDATA RECORDS
  294. 1020    CONTINUE
  295. C NOW HAVE TO EMIT A DATA RECORD.
  296.     IVLD=-1
  297.     IF(N1.EQ.0)IVLD=1
  298.     ICOL=ICOL+1
  299.     IF(IVLD.EQ.1.AND.FORM2(1).EQ.'N'.AND.FORM2(2).EQ.
  300.      1  'A') GOTO 1010
  301. C SKIP 'NA' INVALID NUMBERS AND DON'T BOTHER WRITING THEM.
  302.     IF(IVLD.EQ.1)WRITE(4,1030)ICOL,IROW,(FORM(IV),IV=1,110)
  303.     IF(IVLD.LT.1)WRITE(4,1030)ICOL,IROW,(FORM2(IV),IV=1,110)
  304. 1030    FORMAT('P',I5,',',I5,',',128A1)
  305.     ITYPE=2
  306. C FIGURE OUT TYPE BASED ON PRESENCE OR ABSENCE OF DOT.
  307.     IF(IVLD.GT.1.AND.INDX(CFORM,'.').EQ.0)ITYPE=4
  308.     WRITE(4,1031)IVLD,DFMT,ITYPE
  309. 1031    FORMAT(I3,',',A9,',',I5)
  310.     GOTO 1010
  311. 9900    CONTINUE
  312.     CLOSE(UNIT=4)
  313.     CLOSE(UNIT=3)
  314. 510    CONTINUE
  315. 9990    stop
  316.     END
  317.       INTEGER FUNCTION INDX ( STR, C )
  318. C
  319.       CHARACTER * 1 C, STR ( 1 )
  320. C
  321. C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
  322. C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
  323. C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
  324.     I3B=0
  325.       DO 20019  I = 1, 256
  326.       IF (STR(I).NE.0) GOTO 20021
  327. C RETURN INDX AS EITHER THE LOCATION OF THE CHARACTER OR 0
  328.       INDX=0
  329.       RETURN
  330. 20021 CONTINUE
  331.     IF(ICHAR(STR(I)).EQ.255)I3B=3
  332.     IF(I3B.LE.0)GOTO 2000
  333. C SKIP ENCODED VARIABLES
  334.     I3B=I3B-1
  335.     GOTO 20019
  336. 2000    CONTINUE
  337.       IF (.NOT.( STR ( I ) .EQ. C )) GOTO 20023
  338.     ix=i
  339.     if(i.gt.250)ix=0
  340.       INDX = ( IX )
  341.       RETURN
  342. 20023 CONTINUE
  343. 20022 CONTINUE
  344. C
  345. 20019 CONTINUE
  346. 20020 CONTINUE
  347.       END
  348.     SUBROUTINE RASSIG(IUNIT,NAME)
  349. C
  350. C
  351.     CHARACTER*1 NAME(50)
  352.     INTEGER*4 IUNIT
  353. C &&&& MS FTN 3.2
  354.     LOGICAL LEXIST
  355. C &&&&
  356.     CHARACTER*20 WK
  357.     CHARACTER*1 WK1(20)
  358.     EQUIVALENCE(WK,WK1(1))
  359. C JUST TRY AND NULL FILL A NAME TO USE.
  360.     DO 1 N=1,20
  361.     WK1(N)=' '
  362. 1    CONTINUE
  363.     DO 2 N=1,20
  364.     II=ICHAR(NAME(N))
  365.     IF(II.LT.32)GOTO 3
  366.     WK1(N)=CHAR(II)
  367. C1    CONTINUE
  368. 2    CONTINUE
  369. 3    CONTINUE
  370. C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
  371. C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
  372. C AVOID CRASHES IF THE FILE ISN'T THERE...
  373. C MSDOS FORTRAN 3.2 AND LATER FEATURE...
  374. C &&&&
  375. C
  376. C    INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
  377. C
  378.     INQUIRE(FILE=WK,EXIST=LEXIST)
  379.     IF(LEXIST)GOTO 100
  380. C FILE DOES NOT EXIST, SO CREATE IT HERE.
  381. C IF CREATE FAILS WE LOSE TOO...
  382.     write(6,7766)
  383. 7766    format(' No such file...')
  384. 100    CONTINUE
  385. C &&&&
  386. C IF JUST CALL ASSIGN, ASSUME FOR READ.
  387.     OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
  388.      1  FORM='FORMATTED')
  389. 77    CONTINUE
  390. C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
  391. C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
  392.     RETURN
  393.     END
  394.     SUBROUTINE WASSIG(IUNIT,NAME)
  395. C
  396. C
  397.     CHARACTER*1 NAME(50)
  398.     INTEGER*4 IUNIT
  399.     CHARACTER*20 WK
  400.     CHARACTER*1 WK1(20)
  401.     EQUIVALENCE(WK,WK1(1))
  402. C JUST TRY AND NULL FILL A NAME TO USE.
  403.     DO 1 N=1,20
  404.     WK1(N)=' '
  405. 1    CONTINUE
  406.     DO 2 N=1,20
  407.     II=ICHAR(NAME(N))
  408.     IF(II.LT.32)GOTO 3
  409.     WK1(N)=CHAR(II)
  410. C1    CONTINUE
  411. 2    CONTINUE
  412. 3    OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
  413.      1  FORM='FORMATTED')
  414.     RETURN
  415.     END
  416.