Previous | Contents | Index |
This appendix contains examples that involve accessing OpenVMS system services from Compaq Fortran programs. The individual examples address the following operations:
Each example includes the free-form source program (with comments), a
sample use of the program, and explanatory notes.
E.1 Calling RMS Procedures
When you explicitly call an RMS system service, the order of the arguments in the call must correspond with the order shown in the OpenVMS Record Management Services Reference Manual. You must use commas to reserve a place in the call for every argument. If you omit an argument, the procedure uses a default value of zero.
When calling an RMS routine from Compaq Fortran, the procedure name format is SYS$procedure_name. The following example shows a call to the RMS procedure SYS$SETDDIR. This RMS procedure sets the default directory for a process.
! File: SETDDIR.F90 ! ! This program calls the RMS procedure $SETDDIR to change ! the default directory for the process. IMPLICIT INTEGER (A - Z) CHARACTER(LEN=17) DIR /'[EX.PROG.FOR]'/ (1) STAT = SYS$SETDDIR (DIR,,) (2) IF (.NOT. STAT) TYPE *, 'ERROR' END PROGRAM |
Sample Use:
$ DIRECTORY (3) Directory WORK$:[EX.PROG.FOR.CALL] BASSUM.BAS;1 BASSUM.OBJ;1 COBSUM.COM;1 DOCOMMAND.F90;2 GETMSG.EXE;1 GETMSG.F90;4 GETMSG.LIS;2 GETMSG.OBJ;1 SETDDIR.F90;3 SETDDIR.LIS;1 Total of 10 files. $ FORTRAN SETDDIR $ LINK SETDDIR $ RUN SETDDIR $ DIRECTORY (4) Directory WORK$:[EX.PROG.FOR] CALL.DIR;1 COMU.DIR;1 DEVC.DIR;1 FIL.DIR;1 HAND.DIR;1 INTR.DIR;1 LNKR.DIR;1 MNAG.DIR;1 RMS.DIR;1 SHAR.DIR;1 SYNC.DIR;1 TERM.DIR;1 Total of 12 files. |
WORK$:[EX.V4PROG.FOR.CALL] |
WORK$:[EX.PROG.FOR] |
For More Information:
On calling RMS system services, see Chapter 11.
E.2 Using an AST Routine
The following example demonstrates how to request and declare an AST procedure. It consists of the following:
For More Information:
On AST routines, see the OpenVMS System Services Reference Manual.
! Sample program to show enabling of an AST in Fortran ! ! The program uses a Ctrl/C AST to interrupt a work loop in the ! main program. ! PROGRAM CTRLC IMPLICIT NONE LOGICAL CTRLC_FLAG ! Set to TRUE when Ctrl/C is pressed INTEGER (KIND=2) CHANNEL ! Channel for terminal COMMON /AST_COM/ CTRLC_FLAG,CHANNEL VOLATILE CTRLC_FLAG ! Required because variable (1) ! can change at any time INTEGER ITERATIONS,I ! Do first-time initialization CHANNEL = 0 CTRLC_FLAG = .FALSE. CALL ENABLE_AST ! Read iteration count 100 WRITE (*,'($,A)') ' Enter iteration count (0 to exit): ' READ (*,*) ITERATIONS DO I=1,ITERATIONS IF (CTRLC_FLAG) GOTO 200 ! Was Ctrl/C pressed? WRITE (*,*) 'Count is ',I CALL LIB$WAIT (2.0) ! Pause 2 seconds END DO IF (ITERATIONS .EQ. 0) GOTO 999 GOTO 100 ! Loop back 200 WRITE (*,*) 'Ctrl/C pressed' CTRLC_FLAG = .FALSE. GOTO 100 999 END PROGRAM CTRLC ! Subroutine ENABLE_AST SUBROUTINE ENABLE_AST (2) IMPLICIT NONE INCLUDE '($SYSSRVNAM)' ! System services INCLUDE '($IODEF)' ! $QIO function codes LOGICAL CTRLC_FLAG VOLATILE CTRLC_FLAG (1) INTEGER (KIND=2) CHANNEL COMMON /AST_COM/ CTRLC_FLAG,CHANNEL EXTERNAL AST_ROUTINE INTEGER ASSIGN_STATUS, QIO_STATUS, IOSB(2) ! Assign channel if not already assigned IF (CHANNEL .EQ. 0) THEN ASSIGN_STATUS = SYS$ASSIGN ('TT:', CHANNEL,,,) IF (.NOT. ASSIGN_STATUS) CALL LIB$SIGNAL(%VAL(ASSIGN_STATUS)) END IF ! Enable AST so that AST_ROUTINE is called when Ctrl/C is pressed. QIO_STATUS = SYS$QIOW (, & (3) %VAL(CHANNEL), & %VAL(IO$_SETMODE .OR. IO$M_CTRLCAST), & IOSB,,, & AST_ROUTINE,,,,,) IF (.NOT. QIO_STATUS) CALL LIB$SIGNAL(%VAL(QIO_STATUS)) RETURN END SUBROUTINE ENABLE_AST ! Subroutine AST_ROUTINE SUBROUTINE AST_ROUTINE (4) IMPLICIT NONE LOGICAL CTRLC_FLAG VOLATILE CTRLC_FLAG (1) INTEGER (KIND=2) CHANNEL COMMON /AST_COM/ CTRLC_FLAG,CHANNEL ! Indicate that a CTRL/C has been pressed CTRLC_FLAG = .TRUE. ! Reenable the AST. This must be done by calling ENABLE_AST rather than ! doing it here as we would need a recursive reference to AST_ROUTINE, ! which is disallowed unless /RECURSIVE is used. CALL ENABLE_AST (5) RETURN END SUBROUTINE AST_ROUTINE |
Sample Use:
$ RUN CTRLC Enter iteration count (0 to exit): 9 Count is 1 Count is 2 Count is 3 Ctrl/C (5) Cancel Ctrl/C pressed Enter iteration count (0 to exit): 0 $ |
For More Information:
On the VOLATILE statement, see the Compaq Fortran Language Reference Manual.
E.3 Accessing Devices Using Synchronous I/O
The following example performs output to a terminal via the SYS$QIOW system service.
! File: QIOW.F90 ! ! This program demonstrates the use of the $QIOW system service to ! perform synchronous I/O to a terminal. IMPLICIT INTEGER (KIND=4) (A - Z) INCLUDE '($SYSSRVNAM)' INCLUDE '($IODEF)' CHARACTER(LEN=24) TEXT_STRING /'This is from a SYS$QIOW.'/ (1) CHARACTER(LEN=11) TERMINAL /'SYS$COMMAND'/ INTEGER KIND=2) TERM_CHAN STRUCTURE /TT_WRITE_IOSB/ INTEGER (KIND=2) STATUS INTEGER (KIND=2) BYTES_WRITTEN INTEGER (KIND=4) %FILL END STRUCTURE RECORD /TT_WRITE_IOSB/ IOSB ! Assign the channel number STAT = SYS$ASSIGN (TERMINAL, TERM_CHAN,,) IF (.NOT. STAT) CALL LIB$STOP (%VAL(STAT)) (2) ! Initialize STATUS to zero (0) STATUS = 0 ! Output the message twice DO I=1,2 STAT = SYS$QIOW (%VAL(1),%VAL(TERM_CHAN), & (3) %VAL(IO$_WRITEVBLK),IOSB,,, & %REF(TEXT_STRING), & %VAL(LEN(TEXT_STRING)),, & %VAL(32),,) IF (.NOT. STAT) CALL LIB$STOP (%VAL(STATUS)) IF (.NOT. IOSB.STATUS) CALL LIB$STOP (%VAL(IOSB.STATUS)) ENDDO END PROGRAM |
Sample Use:
$ FORTRAN QIOW $ LINK QIOW $ RUN QIOW This is from a SYS$QIOW. This is from a SYS$QIOW. |
The following example shows how to create a global pagefile section and how two processes can use it to access the same data. One process executes the program PAGEFIL1, which must first be installed. When run, PAGEFIL1 creates and writes to a global pagefile section. PAGEFIL1 then waits for a second process to update the section. The second process executes PAGEFIL2, which maps and updates the pagefile section.
Because PAGEFIL2 maps to the temporary global pagefile section created in PAGEFIL1, PAGEFIL1 must be run first. The two processes coordinate their activity through common event flags.
! File: PAGEFIL1.F90 ! ! This program creates and maps a global page frame section. ! Data in the section is accessed through an array. IMPLICIT INTEGER (KIND=4) (A-Z) INCLUDE '($SECDEF)' INCLUDE '($SYSSRVNAM)' INCLUDE '($SYIDEF)' DIMENSION MY_ADR(2),OUT_ADR(2) COMMON /MYCOM/ IARRAY(50) (1) CHARACTER(LEN=4) NAME/'GSEC'/ VOLATILE /MYCOM/ (2) ! Associate with common cluster MYCLUS STATUS = SYS$ASCEFC (%VAL(64),'MYCLUS',,) (3) ! To calculate the ending address of the page boundary, call ! LIB$GETSYIW to get the processor-specific page size, PAGE_MAX STATUS = LIB$GETSYI(SYI$_PAGE_SIZE,PAGE_MAX,,,,) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) MY_ADR(1) = %LOC(IARRAY(1)) (1) MY_ADR(2) = MY_ADR(1) + PAGE_MAX -1 ! Flags for call to SYS$CRMPSC SEC_FLAGS = SEC$M_PAGFIL.OR.SEC$M_GBL.OR.SEC$M_WRT.OR.SEC$M_DZRO ! Create and map the temporary global section STATUS = SYS$CRMPSC(MY_ADR,OUT_ADR,,%VAL(SEC_FLAGS), & (4) NAME,,,,%VAL(1),,,) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ! Manipulate the data in the global section (5) DO 10 I = 1,50 IARRAY(I) = I END DO STATUS = SYS$SETEF(%VAL(72)) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) TYPE *,'Waiting for PAGEFIL2 to update section' STATUS = SYS$WAITFR(%VAL(73)) ! Print the array modified by PAGEFIL2 in the global section TYPE *, 'Modified data in the global section:' WRITE (6,100) (IARRAY(I), I=1,50) 100 FORMAT(10I5) END PROGRAM |
! File: PAGEFIL2.F90 ! ! This program maps and modifies a global section after PAGEFIL1 ! creates the section. Programs PAGEFIL1 and PAGEFIL2 synchronize ! the processing of the global section through the use of common ! event flags. IMPLICIT INTEGER (KIND=4) (A - Z) INCLUDE '($SECDEF)' INCLUDE '($SYSSRVNAM)' INCLUDE '($SYIDEF)' DIMENSION MY_ADR(2) (1) COMMON /MYCOM/ IARRAY(50) VOLATILE /MYCOM/ (2) ! Call LIB$GETSYIW to get page size, PAGE_MAX STATUS = LIB$GETSYI(SYI$_PAGE_SIZE,PAGE_MAX,,,,) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) MY_ADR(1) = %LOC(IARRAY(1)) (1) MY_ADR(2) = MY_ADR(1) + PAGE_MAX -1 ! Associate with common cluster MYCLUS and wait for ! event flag to be set STATUS = SYS$ASCEFC(%VAL(64),'MYCLUS',,) (3) IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) STATUS = SYS$WAITFR (%VAL(72)) IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) ! Set flag to allow section to be written FLAGS = SEC$M_WRT ! Map the global section STATUS = SYS$MGBLSC(MY_ADR,,,%VAL(FLAGS),'GSEC',,) (6) IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) ! Print out the data in the global section and (7) ! multiply each value by two TYPE *, 'Original data in the global section:' WRITE (6,100) (IARRAY(I), I=1,50) 100 FORMAT (10I5) DO I=1,50 (8) IARRAY(I) = IARRAY(I) * 2 END DO ! Set an event flag to allow PAGEFIL1 to continue execution STATUS = SYS$SETEF(%VAL(73)) IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS)) END PROGRAM |
The options file PAGEFIL.OPT contains the following line of source text:
PSECT_ATTR=MYCOM,PAGE,SHR,WRT,SOLITARY (1) COLLECT=SHARED_CLUS,MYCOM (9) |
$ FORTRAN /ALIGN=NATURAL PAGEFIL1 $ FORTRAN/ALIGN=NATURAL PAGEFIL2 $ LINK PAGEFIL1,PAGEFIL/OPTIONS (1) $ LINK PAGEFIL2,PAGEFIL/OPTIONS (1) $ RUN PAGEFIL1 !***Process 1*** Waiting for PAGEFIL2 to update section (10) Modified data in the global section: 2 4 6 8 10 12 14 16 18 20 22 24 26 28 30 32 34 36 38 40 42 44 46 48 50 52 54 56 58 60 62 64 66 68 70 72 74 76 78 80 82 84 86 88 90 92 94 96 98 100 $ $ RUN PAGEFIL2 !***Process 2*** Original data in the global section: (10) 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 $ |
Waiting for PAGEFIL2 to update section |
For More Information:
On the VOLATILE statement, see the Compaq Fortran Language Reference Manual.
E.5 Sharing Data
The program called SHAREDFIL is used to update records in a relative file. The SHARE qualifier is specified on the OPEN statement to invoke the RMS file sharing facility. In this example, the same program is used to access the file from two processes:
! File: SHAREDFIL.F90 ! ! This program can be run from two or more processes to demonstrate the ! use of an RMS shared file to share data. The program requires the ! relative file named REL.DAT. IMPLICIT INTEGER (KIND=4) (A - Z) CHARACTER(LEN=20) RECORD INCLUDE '($FORIOSDEF)' (1) OPEN (UNIT=1, FILE='REL', STATUS='OLD', SHARED, & (2) ORGANIZATION='RELATIVE', ACCESS='DIRECT', FORM='FORMATTED') (3) ! Request record to be examined 100 TYPE 10 10 FORMAT ('$Record number (Ctrl/Z to quit): ') READ (*,*, END=999) REC_NUM ! Get record from file READ (1,20, REC=REC_NUM, IOSTAT=STATUS), REC_LEN, RECORD 20 FORMAT (Q, A) ! Check I/O status IF (STATUS .EQ. 0) THEN TYPE *, RECORD(1:REC_LEN) (5) ELSE IF (STATUS .EQ. FOR$IOS_ATTACCNON) THEN TYPE *, 'Nonexistent record.' GOTO 100 ELSE IF (STATUS .EQ. FOR$IOS_RECNUMOUT) THEN TYPE *, 'Record number out of range.' GOTO 100 ELSE IF (STATUS .EQ. FOR$IOS_SPERECLOC) THEN TYPE *, 'Record locked by someone else.' (4) GOTO 100 ELSE CALL ERRSNS (, RMS_STS, RMS_STV,,) CALL LIB$SIGNAL (%VAL(RMS_STS), %VAL(RMS_STV)) ENDIF ! Request updated record TYPE 30 30 FORMAT ('$New Value or CR: ') READ (*,20) REC_LEN, RECORD IF (REC_LEN .NE. 0) THEN WRITE (1,40, REC=REC_NUM, IOSTAT=STATUS) RECORD(1:REC_LEN) 40 FORMAT (A) IF (STATUS .NE. 0) THEN CALL ERRSNS (, RMS_STS, RMS_STV,,) CALL LIB$SIGNAL(%VAL(RMS_STS),%VAL(RMS_STV)) ENDIF ENDIF ! Loop GOTO 100 999 END PROGRAM |
Sample Use:
$ FORTRAN SHAREDFIL $ LINK SHAREDFIL $ RUN SHAREDFIL Record number (Ctrl/Z to quit): 2 MSPIGGY New Value or CR: FOZZIE Record number (Ctrl/Z to quit): 1 KERMIT New Value or CR: Record number (Ctrl/Z to quit): Ctrl/Z $ $ RUN SHAREDFIL Record number (Ctrl/Z to quit): 2 (4) Record locked by someone else. Record number (Ctrl/Z to quit): 2 Record locked by someone else. Record number (Ctrl/Z to quit): 2 FOZZIE New Value or CR: MSPIGGY Record number (Ctrl/Z to quit): Ctrl/Z (5) $ |
The following example calls SMG routines to format screen output.
No sample run is included for this example because the program requires a video terminal in order to execute properly.
! File: SMGOUTPUT.F90 ! ! This program calls Run-Time Library Screen Management routines ! to format screen output. IMPLICIT INTEGER (KIND=4) (A-Z) INCLUDE '($SMGDEF)' (1) ! Establish terminal screen as pasteboard STATUS = SMG$CREATE_PASTEBOARD (NEW_PID,,,) (2) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ! Establish a virtual display region STATUS = SMG$CREATE_VIRTUAL_DISPLAY (15,30,DISPLAY_ID,,,) (3) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ! Paste the virtual display to the screen, starting at ! row 2, column 15 STATUS = SMG$PASTE_VIRTUAL_DISPLAY(DISPLAY_ID,NEW_PID,2,15) (4) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ! Put a border around the display area STATUS = SMG$LABEL_BORDER(DISPLAY_ID,'This is the Border',,,,,) (5) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ! Write text lines to the screen STATUS = SMG$PUT_LINE (DISPLAY_ID,' ',,,,,) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) STATUS = SMG$PUT_LINE (DISPLAY_ID,'Howdy, pardner',2,,,,) (6) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) STATUS = SMG$PUT_LINE (DISPLAY_ID,'Double spaced lines...',2,,,,) (6) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) STATUS = SMG$PUT_LINE (DISPLAY_ID,'This line is blinking',2, & (7) SMG$M_BLINK,0,,) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) STATUS = SMG$PUT_LINE (DISPLAY_ID,'This line is reverse video',2, & (7) SMG$M_REVERSE,0,,) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) DO I = 1, 5 (8) STATUS = SMG$PUT_LINE (DISPLAY_ID,'Single spaced lines...',,,,,) IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS)) ENDDO END PROGRAM |
Previous | Next | Contents | Index |