HP 3000 Manuals HP 3000 Manuals
FORTRAN Example Program
$STANDARD_LEVEL SYSTEM
$TABLES ON
$CODE_OFFSETS ON
*********************************************************************
* *
* This FORTRAN program gives examples of calling System *
* Dictionary intrinsics. The examples in this program include *
* *
* Subroutine Example *
* ================= ========================================== *
* OpenDictionary Shows how to open a System Dictionary *
* *
* CloseDictionary Shows how to close a System Dictionary *
* *
* FindElements Shows how to find relationships, when *
* only one of the entities is known, using *
* the SDFindRelList intrinsic. *
* *
* FindByNumber The same example as FindElements, but *
* using internal numbers *
* *
* CreateElement Shows how to create an entity occurrence *
* using both internal and external names *
* *
* LinkElement Shows how to link a local domain entity *
* to a common domain entity *
* *
* RemoveRelationshipLink Shows how to remove a link between a *
* local domain relationship and a common *
* domain relationship *
* *
*********************************************************************
$PAGE
Program FortranExample
Integer*4 Dcb
Common Dcb(30)
Call OpenDictionary
Call FindElements
Call FindByNumber
Call CreateElement
Call LinkEntity
Call RemoveRelationshipLink
Call CloseDictionary
End
$PAGE
*********************************************************************
* *
* Subroutine OpenDictionary *
* *
* This subroutine opens the System Dictionary SYSDIC.PUB.SYS *
* with the PROGRAMMER scope, domain D, and test version *
* *
*********************************************************************
Subroutine OpenDictionary
Character*86 Dictionary
Character*32 Password, Scope, Domain, Version
Integer*4 IScope(8), IDomain(8), IVersion(8)
Equivalence (Scope, IScope)
Equivalence (Domain, IDomain)
Equivalence (Version, IVersion)
Integer*4 Dcb, Status(7)
Common Dcb(30)
System Intrinsic SDOpen
Dictionary = 'SYSDIC.PUB.SYS '
Scope = 'PROGRAMMER '
Password = 'SECRET '
Domain = 'D '
Version = ' '
Call SDOpen(Dictionary, IScope, Password, 3, 2, IDomain,
* IVersion, 1, Dcb, Status)
If (Status(1).NE.0) Then
Print 10, Status(1)
10 Format(" System Dictionary SDOpen Error #", I4)
Call Terminate
EndIf
Print 20
20 Format(" System Dictionary SYSDIC Opened")
End
$PAGE
*********************************************************************
* *
* Subroutine CloseDictionary *
* *
* This subroutine closes System Dictionary *
* *
*********************************************************************
Subroutine CloseDictionary
Integer*4 Dcb, Status(7)
Common Dcb(30)
System Intrinsic SDClose
Call SDClose(Dcb, Status)
If (Status(1).NE.0) Then
Print 20, Status(1)
10 Format(" System Dictionary SDClose Error #", I4)
Call Terminate
EndIf
Print 20
20 Format(" System Dictionary SYSDIC Closed")
End
$PAGE
*********************************************************************
* Subroutine FindElements *
* *
* This subroutine finds all elements related to the record *
* ACCOUNT-RECORD. It uses the intrinsic SDFindRelList to *
* search for the elements. The procedure then calls SDGetEnt *
* to retrieve the COUNT, ELEMENT-TYPE, and BYTE-LENGTH *
* attributes of the element. *
* *
*********************************************************************
Subroutine FindElements
Integer*4 Dcb, RetrievalID(20), Status(7), Count, ByteLength
Common Dcb(30)
Character*2 ElementType
Character*4 CCount, CByteLength
Character*10 ElementAttr
Character*16 RelType
Character*18 EntSearchList
Character*32 RelClass, EntType, Entity, AttrList, CommonEnt
Character*96 EntityList
Integer*4 IRelType(4), IRelClass(8), IEntSearchList(5)
Integer*4 IEntType(8), IEntity(8), IAttrList(8)
Equivalence (RelType, IRelType)
Equivalence (RelClass, IRelClass)
Equivalence (EntSearchList, IEntSearchList)
Equivalence (EntType, IEntType)
Equivalence (AttrList, IAttrList)
Equivalence (IEntity, Entity)
Equivalence (CCount, Count)
Equivalence (CByteLength, ByteLength)
System Intrinsic SDFindRelList, SDGetEnt
RelType = 'RECORD ELEMENT;'
RelClass = 'CONTAINS '
EntSearchList = 'ACCOUNT-RECORD ?;'
RetrievalID(1) = 0
EntType = 'ELEMENT '
AttrList = 'COUNT ELEMENT-TYPE BYTE-LENGTH;'
Print 9
Print 10
Print 11
9 Format(" ")
10 Format(" **** ACCOUNT-RECORD Elements ")
11 Format(" Element Name Count Type Length")
100 Call SDFindRelList(Dcb, IRelType, IRelClass, IEntSearchList,
* RetrievalID, EntityList, Status)
If (Status(1).EQ.0) Then
Entity(1:32) = EntityList(33:64)
Call SDGetEnt(Dcb, IEntType, IEntity, IAttrList,
* ElementAttr, CommonEnt, Status)
If (Status(1).NE.0) Then
Print 10, Status(1)
15 Format(" System Dictionary SDGetEnt Error #", I4)
Call Terminate
EndIf
CCount(1:4) = ElementAttr(1:4)
ElementType(1:2) = ElementAttr(5:6)
CByteLength(1:4) = ElementAttr(7:10)
Print 20, Entity, Count, ElementType, ByteLength
20 Format(' ',A32,' ',I5,' ',A2,' ',I5)
End If
If (Status(1).EQ.0) Goto 100
End
$PAGE
*********************************************************************
* *
* Subroutine FindByNumber *
* *
* This subroutine finds all elements related to the record *
* ACCOUNT-RECORD. It uses the intrinsic SDFindRelList to *
* search for the elements. It is similar to the previous *
* example, FindElement procedure, except internal numbers *
* are used in the call to SDGetEnt. *
* *
* Use of internal numbers will improve the performance of *
* System Dictionary intrinsic calls. *
* *
*********************************************************************
Subroutine FindByNumber
Integer*4 Dcb, EditLength, Count, ByteLength
Common Dcb(30)
Integer*4 AttrNumList(4), AttrParms(2), EntityNumber(2)
Integer*4 EntTypeNumber(2), RetrievalID(20), Status(7)
Integer*4 AttrEdits(64)
System Intrinsic SDFindRelList, SDGetEnt
System Intrinsic SDGetAttr, SDGetEntType
Character*2 ElementType
Character*4 CCount, CByteLength
Character*10 ElementAttr
Character*16 RelType
Character*18 EntSearchList
Character*32 Attribute, CommonEnt, EntType
Character*32 OwnerScope, RelClass
Character*96 EntityList
Integer*4 IRelType(4), IRelClass(8), IEntSearchLIst(5)
Integer*4 IAttribute(8), IEntType(8)
Equivalence (RelType, IRelType)
Equivalence (RelClass, IRelClass)
Equivalence (EntSearchList, IEntSearchList)
Equivalence (Attribute, IAttribute)
Equivalence (EntType, IEntType)
Equivalence (CCount, Count)
Equivalence (CByteLength, ByteLength)
RelType = 'RECORD ELEMENT; '
RelClass = 'CONTAINS '
EntSearchList = 'ACCOUNT-RECORD ?;'
RetrievalID(1) = 0
EntType = 'ELEMENT '
Call SDGetEntType(Dcb, IEntType, OwnerScope, Status)
If (Status(1).NE.0) Then
Print 60, Status(1)
60 Format(" System Dictionary SDGetEntType Error #", I4)
Call Terminate
End If
EntTypeNumber(1) = 1
EntTypeNumber(2) = Status(5)
AttrNumList(1) = 3
Attribute = 'COUNT '
Call SDGetAttr(Dcb, IAttribute, AttrParms, AttrEdits,
* EditLength, OwnerScope, Status)
If (Status(1).NE.0) Then
Print 70, Status(1)
70 Format(" System Dictionary SDGetAttr Error #", I4)
Call Terminate
End If
AttrNumList(2) = Status(5)
Attribute = 'ELEMENT-TYPE '
Call SDGetAttr(Dcb, IAttribute, AttrParms, AttrEdits,
* EditLength, OwnerScope, Status)
If (Status(1).NE.0) Then
Print 70, Status(1)
Call Terminate
End If
AttrNumList(3) = Status(5)
Attribute = 'BYTE-LENGTH '
Call SDGetAttr(Dcb, IAttribute, AttrParms, AttrEdits,
* EditLength, OwnerScope, Status)
If (Status(1).NE.0) Then
Print 70, Status(1)
Call Terminate
End If
AttrNumList(4) = Status(5)
Print 9
Print 10
Print 11
9 Format(" ")
10 Format(" **** ACCOUNT-RECORD Elements ")
11 Format(" Element Name Count Type Length")
100 Call SDFindRelList(Dcb, IRelType, IRelClass, IEntSearchList,
* RetrievalID, EntityList, Status)
If (Status(1).EQ.0) Then
EntityNumber(1) = 1
EntityNumber(2) = Status(6)
Call SDGetEnt(Dcb, EntTypeNumber, EntityNumber,
* AttrNumList, ElementAttr, CommonEnt,
* Status)
If (Status(1).NE.0) Then
Print 30, Status(1)
30 Format(" System Dictionary SDGetEnt Error #", I4)
EndIf
CCount(1:4) = ElementAttr(1:4)
ElementType = ElementAttr(5:6)
CByteLength = ElementAttr(7:10)
Print 40, EntityList(33:64), Count, ElementType, ByteLength
40 Format(' ', A32,' ',I5,' ',A2,' ',I5)
End If
If (Status(1).EQ.0) Goto 100
End
$PAGE
*********************************************************************
* *
* Subroutine CreateElement *
* *
* This subroutine creates an entity occurrence by calling the *
* intrinsic SDCreateEnt. The entity being created has both an *
* internal and external name specified. *
* *
*********************************************************************
Subroutine CreateElement
Integer*4 Dcb, Count, ByteLength, Status(7)
Common Dcb(30)
Character*2 ElementType
Character*4 CCount, CByteLength
Character*10 ElementAttr
Character*32 AttrList, CommonEnt, EntType, Entity(2)
Integer*4 ICommonEnt(8)
Integer*4 IEntType(8), IAttrList(8), IEntity(16)
Equivalence (EntType, IEntType)
Equivalence (Entity, IEntity)
Equivalence (AttrList, IAttrList)
Equivalence (CommonEnt, ICommonEnt)
Equivalence (CCount, Count), (CByteLength, ByteLength)
System Intrinsic SDCreateEnt
EntType = 'ELEMENT '
Entity(1) = 'DATE '
Entity(2) = 'DELIVERY-DATE '
AttrList = 'COUNT ELEMENT-TYPE BYTE-LENGTH;'
Count = 1
ElementType = 'X '
ByteLength = 6
ElementAttr(1:4) = CCount(1:4)
ElementAttr(5:6) = ElementType
ElementAttr(7:10) = CByteLength(1:4)
CommonEnt = ' '
Call SDCreateEnt(Dcb, IEntType, IEntity, IAttrList,
* ElementAttr, ICommonEnt, Status)
If (Status(1).NE.0) Then
Print 10, Status(1)
10 Format(" System Dictionary SDCreateEnt Error #", I4)
Call Terminate
End If
End
$PAGE
*********************************************************************
* *
* Subroutine LinkEntity *
* *
* This subroutine links a local domain entity to a common domain *
* entity. The subroutine calls SDModifyEnt to link the entities. *
* Note that the existing attribute values are removed, and the *
* attribute values will now be retrieved from the common entity. *
* *
*********************************************************************
Subroutine LinkEntity
Integer*4 Dcb, Status(7)
Common Dcb(30)
Character ElementAttr
Character*2 AttrList
Character*32 CommonEnt, EntType, Entity, NewEntityName
Integer*4 IEntType(8), IEntity(8), ICommonEnt(8), IAttrList
Equivalence (EntType, IEntType)
Equivalence (Entity, IEntity)
Equivalence (AttrList, IAttrList)
Equivalence (CommonEnt, ICommonEnt)
System Intrinsic SDModifyEnt
EntType = 'ELEMENT '
Entity = 'P-NUM '
NewEntityName = ' '
AttrList = '; '
CommonEnt = 'PART-NUMBER '
Call SDModifyEnt(Dcb, IEntType, IEntity, NewEntityName,
* IAttrList, ElementAttr, ICommonEnt, Status)
If (Status(1).NE.0) Then
Print 10, Status(1)
10 Format(" System Dictionary SDModifyEnt Error #",I4)
Call Terminate
End If
End
$PAGE
*********************************************************************
* *
* Subroutine RemoveRelationshipLink *
* *
* This subroutine removes the link between a relationship in a *
* local domain and a relationship in the common domain. The *
* procedure calls SDModifyRel to remove the link; the parameter *
* CommonEntityList is set to '/;' to instruct SDModifyRel to *
* remove the link. If a user does not want to remove the link, *
* then the parameter CommonEntityList should be set to a '; '. *
* *
*********************************************************************
Subroutine RemoveRelationshipLink
Integer*4 Dcb, Status(7)
Common Dcb(30)
Character AttrVal
Character*2 AttrList, CommonEntList
Character*16 RelType
Character*32 EntityList, RelClass
Integer*4 IAttrList, ICommonEntList
Integer*4 IRelType(8), IRelClass(8), IEntityList(8)
Equivalence (RelType, IRelType)
Equivalence (RelClass, IRelClass)
Equivalence (EntityList, IEntityList)
Equivalence (AttrList, IAttrList)
Equivalence (CommonEntList, ICommonEntList)
System Intrinsic SDModifyRel
RelType = 'RECORD ELEMENT;'
RelClass = 'CONTAINS '
EntityList = 'ACCOUNT-RECORD ACCOUNT-NUMBER;'
AttrList = '; '
CommonEntList = '/;'
Call SDModifyRel(Dcb, IRelType, IRelClass, IEntityList,
* IAttrList, AttrVal, ICommonEntList, Status)
If (Status(1).NE.0) Then
Print 10, Status(1)
10 Format(" System Dictionary SDModifyRel Error #",I4)
Call Terminate
End If
End