HP OpenVMS Systems Documentation

        Fortran Program
C...
C...    This program demonstrates the Fortran calling sequences
C...    for the merge record interface.
C...
C
C       THE INPUT FILES ARE LISTED BELOW.
C
C               INFILE1.DAT
C
C 1 BBBBBBBBBB REST OF DATA IN RECORD................................END OF RECORD
C 2 UUUUUUUUUU REST OF DATA IN RECORD................................END OF RECORD
C
C               INFILE2.DAT
C
C 1 AAAAAAAAAA REST OF DATA IN RECORD................................END OF RECORD
C 2 TTTTTTTTTT REST OF DATA IN RECORD................................END OF RECORD
C
C               INFILE3.DAT
C
C 1 TTTTTTTTTT REST OF DATA IN RECORD................................END OF RECORD
C 2 BBBBBBBBBB REST OF DATA IN RECORD................................END OF RECORD
C
C               FOROUT.DAT
C
C 1 AAAAAAAAAA REST OF DATA IN RECORD................................END OF RECORD
C 1 BBBBBBBBBB REST OF DATA IN RECORD................................END OF RECORD
C 1 TTTTTTTTTT REST OF DATA IN RECORD................................END OF RECORD
C 2 BBBBBBBBBB REST OF DATA IN RECORD................................END OF RECORD
C 2 TTTTTTTTTT REST OF DATA IN RECORD................................END OF RECORD
C 2 UUUUUUUUUU REST OF DATA IN RECORD................................END OF RECORD
C
C
C.................................................................................
C
C

        IMPLICIT INTEGER (A-Z)

        CHARACTER*80 REC                        ! A record.

        EXTERNAL READ_REC                       ! Routine to read a record.
        EXTERNAL KOMPAR                         ! Routine to compare records.
        EXTERNAL SS$_ENDOFFILE                  ! System end-of-file value

        INTEGER*4 SOR$BEGIN_MERGE               ! SORT/MERGE function names
        INTEGER*4 SOR$RETURN_REC
        INTEGER*4 SOR$END_SORT
        INTEGER*4 ISTAT                         ! storage for SORT/MERGE function value
        INTEGER*4 LENGTH                        ! length of the returned record
        INTEGER*2 LRL                           ! Longest Record Length (LRL)

        LOGICAL*1 ORDER                         ! #files to merge (merge order)

        DATA ORDER,LRL/3,80/                    ! Order of the merge=3,LRL=80
C...
C...    First open all the input files.
C...
        OPEN (UNIT=10, FILE='INFILE1.DAT',TYPE='OLD',READONLY,
     *  FORM='FORMATTED')
        OPEN (UNIT=11, FILE='INFILE2.DAT',TYPE='OLD',READONLY,
     *  FORM='FORMATTED')
        OPEN (UNIT=12, FILE='INFILE3.DAT',TYPE='OLD',READONLY,
     *  FORM='FORMATTED')
C
C...    Open the output file.
C
        OPEN (UNIT=8, FILE='TEMP.TMP', TYPE='NEW')
C...
C...    Initialize the merge.  Pass the merge order, the largest
C...    record length, the compare routine address, and the
C...    input routine address.
C...
        ISTAT = SOR$BEGIN_MERGE (,LRL,,ORDER,
     *  KOMPAR,,READ_REC)
        IF (.NOT. ISTAT) GOTO 10        ! Check for error.



C...
C...    Now loop getting merged records.  SOR$RETURN_REC will
C...    call READ_REC when it needs input.
C...
5       ISTAT = SOR$RETURN_REC (REC, LENGTH)
        IF (ISTAT .EQ. %LOC(SS$_ENDOFFILE)) GO TO 30    ! Check for end of file.
        IF (.NOT. ISTAT) GO TO 10       ! Check for error.

        WRITE(8,200) REC                        ! Output the record.
200     FORMAT(' ',A)
        GOTO 5                                  ! And loop back.
C...
C...    Now tell SORT that we are all done.
C...

30      ISTAT = SOR$END_SORT()
        IF (.NOT. ISTAT) GOTO 10        ! Check for error.
        CALL EXIT

C...
C...    Here if an error occurred.  Write out the error status
C...    and exit.
C...
10      WRITE(8,201)ISTAT
201     FORMAT(' ?ERROR CODE', I20)
        CALL EXIT
        END


        FUNCTION READ_REC (RECX, FILE, SIZE)
