This document covers the following topics:
PROGRAM FEX1
C AN EXAMPLE OF SOFT COUPLING WITH A SEARCH CRITERION WHICH
C CONTAINS FIELDS TAKEN FROM TWO FILES. THE FIELDS PERSONNEL-ID
C NAME, FIRST-NAME, BIRTH AND SEX (FROM THE MAIN FILE,
C PERSONNEL-ID) ARE PRINTED FOR RECORDS THAT SATISFY THE
C FOLLOWING CONDITION:
C PERSONNEL-ID BETWEEN 10000001 AND 19999999
C MODEL-YEAR-MAKE >
C CLASS = 'C'
CHARACTER*22 STARTS
CHARACTER*20 STARTM /'MERCEDES BENZ'/
CHARACTER*2 STAYM /'86'/
EQUIVALENCE (STARTS,STARTM)
EQUIVALENCE (STARTS(21:21),STAYM)
C
EXEC ADABAS
BEGIN DECLARE SECTION
END-EXEC
C
EXEC ADABAS
DECLARE EMPL CURSOR FOR
SELECT PERSONNEL-ID, NAME, FIRST-NAME, BIRTH, SEX
FROM EMPLOYEES, VEHICLES
WHERE EMPLOYEES.PERSONNEL-ID = VEHICLES.PERSONNEL-ID
AND PERSONNEL-ID BETWEEN '10000001' AND '19999999'
AND VEHICLES.MODEL-YEAR-MAKE > :STARTS
AND VEHICLES.CLASS = 'C'
END-EXEC
C
WRITE (6,10)
C
EXEC ADABAS
OPEN EMPL
END-EXEC
C
EXEC ADABAS
FETCH EMPL
END-EXEC
C
1 IF (SQLCOD .EQ. 3) GOTO 2
C
WRITE (6,20) PID,NAME,FNAME,BIRTH,SEX
C
EXEC ADABAS
FETCH EMPL
END-EXEC
C
GOTO 1
C
2 CONTINUE
C
EXEC ADABAS
CLOSE EMPL
END-EXEC
C
EXEC ADABAS
DBCLOSE
END-EXEC
C
10 FORMAT ('1PERSONNEL-ID',8X,'NAME',13X,'FIRST-NAME',8X,
* 'BIRTH',1X,'SEX' / 1X,64('*') / )
20 FORMAT (3X,A8,3X,A20,1X,A20,1X,A6,1X,A1)
C
END
PROGRAM FEX2
C DELETE AN EMPLOYEE RECORD AND RELEASE ALL CARS WHICH ARE
C ASSIGNED TO THIS EMPLOYEE. A PRIVATE CARS WILL BE DELETED
C AND A COMPANY CAR WILL BE MADE A POOL-CAR WHICH IS IDENTIFIED
C BY ITS PERSONNEL-ID CONTAINING ONLY THE COUNTRY CODE.
C
CHARACTER*8 PERSNR /'20007100'/
INTEGER*4 EMPISN
CHARACTER*15 CNUM
CHARACTER*1 CNO
EQUIVALENCE (CNUM,CNO)
C
EXEC ADABAS
BEGIN DECLARE SECTION
END-EXEC
C
EXEC ADABAS
READ LOGICAL
DECLARE VEH1 CURSOR FOR
SELECT REG-NUM, PERSONNEL-ID, CLASS
FROM VEHICLES
WHERE PERSONNEL-ID GE :PERSNR
OPTIONS HOLD
ORDER BY PERSONNEL-ID
END-EXEC
C
C FIND EMPLOYEE
C
EXEC ADABAS
FIND
SELECT
FROM EMPLOYEES EMPL1
WHERE PERSONNEL-ID = :PERSNR
OPTIONS HOLD
END-EXEC
C
C IF THE PERSONNEL-ID EXISTS DELETE THE EMPLOYEE AND READ THE
C VEHICLES FILE
C
IF (SQLQTY .EQ. 1) THEN
EMPISN = SQLISN
GOTO 3
1 GOTO 4
ELSE
WRITE (6,10) PERSNR
END IF
C
2 CONTINUE
C
EXEC ADABAS
DBCLOSE
END-EXEC
C
STOP
C
C*** DELETE EMPLOYEE
C
3 CONTINUE
C
EXEC ADABAS
DELETE
FROM EMPLOYEES
WHERE ISN = :EMPISN
END-EXEC
C
WRITE (6,20) PERSNR
C
GOTO 1
C
C*** DEALLOCATE CARS
C
4 CONTINUE
C
EXEC ADABAS
OPEN VEH1
END-EXEC
C
EXEC ADABAS
FETCH VEH1
END-EXEC
C
5 IF (SQLCOD .EQ. 3 .OR. PID .NE. PERSNR) GOTO 6
C
IF (CLASS .EQ. 'P') THEN
EXEC ADABAS
DELETE
FROM VEHICLES
WHERE CURRENT OF VEH1
END-EXEC
WRITE (6,30) REGNUM
ELSE
CNUM = PID
PID = CNO
EXEC ADABAS
UPDATE VEHICLES
WHERE CURRENT OF VEH1
END-EXEC
WRITE (6,40) REGNUM
END IF
C
EXEC ADABAS
FETCH VEH1
END-EXEC
C
GOTO 5
C
6 CONTINUE
C
EXEC ADABAS
CLOSE VEH1
END-EXEC
C
EXEC ADABAS
COMMIT WORK
END-EXEC
C
GOTO 2
C
10 FORMAT (' NO EMPLOYEE FOUND WITH PERSONNEL-ID ',A8)
20 FORMAT (' EMPLOYEE ',A8,' HAS BEEN DELETED')
30 FORMAT (' PRIVATE CAR ',A15,' HAS BEEN DELETED')
40 FORMAT (' COMPANY CAR ',A15,' HAS BEEN UPDATED')
END
PROGRAM FEX3
C SALARY INCREASE.
C THIS PROGRAM INCREASES THE SALARY OF EVERY EMPLOYEE BY
C 4 PERCENT.
C THE DEPARTMENT, THE OVERALL AMOUNT OF PAY RISE FOR THE
C DEPARTMENT AND THE PAY RISE FOR ALL DEPARTMENTS WILL BE PRINTED
C OUT.
C THE PROGRAM IS RESTARTABLE. AFTER AN ABNORMAL TERMINATION THE
C PROGRAM EXECUTION WOULD RESTART WITH THE LAST DEPARTMENT
C WHOSE SALARY UPDATE HAD BEEN COMPLETED BEFORE THE ABEND
C OCCURED.
C
CHARACTER*10 COMDAT
CHARACTER*6 COMDEP
INTEGER*4 COMSUM
EQUIVALENCE (COMDAT,COMDEP)
EQUIVALENCE (COMDAT(7:7),COMSUM)
CHARACTER*6 SDEP
INTEGER*4 IND, I, J, NEWSAL, INCRS, SUMDEP, SUMTOT, E1QTY
C
EXEC ADABAS
BEGIN DECLARE SECTION
END-EXEC
C
EXEC ADABAS
HISTOGRAM
DECLARE EMP1 CURSOR FOR
SELECT DEPT
FROM EMPLOYEES E1
WHERE DEPT GE :COMDEP
OPTIONS PREFIX=E1
GROUP BY DEPT
END-EXEC
C
EXEC ADABAS
READ LOGICAL
DECLARE EMP2 CURSOR FOR
SELECT PERSONNEL-ID, DEPT, SALARY, INCOME(COUNT)
FROM EMPLOYEES
WHERE DEPT GE :SDEP
OPTIONS HOLD
ORDER BY DEPT
END-EXEC
C
EXEC ADABAS
CONNECT 'INCREASE'
UPD=EMPLOYEES
AND USERDATA INTO :COMDAT
END-EXEC
C
C A HISTOGRAM STATEMENT IS USED TO ASCERTAIN THE NUMBER OF
C EMPLOYEES PER DEPARTMENT
C
EXEC ADABAS
OPEN EMP1
END-EXEC
C
EXEC ADABAS
FETCH EMP1
END-EXEC
E1QTY = SQLQTY
C
IF (COMDAT .NE. ' ') THEN
C
C RESTART PROCESSING
C
WRITE (6,*) 'LAST PROGRAM RUN TERMINATED ABNORMALLY'
WRITE (6,50) COMDEP
C
EXEC ADABAS
FETCH EMP1
END-EXEC.
E1QTY = SQLQTY
END IF
C
SDEP = E1DEPT
C
EXEC ADABAS
OPEN EMP2
END-EXEC
C
WRITE (6,10)
C
1 IF (SQLCOD .EQ. 3) GOTO 4
C
C THE EMPLOYEES FILE WILL BE READ UNTIL ALL RECORDS FOR THE
C DEPARTMENT HAVE BEEN PROCESSED AND THE SALARY HAS BEEN
C UPDATED
C
DO 3 J=1, E1QTY
EXEC ADABAS
FETCH EMP2
END-EXEC
C THE SALARY INCREASE CAN BE EXECUTED WHEN THE COUNT OF THE
C PERIODIC GROUP IS LESS THAN 40.
IF (CINC .LT. 40) THEN
INCRS = NINT(REAL(SALARY(1)) * 0.04)
NEWSAL = SALARY(1) + INCRS
IND = CINC + 1
C
DO 2 I = CINC, 0, -1
SALARY(IND) = SALARY(I)
IND = IND - 1
2 CONTINUE
C
SALARY(1) = NEWSAL
C
EXEC ADABAS
UPDATE EMPLOYEES
WHERE CURRENT OF EMP2
END-EXEC
C
SUMDEP = SUMDEP + INCRS
SUMTOT = SUMTOT + INCRS
ELSE
WRITE (6,40) PID
END IF
C
3 CONTINUE
C
WRITE (6,20) DEPT, SUMDEP
SUMDEP = 0
C
COMDEP = DEPT
COMSUM = SUMTOT
EXEC ADABAS
COMMIT WORK
USERDATA = :COMDAT
END-EXEC
C
EXEC ADABAS
FETCH EMP1
END-EXEC
E1QTY = SQLQTY
C
GOTO 1
C
4 CONTINUE
C
EXEC ADABAS
CLOSE EMP1
END-EXEC
C
EXEC ADABAS
CLOSE EMP2
END-EXEC
C
WRITE (6,30) SUMTOT
COMDAT = ' '
C
EXEC ADABAS
DBCLOSE
USERDATA = :COMDAT
END-EXEC
C
10 FORMAT (' DEPARTMENT',15X,'SALARY INCREASE'/1X,40('*'))
20 FORMAT (4X,A6,16X,I10)
30 FORMAT (/50('-')//' TOTAL SALARY INCREASE : ',I11)
40 FORMAT (' UPDATE PERSON ',A8,' NOT POSSIBLE')
50 FORMAT (' LAST DEPARTMENT WAS ',A6)
END