C PROGRAM TO READ/WRITE DIF FILES FROM .PCC FILES
c
c Compilation:
c FORTRAN/NOCHECK/NODEBUG DIFRW
c Link:
c LINK/NOMAP DIFRW
c
c Reads DIF files into AnalytiCalc save format files
c or reads AnalytiCalc save files into DIF files.
c  Note that the version of AnalytiCalc must be the
c  new one that saves across rows rather than down
c  columns for the latter ability to work.
c
c
c ADD SPECIAL "D" OPTION TO WRITE random access database files
C for databases that can use them. Write files as sequential
C fixed length record files, no keys used in access, but able
C to be sorted etc. because key fields will be there.
C
C D AND P OPTIONS write out database files and ask for an
c auxiliary key which can then be used in DTR retrievals
c for file access where multiple sheet files are stored
c in the same DTR domain.
c
C Also includes options to extract PCC files from the
c database files as desired, with potential reorganization
c according to user wishes.
C
c	Copyright (c) Glenn C. Everhart 1985
c	Noncommercial use permitted, but for-profit
c	distribution prohibited.
c
	CHARACTER*1 FORM,FVLD
	INTEGER*4 VNLT
	CHARACTER*1 LET1,LET2,FORM2(128),NMSH(80)
	CHARACTER*1 DIFHDR(10)
	COMMON/NMSH/NMSH
	INTEGER*2 IOLVL
	DIMENSION FORM(128),FVLD(1,1)
	CHARACTER*1 FVWRK,FVWRK2
C FVLD FLAG 0 = NO FORMULA, -1= DISPLAY FORMULA ITSELF, NOT VALUE
C 1=VALID ACTIVE FORMULA THERE TO EVALUATE. INITIALLY ALL 0'S
C SO INITIALLY IGNORE.
C FVLD=2 = CONST NUMERIC ONLY, COMPUTED. =3, CONST, NEEDS CALC.
C
C ROUTINE IN2AS COMPUTES ASCII CHARACTER NAMES OF SUBSCRIPTS IN1,IN2
C SO DISPLAY CAN HAVE THEM. IT MUST BE THE INVERSE OF VARSCN.
	CHARACTER*1 LETA
	CHARACTER*127 CFORM,CFORM2
	EQUIVALENCE(CFORM,FORM(1))
	EQUIVALENCE(CFORM2,FORM2(1))
	CHARACTER*1 LFN(80)
	CHARACTER*80 CLFN
	EQUIVALENCE(LFN(1),CLFN)
	INTEGER*4 IDREC,ICW,IRW
	CHARACTER*1 RBF(143)
	integer*2 nrows,ncols
	character*9 DFMT
	character*8 auxkey,AK2
	integer*4 idbase
C ENCODE ICREF, IRREF AND CWIDS PAST TITLE IN FIRST LINE
C (THAT WAY, NOTHING BREAKS IN OTHER PGMS THAT USE THIS)
C
C PUT NUMBERS OUT TO FILE
C USES RELATIVE FORMS TO CURRENT POS.
C PD = PUT OURT DISPLAY SHEET. PP = PUT OUT PHYSICAL SHEET.
C ONLY WRITES PHYSICALLY PRESENT DATA.
C P/D RRR,CCC,FORMULA,VALID,FORMAT
C N IN 3RD CHR (PPN/PDN) SAVES NUMBERS, ELSE FORMULAS.
	IOLVL=5
	OPEN(UNIT=5,FILE='CON:',STATUS='OLD')
	OPEN(UNIT=6,FILE='CON:',STATUS='NEW')
	WRITE(6,101)
101	FORMAT(' Read DIF file to PCC or Write DIF file from'
     1  ,' PCC or Read DIF to DB',
     2  /,'$or Read PCC to DB or extract PCC '
     3  'from DB [R/W/D/P/X]:')
	READ(5,7953)FORM2
	MODIF=ICHAR(FORM2(2))
	INDIF=1
	IF(FORM2(1).EQ.'R'.OR.FORM2(1).EQ.'r')INDIF=0
	IF(FORM2(1).EQ.'X'.OR.FORM2(1).EQ.'x')GOTO 7000
	INDB=0
	IF(FORM2(1).EQ.'D'.OR.FORM2(1).EQ.'d')INDB=1
	IF(FORM2(1).EQ.'P'.OR.FORM2(1).EQ.'p')INDB=2
C IF READING PCC FILE TO DTR TYPE FILE JUST FAKE THAT WE'RE
C READING PCC FILES. IF READING DIF FILE TO DTR FILE SAY
C WE'RE READING DIF FILES.
	IF(INDB.EQ.1)INDIF=0
	IF(INDB.EQ.2)INDIF=1
	IF(INDB.EQ.0)GOTO 165