C...
C...    This routine reads a record from one of the input files
C...    for merging.  It will be called by SOR$BEGIN_MERGE and by
C...    SOR$RETURN_REC.
C...    Parameters:
C...
C...            RECX.wcp.ds     character buffer to hold the record after
C...                            it is read in.
C...
C...            FILE.rl.r       indicates which file the record is
C...                            to be read from.  1 specifies the
C...                            first file, 2 specifies the second
C...                            etc.
C...
C...            LENGTH.wl.r     is the actual number of bytes in
C...                            the record.  This is set by READ_REC.
C...
        IMPLICIT INTEGER (A-Z)

        PARAMETER MAXFIL=10                     ! Max number of files.

        EXTERNAL SS$_ENDOFFILE                  ! End of file status code.
        EXTERNAL SS$_NORMAL                     ! Success status code.

        LOGICAL*1 FILTAB(MAXFIL)
        CHARACTER*(80) RECX                     ! MAX LRL =80

        DATA FILTAB/10,11,12,13,14,15,16,17,18,19/ ! Table of I/O unit numbers.

        READ_REC = %LOC(SS$_ENDOFFILE)         ! Give end of file return
        IF (FILE .LT. 1 .OR. FILE .GT. MAXFIL) RETURN   !   if illegal call.

        READ (FILTAB(FILE), 100, ERR=75, END=50) RECX   ! Read the record.
100     FORMAT(A)

        READ_REC = %LOC(SS$_NORMAL)             ! Return success code.
        SIZE = LEN (RECX)                       ! Return size of record.
        RETURN

C...    Here if end of file.
50      READ_REC = %LOC(SS$_ENDOFFILE)          ! Return "end of file" code.
        RETURN

C...    Here if error while reading
75      READ_REC = 0
        SIZE = 0
        RETURN
        END


        FUNCTION KOMPAR (REC1,REC2)
C...
C...    This routine compares two records.  It returns -1
C...    if the first record is smaller than the second,
C...    0 if the records are equal, and 1 if the first record
C...    is larger than the second.
C...
        PARAMETER KEYSIZ=10

        IMPLICIT INTEGER (A-Z)

        LOGICAL*1 REC1(KEYSIZ),REC2(KEYSIZ)

        DO 20 I=1,KEYSIZ
        KOMPAR = REC1(I) - REC2(I)
        IF (KOMPAR .NE. 0) GOTO 50
20      CONTINUE

        RETURN

50      KOMPAR = ISIGN (1, KOMPAR)
        RETURN
        END

Program

        PROGRAM CALLSORT
C
C
C       This is a sample Fortran program that calls the SOR
C       routines using the file interface for input and the
C       record interface for output.  This program requests
C       a record sort of the file 'R010SQ.DAT'  and  writes
C       the records to SYS$OUTPUT.  The key is  an  80-byte
C       character ascending  key starting in  position 1 of
C       each record.
C
C       A short version of the input and output files follows:
C
C                       Input file R010SQ.DAT
C 1 BBBBBBBBBB REST OF DATA IN RECORD................................END OF RECORD
C 2 UUUUUUUUUU REST OF DATA IN RECORD................................END OF RECORD
C 1 AAAAAAAAAA REST OF DATA IN RECORD................................END OF RECORD
C 2 TTTTTTTTTT REST OF DATA IN RECORD................................END OF RECORD
C 1 TTTTTTTTTT REST OF DATA IN RECORD................................END OF RECORD
C 2 BBBBBBBBBB REST OF DATA IN RECORD................................END OF RECORD
C 1 QQQQQQQQQQ REST OF DATA IN RECORD................................END OF RECORD
C 2 AAAAAAAAAA REST OF DATA IN RECORD................................END OF RECORD
C 1 UUUUUUUUUU REST OF DATA IN RECORD................................END OF RECORD
C 2 QQQQQQQQQQ REST OF DATA IN RECORD................................END OF RECORD
C
C                       Output file SYS$OUTPUT
C
C 1 AAAAAAAAAA REST OF DATA IN RECORD...............................END OF RECORD
C 1 BBBBBBBBBB REST OF DATA IN RECORD...............................END OF RECORD
C 1 QQQQQQQQQQ REST OF DATA IN RECORD...............................END OF RECORD
C 1 TTTTTTTTTT REST OF DATA IN RECORD...............................END OF RECORD
C 1 UUUUUUUUUU REST OF DATA IN RECORD...............................END OF RECORD
C 2 AAAAAAAAAA REST OF DATA IN RECORD...............................END OF RECORD
C 2 BBBBBBBBBB REST OF DATA IN RECORD...............................END OF RECORD
C 2 QQQQQQQQQQ REST OF DATA IN RECORD...............................END OF RECORD
C 2 TTTTTTTTTT REST OF DATA IN RECORD...............................END OF RECORD
C 2 UUUUUUUUUU REST OF DATA IN RECORD...............................END OF RECORD
C
C-----------------------------------------------------------------------------
C
C       Define external functions and data.
C
        CHARACTER*80 RECBUF
        CHARACTER*10 INPUTNAME          !Input file name
        INTEGER*2 KEYBUF(5)             !Key definition buffer
        INTEGER*4 SOR$PASS_FILES        !SORT function names
        INTEGER*4 SOR$BEGIN_SORT
        INTEGER*4 SOR$SORT_MERGE
        INTEGER*4 SOR$RETURN_REC
        INTEGER*4 SOR$END_SORT
        INTEGER*4 ISTATUS               !Storage for SORT function value
        EXTERNAL SS$_ENDOFFILE
        EXTERNAL DSC$K_DTYPE_T
        EXTERNAL SOR$GK_RECORD
        INTEGER*4 SRTTYPE

