Farba Research VAX FORTRAN Example

C     SUBROUTINE BPDINI.FOR
C+
C;  BPDINI IS THE INITIALIZATION SUBROUTINE FOR PROGRAM "BPD".
C-
CD+
C;   THIS SUBROUTINE WILL DETERMINE THE RECORD NUMBER OF THE PICTORIAL
C;DISPLAY THAT IS TO BE BACKED-UP AS A VAX-11 RMS FILE (OR THE FACT THAT
C;ALL DEFINED DISPLAYS ARE TO BE BACKED-UP).  THIS INFORMATION MUST
C;EXIST IN A "FOREIGN COMMAND-LINE" IN THE EXACT FORMAT DESCRIBED
C;BELOW:
C;
C;           BPD XXX
C;
C;     WHERE;       "XXX" IS THE RECORD NUMBER IN THE PICTORIAL FILE THAT IS TO
C;               BE BACKED-UP.  "XXX" MAY BE ANY NUMBER OF DECIMAL DIGITS
C;               BETWEEN ONE AND SIX.  LEADING ZEROES ARE OPTIONAL AND
C;               IGNORED.  A TRAILING DECIMAL-POINT IS OPTIONAL AND IGNORED.
C;                  THE THREE-CHARACTER STRING "ALL" MAY BE SUPPLIED INSTEAD,
C;               IN WHICH CASE ALL DEFINED DISPLAYS WILL BE BACKED-UP.
C;
C;
CD-
C;   WRITTEN BY  E. NICHOLAS CUPERY  26 AUGUST 1981
C*+
      SUBROUTINE BPDINI(TI,ALLFLG,RECNUM,STATUS)
C*
C* ARGUMENT INPUTS:
C*      TI     = INITIATING TERMINAL LUN (NOT USED)                             

[WORD]
C*
C* INPUTS FROM COMMON:
C*      (NONE)
C*
C* ARGUMENT OUTPUTS:
C*      ALLFLG = BACKUP-ALL-DISPLAYS FLAG (0=NO)                     [WORD]
C*      RECNUM = RECORD NUMBER IN PICTORIAL FILE (IF ALLFLG=0)       [LONGWORD]
C*      STATUS = RETURN STATUS (+1 = SUCCESS)                        [WORD]
C*
C* OUTPUTS TO COMMON:
C*      (NONE)
C*
C*-
C
C
C
      INTEGER*2     TI           !INITIATING TERMINAL LUN
      INTEGER*2     ALLFLG       !BACKUP-ALL-DISPLAYS FLAG (0=NO)
      INTEGER*4     RECNUM       !RECORD NUMBER IN PICTORIAL FILE
      INTEGER*2     STATUS       !RETURN STATUS FOR CALLER
C
      INTEGER*4     I            !LOCAL DO-LOOP COUNTER
      INTEGER*4     J            !LOCAL DO-LOOP COUNTER
      CHARACTER*84  CHRBUF       !CHARACTER BUFFER FOR "LIB$GET_FOREIGN"
      BYTE          FILSPC(84)   !ASCII ARRAY FOR COMMAND-LINE
      INTEGER*2     NCHARS       !COMMAND-LINE CHARACTER-COUNT
      INTEGER*2     NUMDIG       !NUMBER OF DIGITS IN RECORD NUMBER
      INTEGER*4     SYSTAT       !STATUS VALUE FOR "GET-FOREIGN-COMMAND-LINE"
      INTEGER*4     LIB$GET_FOREIGN   !"GET-FOREIGN-COMMAND-LINE" FUNCTION
      INTEGER*4     LIB$CVT_DTB  !"CONVERT-DECIMAL-TO-BINARY" FUNCTION
C
      EQUIVALENCE   (CHRBUF,FILSPC)
C
C
C
C
C
C$INDENT
C
C     SET BAD RETURN STATUS FOR CALLER
      STATUS = -1
C
C     ASSUME SPECIFICATION IS NOT "ALL"
      ALLFLG = 0
C
C     GET "FOREIGN" COMMAND-LINE
      SYSTAT = LIB$GET_FOREIGN(CHRBUF,,NCHARS)
C
C     IF ANY ERROR OCCURRED
      IF (SYSTAT) GO TO 10
C
C       DECLARE ERROR GETTING COMMAND-LINE
        WRITE (*,5)
    5   FORMAT(' BPD -- ERROR GETTING COMMAND-LINE',/)
C
C       BREAK -- RETURN IMMEDIATELY
        GO TO 999
C
C     ENDI
   10 CONTINUE
C
C     IF SPECIFICATION IS "ALL
      IF (FILSPC(1) .NE. 'A' .OR. FILSPC(2) .NE. 'L'
     *.OR. FILSPC(3) .NE. 'L' .OR. NCHARS .NE. 3) GO TO 20
C
C       SET THE "BACKUP-ALL-DISPLAYS" FLAG
        ALLFLG = 1
C
C       SET A GOOD RETURN STATUS FOR CALLER
        STATUS = 1
C
C       BREAK -- RETURN TO CALLER NOW
        GO TO 999
C
C     ENDI
   20 CONTINUE
C
C
C
C
C
C     CALCULATE NUMBER OF DIGITS IN THE RECORD NUMBER
      NUMDIG = NCHARS
C
C     IF THE DIGIT-COUNT IS ILLEGAL
      IF (NUMDIG .GT. 0 .AND. NUMDIG .LE. 6) GO TO 30
C
C       BREAK -- DECLARE SYNTAX ERROR
        GO TO 888
C
C     ENDI
   30 CONTINUE
C
C     CONVERT DECIMAL ASCII DIGITS TO BINARY
      SYSTAT = LIB$CVT_DTB(%VAL(NUMDIG),FILSPC(1),RECNUM)
C
C     IF ANY ERROR OCCURRED
      IF (SYSTAT) GO TO 40
C
C       DECLARE SYNTAX ERROR
  888   WRITE (*,889)
  889   FORMAT(' BPD -- COMMAND-LINE SYNTAX ERROR   ',
     *  '(NEED DISPLAY NUMBER OR "ALL")',/)
C
C       BREAK -- RETURN TO CALLER
        GO TO 999
C
C     ENDI
   40 CONTINUE
C
C     SET GOOD RETURN STATUS FOR CALLER
      STATUS = 1
C
C     RETURN TO CALLER
  999 RETURN
C
C     END OF SUBROUTINE
      END

Farba Products WORK