dorl@vms.macc.wisc.edu (Michael Dorl - MACC) (07/29/88)
******** user_open.common ********
C Common Declarations to communicate between User_Open_Init/Param and
C User_Open
Include '($XABDef)'
Include '($XABKeyDef)'
Include '($XABProDef)'
Include '($XABDatDef)'
Include '($FABDef)'
Include '($RABDef)'
Include '($PSLDef)'
Integer Status, Status_Value ! 1=new, 2=old, 3=unknown
Integer LogNames, LogNames_Value !
Integer Prot ! protection flag
Integer *2 Prot_Value ! mask
Integer Prot_Active ! active
Integer DupKeys, DupKeys_Value ! duplicate key
Record /XABProDef1/ LUNXABPro(100)
Record /XABDatDef/ LUNXABDat(100)
Integer *4 LUNFab(100) ! LUN FAB Pointers
Integer *4 Unit ! Logical unit
Integer *4 User_Open_Status_Value
! Last status returned by
! User_Open
Character *256 ESA_Name ! Resultant file name
Integer *4 ESA_Name_L ! Length of above
Integer *4 What_Happened ! What happened on last open
! 0 = failed
! 1 = Open
! 2 = Create
Common /User_Open_Common/
$ Status, Status_Value,
$ LogNames, LogNames_Value,
$ Prot, Prot_Value, Prot_Active,
$ DupKeys, DupKeys_Value,
$ LUNXABPro,LUNFAB,
$ Unit, User_Open_Status_Value,
$ ESA_Name,ESA_Name_L, What_Happened,
$ LUNXABDat
******** user_open.for ********
Integer Function User_Open (Fab, Rab, Lun)
Implicit None
Include 'User_Open.Common'
Include '($IODef)/list'
C Parameter Definitions
Record /FABDef/ Fab
Record /RABDef/ Rab
Integer Lun
C Description
C User_Open is designed to be called from a Fortran Open statement
C through a UserOpen clause. Since it must do several different
C things, calls on it must be preceded with calls on User_Open_Init
C and User_Open_Param to tell it what needs to be done. These
C routines have the same calling sequence...
C
C Call User_Open_Init (What_String, P1, P2, ... P8)
C Call User_Open_Init (What_String, P1, P2, ... P8)
C
C What_String tells what kind of action User_Open should take while
C P1 - P8 provide provide parameters for that action.
C
C What_String Explanation
C
C 'Status_New' File to be created
C 'Status_Old' File exists
C 'Status_Unknown' Use old file or create
C 'Exec_Log' Don't use user logicals
C 'Protection' Set protection to P1
C 'Dup_Keys' Allow duplicate keys for key P1
C External Definitions
External Sys$Open, Sys$Create, Sys$Connect
Integer Sys$Open, Sys$Create, Sys$Connect
external Sys$put, Sys$Close
integer Sys$put, Sys$Close
C Local Definitions
Integer *4 X, Off, Byte, XAB_Addr, XAB_Last
Integer *2 Prot_IOSB
Integer *4 XABSave
Integer *4 Old_Prot
C Begin User_Open
Unit = Lun ! save unit in common
LUNFab(Lun) = %Loc(FAB)
C Set exec mode translate
If (LogNames) Then
X = PSL$C_EXEC
Off = FAB$V_LNm_Mode
Byte = Fab.FAB$B_ACModes
Call MvBits (X,0,FAB$S_LNm_Mode,Byte,Off)
Fab.FAB$B_AcModes = Byte
EndIf
C Wander through all of the XAB's doing whatever needs to be done
XAB_Last = 0
XAB_Addr = Fab.FAB$L_XAB
Do While (XAB_Addr .ne. 0)
XAB_Last = XAB_Addr
Call User_Open_XAB
$ (%Val(XAB_Addr),
$ %Val(XAB_Addr),
$ %Val(XAB_Addr),
$ XAB_Addr
$ )
EndDo
C If any options were not handled, handle them now!
Call User_Open_XAB_Last (%Val(XAB_Last), Fab)
C Open the file
If ((Status_Value .eq. 2) .or. (Status_Value .eq. 3)) Then
User_Open = Sys$Open (Fab)
If (User_Open) Then
What_Happened = 1
If (Prot_Active) Then
Old_Prot = LUNXABPro(Lun).XAB$W_Pro
! Put the protection flags back in the XAB since the
! Open filled in existing values.
LUNXABPro(Lun).XAB$W_Pro = Prot_Value
If ((User_Open) .and. (Old_Prot .ne. Prot_Value)) Then
User_Open = Sys$Close (Fab)
User_Open = Sys$Open (Fab)
EndIf
EndIf ! (Prot_Active)
EndIf ! (User_Open)
EndIf
If ((Status_Value .eq. 1) .or.
$ ((Status_Value .eq. 3) .and. (.not. User_Open))
$ ) Then
User_Open = Sys$Create (Fab)
If (User_Open) Then
What_Happened = 2
EndIf
EndIf
C If open worked, attach a record stream to it
If (User_Open) Then
User_Open = Sys$Connect (RAB)
Call User_Open_Name (%Val(Fab.Fab$L_Nam)) ! Glom onto the name
Else
What_Happened = 0
EndIf
User_Open_Status_Value = User_Open ! save status value for
! User_Open_Status
End ! User_Open
Subroutine User_Open_Init (What, P1, P2, P3, P4, P5, P6, P7, P8)
Implicit None
Include 'User_Open.Common'
C Description
C
C Call User_Open_Init (What_String, P1, P2, ... P8)
C Call User_Open_Init (What_String, P1, P2, ... P8)
C
C What_String tells what kind of action User_Open should take while
C P1 - P8 provide provide parameters for that action.
C
C What_String Explanation
C
C 'Status_New' File to be created
C 'Status_Old' File exists
C 'Status_Unknown' Use old file or create
C 'Exec_Log' Don't use user logicals
C 'Protection' Set protection to P1
C 'Dup_Keys' Allow duplicate keys for key P1
C
C Parameter Definition
Character *(*) What
Integer *4 P1, P2, P3, P4, P5, P6, P7, P8
C Local Definitions
Integer *4 LWord
Integer *2 Word
Equivalence (Word, LWord)
C Begin User_Open_Init
Status = 0
LogNames = 0
Prot = 0
Prot_Active = 0
DupKeys = 0
C Begin User_open_Param
Entry User_Open_Param (What, P1, P2, P3, P4, P5, P6, P7, P8)
If (What .eq. 'STATUS_NEW') Then
Status = 1
Status_Value = 1
Else If (What .eq. 'STATUS_OLD') Then
Status = 1
Status_Value = 2
Else If (What .eq. 'STATUS_UNKNOWN') Then
Status = 1
Status_Value = 3
Else If (What .eq. 'EXEC_LOG') Then
LogNames = 1
Else If (What .eq. 'PROTECTION') Then
Prot = 1
Prot_Active = 1
LWord = P1 ! nonsense to prevent
Prot_Value = Word ! integer overflow
Else If (What .eq. 'DUP_KEYS') Then
DupKeys = 1
DupKeys_Value = 1
Else
Print '(A)', ' Unknown User_Open_Parameter: ' // What
Call Lib$Stop (%Val(0))
EndIf
Return
End ! User_Open_Init User_Open_Param
Subroutine User_Open_XAB (XABKey, XABPro, XAB, XAB_Ptr)
Implicit None
Include 'User_Open.Common'
C External Definitions
Integer IOr
C Parameter Definitions
Record /XABDef/ XAB
Record /XABKeyDef/ XABKey
Record /XABProDef1/ XABPro
Integer XAB_Ptr
C Local Definitions
Integer T, B
C Begin User_Open_XAB
If (DupKeys) Then
If (
$ (XAB.XAB$B_Cod .eq. XAB$C_Key)
$ .and.
$ (XABKey.XAB$B_Ref .eq. DupKeys_Value)
$ )
$ Then
T = XAB$M_Dup
B = XABKey.XAB$B_Flg
B = IOr (B, T)
XABKey.XAB$B_Flg = B
DupKeys = 0
EndIf
EndIf
If (Prot) Then
If (XAB.XAB$B_Cod .eq. XAB$C_Pro) Then
XABPro.XAB$W_Pro = Prot_Value
Prot = 0
EndIf
EndIf
XAB_Ptr = XAB.XAB$L_Nxt
End ! User_Open_XAB
Subroutine User_Open_XAB_Last (XAB, FAB)
Implicit None
Include 'User_Open.Common'
C Parameter Definitions
Record /XABDef/ XAB
Record /FABDef/ FAB
c Call User_Open_XAB_Last (%Val(XAB_Last), Fab)
C If end of XABs and Protection not already handled, chain on a new XAB
If (Prot) Then
Call User_Open_XAB_Prot
$ (%Val(%Loc(LUNXABPro(Unit))),
$ %Val(%Loc(LUNXABPro(Unit))))
Prot = 0
If (%Loc(XAB) .ne. 0) Then
XAB.XAB$L_Nxt = %Loc(LUNXABPro(Unit))
Else
Fab.FAB$L_XAB = %Loc(LUNXABPro(Unit))
EndIf
C Add a date XAB
Call Set_XAB_L_Nxt (LUNXABPro(Unit), %Loc(LUNXABDat(Unit)))
Else
If (%Loc(XAB) .ne. 0) Then
XAB.XAB$L_Nxt = %Loc(LUNXABDat(Unit))
Else
Fab.FAB$L_XAB = %Loc(LUNXABDat(Unit))
EndIf
EndIf
Call Set_XAB_B_Cod (LUNXABDat(Unit), XAB$C_Dat)
Call Set_XAB_B_BLn (LUNXABDat(Unit), XAB$C_DatLen)
Call Set_XAB_L_Nxt (LUNXABDat(Unit), 0)
End ! User_Open_XAB_Last
Subroutine Set_XAB_B_Cod (XAB, V)
Implicit None
Include 'User_Open.Common'
Record /XABDef/ XAB
Byte V
XAB.XAB$B_Cod = V
End
Subroutine Set_XAB_B_BLn (XAB, V)
Implicit None
Include 'User_Open.Common'
Record /XABDef/ XAB
Byte V
XAB.XAB$B_BLn = V
End
Subroutine Set_XAB_L_Nxt (XAB, V)
Implicit None
Include 'User_Open.Common'
Record /XABDef/ XAB
Integer *4 V
XAB.XAB$L_Nxt = V
End
Subroutine User_Open_XAB_Prot (XAB, XABP)
Implicit None
Include 'User_Open.Common'
C Parameter Definition
Record /XABDef/ XAB
Record /XABProDef1/ XABP
C Begin User_Open_XAB_Prot
Call Lib$Movc5 (0,0,0,XAB$C_ProLen,XAB)
XAB.XAB$B_Cod = XAB$C_Pro
XAB.XAB$B_BLN = XAB$C_ProLen
XABP.XAB$W_Pro = Prot_Value
Return
End ! User_Open_XAB_Prot
Subroutine User_Close (Lun)
Implicit None
Integer Lun
Include 'User_Open.Common'
Call User_Open_exfab (%Val(LunFab(Lun)))
Call Sys$Close (%Val(LUNFAB(Lun)))
End
Subroutine user_open_exfab (fab)
implicit none
Include 'User_open.common'
integer xab_addr
Record /fabdef/ fab
XAB_Addr = Fab.FAB$L_XAB
Do While (XAB_Addr .ne. 0)
Call User_Open_exxab
$ (%Val(XAB_Addr),%Val(XAB_Addr),XAB_Addr)
EndDo
Return
End
Subroutine user_open_exxab (xab,xabpro,addr)
implicit none
include 'user_open.common'
record /xabdef/ xab
record /xabprodef1/ xabpro
integer addr
addr = XAB.XAB$L_Nxt
return
end
Subroutine User_Open_Name (N)
Implicit None
Include '($NamDef)'
Include 'User_Open.Common'
Record /NamDef/ N
Integer A
Integer L
A = N.Nam$L_ESA
L = N.Nam$B_ESL
Call User_Open_NameX (%Val(A), L)
Return
End ! User_Open_Name
Subroutine User_Open_NameX (A, L)
Implicit None
Include 'User_Open.Common'
Integer I
Byte A(255)
Integer L
If ((%Loc(A) .eq. 0) .or. (L .eq. 0)) Then
Esa_Name = ' '
Esa_Name_L = 0
Else
Do I = 1,L
Esa_Name(I:I) = Char(A(I))
EndDo
Esa_Name_L = L
End If
Return
End ! User_Open_NameX
Integer Function User_Open_Get_Status_Value ()
Implicit None
Include 'User_Open.Common'
User_Open_Get_Status_Value = User_Open_Status_Value
Return
End
Subroutine User_Open_Get_Name (S)
Implicit None
Include 'User_Open.Common'
Character *(*) S
Integer X
X = ESA_Name_L
If (X .gt. Len(S)) Then
X = Len(S)
EndIf
If (X .gt. 0) Then
S = ESA_Name(1:X)
Else
S = ' '
EndIf
Return
End ! User_Open_Get_Name
Integer Function User_Open_Get_What_Happened
Implicit None
Include 'User_Open.Common'
User_Open_Get_What_Happened = What_Happened
Return
End ! User_Open_Get_What_Happened
Subroutine User_Open_Get_CDT (LUN, CDT)
Implicit None
Include 'User_Open.Common'
C Parameter definitions
Integer *4 LUN
Character *(*) CDT
C External routines
Integer Sys$AscTim
C Local definitions
Integer *4 XStatus, CDT_Lg
C Begin User_Open_Get_CDT
CDT = ' '
XStatus = Sys$AscTim
$ (CDT_Lg, CDT, LUNXABDat(LUN).XAB$Q_CDT, 0)
End ! User_Open_Get_CDT
******** end ********
%%end part e
thats all folks...
Michael Dorl (608) 262-0466
dorl@vms.macc.wisc.edu
dorl@wiscmacc.bitnet