C
C       Initialize data -- first the file names, then the key buffer for
C       one 80-byte character key starting in position 1, 3 work files,
C       and a record sort process.
C
        DATA INPUTNAME/'R010SQ.DAT'/
        KEYBUF(1) = 1
        KEYBUF(2) = %LOC(DSC$K_DTYPE_T)
        KEYBUF(3) = 0
        KEYBUF(4) = 0
        KEYBUF(5) = 80
        SRTTYPE = %LOC(SOR$GK_RECORD)

C
C       Call the SORT -- each call is a function.
C
C
C       Pass SORT the file names.
C
        ISTATUS = SOR$PASS_FILES(INPUTNAME)
        IF (.NOT. ISTATUS) GOTO 10
C
C       Initialize the work areas and keys.
C
        ISTATUS = SOR$BEGIN_SORT(KEYBUF,,,,,,SRTTYPE,%REF(3))
        IF (.NOT. ISTATUS) GOTO 10
C
C       Sort the records.
C
        ISTATUS = SOR$SORT_MERGE( )
        IF (.NOT. ISTATUS) GOTO 10
C
C       Now retrieve the individual records and display them.
C
5       ISTATUS = SOR$RETURN_REC(RECBUF)
        IF (.NOT. ISTATUS) GOTO 6
        ISTATUS = LIB$PUT_OUTPUT(RECBUF)
        GOTO 5
6       IF (ISTATUS .EQ. %LOC(SS$_ENDOFFILE)) GOTO 7
        GOTO 10
C
C       Clean up the work areas and files.
C
7       ISTATUS = SOR$END_SORT()
        IF (.NOT. ISTATUS) GOTO 10
        STOP 'SORT SUCCESSFUL'
10      STOP 'SORT UNSUCCESSFUL'
        END

Program


(* This program merges three input files, (IN_FILE.DAT,
 IN_FILE2.DAT IN_FILE3.DAT), and creates one merged output file.  *)


program mergerecs( output, in_file1, in_file2, in_file3, out_file );

CONST
   SS$_NORMAL = 1;
   SS$_ENDOFFILE = %X870;
   SOR$GK_RECORD = 1;
   SOR$M_STABLE = 1;
   SOR$M_SEQ_CHECK = 4;
   SOR$M_SIGNAL = 8;
   DSC$K_DTYPE_T = 14;

TYPE
   $UBYTE = [BYTE] 0..255;
   $UWORD = [WORD] 0..65535;

const
    num_of_keys = 1;
    merge_order = 3;
    lrl         = 131;

    ascending   = 0;
    descending  = 1;


type
    key_buffer_block=
        packed record
        key_type:       $uword;
        key_order:      $uword;
        key_offset:     $uword;
        key_length:     $uword;
        end;

   key_buffer_type=
        packed record
        key_count:      $uword;
        blocks:         packed array[1..num_of_keys] of key_buffer_block;
        end;

   record_buffer =      packed array[1..lrl] of char;

   record_buffer_descr =
        packed record
        length: $uword;
        dummy:  $uword;
        addr:   ^record_buffer;
        end;

var
   in_file1,
   in_file2,
   in_file3,
   out_file:    text;
   key_buffer:  key_buffer_type;
   rec_buffer:  record_buffer;
   rec_length:  $uword;
   status:      integer;
   i:           integer;

function sor$begin_merge(
        var buffer:     key_buffer_type;
        lrl:            $uword;
        mrg_options:    integer;
        merge_order:    $ubyte;
        %immed cmp_rtn: integer := 0;
        %immed eql_rtn: integer := 0;
        %immed [unbound] function
            read_record(
                var rec:        record_buffer_descr;
                var filenumber: integer;
                var recordsize: $uword): integer
        ): integer; extern;

