 |
» |
|
|
|
The following program sorts the personnel files shown below.
They are sorted together by last name. The record size is determined
by the input files. The status parameter is checked after the calls to HPSORTINIT and HPSORTEND. The files that are used in this example are as follows (character
positions and data descriptions are for convenience only): - TEMPEMP
information file about temporary employees: Last Name First Name Employee Number Hire Date
Gangley, Tomas 000003 06/06/87
Rields, Evelyn 000007 07/12/87
Everett, Joyce 000029 10/19/87
0 1 2 3 4 5 6 7
1234567890123456789012345678901234567890123456789012345678901234567890 - PERMEMP
information file about permanent employees: Last Name First Name Employee Number Hire Date
Jones, Eliza 000001 06/06/87
Smith, James 000005 06/06/87
Jackson, Johnathon 000006 06/06/87
Washington, Lois 000014 07/23/87
Jackson, Rosa 000022 08/15/87
0 1 2 3 4 5 6 7
1234567890123456789012345678901234567890123456789012345678901234567890
Example D-1 SORTFILE Program $standard_level system
program SORTFILE
C
C This program reads the files TEMPEMP and PERMEMP, sorts by last name,
C and outputs to the file ALLEMP. The compiler directive '$standard_level
C system' is used to supress FORTRAN 77 warnings for non-standard features,
C which include intrinsics calls.
C
integer TEMPFILENUM
2 ,PERMFILENUM
3 ,OUTFILENUM
4 ,STATUS
C
common /PARMS/ TEMPFILENUM, PERMFILENUM
2 ,OUTFILENUM, 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 ,RECORD_SIZE
5 ,PERMANENT
6 ,NEW
7 ,WRITE
8 ,SIZE
9 ,TEMPFILENUM
A ,PERMFILENUM
B ,OUTFILENUM
C ,STATUS
C
character TEMPFILE*10
2 ,PERMFILE*10
3 ,OUTFILE*10
C
common /PARMS/ TEMPFILENUM, PERMFILENUM
2 ,OUTFILENUM, STATUS
C
DESIGNATOR = 2
DOMAIN = 3
ACCESS = 11
RECORD_SIZE = 19
C
TEMPFILE = '%TEMPEMP%'
PERMANENT = 1
call HPFOPEN (TEMPFILENUM, STATUS, DESIGNATOR,
2 ,TEMPFILE, DOMAIN, PERMANENT)
if (STATUS .ne. 0) then
PRINT *,STATUS
print *,'HPFOPEN error on TEMPEMP. 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
NEW = 4
WRITE = 1
SIZE = 80
OUTFILE = '%ALLEMP%'
call HPFOPEN (OUTFILENUM, STATUS, DESIGNATOR,
2 ,OUTFILE, DOMAIN, NEW, ACCESS, WRITE
3 ,RECORD_SIZE, SIZE)
if (STATUS .ne. 0) then
print *,'HPFOPEN error on ALLEMP. Terminating.'
endif
C
return
end
C
subroutine DO_SORT
C
system intrinsic HPSORTINIT
2 ,HPSORTERRORMESS
3 ,HPSORTEND
C
integer OUTPUT_OPTION
2 ,NUMKEYS
3 ,LENGTH
4 ,INPUTFILES(3)
5 ,OUTPUTFILE(2)
6 ,KEYS(4)
7 ,STATISTICS(6)
8 ,TEMPFILENUM
9 ,PERMFILENUM
A ,OUTFILENUM
B ,STATUS
C
character ALTSEQ*2
2 ,MESSAGE*80
C
common /PARMS/ TEMPFILENUM, PERMFILENUM
2 ,OUTFILENUM, STATUS
C
INPUTFILES(1) = TEMPFILENUM
INPUTFILES(2) = PERMFILENUM
INPUTFILES(3) = 0
OUTPUTFILE(1) = OUTFILENUM
OUTPUTFILE(2) = 0
OUTPUT_OPTION = 0
NUMKEYS = 1
KEYS(1) = 1
KEYS(2) = 20
KEYS(3) = 0
KEYS(4) = 0
ALTSEQ(1:1) = CHAR(255)
ALTSEQ(1:2) = CHAR(255)
call HPSORTINIT (STATUS, INPUTFILES, OUTPUTFILE,
2 OUTPUT_OPTION,,, NUMKEYS, KEYS, ALTSEQ)
if (STATUS .ne. 0) then
MESSAGE = ' '
call HPSORTERRORMESS (STATUS, MESSAGE, LENGTH)
print *,MESSAGE
endif
call HPSORTEND (STATUS,STATISTICS)
if (STATUS .ne. 0) then
MESSAGE = ' '
call HPSORTERRORMESS (STATUS, MESSAGE, LENGTH)
print *,MESSAGE
endif
return
end
C
subroutine CLOSE_FILES
C
system intrinsic FCLOSE
C
integer*2 DISPOSITION
2 ,SECURITYCODE
C
integer TEMPFILENUM
2 ,PERMFILENUM
3 ,OUTFILENUM
4 ,STATUS
C
common /PARMS/ TEMPFILENUM, PERMFILENUM
2 ,OUTFILENUM, STATUS
C
DISPOSITION = 0
SECURITYCODE = 0
C
call FCLOSE (TEMPFILENUM, DISPOSITION, SECURITYCODE)
call FCLOSE (PERMFILENUM, DISPOSITION, SECURITYCODE)
DISPOSITION = 1
call FCLOSE (OUTFILENUM, DISPOSITION, SECURITYCODE)
return
end When this program is executed, the output from the sort is
written to ALLEMP. To view the output: :print allemp
Everett, Joyce 000029 10/19/87
Gangley, Tomas 000003 06/06/87
Jackson, Jonathan 000006 06/06/87
Jackson, Rosa 000022 08/15/87
Jones, Eliza 000001 06/06/87
Rields, Evelyn 000007 07/12/87
Smith, James 000005 06/06/87
Washington, Lois 000014 07/23/87 |
|
Printable version
