Adabas ダイレクトコールを使用する VAX-11 FORTRAN の例です。付録 B で定義された Adabas ファイルが使用されています。
PROGRAM EXAMPLE
C******************************************************** C * C A D A B A S / V M S FORTRAN example program * C --------------------------------------------- * C * C Compile, link and run this program by typing: * C * C $ FORTRAN EXAMPLE * C $ LINK EXAMPLE * C $ RUN EXAMPLE * C * C Function: * C * C Find in the default database all people * C named 'SMITH' and increase their salary * C by 10% * C * C********************************************************
BYTE EXAMPLE_DB,
2 EMPLOYEES_FILE
PARAMETER (EXAMPLE_DB = 0, ! Use default database
2 EMPLOYEES_FILE = 11) ! and example file ! 'EMPLOYEES'
INCLUDE 'EXAINC /LIST'
CHARACTER*(*) FB, SB, VB
PARAMETER (FB = 'ASN,4,F.',
2 SB = 'AE,5.',
2 VB = 'SMITH')
STRUCTURE /RECORD_BUFFER/
UNION
MAP ! Preset for the OPEN call
CHARACTER*7 OP /'UPD=11.'/
END MAP
MAP
INTEGER*4 SALARY
END MAP
END UNION
END STRUCTURE
RECORD /RECORD_BUFFER/ RB ! Record Buffer
INTEGER*4 OLD_SALARY,
2 UPD_COUNT /0/ ! No. of records updated
LOGICAL OPEN_DATABASE, ! Functions
2 CLOSE_DATABASE, ! being referenced later
2 ISSUE_BT,
2 FIND_RECORD,
2 UPDATE_RECORD
WRITE (6,1)
CB.DB_ID = EXAMPLE_DB
IF (.NOT. OPEN_DATABASE (CB, RB.OP)) THEN
CALL RESPONSE(CB)
ELSE
CB.FILE_NUMBER = EMPLOYEES_FILE
CB.ISN_QUANTITY = 0
IF (FIND_RECORD (CB, FB, %DESCR(RB.SALARY), SB, VB)) THEN
WRITE (6,2) CB.ISN_QUANTITY
DO WHILE (CB.ISN_QUANTITY .NE. 0)
OLD_SALARY = RB.SALARY
IF (.NOT. UPDATE_RECORD (CB, FB, RB.SALARY, SB, VB)) THEN
CB.ISN_QUANTITY = 0
ELSE
WRITE (6,3) CB.ISN, OLD_SALARY, RB.SALARY
UPD_COUNT = UPD_COUNT + 1
IF (.NOT. FIND_RECORD (CB, FB, %DESCR(RB.SALARY),SB,VB))
2 THEN
CB.ISN_QUANTITY = 0
IF (CB.RESPONSE_CODE .EQ. 3) THEN
CB.RESPONSE_CODE = 0
END IF
END IF
END IF
END DO
END IF
IF (CB.RESPONSE_CODE .NE. 0) THEN
CALL RESPONSE (CB)
CB.RESPONSE_CODE = 0
IF (UPD_COUNT .NE. 0) THEN
IF (ISSUE_BT (CB)) THEN
UPD_COUNT = 0
ELSE
CALL RESPONSE (CB)
END IF
END IF
END IF
IF (CB.RESPONSE_CODE .EQ. 0) THEN
IF (.NOT. CLOSE_DATABASE (CB)) THEN
CALL RESPONSE (CB)
END IF
END IF
END IF
1 FORMAT (' FORTRAN example program for calling ADABAS (OpenVMS)')
2 FORMAT (' Found :',I5,' records')
3 FORMAT (' ISN =',I8,' old salary = ',I10,' new salary = ',I10)
END
LOGICAL FUNCTION OPEN_DATABASE (CB, RB)
INCLUDE 'EXAINC' ! ADABAS Control Block ! layout
CHARACTER*(*) RB
CB.COMMAND_CODE = 'OP'
CB.REC_BUF_LNG = LEN(RB)
CALL ADABAS (CB,,%REF(RB))
DO WHILE (CB.RESPONSE_CODE .EQ. 9)
CALL ADABAS (CB,,%REF(RB))
END DO
OPEN_DATABASE = (CB.RESPONSE_CODE .EQ. 0)
END
LOGICAL FUNCTION CLOSE_DATABASE (CB)
INCLUDE 'EXAINC' ! ADABAS Control Block ! layout
CB.COMMAND_CODE = 'CL'
CALL ADABAS (CB)
CLOSE_DATABASE = (CB.RESPONSE_CODE .EQ. 0)
END
LOGICAL FUNCTION ISSUE_BT (CB)
INCLUDE 'EXAINC' ! ADABAS Control Block ! layout
CB.COMMAND_CODE = 'BT'
CALL ADABAS (CB)
ISSUE_BT = (CB.RESPONSE_CODE .EQ. 0)
END
LOGICAL FUNCTION FIND_RECORD (CB, FB, RB, SB, VB)
INCLUDE 'EXAINC' ! ADABAS Control Block ! layout
CHARACTER*(*) FB, RB, SB, VB
INTEGER*4 IB ! ISN Buffer
CB.COMMAND_CODE = 'L4'
IF (CB.ISN_QUANTITY .EQ. 0) THEN
CB.COMMAND_CODE = 'S4'
CB.COMMAND_ID = 'FIND'
CB.FMT_BUF_LNG = LEN(FB)
CB.REC_BUF_LNG = LEN(RB)
CB.SEA_BUF_LNG = LEN(SB)
CB.VAL_BUF_LNG = LEN(VB)
CB.ISN_BUF_LNG = 4
CB.CMD_OPT_2 = 'N'
END IF
CALL ADABAS (CB, %REF(FB), %REF(RB), %REF(SB), %REF(VB), IB)
FIND_RECORD = (CB.RESPONSE_CODE .EQ. 0)
END
LOGICAL FUNCTION UPDATE_RECORD (CB, FB, RB)
INCLUDE 'EXAINC' ! ADABAS Control Block ! layout
STRUCTURE /RECORD_BUFFER/
INTEGER*4 SALARY
END STRUCTURE
CHARACTER*(*) FB
RECORD /RECORD_BUFFER/ RB ! Record Buffer
RB.SALARY = RB.SALARY + RB.SALARY / 10
CB.COMMAND_CODE = 'A1'
CALL ADABAS (CB, %REF(FB), %REF(RB))
UPDATE_RECORD = (CB.RESPONSE_CODE .EQ. 0)
END
SUBROUTINE RESPONSE (CB)
INCLUDE 'EXAINC' ! ADABAS Control Block ! layout
WRITE (6,2) CB.RESPONSE_CODE, CB.COMMAND_CODE
2 FORMAT (' ** Response Code ', I<ALOG10(FLOATI(CB.RESPONSE_CODE))+1>,
2 ' from ADABAS for command ', A2)
END
STRUCTURE /CONTROL_BLOCK/
CHARACTER*2 %FILL,
2 COMMAND_CODE
CHARACTER*4 COMMAND_ID
BYTE FILE_NUMBER,
2 DB_ID
INTEGER*2 RESPONSE_CODE
INTEGER*4 ISN,
2 ISN_LL,
2 ISN_QUANTITY
INTEGER*2 FMT_BUF_LNG,
2 REC_BUF_LNG,
2 SEA_BUF_LNG,
2 VAL_BUF_LNG,
2 ISN_BUF_LNG
CHARACTER*1 CMD_OPT_1,
2 CMD_OPT_2
CHARACTER*8 ADDITIONS_1
CHARACTER*4 ADDITIONS_2
CHARACTER*8 ADDITIONS_3,
2 ADDITIONS_4,
2 ADDITIONS_5
INTEGER*4 COMMAND_TIME
CHARACTER*4 USER_AREA
END STRUCTURE
RECORD /CONTROL_BLOCK/ CB ! Control Block