function sor$return_rec(
        %stdescr rec:   record_buffer;
        var rec_size:   $uword
        ): integer; extern;

function sor$end_sort: integer; extern;

procedure sys$exit( %immed status : integer ); extern;

function read_record(
        var rec:        record_buffer_descr;
        var filenumber: integer;
        var recordsize: $uword
        ): integer;

procedure readone( var filename: text );
begin
recordsize := 0;
if eof(filename)
then
    read_record := ss$_endoffile
else
    begin
    while not eoln(filename) and (recordsize < rec.length) do
        begin
        recordsize := recordsize + 1;
        read(filename,rec.addr^[recordsize]);
        end;
    readln(filename);
    end;
end;

begin
read_record := ss$_normal;
case filenumber of
    1: readone(in_file1);
    2: readone(in_file2);
    3: readone(in_file3);
    otherwise
        read_record := ss$_endoffile;
    end;
end;

procedure initfiles;
begin
open( in_file1, 'infile1.dat', old );
open( in_file2, 'infile2.dat', old );
open( in_file3, 'infile3.dat', old );
open( out_file, 'temp.tmp' );
reset( in_file1 );
reset( in_file2 );
reset( in_file3 );
rewrite( out_file );
end;

procedure error( status : integer );
begin
writeln( 'merge unsuccessful.  status=%x', status:8 hex );
sys$exit(status);
end;
begin

with key_buffer do
    begin
    key_count := 1;
    with blocks[1] do
        begin
        key_type := dsc$k_dtype_t;
        key_order := ascending;
        key_offset := 0;
        key_length := 5;
        end;
    end;

initfiles;

status := sor$begin_merge( key_buffer, lrl,
        sor$m_seq_check + sor$m_signal,
        merge_order, 0, 0, read_record );

repeat
    begin
    rec_length := 0;
    status := sor$return_rec( rec_buffer, rec_length );
    if odd(status)
    then
        begin
        for i := 1 to rec_length do write(out_file, rec_buffer[i]);
        writeln(out_file);
        end;
    end
until not odd(status);

if status <> ss$_endoffile then error(status);

status := sor$end_sort;
if not odd(status) then error(status);

writeln( 'merge successful.' );

end.

Pascal Program

PROGRAM FILETORECORDSORT (OUTPUT,SORTOUT);

(*      This program calls SOR routines to read and sort records from
        two input files, (PASINPUT1.DAT and PASINPUT2.DAT) and to return
        sorted records to this program to be written to the output file,
        (TEMP.TMP).  *)

(*      Declarations for external status codes, and data structures, such as
        the types $UBYTE (an unsigned byte) and $UWORD (an unsigned word). *)

CONST
   SS$_NORMAL = 1;
   SS$_ENDOFFILE = %X870;
   SOR$GK_RECORD = 1;
   SOR$M_STABLE = 1;
   SOR$M_SEQ_CHECK = 4;
   SOR$M_SIGNAL = 8;
   DSC$K_DTYPE_T = 14;

TYPE
   $UBYTE = [BYTE] 0..255;
   $UWORD = [WORD] 0..65535;

CONST
   Numberofkeys = 1 ;   (* Number of keys for this sort *)
   LRL = 131 ;          (* Longest Record Length for output records *)

(* Key orders *)

   Ascending = 0 ;
   Descending = 1 ;


TYPE
   Keybufferblock= packed record
                   Keytype : $UWORD ;
                   Keyorder : $UWORD ;
                   Keyoffset : $UWORD ;
                   Keylength : $UWORD
                   end ;

(* The keybuffer. Note that the field buffer is a one-component array in
   this program. This type definition would allow a multikeyed sort. *)

   Keybuffer= packed record
              Numkeys : $UWORD ;
              Blocks : packed array[1..Numberofkeys] OF Keybufferblock
              end ;

(* The record buffer. This buffer will be used to hold the returned
        records from SORT. *)

   Recordbuffer = packed array[1..LRL] of char ;

(* Name type for input and output files. A necessary fudge for %stdescr
   mechanism.  *)

   nametype= packed array[1..13] of char ;



VAR
   Sortout : text ;             (* the output file *)
   Buffer : Keybuffer ;         (* the actual keybuffer *)
   Sortoptions : integer ;      (* flag for sorting options *)
   Sorttype : $UBYTE ;          (* sorting process *)
   Numworkfiles : $UBYTE ;      (* number of work files *)
   Status : integer ;           (* function return status code *)
   Rec : Recordbuffer ;         (* a record buffer *)
   Recordlength : $UWORD ;      (* the returned record length *)
   Inputname:  nametype ;       (* input file name *)
   i : integer ;                (* loop control variable *)