C GET HOLD OF AUXILIARY KEY (FOR USE WHEN CROSS REFERENCING
C MULTIPLE DATABASE FILES) AND OF ID BASE IF NOT 0
	WRITE(6,173)
173	FORMAT(' Customization Section - allows you to diff'
     1  'erentiate this DB section from others',/,
     2  ' within the file:')
	Write(6,166)
166	FORMAT('$ Enter auxiliary key, up to 8 chars>')
	Read(5,167)auxkey
167	format(a8)
	Write(6,168)
168	Format('$Enter desired cell ID base or 0>')
	Read(5,169)idbase
169	format(i8)
	if(iabs(idbase).gt.65536)goto 165
	IF(IDBASE.EQ.0)GOTO 165
	write(6,170)
170	format(' Warning - ID base may conflict with cell IDs')
	Write(6,171)
171	format('$Are you sure you want to use it? [Y/N]:')
	Read(5,172)leta
172	format(1a1)
	if(leta.ne.'y'.and.leta.ne.'Y')stop 'OK. Rerun.'
165	CONTINUE
C DON'T BOTHER WITH DIF FILE UNLESS NEEDED.
	IF(INDB.EQ.2)GOTO 155
	WRITE(6,102)
102	FORMAT('$ Enter DIF filename>')
	III=IOLVL
	READ(III,7953,END=510,ERR=510)FORM2
7953	FORMAT(128A1)
	DO 6940 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6941
	FORM2(ILN)=CHAR(0)
6940	CONTINUE
6941	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=CHAR(0)
	IF(INDIF.EQ.0)CALL RASSIG(3,FORM2)
	IF(INDIF.NE.0)CALL WASSIG(4,FORM2)
	GOTO 157
155	CONTINUE
C LEAVE DUMMY DIF OUTPUT OPEN SO WRITES DON'T ALL HAVE TO
C BE TESTED...
	OPEN(UNIT=4,FILE='NUL',STATUS='NEW')
157	CONTINUE
C LUN 3 IS INPUT, LUN 4 IS OUTPUT
C NOW GET PCC FILENAME
	IF(INDB.EQ.0.OR.INDB.EQ.2)WRITE(6,103)
	IF(INDB.EQ.1)WRITE(6,140)
103	FORMAT('$ Enter PCC filename>')
140	FORMAT('$ Enter Database Data File name>')
	READ(IOLVL,7953)FORM2
	DO 6340 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 6341
	FORM2(ILN)=CHAR(0)
6340	CONTINUE
6341	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=CHAR(0)
	IF(INDIF.ne.0)CALL RASSIG(3,FORM2)
	IF(INDB.EQ.0.AND.INDIF.eq.0)CALL WASSIG(4,FORM2)
C IF WE'RE READING PCC FILES, PCC FILE ALREADY OPEN
C BUT IF WRITING DB FILES FROM DIF FILES, NEED TO DUMMY
C THE PCC FILE OPEN HERE. DO SO.
	IF(INDB.EQ.1)OPEN(UNIT=4,FILE='NUL',STATUS='NEW')
C IF INDB USED, FORGET OUTPUT TO .PCC FILE.
C FIRST GET THE FILENAME IF INDB=2
	IF(INDB.NE.2)GOTO 156
	WRITE(6,140)
C GET THE FILENAME HERE AND MAKE SURE IT'S NULL TERMINATED
C (DON'T USE Q FORMAT TO MAKE THIS PROGRAM EASIER TO MOVE
C TO COMPILERS THAT DON'T HAVE IT.)
	READ(IOLVL,7953,END=510,ERR=510)FORM2
C JUST ZOT OUT TRAILING WHITESPACE BY NULLING BEYOND IT.
	DO 5340 II=1,128
	ILN=129-II
C STOP ON FIRST CHARACTER THAT CAN'T BE WHITESPACE.
C NOTE THAT THIS GIVES UNIFORM RESULTS EVEN IN WEIRD
C OTSs THAT PASS THE C.R. OR EVEN THE CRLF.
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 5341
	FORM2(ILN)=CHAR(0)
5340	CONTINUE
5341	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=CHAR(0)
156	CONTINUE
c
c provide option to open file in 'OLD' status (i.e.
c  allow adding to existing ones) if desired.
	IF(INDB.EQ.0)GOTO 3214
	WRITE(6,141)
141	FORMAT('$ Enter N for New file, O for Old file>')
	Read(5,7953)leta
	DO 3216 IV=1,80
	II=ICHAR(FORM2(IV))
	IF(II.LT.32)II=32
	LFN(IV)=CHAR(II)
3216	CONTINUE
3217	CONTINUE
	if(leta.NE.'n'.and.leta.ne.'N')goto 3215
c he says it's new file; open it that way (i.e., create a
c new version if one already exists.)
	OPEN(UNIT=7,FILE=CLFN,STATUS='NEW',
     1  ACCESS='SEQUENTIAL',
     2  FORM='FORMATTED')
	goto 3214
