$standard_level system
program SORTREC_OUTPUT
C
C This program reads the files TEMPEMP and PERMEMP, sorts them by last
C name, outputs them by record, alters the output recors, and prints the
C record to $STDLIST.
C
integer TEMPFILENUM
2 ,PERMFILENUM
3 ,STATUS
C
common /PARMS/ TEMPFILENUM, PERMFILENUM, STATUS
C
call OPEN_FILES
call DO_SORT
call CLOSE_FILES
stop
end
C
subroutine OPEN_FILES
C
system intrinsic HPFOPEN
2 ,QUIT
C
integer DESIGNATOR
2 ,DOMAIN
3 ,ACCESS
4 ,PERMANENT
5 ,TEMPFILENUM
6 ,PERMFILENUM
7 ,STATUS
C
character TEMPFILE*10
2 ,PERMFILE*10
C
common /PARMS/ TEMPFILENUM, PERMFILENUM, STATUS
C
DESIGNATOR = 2
DOMAIN = 3
ACCESS = 11
C
TEMPFILE = '%TEMPEMP%'
PERMANENT = 1
call HPFOPEN (TEMPFILENUM, STATUS, DESIGNATOR,
2 ,TEMPFILE, DOMAIN, PERMANENT)
if (STATUS .ne. 0) then
print *, 'HPFOPEN error on TEMPFILE. Terminating.'
call QUIT (1)
endif
C
PERMFILE = '%PERMEMP%'
call HPFOPEN (PERMFILENUM, STATUS, DESIGNATOR,
2 ,PERMFILE, DOMAIN, PERMANENT)
if (STATUS .ne. 0) then
print *, 'HPFOPEN error on PERMEMP. Terminating.'
call QUIT (2)
endif
C
return
end
C
subroutine DO_SORT
C
system intrinsic HPSORTINIT
2 ,HPSORTERRORMESS
3 ,HPSORTEND
4 ,HPSORTINPUT
5 ,HPSORTOUTPUT
6 ,QUIT
C
integer OUTPUT_OPTION
2 ,NUMKEYS
3 ,LENGTH
4 ,INPUTFILES(3)
5 ,KEYS(4)
6 ,TEMPFILENUM
7 ,PERMFILENUM
8 ,STATUS
C
character ALTSEQ*2
2 ,MESSAGE*80
3 ,BUFFER*80
C
common /PARMS/ TEMPFILENUM, PERMFILENUM, STATUS
C
INPUTFILES(1) = TEMPFILENUM
INPUTFILES(2) = PERMFILENUM
INPUTFILES(3) = 0
LENGTH = 1
C
OUTPUT_OPTION = 0
C
NUMKEYS = 1
KEYS(1) = 1
KEYS(2) = 20
KEYS(3) = 0
KEYS(4) = 0
C
ALTSEQ(1:1) = CHAR(255)
ALTSEQ(2:2) = CHAR(255)
C
call HPSORTINIT (STATUS, INPUTFILES,, OUTPUT_OPTION
2 ,,, NUMKEYS, KEYS, ALTSEQ)
if (STATUS .ne. 0) then
MESSAGE = ' '
call HPSORTERRORMESS (STATUS, MESSAGE, LENGTH)
print *,MESSAGE
endif
C
do while (LENGTH .gt. 0)
call HPSORTOUTPUT (STATUS, BUFFER, LENGTH)
BUFFER(33:39) = 'Empl. #'
BUFFER(50:59) = 'Hire Date:'
print *,BUFFER
if (STATUS .ne. 0) then
call HPSORTERRORMESS (STATUS, MESSAGE, LENGTH)
print *,MESSAGE
endif
end do
C
call HPSORTEND (STATUS)
if (STATUS .ne. 0) then
MESSAGE = ' '
call HPSORTERRORMESS (STATUS, MESSAGE, LENGTH)
print *,MESSAGE
endif
C
return
end
C
subroutine CLOSE_FILES
C
system intrinsic FCLOSE
C
integer*2 DISPOSITION
2 ,SECURITYCODE
C
integer TEMPFILENUM
2 ,PERMFILENUM
3 ,STATUS
C
common /PARMS/ TEMPFILENUM, PERMFILENUM, STATUS
C
DISPOSITION = 0
SECURITYCODE = 0
C
call FCLOSE (TEMPFILENUM, DISPOSITION, SECURITYCODE)
call FCLOSE (PERMFILENUM, DISPOSITION, SECURITYCODE)
C
return
end
|
.gif)
