PROGRAM READ_WITH_PROMPT
C
C     The purpose of this program is to
C     illustrate the useropen technique
C     for accessing RMS features not
C     normally available through FORTRAN.
C
C     The user open routine must be declared
      EXTERNAL PROMPT_OPEN
C     Common area for communication to
C     user open routine.
C     We will pass it the address of the
C     prompt string and its size.
      COMMON/PROMPT/PROMPT_ADDR,PROMPT_LEN
      INTEGER*4 PROMPT_ADDR,PROMPT_LEN
      CHARACTER*80 PROMPT,LINE
C     Define the prompt
C     (Note that ASCII carriage return &
C     line feed are decimal 10 and 13).
      PROMPT = CHAR(10)//CHAR(13)//'LINE 00000 : '
C     Fill in the common area
      PROMPT_ADDR = %LOC(PROMPT)
      PROMPT_LEN = 15
C     Now, open the lun
      OPEN(UNIT=1,NAME='SYS$INPUT',READONLY,
     &   TYPE='OLD',USEROPEN=PROMPT_OPEN)
C     Next, begin doing reads with prompts.
      ILINE = 0
10    CONTINUE
C     Encode the line number into the prompt
      ILINE = ILINE + 1
      ENCODE(5,100,PROMPT(8:12))ILINE
100   FORMAT(I5)
C     and issue READ
      READ(1,101,END=20)LINE
101   FORMAT(A)
C     repeat until EOF
      GOTO 10
20    STOP 'THANKS'
      END
      
      INTEGER FUNCTION PROMPT_OPEN(IFAB,IRAB,ILUN)
C
C     This subroutine modifies the RAB so
C     that read with prompt is specified
C     on all reads.
C
      COMMON/PROMPT/PROMPT_ADDR(4),PROMPT_LEN(4)
      BYTE PROMPT_ADDR,PROMPT_LEN
      EXTERNAL RAB$L_PBF,RAB$B_PSZ,RAB$L_ROP
      EXTERNAL RAB$V_PMT
      INTEGER*4 SYS$OPEN,SYS$CONNECT
C     Dimension IRAB big enough to avoid problems
C     if they use /CHECK option on compile.
      BYTE IRAB(0:1000)
C     set PBF and PSZ fields in RAB
      DO 10 I = 1 , 4
10    IRAB(%LOC(RAB$L_PBF)+I-1) = PROMPT_ADDR(I)
      IRAB(%LOC(RAB$B_PSZ)) = PROMPT_LEN(1)
C     set prompt in record options
C     Note that LIB$INSV does not return a status
      CALL LIB$INSV(1,%LOC(RAB$V_PMT),1,
     &   IRAB(%LOC(RAB$L_ROP)))
C     Now open the file and
C     connect the record stream.
      PROMPT_OPEN = SYS$OPEN(IFAB)
C     If open failed, don't bother with connect !
      IF(MOD(PROMPT_OPEN,2).NE.1)RETURN
      PROMPT_OPEN = SYS$CONNECT(IRAB)
      RETURN
      END