3215	continue
C USE STATUS OLD
C NONE EXISTS.
C ALLOW, ON CV (WHERE C IS X OR D OR P) COMMANDS, TO BUILD A
C VARIABLE RECORD SIZED RECORD.
	OPEN(UNIT=7,FILE=CLFN,STATUS='OLD',
     1  ACCESS='SEQUENTIAL',
     2  FORM='FORMATTED')
C GET PAST ALL DATA IN FILE TO EOF, EHEN WRITE...
	DO 3314 N=1,9999
	READ(7,3315,END=3316,ERR=3316)RBF
3315	FORMAT(100A1,43A1)
3314	CONTINUE
3316	CONTINUE
	BACKSPACE 7
C BACKSPACE OVER EOF SO WE CAN CONTINUE.
3214	CONTINUE
C WRITE ROW#,COL#,FVLD,TYPE,FORMAT,FORMULA,IJUNK
c Now both files are opened and all set, and INDIF flag tells
c whether the DIF file is the input or the output (0=input)
c
c Now since DIF files don't have a valid format, if we're reading
c DIF and writing PCC files, ask for a display format.
	IF (Indif.ne.0)goto 105
	Write(6,106)
106	Format('$ Enter display format, no ().>')
	Read(5,107)DFMT
c may need to change format...
107	Format(A9)
	GOTO 1000
105	Continue
	WRITE(6,900)
900	FORMAT('$ Emit Values or Formulas [V/F]:')
	Read(5,7953)let2
	IF(LET2.EQ.'v')LET2='V'
c LET2 tells us whether to emit Values or "Labels" in the DIF
c file...
C AT 1000 HANDLE READING DIF FILES TO PCC FILES
C NEXT HANDLE READING PCC FILES TO DIF FILES.
C
C  PCC IN, DIF OUT
C
C FIRST PASS: READ IN PCC FILE TO SEE HOW MANY ROWS AND COLS
C ARE THERE SINCE THAT'S NEEDED FOR DIF.
	NCOLS=0
	NROWS=0
	READ(3,6951,END=9990,ERR=9990)NMSH,FORM
6951	FORMAT(100A1,100A1,100A1)
1107	CONTINUE
C7955	FORMAT('P',I5,',',I5,',',128A1)
C READ THE DATA AND KEEP MAXIMA FOR ROW, COL UNTIL EOF
	READ (3,108,END=109,ERR=109)LETR,ICOL,IROW,FORM
	NCOL=ICOL
	NROW=IROW
108	FORMAT(1A1,I5,1X,I5,1X,128A1)
C7956	FORMAT(I3,',',9A1,',',I5)
7956	FORMAT(I3,1X,9A1,1X,I5)
C NOTE SOME FORTRANS NEED TO USE 1X IN READ FORMAT, NOT
C JUST USE SAME AS WRITE FORMAT HERE.
	READ(3,7956,END=109,ERR=109)IVLD,(FORM2(IV),IV=120,
     1  128),ITYPE
	IF(LETR.EQ.'M')GOTO 109
C DON'T BOTHER WITH MAPPING RECORDS WHICH ARE AT END...
	IF(LETR.NE.'P')GOTO 1107
	IF(NCOL.GT.NCOLS)NCOLS=NCOL
	IF(NROW.GT.NROWS)NROWS=NROW
	GOTO 1107
109	CONTINUE
C NOW HAVE DIMENSIONS...
	REWIND 3
	WRITE(6,5000)NCOLS,NROWS
5000	FORMAT(' NUMBER OF COLS FOUND=',I6,';NUMBER OF ROWS='
     1  ,I6)
	IF(NCOLS.LE.0.OR.NCOLS.GT.999)STOP 'COLS ERR'
	IF(NROWS.LE.0.OR.NROWS.GT.999)STOP 'ROWS ERR'
C PASS THROUGH THE FILE ONCE TO BE SURE ROWS AND COLUMNS
C WILL FIT...
	READ(3,6951,END=9990,ERR=9990)NMSH,FORM
C NOW EMIT TABLE RECORD USING TITLE OF SHEET AS STRING
	WRITE(4,110)
