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