
$STORAGE: 2

*****************************************************************
*
* This program illustrates how to call the  SortMerge object
* modules from FORTRAN.  The records to be sorted are read from 
* the SAM file Files.In, contained on the distribution diskette.  
* The sorted records are written to the SAM file Files.Out.
*
* Files.In contains a sequence of 65byte records terminated by 
* line feeds.  All the records must be exactly 65bytes long 
* (including the line feed), or the sort will not work.
*
* Two 6byte keys are used for the sort, both of type character.  
* The first is located 6 bytes from the beginning of the record, 
* and the second 26 bytes from the beginning.  Both are sorted in 
* ascending order.
*
*****************************************************************


* Subroutine to check for unexpected status codes.

	Subroutine ChkErc(iErc)
		if (iErc.eq.0) return
		write(*,'(  1x,17hError encountered)')
		write(*,'(1x,15h    Status code,I5)') iErc
		stop
	end


* Subroutine to check for unexpected SortMerge errors.

	Subroutine ChkSts(iErc, irgSts)
	dimension irgSts(2)
		if (iErc.ne.irgSts(1)) call ChkErc(8)
		if (iErc.eq.0) return
		write(*,'(  1x,10hSort Error)')
		write(*,'(1x,15h    Status code,I5)') iErc
		if (irgSts(2).ne.0) 
     .			write(*,
     .			    '(1x,22h    Detail status code,I5)') irgSts(2)
		iErc = SMTRST(irgSts)
		stop
	end


* Main Program

	Program SortEx

* Variables
	implicit integer (f)
	implicit integer (s)
	implicit integer (b)
	character*65 chRecrd
	character*8  filin
	character*9  filout
	character*1  pswd
	character*21 nWf1
	character*21 nWf2
	character*2  modeR
	character*2  modeW
	character    LF
	integer*4    q0
	integer*4    qsWFCr
	integer*4    qsWrkA
	integer*2    iErc
	integer*2    wRet
	integer*2    sRecrd
	dimension iRgbIn(512),iRgbOu(512),iBsIn(65),iBsOut(65)
	dimension iRgbWk(4096),iPrpSB(112),iKeyDs(9),iStsBk(2)
	data filin'Files.In',filout'Files.Out',pswd' '
	data modeR'rm',modeW'wm'
	data nWf1'[Sys]<$>WorkFile1.Tmp'
	data nWf2'[Sys]<$>WorkFile2.Tmp'

	q0 = 0
	lf = char(10)

* Open input file
	call ChkErc(BSOPEN(iBsIn,filin,8,pswd,0,modeR,iRgbIn,1024))

* Open output file
	call ChkErc(BSOPEN(
     .    iBsOut,filout,9,pswd,0,modeW,iRgbOu,1024))

* Initialize prepare sort block variables
	qsWFCr = 1024
	qsWrkA = 8192

* Initialize key descriptor
* 2 keys are used.
* The first key is of type character, is 6 bytes long, has an 
* offset of 6 bytes from the  beginning of the record, and is 
* sorted in ascending order.
	iKeyDs(1) = 2
	iKeyDs(2) = 6
	iKeyDs(3) = 6
	iKeyDs(4) = 2
	iKeyDs(5) = 255
* The second key is of type character, is 6 bytes long, has an
* offset of 26 bytes from the  beginning of the record, and is
* sorted in ascending order.
	iKeyDs(6) = 26
	iKeyDs(7) = 6
	iKeyDs(8) = 2
	iKeyDs(9) = 255


* Initialize sort
	call ChkSts(SMBPKS(iPrpSB,nWf1,21,nWf1,0,nWf2,21,nWf2,0,
     .			       qsWFCr,512,qsWrkA,65,0,iKeyDs,iRgbWk,iStsBk),
     .            iStsBk)


* Release records
	sRecrd = 65
	write(*, 9)
 9	format(1x  ' Release Records')

10	iErc = BSRDRC(iBsIn,chRecrd,65,wRet)
	IF (iErc.ne.0) goto 20
	call ChkSts(SMRLRC(sRecrd,chRecrd,iStsBk), iStsBk)
	write(*, '(1x,a64)') chRecrd
	goto 10

20	IF (iErc.ne.1) CALL ChkErc(iErc)


* Do sort
	write(*,'(1x,7hDo Sort,1a)') LF
	call ChkSts(SMDOST(iStsBk), iStsBk)


* Retrieve records
	write(*,'(1x,14hReturn Records,1a)') LF
30	iErc = SMRTRC(sRecrd,chRecrd,iStsBk)
	IF (iErc.ne.0) goto 40
	call ChkErc(BSWRRC(iBsOut,chRecrd,sRecrd,wRet))
	write(*, '(1x,a64)') chRecrd
	goto 30

40	IF (iErc.ne.3404)  CALL ChkSts(iErc, iStsBk)


* Close files and end sort
	CALL ChkSts(SMCDST(iStsBk), iStsBk)

	CALL ChkErc(BSCLOS(iBsIn))

	CALL ChkErc(BSCLOS(iBsOut))

	write(*,'(1x,27hSort concluded successfully,1a)') LF

	end