110	FORMAT('TABLE',/,'0,1')
	WRITE(4,111)(NMSH(IV),IV=1,75)
111	FORMAT('"',75A1,'"')
C VECTORS IS DIF SLANG FOR COLUMNS. EMIT NUMBER OF VECTORS.
	WRITE(4,112)NCOLS
112	FORMAT('VECTORS',/,'0,',I3,/,'""')
C NEXT WRITE TUPLES RECORD WHICH IS BASICALLY NUMBER OF ROWS
	WRITE(4,113)NROWS
113	FORMAT('TUPLES',/,'0,',I3,/,'""')
	WRITE(4,114)
114	FORMAT('DATA',/,'0,0',/,'""')
C WE ASKED EARLIER FOR LET2 TO BE V FOR VALUES OR F FOR FORMULAS
C TO TELL WHICH TO EMIT.
C NOW GO THROUGH AND HANDLE THE STUFF...
	ICOLI=0
	IROWI=1
	ICOLS=NCOLS
	IROWX=1
	ICOLX=1
	IROWS=NROWS
	WRITE(4,121)
121	FORMAT('-1,0',/,'BOT')
118	CONTINUE
	READ (3,108,END=119,ERR=119)LETR,ICOL,IROW,FORM
	NCOL=ICOL
	NROW=IROW
	READ(3,7956,END=119,ERR=119)IVLD,(FORM2(IV),IV=120,
     1  128),ITYPE
C ONLY ACCEPT P OR p TYPE RECORDS (ONLY ONE, DEPENDING ON LET1)
	IF(LETR.NE.'P'.AND.LET2.NE.'V')GOTO 118
	IF(LETR.NE.'p'.AND.LET2.EQ.'V')GOTO 118
C HERE WE KNOW WE'RE LEGAL
C SINCE THE NEW VERSIONS OF ANALYTICALC GENERATE DATA ACROSS COLUMNS
C FIRST (I.E., ALONG TUPLES), JUST KEEP TRACK OF LAST ONE
C READ AND FILL IN NULLS IF WE MUST.
C ICOLX AND IROWX ARE NEXT COL AND ROW EXPECTED IF WE READ A TOTALLY
C FILLED TABLE AREA'S SAVED FILE.
122	CONTINUE
	IF(ICOL.LE.ICOLX.AND.IROW.LE.IROWX)GOTO 123
C NEED TO FILL IN EMPTIES...
	WRITE(4,125)
125	FORMAT('0,0',/,'NA')
	ICOLX=ICOLX+1
	IF(ICOLX.LE.ICOLS)GOTO 124
	ICOLX=1
	IROWX=IROWX+1
C WRITE ANOTHER BOT RECORD AS NEEDED HERE (IN CASE WHOLE ROW IS
C EMPTY)
C ONLY EMIT RECORD IF WE DIDN'T JUST FINISH THE LAST ROW THOUGH...
	IF(IROWX.LE.IROWS)WRITE(4,121)
124	CONTINUE
	GOTO 122
123	CONTINUE
C OK, NOW HAVE THIS FILLED IN...
	IF(LET2.NE.'V')GOTO 128
C MUST ENSURE THAT THE EXPONENT IS NN.NNNEXX RATHER THAN NN.NNNNDXX
C I.E., D EXPONENTS AREN'T UNDERSTOOD. THEREFORE WRITE OUT E INSTEAD
C OF D.
	DO 200 IV=1,50
	IF(FORM(IV).EQ.'D')FORM(IV)='E'
200	CONTINUE
128	CONTINUE
	IF(LET2.EQ.'V')WRITE(4,126)(FORM(IV),IV=1,50)
126	FORMAT('0,',50A1,/,'V')
	IF(LET2.NE.'V')WRITE(4,127)(FORM(IV),IV=1,109)
127	FORMAT('1,0',/,109A1)
C
C EMIT DATABASE FILE IF CALLED FOR
C THIS IS HERE TO MAKE PCC AND DIF FILES BE ON AN EQUAL
C FOOTING. NOTE THAT ESSENTIALLY ALL INFO ON THE PCC FILE
C IS SAVED IN THE DATABASE FILE EXCEPT TITLES AND MAPPING.
C ***
	IFT=32+(ITYPE*4)+IVLD
C ADD UNIQUE CELL ID INDEX HERE. USE A FIXED CODE SINCE WE'RE
C NOT STORING IT CONTIGUOUSLY ANYHOW.
	ICW=ICOL
	IRW=IROW
	IDREC=(IRW-1)*1024+ICW+IDBASE
	IF(INDB.NE.0)WRITE(7,5219)IDREC,ICOL,IROW,AUXKEY,
     1  (FORM(IV),IV=1,109),
     1  (FORM2(IV),IV=120,128),IFT
