*DECK DMLOPN                                                            004270
      PROC DMLOPN (FIT,REALMORD,MODE,ERRRTRN);
  BEGIN                                                                 004290
 #
* *   DMLOPN - OPEN INTERFACE ROUTINE 
*     R. E. FOX                                      4/25/77
* 
* DC  PURPOSE 
* 
*     ISSUE AN OPEN REQUEST TO CDCS AND 
*     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. 
* 
* DC  ENTRY CONDITIONS
* 
* DC  PARAMETERS
* 
*     FIT  --    APPLICATION PROGRAM FIT FOR REALM TO BE OPENED 
* 
*     REALMORD  -- ORDINAL OF THE REALM TO BE OPENED
* 
*     MODE  --    USAGE MODE - "I", "IO", OR "O"
* 
*     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 THE DML STATEMENT. 
*     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
* 
*     DMLOPN IS CALLED FROM THE APPLICATION PROGRAM 
*     AS A RESULT OF A DML OPEN STATEMENT.
* 
* DC  CALLED ROUTINES 
* 
*     DB$OPN  --     CDCS OPEN INTERFACE ROUTINE
* 
*     DMLRTRN  --  RETURN ROUTINE--SETS REGISTER TO RETURN PARAMETER
* 
* DC  NON-LOCAL VARIABLES 
* 
*     VARIABLES IN DB0000 WHICH ARE MODIFIED ARE: 
*     DBSTAT, DBSXXXX, DBREALM
* 
* DC  DESCRIPTION 
* 
*     A CALL TO DMLOPN IS GENERATED BY THE PREPASS AS 
*     A RESULT OF A DML OPEN STATEMENT.  DMLOPN CONVERTS THE USER-
*     SPECIFIED MODE INTO A CRM CODE AND STORES IT IN THE FIT.
*     DMLOPN THEN ISSUES THE OPEN 
*     REQUEST TO CDCS, 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;                                                    004300
      CONTROL DISJOINT;                                                 004310
      CONTROL INERT;                                                    004320
                                                                        004330
                                        #-------------DEFS-------------#
  
      DEF RDNTOPN     #O"652"#;         # REDUNDANT OPEN CODE - CDCS   #
      DEF FITSIZE     #35#;             # SIZE OF FIT IN WORDS         #004360
                                                                        004370
# THE FOLLOWING ARE PARAMETERS FROM THE "OPEN" CALLING SEQUENCE        #004380
                                                                        004390
      ARRAY FIT;                 # USER FIT                            #004400
*CALL FITDCLS                                                           004410
                                                                        004420
      ITEM REALMORD;                        # REALM ORDINAL            #004430
                                                                        004440
      ITEM MODE C(10);                  # USAGE MODE                   #004450
                                        # POSSIBLE VALUES ARE:         #004460
                                        # "I" FOR INPUT ONLY           #004470
                                        # "IO" FOR INPUT OR OUTPUT     #004480
                                        # "O" FOR OUTPUT ONLY-NEW FILE #004490
  
      ITEM ERRRTRN;                     # ERROR RETURN PARAMETER       #
                                        # WARNING: DO NOT REFERENCE    #
                                                                        004500
# THE FOLLOWING DESCRIBES THE COMMON BLOCK CREATED IN THE FORTRAN      #004510
#     PROGRAM                                                          #004520
                                                                        004530
      COMMON DB0000;                                                    004540
*CALL DB0DCLS                                                           004550
                                                                        004560
                                        #------------XREFS-------------#
  
      XREF
        BEGIN 
        PROC DB$OPN;                    # OPEN INTERFACE ROUTINE       #
        PROC DMLRTRN;                   # SET RETURN REGISTER ROUTINE  #
        END 
  
                                        #----------LOCAL ITEMS---------#
  
      ITEM RTNPARM;                     # RETURN PARAMETER - DMLRTRN   #
  
      CONTROL EJECT;                                                    004630
# SET UP POINTER TO REALMBLOCK                                         #004640
                                                                        004650
      P<REALMBLOCK> = LOC(FIT) - 4;                                     004660
      P<DBTXXXX> = LOC(FIT) + FITSIZE;                                  000230
                                                                        004670
# STORE USER-SPECIFIED MODE IN PD FIELD OF FIT                         #004680
                                                                        004690
      IF MODE EQ "IO"                   # INPUT OR OUTPUT              #004700
      THEN                                                              004710
        FITPD[0] = O"3";                # CRM CODE FOR IO              #004720
      ELSE                                                              004730
        IF MODE EQ "I"                  # INPUT ONLY                   #004740
        THEN                                                            004750
          FITPD[0] = O"1";              # CRM CODE FOR I               #004760
        ELSE                                                            004770
          IF MODE EQ "O"                # OUTPUT ONLY - NEW FILE       #004780
          THEN                                                          004790
            FITPD[0] = O"2";            # CRM CODE FOR O               #004800
                                                                        004830
                                                                        004840
# PERFORM OPEN CALL AND PASS FIT AND REALM ORDINAL                     #004850
                                                                        004860
      DB$OPN(FIT,REALMORD);                                             004870
                                                                        004880
# RETURN ERROR STATUS FIELD OF FIT                                     #004890
                                                                        004900
      DBSTAT = FITES[0];                                                004910
      DBSXXXX = FITES[0];                                               000230
      DBREALM = DBRXXXX;                                                000240
  
# CHECK ERROR STATUS ON CDCS CALL                                      #
  
      IF (FITES[0] NQ 0)                # IF CDCS/CRM ERROR OCCURRED   #
        AND (FITES[0] NQ RDNTOPN)       # AND IT IS NOT REDUNDANT OPEN #
      THEN
        RTNPARM = 1;                    # SET THE RETURN PARAMETER TO 1#
      ELSE                              #             ELSE             #
        RTNPARM = 0;                    # SET THE RETURN PARAMETER TO 0#
  
# SET THE RETURN REGISTER                                              #
  
      DMLRTRN(RTNPARM); 
  
# RETURN TO THE APPLICATION PROGRAM                                    #
  
      RETURN;                                                           004940
      END                                                               004950
TERM                                                                    004960
