Version 2.4.1
 —  Adabas Native SQL Reference Manual  —

APPENDIX H - FORTRAN EXAMPLES

This document covers the following topics:


Example 1

      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

Top of page

Example 2

      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

Top of page

Example 3

      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

Top of page