5219	FORMAT(I8.8,2I4.4,A8,109A1,9A1,A1)
C
C ***
C GO BACK AND READ SOME MORE NOW
	ICOLI=ICOL
	IROWI=IROW
	ICOLI=ICOLI+1
	IF(ICOLI.LE.ICOLS)GOTO 2120
	ICOLI=1
	IROWI=IROWI+1
	WRITE(4,121)
2120	CONTINUE
	ICOLX=ICOLI
	IROWX=IROWI
	GOTO 118
C
119	CONTINUE
C ALL DONE, SO MARK END DATA AND GO HOME.
C MUST BE SURE WE FILL OUT THE LAST TUPLE (ROW) SO
C WRITE "NA" RECORDS IF IT'S OK TO DO SO.
	IF(IROWX.GT.IROWS.OR.ICOLX.GT.ICOLS)GOTO 9191
	DO 9192 N=ICOLX,ICOLS
	WRITE(4,125)
C WRITE 'NA' RECORDS TO FILL OUT COLUMNS
9192	CONTINUE
9191	CONTINUE
	WRITE(4,129)
129	FORMAT('-1,0'/,'EOD')
	CLOSE(UNIT=4)
	CLOSE(UNIT=3)
	GOTO 9990
1000	CONTINUE
C
C DIF IN, PCC OUT
C
C ASSUME DIF FILE STARTS WITH TABLE, VECTORS, TUPLES RECORDS
	READ(3,1001)DIFHDR
1001	FORMAT(10A1)
	READ(3,1002)N1,N2
1002	FORMAT(I1,1X,I5)
	READ(3,7953)FORM2
C FORM2 GETS STRING OUT OF DIF RECORD
C
C GET RID OF " CHARACTERS
3211	CONTINUE
	N1=INDEX(CFORM2,'"')
	IF(N1.LE.0.OR.N1.GT.127)GOTO 3212
	FORM2(N1)=' '
	GOTO 3211
3212	CONTINUE
	IF(DIFHDR(1).EQ.'T'.AND.DIFHDR(2).EQ.'A'.AND.DIFHDR(3)
     1  .EQ.'B')WRITE(4,1003)(FORM2(IV),IV=2,81)
1003	FORMAT(80A1)
	IF(DIFHDR(1).EQ.'T'.AND.DIFHDR(2).EQ.'U'.AND.
     1  DIFHDR(3).EQ.'P')NROWS=N2
	IF(DIFHDR(1).EQ.'V'.AND.DIFHDR(2).EQ.'E'.AND.
     1  DIFHDR(3).EQ.'C')NCOLS=N2
	IF(DIFHDR(1).NE.'D'.OR.DIFHDR(2).NE.'A')GOTO 1000
C FALL THROUGH AFTER READING DATA RECORD
C HOPEFULLY WE NOW HAVE NUMBER OF ROWS AND COLUMNS EXPECTED
C ALL STORED IN NROWS AND NCOLS.
	IROW=0
	ICOL=0
1010	CONTINUE
	READ(3,7953,END=9900)FORM
	N1=0
	IX=INDEX(CFORM,',')-1
	IF(IX.LE.0)GOTO 8092
	READ(CFORM,8090)N1
8090	FORMAT(I3)
	DO 8091 N=1,123
8091	FORM(N)=FORM(N+IX+1)
8092	CONTINUE
C READ NUMBER VALUE IN A STRING SO WE CAN DECODE IT AS
C NEEDED.
	READ(3,7961,END=9900)FORM2
7961	FORMAT(100A1,100A1)
C READ A RECORD
C N1 = -1 FLAGS SPECIAL RECORDS
	IF(N1.GE.0)GOTO 1020
	IF(FORM2(1).EQ.'B'.AND.FORM2(2).EQ.'O'
     1  .AND.FORM2(3).EQ.'T')GOTO 1019
	IF(FORM2(1).EQ.'E'.AND.FORM2(2).EQ.'O')GOTO 9900
	GOTO 1010
1019	CONTINUE
C AT START OF TUPLE RESET COL TO 1 AND ROW BUMPS...
	IROW=IROW+1
	ICOL=0
	GOTO 1010
C SKIP OVER NONDATA RECORDS
1020	CONTINUE
C NOW HAVE TO EMIT A DATA RECORD.
	IVLD=-1
	IF(N1.EQ.0)IVLD=1
	ICOL=ICOL+1
	IF(IVLD.EQ.1.AND.FORM2(1).EQ.'N'.AND.FORM2(2).EQ.
     1  'A') GOTO 1010
