d c. DO	DB
╚ c.		Simple data base program
,c.
Рc.	This program permits the definition and processing of a data
Їc. base structure. The user is prompted for a file that contains
Xc. his data. The default type of the file is .DB. The structure of
╝c. the file is given by an associated file with the same name, but
 c. with the type .DS. Once these two files are active the user can
Дc. process this file. The commands are identified by entering a ? for
шc. help. More documentation will be available later.
Lc.
░c. -end.of.infi-
c.
x	program db
▄c.
@c.		== Simple data base edit
дc.
	include 'dbinc.for'
lc===
╨	call initdb( isw )
4c.
Ш200	continue
№	call incmd('db',inp)
`		call jjupp(inp)
─	c.
(
	if( isadd(inp) ) goto 200
М
	if( ischa(inp) ) goto 200
Ё
	if( isdel(inp) ) goto 200
T	if( isexi(inp) ) goto 9000
╕	if( isfin(inp) ) goto 200
	if( islis(inp) ) goto 200
А	if( isund(inp) ) goto 200
ф	if( ismov(inp) ) goto 200
H	if( isset(inp) ) goto 200
мc.
850	continue
t	ieof = 1
╪	if( inp.eq.'?' ) then
<	  write(6,*)'	]	..	To repeat a command line'
а	else
	  write(6,*)'Enter:	?	..	to get a command list'
h	endif
╠	goto 200
0c.
Ф9000	continue
°		end
  
d c======
╚ 	function incmd( prompt, cmd )
,c.
Рc... Input a command
Їc.
X	character*(*) prompt, cmd
╝	include 'dbinc.for'
 	data inp/ ' ' /
Д	data ipos/1/
шc===
L200	continue
░	call jjwrd( inp, ipos, cmd )
	if( cmd.eq.' ' ) then
x210	  continue
▄	  type 91,'$['
@	  inp = ' '
д	  cmd = '^Z'
	  read(5,91,end=9000)inp
l	  ipos = 1
╨	  ieof = -1
4	  cmd = inp
Ш	  if( cmd.ne.' ' ) goto 200
№	endif
`		if( cmd.eq.',' ) cmd = ' '
─		if( cmd.eq.']' ) then
(
	  if( ieof.eq.1 ) goto 210
М
	  ipos = 1
Ё
	  if( inp(1:1).ge.'0' .and. inp(1:1).le.'9' ) then
T	    call jjwrd(inp,ipos,cmd)
╕	  endif
	  goto 200
А	endif
фc.
H9000	continue
м	return
		end
  
d c======
╚ 	function initdb( idb )
,c.
Рc... Initalize data base format
Їc.
X	include 'dbinc.for'
╝	character*80 nmdbs
 c===
Д	call stopctc(1)
шc.
L	idb = -1
░	type 91,'$File<.db>? '
	read(5,91,end=9000) fnam
x	call jjupp( fnam )
▄	inx = index(fnam,'.')-1
@	if(inx.lt.0) then
д	  inx = jjlen(fnam)
	  fnam = fnam(1:inx)//'.db'
l	endif
╨	nmdbs = fnam(1:inx)//'.ds'
4	if( index( fnam,'.DS' ).ne.0 ) goto 550
Шc.
№	open(unit=1,type='old',name=nmdbs,err=500)
`	c.
─	c... Old db format
(
c.
М
200	continue
Ё
	idb = 1
T	ii = ii+1
╕	read( 1,91,end=290 ) dbfmt(ii)
	goto 200
Аc.
ф290	continue
H	close( unit=1 )
м	goto 1000
c.
tc... New db dbs
╪c.
<500	continue
а	idb = 2
	write(6,*) 'New DB format ',nmdbs(1:jjlen(nmdbs))
hc.	..........12345678901234567890
╠550	continue
0	dbfmt(1)='Fld Name  a10'
Ф	dbfmt(2)='Fld fmt   a5'
°	fnam = nmdbs
\c.
└1000	continue
$	ii = 1
И	ipos = 1
ьc.
P1010	continue
┤	do 1090 ii=1,100
	  if(dbfmt(ii).lt.' ') goto 1095
|	  inp = dbfmt(ii)(11:)
р	  len = index(inp,' ')-1
D	  inx = index(inp(1:len),'.')
и	  if(inx.ne.0) len = inx-1
	  decode( len-1,1020,inp(2:5))isize
p1020	  format(i)
╘	  ifst(ii)=ipos
8	  ilst(ii)=ipos+isize-1
Ь	  ipos = ipos+isize
 1090	continue
d1095	continue
╚c.
,c... open files
Рc.
Ї	open(unit=1,name=fnam,type='old',err=2100)
X	goto 2190
╝2100	continue
 	write(6,*) 'New DB   file ',fnam(1:jjlen(fnam))
Дc.
ш2190	continue
L	open(unit=2,name='DB.SCI',type='new',carriagecontrol='list')
░	call movdat(0)
c.
x9000	continue
▄	initdb = idb
@	return
д		end
  
d c======
╚ 	function isadd( cmd )
,c.
Рc... add a record
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 c.
Д	isadd = .false.
ш	if( cmd.eq.'?' ) then
L	  write(6,*)'	ADd	..	Adds a record to the file'
░	else if( cmd(1:2).eq.'AD' ) then
	  isadd = .true.
x	  iodata = ' '
▄	  do 290 ii=1,100
@	    if( dbfmt(ii).le.' ' ) goto 295
д	    write(6,91)'$', dbfmt(ii)(1:8),'? '
	    read(5,91,end=9000) iodata(ifst(ii):ilst(ii))
l	    goto 290
╨290	  continue
4c.
Ш295	  continue
№	  write(6,*)'..Added..'
`		  call movdat(-1 )
─		endif
(
c.
М
9000	continue
Ё
	return
T		end
  
d c======
╚ 	function ischa( cmd )
,c.
Рc... change a record
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 	character*80 infld
Дc===
ш	ischa = .false.
L	if( cmd.eq.'?' ) then
░	  write(6,*)'	CHange	..	Changes the current record'
c.
x	else if( cmd(1:2).eq.'CH' ) then
▄	  nrec = movdat( -4 )
@200	  continue
д	  ii = lofld( cmd )
	  if( ii.eq.-1 ) then
l	    goto 1090
╨c.
4	  else if( ii.gt.0 ) then
Ш	    write(6,91)' ',dbfmt(ii)(1:8),': '
№	1    , iodata(ifst(ii):ilst(ii))
`		    write(6,91)'$     new? '
─		    read(5,91,err=200)iodata(ifst(ii):ilst(ii))
(
	    goto 200
М
c.
Ё
	  else
T	    write(6,*) '..Changed..'
╕	    call movdat( -2 )
	    call movdat( -1 )
А	  endif
фc.
H1090	  continue
м	  ischa = .true.
	endif
tc.
╪	return
<		end
  
d c======
╚ 	function isdel( cmd )
,c.
Рc... Delete a record
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 c.
Д	isdel = .false.
ш	if( cmd.eq.'?' ) then
L	  write(6,*)'	DElete	..	Deletes the current record'
░	else if( cmd(1:2).eq.'DE' ) then
	  isdel = .true.
x	  call movdat( -2 )
▄	  write(6,*)'..Deleted..'
@	endif
д	return
		end
  
d c======
╚ 	function isexi( cmd )
,c.
Рc... Exit from the program
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 c.
Д	isexi = .false.
ш	if( cmd.eq.'?' ) then
L	  write(6,*)'	EXit	..	Exit from the DB program'
░	  write(6,*)'	  ^Z 	..	Also exit'
c.
x	else if( cmd(1:2).eq.'EX' .or. cmd(1:3).eq.'^Z' ) then
▄	  if(iadd.eq.0 .and. idel.eq.0 ) goto 500
@	  write(6,210) iadd,idel
д210	  format( i5,' Add ',i5,' Del ')
	  type 91,'$Update <Yes> ? '
l	  read(5,91,end=300)inp
╨	  call jjupp(inp)
4c.
Ш	  if( inp(1:1).eq.' '.or. inp(1:1).eq.'Y' ) then
№	    open(unit=3,name=fnam,type='new',carriagecontrol='list')
`	300	    continue
─		    nwrite = 0
(
	    do 390 ii=1,10000
М
	      nrec = movdat( ii )
Ё
	      if( abs(nrec).ne.ii ) goto 395
T	      if( nrec.lt.0 ) goto 390
╕	      write(3,91)iodata(1:jjlen(iodata))
	      nwrite = nwrite+1
А390	    continue
ф395	    continue
H	    write(6,410)nwrite, fnam(1:jjlen(fnam))
м410	    format( i5, ' records in ', a )
	    close(unit=2,disp='delete')
tc.
╪	  else
<500	    continue
а	    write(6,*)' No change ', fnam(1:jjlen(fnam))
	    if( iadd.eq.0 ) close(unit=2,disp='delete')
h	    close(unit=3,disp='delete')
╠	  endif
0	  isexi = .true.
Ф	endif
°c.
\9000	continue
└	return
$		end
  
d c======
╚ 	function isfin( cmd )
,c.
Рc... Set up search condition
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 	character*80 sval, temp
Д	character*2 cond(6)
ш	data cond/'EQ','NE','GT','GE','LT','LE'/
Lc.
░	isfin = .false.
	if( cmd.eq.'?' ) then
x	  write(6,*)'	FInd	..	FInd a record'
▄	  write(6,*)'	=	..	To set up find condition'
@	else if( cmd(1:2).eq.'FI' ) then
д	  isfin = .true.
	  irec = movdat( -4 )
l250	  continue
╨	  ir = abs(irec)+1
4	  irec = movdat( ir )
Ш	  if( ir .ne. abs(irec) ) then
№	    write(6,310) irec,'~EOF~'
`		    goto 9000
─		  endif
(
	  if( (imod.and.2).eq.0 .and.irec.lt.0) goto 250
М
	  if( iis.ne.0 ) then
Ё
	    temp = iodata(ifst(iis):ilst(iis))
T	    call jjupp(temp)
╕	    if(icon.eq.1.and.sval.ne.temp(1:jjlen(sval)))goto 250
	    if(icon.eq.2.and.sval.eq.temp(1:jjlen(sval)))goto 250
А	    if(icon.eq.3.and.sval.ge.temp(1:jjlen(sval)))goto 250
ф	    if(icon.eq.4.and.sval.gt.temp(1:jjlen(sval)))goto 250
H	    if(icon.eq.5.and.sval.le.temp(1:jjlen(sval)))goto 250
м	    if(icon.eq.6.and.sval.lt.temp(1:jjlen(sval)))goto 250
	  endif
t	  if( (imod.and.1).ne.0 ) then
╪	    call islis('LIST')
<	  else if( irec.gt.0 ) then
а	    write(6,310) irec,': ',iodata(1:65)
310	  format(i9,10a)
h	  else
╠	    write(6,310) irec,'- ',iodata(1:65)
0	  endif
Фc.
°	else if( cmd(1:2).eq.'= ' ) then
\	  isfin = .true.
└	  ii = lofld( cmd )
$	  if( ii.eq.0 ) then
И	    iis = 0
ь	  else if( ii.gt.0 ) then
P	    iis = ii
┤500	    continue
	    type 91,'$',dbfmt(iis)(1:8),'? '
|	    read(5,91)inp
р	    call jjupp(inp)
D	    do 510 icon=1,6
и	      if(inp.eq.cond(icon)) goto 515
510	    continue
p	    write(6,*)'**Illegal condition**'
╘	    write(6,*) cond
8	    goto 500
Ьc.
 515	    continue
d	    type 91,'$Fld ',cond(icon),'  ? '
╚	    read(5,91)sval
,	    call jjupp(sval)
Рc.
Ї	  endif
X	endif
╝9000	continue
 	return
Д		end
  
d c======
╚ 	function islis(cmd)
,c.
Рc... Show the current record
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 	character rtype*2
Дc.
ш	islis = .false.
L	if( cmd.eq.'?' ) then
░	  write(6,*)'	LIst	..	Shows the current record'
	else if( cmd(1:2).eq.'LI' ) then
x	  irec = movdat( -4 )
▄	  rtype = ':'
@	  if( irec.le.0 ) rtype = '-'
д	  write(6,210) irec, rtype
210	  format( i9,10a )
l	  do 290 ii=1,100
╨	    if( dbfmt(ii).le.' ' ) goto 295
4	    write(6,91)' ', dbfmt(ii)(1:8),rtype
Ш	1	,iodata(ifst(ii):ilst(ii))
№290	  continue
`	c.
─	295	  continue
(
	islis = .true.
М
	endif
Ё
	return
T		end
  
d c======
╚ 	function ismov( cmd )
,c.
Рc... Move, and list to the n-th record
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 c===
Д	ismov = .false.
ш	if( cmd.eq.'?' ) then
L	  write(6,*)'	nnn	..	Move to record nnn'
░	  write(6,*)'	+nn	..	Move + nn records'
	  write(6,*)'	-nn	..	Move - nn records'
x	else
▄	  decode( jjlen(cmd),210,cmd,err=9000 ) irec
@210	  format( i )
д	  ismov = .true.
	  if( cmd(1:1).eq.'+' .or.cmd(1:1).eq.'-' ) then
l	    jrec = irec+abs(nrec)
╨	    if( jrec.le.0 ) jrec=1
4	  else
Ш	    jrec = irec
№	  endif
`		  if( jrec.lt.0 .or. cmd.eq.' ' ) jrec = 1+abs(nrec)
─		  nrec = movdat( jrec )
(
	  if( jrec.ne.abs(nrec) ) then
М
	    write(6,310) nrec,'~EOF~'
Ё
310	    format( i9,10a )
T	  endif
╕	endif
c.
А9000	continue
ф	return
H		end
  
d c======
╚ 	function isset( cmd )
,c.
Рc... Set the move 'list' mode
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 c.
Д	isset = .false.
ш	if( cmd.eq.'?' ) then
L	  write(6,*)'	/Active	..	Find only active records (def)'
░	  write(6,*)'	/Delete	..	Find all, inc. deleted, records'
	  write(6,*)'	/Full	..	Full record list on find'
x	  write(6,*)'	/Short	..	Short record list on find (def)'
▄	else if( cmd(1:2).eq.'/A' ) then
@	  imod = imod .and.-1-2
д	  isset = .true.
	else if( cmd(1:2).eq.'/D' ) then
l	  imod = imod .or. 2
╨	  isset = .true.
4	else if( cmd(1:2).eq.'/F' ) then
Ш	  imod = imod .or. 1
№	  isset = .true.
`		else if( cmd(1:2).eq.'/S' ) then
─		  imod = imod .and. -2
(
	  isset = .true.
М
	endif
Ё
c.
T	return
╕		end
  
d c======
╚ 	function isund( cmd )
,c.
Рc... Undelete a record
Їc.
X	character*(*) cmd
╝	include 'dbinc.for'
 c.
Д	isund = .false.
ш	if( cmd.eq.'?' ) then
L	  write(6,*) '	UNdel	..	Un-Delete a record'
░	else if( cmd(1:2).eq.'UN' ) then
	  isund = .true.
x	  call movdat( -3 )
▄	endif
@	return
д		end
  
d c======
╚ 	function lofld( cmd )
,c.
Рc... Locate a field
Їc.
Xc.out.	lofld: ^Z=-1, Blank=0, Field=+N
╝c.
 	character*(*) cmd
Д	include 'dbinc.for'
ш	character*80 inp2
Lc===
░200	continue
	lofld = -1
x	type 91,'$Fld Name? '
▄	read(5,91,end=9000) inp2
@	call jjupp(inp2)
д	if( inp2.eq.'^Z' ) goto 9000
	if( inp2.eq.' ' .or. inp2.eq.',' ) then
l	  lofld = 0
╨	  goto 9000
4	else if( inp2.eq.'?' ) then
Ш	  call islis('LIST')
№	  goto 200
`		else
─		  do 210 ii=1,100
(
	    if( dbfmt(ii).le.' ' ) goto 215
М
	    inp = dbfmt(ii)(1:8)
Ё
	    call jjupp(inp)
T	    if( inp2.eq.inp(1:jjlen(inp2)) ) then
╕	      lofld = ii
	      goto 9000
А	    endif
ф210	  continue
H215	  continue
м	  type *,'**No such field**'
	  goto 200
tc.	....
╪	endif
<c.
а9000	continue
	return
h		end
  
d c======
╚ 	function movdat( jrec )
,c.
Рc.inp.	jrec: Add=-1, Delete=-2, Undel=-3, Re-read=-4,
Їc.	Read = +N
Xc.out.	movdat: +n for not deleted, -n for deleted, +last at EOF
╝c.
 	include 'dbinc.for'
Д	character*1 trash
ш	integer ixdel(1000)
L	data mxrec/10000/
░c.
	if( jrec.eq.-1 ) then			!!Add
x100	  continue
▄	  read(2,91,err=110)trash
@	  goto 100
дc.
110	  continue
l	  iadd = iadd+1
╨	  call update
4	  write(2,91)iodata(1:jjlen(iodata))
Ш	  nrec = 999
№	  movdat = 999
`	c.
─		else if( jrec.eq.-2 ) then		!!Del
(
	  idel = idel+1
М
	  ndel = ndel+1
Ё
	  ixdel(ndel)=nrec
T	  movdat = -nrec
╕c.
	else if(jrec.eq.-4 ) then		!!Re-Read
А	  goto 1500
фc.
H	else if(jrec.ge.0) then			!!Read
м	  if(jrec.lt.nrec) then
	    rewind 1
t	    rewind 2
╪	    nrec = 0
<	    if( jrec.eq.0 ) then
а	      iodata = ' '
	      do 590 ii=1,100
h	        if( dbfmt(ii).le.' ' ) goto 595
╠	        iodata(ifst(ii):ilst(ii))=dbfmt(ii)(11:)
0590	      continue
Ф595	      continue
°	      goto 1500
\	    endif
└	  endif
$c.
И1110	  continue
ь	  if( jrec.eq.nrec ) goto 1500
P	    read(1,91,err=1200)iodata
┤	    nrec = nrec+1
	    if(jrec.gt.nrec) goto 1110
|	    goto 1500
рc.
D1200	  continue
и1210	  continue
	    read(2,91,err=1400)iodata
p	    nrec = nrec+1
╘	    if(jrec.gt.nrec) goto 1210
8	  goto 1500
Ьc.
 1400	continue
d	ieof = 1
╚c.
,1500	  continue
Р	  movdat = nrec
Ї	  do 1590 ii=1,ndel
X	    if( nrec.eq.ixdel(ii) ) then
╝	      movdat = -nrec
 	      goto 1595
Д	    endif
ш1590	  continue
L1595	  continue
░c.
	else
x	  write(6,*)'illegal',jrec
▄	  ieof = 1
@	endif
д	return
 		end
  
d c======
╚ 	subroutine stopctc(iflag)
,c.
Р	include 'dbinc.for'
Їc.
X	call stopit
╝	ieof = 1
 	return
Д		end
шc======
L	subroutine stopit
░c.
	external io$_setmode,io$m_ctrlcast,stopctc
xc.
▄	ioset = %loc(io$_setmode).or.%loc(io$m_ctrlcast)
@	call jjmess( sys$assign( 'TT:', ichan, , ) )
д	call jjmess( sys$qio( , %val(ichan), %val(ioset) , , ,
	1	, stopctc, 1, , , , , ) )
l	return
╨		end
4c======
Ш	subroutine update
№c.
`		include 'dbinc.for'
─		character vaxtime*12, dbtime*20
(
	character*3 month(12)
М
	data month/'JAN','FEB','MAR','APR','MAY','JUN'
Ё
	1	,'JUL','AUG','SEP','OCT','NOV','DEC' /
T	character*2 moinx(12)
╕	data moinx/'01','02','03','04','05','06'
	1	,'07','08','09','10','11','12'/
Аc.
ф	do 210 ii=1,100
H	  if( dbfmt(ii)(11:11).eq.'U' ) goto 215
м210	continue
	return
tc.
╪215	continue
<	call date( vaxtime )
а	dbtime = vaxtime(8:)
	do 220 jj=1,11
h	  if( vaxtime(4:6).eq.month(jj) ) goto 250
╠220	continue
0c.
Ф250	continue
°	dbtime(3:4)=moinx(jj)
\	dbtime(5:) =vaxtime(1:2)
└	if(dbtime(5:5).eq.' ')dbtime(5:5)='0'
$c.
И	iodata(ifst(ii):ilst(ii)) = dbtime
ь	do 310 ii=1,100
P	  if( dbfmt(ii)(11:11).eq.'C' ) goto 325
┤310	continue
	return
|c.
р325	continue
D	if( iodata(ifst(ii):ilst(ii)).eq.' ' )
и	1	iodata(ifst(ii):ilst(ii)) = dbtime
c.
p	return
╘		end