(* function and procedure declarations *)

(* Declarations of SORT functions *)
(* Note that the following SORT routine declarations
        do not use all of the possible routine parameters. *)
(* The parameters used MUST have all preceding parameters specified,
        however. *)

FUNCTION SOR$PASS_FILES
   (%STDESCR Inname : nametype )
   : INTEGER ; EXTERN ;

FUNCTION SOR$BEGIN_SORT(
    VAR Buffer : Keybuffer ;
    Lrlen : $UWORD ;
    VAR Sortoptions : INTEGER ;
    %IMMED Filesize : INTEGER ;
    %IMMED Usercompare : INTEGER ;
    %IMMED Userequal : INTEGER ;
    VAR Sorttype : $UBYTE ;
    VAR Numworkfiles : $UBYTE )
    : INTEGER ; EXTERN ;

FUNCTION SOR$SORT_MERGE
   : INTEGER ; EXTERN ;

FUNCTION SOR$RETURN_REC(
   %STDESCR  Rec : Recordbuffer ;
   VAR Recordsize : $UWORD )
   : INTEGER ; EXTERN ;

FUNCTION SOR$END_SORT
   : INTEGER ; EXTERN ;


(* End of the SORT function declarations *)

(* The CHECKSTATUS routine checks the return status for errors. *)
(* If there is an error, write an error message and exit via sys$exit *)
PROCEDURE CHECKSTATUS( var status : integer ) ;

        procedure sys$exit( status : integer ) ; extern ;

begin           (* begin checkstatus *)
   if odd(status) then
        begin
        writeln( ' SORT unsuccessful. Error status = ', status:8 hex ) ;
        SYS$EXIT( status ) ;
        end ;
end ;           (* end checkstatus *)

(* end function and routine declarations *)


BEGIN   (* begin the main routine *)

(* Initialize data for one 8-byte character key, starting at record
   offset 0, 3 work files, and the record sorting process *)

Inputname := 'PASINPUT1.DAT' ;
WITH Buffer DO
   BEGIN
   Numkeys := 1;
   WITH Blocks[1] DO
      BEGIN
      Keytype := DSC$K_DTYPE_T ;        (* Use OpenVMS descriptor data types to
                                                define SORT data types. *)
      Keyorder := Ascending ;
      Keyoffset := 0 ;
      Keylength := 8 ;
      END;
   END;

Sorttype := SOR$GK_RECORD ;             (* Use the global SORT constant to
                                             define the sort process. *)
Sortoptions := SOR$M_STABLE ;           (* Use the global SORT constant to
                                             define the stable sort option. *)
Numworkfiles := 3 ;

(* call the sort routines as a series of functions *)

(* pass the first filename to SORT *)
Status := SOR$PASS_FILES( Inputname ) ;

(* Check status for error. *)
CHECKSTATUS( Status ) ;

(* pass the second filename to SORT *)
Inputname := 'PASINPUT2.DAT' ;

Status := SOR$PASS_FILES( Inputname ) ;

(* Check status for error. *)
CHECKSTATUS( Status ) ;

(* initialize work areas and keys *)
Status := SOR$BEGIN_SORT( Buffer, 0, Sortoptions, 0, 0, 0,
                                Sorttype, Numworkfiles ) ;

(* Check status for error. *)
CHECKSTATUS( Status ) ;

(* sort the records *)
Status := SOR$SORT_MERGE ;

(* Check status for error. *)
CHECKSTATUS( Status ) ;

(* Ready output file for writing returned records from SORT. *)
OPEN( SORTOUT, 'TEMP.TMP' ) ;
REWRITE( SORTOUT ) ;

(* Now get the sorted records from SORT. *)
Recordlength := 0 ;
REPEAT
   Status := SOR$RETURN_REC( Rec, Recordlength ) ;

   if odd( Status )
   then                 (* if successful, write record to output file. *)
        begin
        for i := 1 to Recordlength do
           write( sortout, Rec[i] ) ;   (* write each character *)
        writeln (sortout) ;                     (* end output line *)
        end;
UNTIL not odd( Status ) ;

(* If there was just no more data to be returned (eof) continue, otherwise
        exit with an error. *)
if Status <> SS$_ENDOFFILE then
   CHECKSTATUS( Status ) ;

(* The sort has been successful to this point. *)

(* Close the output file *)
CLOSE( sortout ) ;

(* clean up work areas and files *)
Status := SOR$END_SORT ;

(* Check status for error. *)
CHECKSTATUS( Status );

WRITELN ('SORT SUCCESSFUL') ;

END.