C SKIP 'NA' INVALID NUMBERS AND DON'T BOTHER WRITING THEM.
	IF(IVLD.EQ.1)WRITE(4,1030)ICOL,IROW,(FORM(IV),IV=1,110)
	IF(IVLD.LT.1)WRITE(4,1030)ICOL,IROW,(FORM2(IV),IV=1,110)
1030	FORMAT('P',I5,',',I5,',',128A1)
	ITYPE=2
C FIGURE OUT TYPE BASED ON PRESENCE OR ABSENCE OF DOT.
	IF(IVLD.GT.1.AND.INDEX(CFORM,'.').EQ.0)ITYPE=4
	WRITE(4,1031)IVLD,DFMT,ITYPE
1031	FORMAT(I3,',',A9,',',I5)
	IF(INDB.LE.0)GOTO 1010
	IFT=32+(ITYPE*4)+IVLD
C WRITE OUT THE DIRECT ACCESS FILE FROM THE DIF FILE
C DIRECT ACCESS FILE OUGHT TO BE SUITABLE FOR DATATRIEVE
C
C RECORD FORMAT IS:
C 8 DIGITS - ID
C 4 DIGITS - COL
C 4 DIGITS - ROW
C 8 CHARACTERS - USER'S AUXILIARY KEY
C 109 CHARS - FORMULA
C 9 CHARS - FORMAT
C 1 CHAR - ENCODED FVLD AND TYPE
C
C NOTE DTR CANNOT HANDLE BINARY DATA. IT NEEDS ALL CHARACTER
C DATA. SO OUTPUT THE STUFF HERE AS CHARACTERS SO DTR CAN
C ACCESS IT.
C
C ADD UNIQUE CELL ID INDEX HERE. USE A FIXED CODE SINCE WE'RE
C NOT STORING IT CONTIGUOUSLY ANYHOW.
	ICW=ICOL
	IRW=IROW
	IDREC=(IRW-1)*1024+ICW+IDBASE
	IF(IVLD.EQ.1)GOTO 8544
	WRITE(7,3219)IDREC,ICOL,IROW,AUXKEY,
     1  (FORM2(IV),IV=1,109),DFMT,IFT
C ENSURE NUMERIC FIELDS ARE ALL FILLED IN WITH 0'S.
3219	FORMAT(I8.8,2I4.4,A8,109A1,A9,A1)
	GOTO 1010
8544	CONTINUE
	WRITE(7,3219)IDREC,ICOL,IROW,AUXKEY,
     1  (FORM(IV),IV=1,109),DFMT,IFT
	GOTO 1010
9900	CONTINUE
	CLOSE(UNIT=4)
	CLOSE(UNIT=3)
510	CONTINUE
9990	stop 'End DIFDB'
7000	CONTINUE
C HERE READ DB FILE AND WRITE A PCC FILE
	WRITE(6,103)
	READ(IOLVL,7953)FORM2
	DO 8340 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 8341
	FORM2(ILN)=CHAR(0)
8340	CONTINUE
8341	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=CHAR(0)
	CALL WASSIG(4,FORM2)
	WRITE(6,140)
	READ(IOLVL,7953)FORM2
	DO 8640 II=1,128
	ILN=129-II
	IF(ICHAR(FORM2(ILN)).GT.32)GOTO 8641
	FORM2(ILN)=CHAR(0)
8640	CONTINUE
8641	CONTINUE
C ILN IS LENGTH OFLINE NOW.
	ILN=MIN0(ILN,127)
	FORM2(ILN+1)=CHAR(0)
	DO 1326 IV=1,80
	II=ICHAR(FORM2(IV))
	IF(II.LT.32)II=32
	LFN(IV)=CHAR(II)
1326	CONTINUE
1327	CONTINUE
C FILE MUST PRE EXIST HERE.
	OPEN(UNIT=7,FILE=CLFN,STATUS='OLD',
     1  ACCESS='SEQUENTIAL',
     2  FORM='FORMATTED')
C NOW HAVE FILES OPEN. GET USER TO GIVE US THE TITLE
C ASK FOR AUXILIARY KEY. * MEANS ALL.
	Write(6,166)
	Read(5,167)AK2
	IRESET=0
	ICOLAC=0
	IROWAC=1
