*DECK DMLCLSR 
      PROC DMLCLSR (FITLIST,REALMORDLIST,ERRRTRN);
  
 #
* *   DMLCLSR - CLOSE RELATION INTERFACE ROUTINE
* 
*     J. G. SERPA                                      10/10/78 
* 
* DC  PURPOSE 
* 
*     ISSUE A CLOSE REQUEST TO CDCS FOR EACH REALM IN A RELATION
*     CHECK FOR AN ERROR CONDITION UPON RETURNING FROM CDCS.
*     ON ERROR, CAUSES A BRANCH TO AN ALTERNATE RETURN IN THE 
*     APPLICATION PROGRAM IF SPECIFIED, ELSE, RETURNS NORMALLY. 
*     AND RETURN THE FIT STATUS FIELD TO THE APPLICATION PROGRAM
* 
* DC  ENTRY CONDITIONS
* 
* DC  PARAMETERS
* 
*     FITLIST  --  FITLIST FOR RELATION TO BE CLOSED
* 
*     REALMORDLIST -- LIST OF REALM ORDINALS IN RELATION TO BE CLOSED 
* 
*     ERRRTRN  --  (OPTIONAL) ALTERNATE RETURN ON ERROR (FTN 5 ONLY)
*                  WARNING:  DO NOT REFERENCE - MAY NOT BE PRESENT
* 
* DC  ASSUMPTIONS 
* 
*     COMMON BLOCK DB0000 HAS BEEN GENERATED AND INITIALIZED
* 
* 
* DC  EXIT CONDITIONS 
* 
*     UPON RETURN FROM CDCS, THE FIT ES FIELD IS STORED 
*     IN DBSTAT AND IN DBSXXXX AND DBREALM IS SET TO THE
*     NAME OF THE REALM IN WHICH AN ERROR OCCURRED, IF ANY. 
*     CONTROL IS RETURNED TO THE APPLICATION PROGRAM. 
      THE RETURN POINT CAN BE ALTERED, GIVEN AN *ON ERROR*
*     LABEL AND THE DETECTION OF AN ERROR (FTN 5 ONLY). 
* 
* DC  CALLING ROUTINES
* 
*     DMLCLSR IS CALLED FROM THE APPLICATION PROGRAM
*     AS A RESULT OF A DML CLOSE RELATION STATEMENT.
* 
* DC  CALLED ROUTINES 
* 
*     DB$CLS  --     CDCS CLOSE INTERFACE ROUTINE 
* 
*     DMLRTRN  --  RETURN ROUTINE--SETS REGISTER TO RETURN PARAMETER
* 
* DC  NON-LOCAL VARIABLES 
* 
*     VARIABLES IN DB000 WHICH ARE MODIFIED ARE:  
*     DBSTAT, DBSXXXX, DBREALM
* 
* DC  DESCRIPTION 
* 
*     A CALL TO DMLCLSR IS GENERATED BY THE PREPASS AS
*     A RESULT OF A DML CLOSE RELATION STATEMENT. DMLCLSR ISSUES
*     A CLOSE REQUEST TO CDCS FOR EACH REALM IN FITLIST 
*     DMLCLSR RETURNS THE FIT STATUS FIELDS TO THE APPLICATION
*     PROGRAM AND RETURNS CONTROL TO THE APPLICATION PROGRAM
*     WITH FORTRAN 5, AN ALTERNATE RETURN CAN BE SPECIFIED.  IF AN
*     ERROR IS DETECTED, CONTROL IS PASSED TO THE SPECIFIED LABEL 
*     IN THE APPLICATION PROGRAM. 
* 
 #
      CONTROL EJECT;
      CONTROL INERT;
      CONTROL DISJOINT; 
  
                                   #---------------DEFS----------------#
  
      DEF  RDNTCLS   #O"654"#;     # REDUNDANT CLOSE CODE - CDCS       #
      DEF  FITLENGTH # 35#;        # LENGTH OF FIT IN WORDS            #
      DEF  WC        # 10#;        # LENGTH OF WORD IN CHARACTERS      #
  
#     PARAMETERS PASSED IN THE CALL TO DMLRLCL                         #
  
      ARRAY FITLIST;               # CONTAINS LIST OF FIT ADDRESSES OF #
          ITEM FITADDR;            # REALMS IN RELATION                #
  
      ARRAY REALMORDLIST;          # CONTAINS ORDINALS OF REAMLS IN    #
          ITEM REALMORD;           # RELATION                          #
  
      ITEM ERRRTRN;                # ERROR RETURN PARAMETER            #
                                   # WARNING: DO NOT REFERENCE         #
  
#     THE FOLLOWING COMMON BLOCK DESCRIBES VARIABLES CREATED IN THE    #
#     FORTRAN APPLICATIONS PROGRAM                                     #
  
      COMMON DB0000;
*CALL DB0DCLS                      COMMON BLOCK DB0000 DECLARATIONS 
  
      BASED ARRAY FIT[0:0] S(FITLENGTH);    # USER FIT                 #
  
*CALL FITDCLS                      STANDARD FIT DECLARATIONS
                                        #------------XREFS-------------#
  
      XREF
        BEGIN 
        PROC DB$CLS;                    # CLOSE INTERFACE ROUTINE      #
        PROC DMLRTRN;                   # SET RETURN REGISTER ROUTINE  #
        END 
  
                                        #----------LOCAL ITEMS---------#
  
      ITEM I;                           # DUMMY INDEX VARIABLE         #
      ITEM RTNPARM;                     # RETURN PARAMETER - DMLRTRN   #
  
      CONTROL EJECT;
      BEGIN 
  
      DBSTAT = 0;                       # ZERO ERROR STATUS            #
      DBREALM = " ";                    # ZERO REALM ERROR             #
  
#     ISSUE DB$CLS CALLS FOR EACH REALM IN FITLIST                     #
  
      FOR I = 0 STEP 1 WHILE FITADDR[I] NQ 0 DO 
          BEGIN 
          P<FIT> = FITADDR[I];      # SET UP POINTER TO FIT            #
  
                                        # CALL CDCS TO CLOSE EACH REALM#
          DB$CLS(FIT,REALMORD[I]);
                                        # IF REDUNDANT CLOSE ON REALM  #
          IF FITES[0] EQ RDNTCLS
          THEN
            BEGIN 
            FITES[0] = 0;               # IGNORE IT                    #
            TEST; 
            END 
  
# CHECK ERROR STATUS ON CDCS CALL                                      #
  
          IF FITES[0] NQ 0          # CLOSE NOT SUCCESSFUL             #
          THEN BEGIN
               DBSTAT = FITES[0]; 
               P<REALMBLOCK> = FITADDR[I] - 4;
               DBSXXXX[0] = DBSTAT; 
               DBREALM = DBRXXXX[0];
               RTNPARM = 1;        # SET THE ERROR FLAG                #
               DMLRTRN(RTNPARM);   # SET RETURN REGISTER TO ERROR      #
               RETURN;             # RETURN TO APPLICATION PGRM        #
               END
          END 
  
      RTNPARM = 0;                      # RESET THE ERROR FLAG         #
  
      DMLRTRN(RTNPARM);                 # SET RETURN REGISTER TO NORMAL#
  
      RETURN;                           # RETURN TO APPLICATION PGRM   #
  
      END 
      TERM