C THE FOLLOWING CODE AND THE CODE AROUND 7116
C IS DESIGNED TO ALLOW SAVED SHEETS TO BE RE-ORDERED IN
C A PCC FILE. THE USER PLACES WHAT DATA HE LIKES IN A
C DATABASE FILE, AND THEN GIVES THE SPECIAL KEYWORD
C % IN THE AUXILIARY KEY. IF HE USES %*, THEN THE
C AUX KEY IS TREATED AS CONTAINING *; OTHERWISE IT IS
C ASKED FOR AGAIN.
C ONCE THE KEY IS OBTAINED, THE PROGRAM ASKS FOR THE
C NUMBER OF ROWS AND COLUMNS IN THE REGION BEING SET UP
C AND WHEN THE PCC FILE IS BEING CREATED, RECORDS READ
C OFF THE DATABASE FILE ARE JUST READ SEQUENTIALLY IN THE
C ORDER OF THE PRIMARRY KEY (CELL ID) AND PLACED IN THE PCC
C FILE AS THOUGH THEY DENSELY FILLED THE UPPER LEFT REGION
C OF A SPREADSHEET, GOING ACROSS COLUMNS FIRST, THEN DOWN
C ROWS (SO THE COLUMN INDEX VARIES MOST QUICKLY).
C   THIS ALLOWS SPREADSHEETS IN WHICH, SAY, 20 OR 30 NUMBERS
C ARE SAVED FROM ALL OVER THE PLACE TO BE REARRANGED INTO
C A DIFFERENT SUMMARY SHEET THAT IS, SAY, 30 COLUMNS WIDE
C WITH EVERY SHEET SAVED AS A ROW OF THE SUMMARY. THE ONLY
C PREREQUISITE IS THAT THE ID BASE THAT GETS ADDED TO CELL ID
C NEEDS TO BE BIG ENOUGH FOR ALL SHEETS AFTER THE FIRST SO
C THAT ALL SHEET 1 ID'S ARE FIRST, ALL SHEET 2 ID'S NEXT, ALL
C SHEET 3 ID'S NEXT, AND SO ON.
	IF(AK2(1:1).NE.'%')GOTO 7111
	IF(AK2(2:2).EQ.'*')AK2(1:1)='*'
C % IS PART SYNONYM FOR *
	IF(AK2(2:2).NE.'*')WRITE(6,166)
	IF(AK2(2:2).NE.'*')READ(5,167)AK2
C IF WE GET %* IT MEANS TAKE ALL AND ASK QUESTIONS
C IF WE GET JUST % WE ASK FOR NEW KEY
C AGAIN AND THEN ASK FOR RESETTING LIMITS
C
	IRESET=1
	WRITE(6,7112)
7112	FORMAT('$Enter No. Cols in region to build>')
	Read(5,7113)irstc
7113	format(I6)
	Write(6,7114)
7114	Format('$Enter No. Rows in region to build>')
	Read(5,7113)irstr
c irstc and irstr are region that we pretend was saved.
	if(irstc.le.0)stop 'wrong colnos'
	if(irstr.le.0)stop 'wrong rownos'
7111	CONTINUE
	WRITE(6,7003)
7003	FORMAT('$TITLE:')
	READ(5,7004)NMSH
7004	FORMAT(80A1)
	WRITE(4,7004)NMSH
C NOW ALL SET FOR THE DATA ITSELF. GO GET IT.
	IRCT=0
7200	CONTINUE
C FOR SEQUENTIAL FILE, FORGET ABOUT DIFFERENCES FROM INITIAL
C KEYED READ AND REMAINDER SEQUENTIAL; JUST DO THE WHOLE
C THING SEQUENTIALLY. NEVERTHELESS, THE RECORD FORMAT
C ALLOWS OTHER PROGRAMS TO ACCESS IT EASILY.
	READ(7,7219,END=7501)IDREC,ICOL,IROW,AUXKEY,
     1  (FORM(IV),IV=1,109),(FORM(IV),IV=120,128),
     2  LETA
	IRCT=1
	IFT=ICHAR(LETA)-29
	ITYPE=2*(IFT/8)
	IFT=IFT-4*ITYPE
	IVLD=IFT-3
7219	FORMAT(I8,2I4,A8,109A1,9A1,A1)
	IF((AUXKEY.NE.AK2).AND.(AK2(1:1).NE.'*'))GOTO 7200
C ALLOW * TO READ FILE REGARDLESS OF AUX KEYS
C WRITE THE STUFF OUT NOW
	IF(IRESET.NE.0)GOTO 7116
	WRITE(4,1030)ICOL,IROW,(FORM(IV),IV=1,110)
	WRITE(4,7031)IVLD,(FORM(IV),IV=120,128),ITYPE
7031	FORMAT(I3,',',9A1,',',I5)
	GOTO 7200
7116	CONTINUE
	ICOLAC=ICOLAC+1
	IF(ICOLAC.LE.IRSTC)GOTO 7117
	IROWAC=IROWAC+1
	ICOLAC=1
7117	CONTINUE
	IF(IROWAC.GT.IRSTR)GOTO 7200
C SKIP SAVE IF REGION IS TOO FAR DOWN FOR OUR USE.
	WRITE(4,1030)ICOLAC,IROWAC,(FORM(IV),IV=1,110)
	WRITE(4,7031)IVLD,(FORM(IV),IV=120,128),ITYPE
	GOTO 7200
7501	CONTINUE
	CLOSE(UNIT=4)
	CLOSE(UNIT=7)
	STOP
	END
$NOFLOATCALLS
$STORAGE: 2
      INTEGER FUNCTION INDEX ( STR, C )
C
      CHARACTER * 1 C, STR ( 1 )
C
C LIMIT RANGE OF SEARCH TO 256 BYTES. THIS IS ARBITRARY BUT I DOUBT
C ANALYTICALC WILL EVER DEAL IN LONGER STRINGS THAN THIS AND
C SEARCHES ALL OVER THE CREATION ARE TO BE AVOIDED.
	I3B=0
      DO 20019  I = 1, 256
      IF (STR(I).NE.0) GOTO 20021
C RETURN INDEX AS EITHER THE LOCATION OF THE CHARACTER OR 0
      INDEX=0
      RETURN
20021 CONTINUE
	IF(ICHAR(STR(I)).EQ.255)I3B=3
	IF(I3B.LE.0)GOTO 2000
C SKIP ENCODED VARIABLES
	I3B=I3B-1
	GOTO 20019
2000	CONTINUE
      IF (.NOT.( STR ( I ) .EQ. C )) GOTO 20023
	ix=i
	if(i.gt.250)ix=0
      INDEX = ( IX )
      RETURN
20023 CONTINUE
20022 CONTINUE
C
20019 CONTINUE
20020 CONTINUE
      END
$NOFLOATCALLS
$STORAGE: 2
	SUBROUTINE RASSIG(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	INTEGER*2 IUNIT
C &&&& MS FTN 3.2
	LOGICAL LEXIST
C &&&&
	CHARACTER*20 WK
	CHARACTER*1 WK1(20)
	EQUIVALENCE(WK,WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
	DO 1 N=1,20
	WK1(N)=' '
1	CONTINUE
	DO 2 N=1,20
	II=ICHAR(NAME(N))
	IF(II.LT.32)GOTO 3
	WK1(N)=CHAR(II)
C1	CONTINUE
2	CONTINUE
3	CONTINUE
C CHECK FOR NONEXISTENT FILE FIRST AND CREATE AN EMPTY ONE
C IF POSSIBLE, THEN CLOSE AND OPEN FOR READ. THIS MAY
C AVOID CRASHES IF THE FILE ISN'T THERE...
C MSDOS FORTRAN 3.2 AND LATER FEATURE...
C &&&&
C
C	INQUIRE(FILE=WK,EXIST=LEXIST,ERR=77)
C
	INQUIRE(FILE=WK,EXIST=LEXIST)
	IF(LEXIST)GOTO 100
C FILE DOES NOT EXIST, SO CREATE IT HERE.
C IF CREATE FAILS WE LOSE TOO...
	write(6,7766)
7766	format(' No such file...')
100	CONTINUE
C &&&&
C IF JUST CALL ASSIGN, ASSUME FOR READ.
	OPEN(IUNIT,FILE=WK,STATUS='OLD',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
77	CONTINUE
C ON ERRORS IN INQUIRE, ASSUME AN ILLEGAL DEVICE OR SOMETHING
C ELSE WEIRD AND JUST DON'T BOTHER WITH THE OPEN.
	RETURN
	END
$NOFLOATCALLS
$STORAGE: 2
	SUBROUTINE WASSIG(IUNIT,NAME)
C
C
	CHARACTER*1 NAME(50)
	INTEGER*2 IUNIT
	CHARACTER*20 WK
	CHARACTER*1 WK1(20)
	EQUIVALENCE(WK,WK1(1))
C JUST TRY AND NULL FILL A NAME TO USE.
	DO 1 N=1,20
	WK1(N)=' '
1	CONTINUE
	DO 2 N=1,20
	II=ICHAR(NAME(N))
	IF(II.LT.32)GOTO 3
	WK1(N)=CHAR(II)
C1	CONTINUE
2	CONTINUE
3	OPEN(IUNIT,FILE=WK,STATUS='NEW',ACCESS='SEQUENTIAL',
     1  FORM='FORMATTED')
	RETURN
	END
