HP 3000 Manuals HP 3000 Manuals
FORTRAN Sample Program
$CONTROL list on, tables on
!
! This application collects employee payroll deduction
! transactions and places the edited transactions into
! a file.
!
! For this application: Enter key = edit and file
! transaction;
!
! f8 = exit application;
!
! all other f keys = redo transaction.
!
! Each transaction entered by the operator is subjected to the
! data edits embedded within the input form.
!
! The application continues to collect transactions until either
! the operator signals to exit or a system error is detected.
!
$TITLE ' Main Program'
!***************************************************************!
! !
! Main Program !
! !
!***************************************************************!
!
PROGRAM FTN77EXMP
!
IMPLICIT NONE
!
COMMON /COM01/ GLOBALPAK
COMMON /COM02/ RETURNPAK
COMMON /COM03/ FORMSFILE
COMMON /COM04/ TERMPAK
COMMON /COM07/ MSGFORWINDOW
COMMON /COM10/ UNUSED_PARM
COMMON /COM101/ ERROR_LOCATION
COMMON /COM102/ STOP_NOW
COMMON /COM103/ DONE_WITH_TXNS
COMMON /COM104/ NBR_TXN_COLLECTED
!
INTEGER*4 GLOBALPAK(79)
INTEGER*4 RETURNPAK(79)
INTEGER*4 FORMSFILE(22)
INTEGER*4 TERMPAK (23)
INTEGER*4 MSGFORWINDOW(21)
INTEGER*4 UNUSED_PARM
CHARACTER*70 ERROR_LOCATION
INTEGER*2 STOP_NOW
INTEGER*2 DONE_WITH_TXNS
INTEGER*2 NBR_TXN_COLLECTED
!
STOP_NOW = 0
DONE_WITH_TXNS = 0
!
NBR_TXN_COLLECTED = 0
!
CALL SETUP_FOR_WORK
!
DO WHILE (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0)
CALL COLLECT_TXNS
END DO
!
CALL CLEANUP_AFTER_WORK
!
PRINT *,
+ "Deduction transactions collected this session = ",
+ NBR_TXN_COLLECTED
!
IF (STOP_NOW.EQ.1) THEN
CALL DISPLAY_SYSTEM_ERROR
END IF
!
STOP
END
$TITLE ' Setup For Work'
!***************************************************************!
! !
! Setup For Work !
! !
!***************************************************************!
!
SUBROUTINE SETUP_FOR_WORK
!
IMPLICIT NONE
!
COMMON /COM01/ GLOBALPAK
COMMON /COM02/ RETURNPAK
COMMON /COM03/ FORMSFILE
COMMON /COM04/ TERMPAK
COMMON /COM07/ MSGFORWINDOW
COMMON /COM10/ UNUSED_PARM
COMMON /COM102/ STOP_NOW
COMMON /COM101/ ERROR_LOCATION
!
SYSTEM INTRINSIC HPDOPENFORMS,
+ HPDENABLETERM
!
INTEGER*4 GLOBALPAK(79)
CHARACTER*8 EXPECTEDVUF
INTEGER*4 CALLPROTOCOL
INTEGER*4 COMAREALEN
INTEGER*4 COMAREA(75)
EQUIVALENCE (GLOBALPAK(1), EXPECTEDVUF),
+ (GLOBALPAK(3), CALLPROTOCOL),
+ (GLOBALPAK(4), COMAREALEN),
+ (GLOBALPAK(5), COMAREA)
!
INTEGER*4 RETURNPAK(79)
INTEGER*4 RETURNSTATUS
EQUIVALENCE (RETURNPAK(1), RETURNSTATUS)
!
INTEGER*4 FORMSFILE(22)
CHARACTER*88 FFNAME
EQUIVALENCE (FORMSFILE(1), FFNAME)
!
INTEGER*4 TERMPAK (23)
CHARACTER*88 TERMNAME
INTEGER*4 TERMBYPASSFEAT
EQUIVALENCE (TERMPAK(1), TERMNAME),
+ (TERMPAK(23), TERMBYPASSFEAT)
!
INTEGER*4 MSGFORWINDOW(21)
CHARACTER*79 MSGAREA
EQUIVALENCE (MSGFORWINDOW(2), MSGAREA)
!
INTEGER*4 UNUSED_PARM
!
INTEGER*2 STOP_NOW
CHARACTER*70 ERROR_LOCATION
!
INTEGER*2 ARRAY_INDEX
!
! Init Unused Parm which is used whenever intrinsic input
! parameter is not active.
!
UNUSED_PARM = 0
!
! Init Comarea to all zeros.
!
ARRAY_INDEX = 1
DO WHILE (ARRAY_INDEX.LE.75)
COMAREA(ARRAY_INDEX) = 0
ARRAY_INDEX = ARRAY_INDEX + 1
END DO
!
! Set Expected HP32424A Version.
!
EXPECTEDVUF = "A.00.00 "
!
! Set Language for FORTRAN-77.
!
CALLPROTOCOL = 210
!
! Set Comarealen for 300 bytes.
!
COMAREALEN = 300
!
! Open the Transaction File:
!
OPEN (UNIT = 10,
+ FILE = 'PAYTXN',
+ ACCESS = 'DIRECT',
+ RECL = 200,
+ FORM = 'UNFORMATTED',
+ STATUS = 'NEW',
+ ERR = 110)
!
GOTO 120
!
110 STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Setup For Work - Open Transaction File"
MSGAREA =
+ "**** File open failed!"
!
! Open the Forms File.
!
120 IF (STOP_NOW.EQ.0) THEN
FFNAME = "PAYROLL.WORK.ADMIN"
!
CALL HPDOPENFORMS (GLOBALPAK,
+ RETURNPAK,
+ FORMSFILE)
!
IF (RETURNSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Setup For Work - Forms File Open"
CALL UNBLOCK_MSG
END IF
END IF
!
! Open the Terminal.
!
IF (STOP_NOW.EQ.0) THEN
TERMNAME = "HPTERM"
TERMBYPASSFEAT = 0
!
CALL HPDENABLETERM (GLOBALPAK,
+ RETURNPAK,
+ TERMPAK,
+ UNUSED_PARM)
!
IF (RETURNSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Setup For Work - Terminal Setup"
CALL UNBLOCK_MSG
END IF
END IF
!
END
$TITLE ' Collect Transactions'
!***************************************************************!
! !
! Collect Transactions !
! !
!***************************************************************!
!
SUBROUTINE COLLECT_TXNS
!
IMPLICIT NONE
!
COMMON /COM01/ GLOBALPAK
COMMON /COM02/ RETURNPAK
COMMON /COM07/ MSGFORWINDOW
COMMON /COM08/ DATADESCRPT
COMMON /COM10/ UNUSED_PARM
COMMON /COM102/ STOP_NOW
COMMON /COM103/ DONE_WITH_TXNS
COMMON /COM104/ NBR_TXN_COLLECTED
COMMON /COM101/ ERROR_LOCATION
COMMON /COM105/ DATA_ENTRY_ERRS
!
SYSTEM INTRINSIC HPDSEND
!
INTEGER*4 GLOBALPAK(79)
!
INTEGER*4 RETURNPAK(79)
INTEGER*4 RETURNSTATUS
EQUIVALENCE (RETURNPAK(1), RETURNSTATUS)
!
INTEGER*4 MSGFORWINDOW(21)
INTEGER*4 MSGLEN
CHARACTER*79 MSGAREA
EQUIVALENCE (MSGFORWINDOW(1), MSGLEN),
+ (MSGFORWINDOW(2), MSGAREA)
!
INTEGER*4 DATADESCRPT(3)
!
INTEGER*4 UNUSED_PARM
!
INTEGER*2 STOP_NOW
INTEGER*2 DONE_WITH_TXNS
INTEGER*2 NBR_TXN_COLLECTED
CHARACTER*70 ERROR_LOCATION
INTEGER*2 DATA_ENTRY_ERRS
!
INTEGER*4 SENDPAK(4)
!
INTEGER*4 FORMPAK(44)
CHARACTER*32 FORMNAME
INTEGER*4 FORMPOSITION
INTEGER*4 LISTTYPE
INTEGER*4 LISTCOUNT
EQUIVALENCE (FORMPAK(1), FORMNAME),
+ (FORMPAK(9), FORMPOSITION),
+ (FORMPAK(10), LISTTYPE),
+ (FORMPAK(11), LISTCOUNT)
CHARACTER*44 FIELD_ID(1,3)
EQUIVALENCE (FORMPAK(12), FIELD_ID)
INTEGER*4 CHANGE_TYPE (11,3)
CHARACTER*4 CHANGE_SPEC (11,3)
EQUIVALENCE (FORMPAK(12), CHANGE_TYPE),
+ (FORMPAK(12), CHANGE_SPEC)
!
! No special Send instructions
!
SENDPAK(1) = 0
SENDPAK(2) = 0
SENDPAK(3) = 0
SENDPAK(4) = 0
!
! Setup to get and modify data entry form, toggling three
! fields to "input allowed".
!
FORMNAME = "DEDUCTION"
!
! Position form to start at top left of display (home).
!
FORMPOSITION = 0
!
! Indicate that the fields in the form which will be modified
! are identified by name.
!
LISTTYPE = 2
!
! Indicate the number of fields to modify.
!
LISTCOUNT = 3
!
! List fields to be modified, indicate modification type, and
! new value.
!
FIELD_ID (1,1) = "BADGE_NUMBER"
CHANGE_TYPE (9,1) = 5
CHANGE_SPEC (10,1) = "O"
!
FIELD_ID (1,2) = "LAST_NAME"
CHANGE_TYPE (9,2) = 5
CHANGE_SPEC (10,2) = "O"
!
FIELD_ID (1,3) = "SUR_NAME"
CHANGE_TYPE (9,3) = 5
CHANGE_SPEC (10,3) = "O"
!
! Setup window message.
!
MSGLEN = 79
!
MSGAREA =
+ "Fill in Deduction Transaction according to worksheet."
!
! Don't copy application data out to display.
!
DATADESCRPT(1) = -1
!
! Show form.
!
CALL HPDSEND (GLOBALPAK,
+ RETURNPAK,
+ SENDPAK,
+ FORMPAK,
+ UNUSED_PARM,
+ MSGFORWINDOW,
+ DATADESCRPT,
+ UNUSED_PARM,
+ UNUSED_PARM,
+ UNUSED_PARM)
!
IF (RETURNSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Collect Transactions - Form display"
CALL UNBLOCK_MSG
END IF
!
! Setup and loop on transaction until it can be filed.
!
DATA_ENTRY_ERRS = 1
!
DO WHILE (DATA_ENTRY_ERRS.EQ.1
+ .AND.STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0)
!
CALL READ_EDIT_AND_FILE
!
END DO
!
END
$TITLE ' Read Edit and File'
!***************************************************************!
! !
! Read Edit and File !
! !
!***************************************************************!
!
SUBROUTINE READ_EDIT_AND_FILE
!
IMPLICIT NONE
!
COMMON /COM01/ GLOBALPAK
COMMON /COM02/ RETURNPAK
COMMON /COM07/ MSGFORWINDOW
COMMON /COM08/ DATADESCRPT
COMMON /COM10/ UNUSED_PARM
COMMON /COM102/ STOP_NOW
COMMON /COM103/ DONE_WITH_TXNS
COMMON /COM104/ NBR_TXN_COLLECTED
COMMON /COM101/ ERROR_LOCATION
COMMON /COM105/ DATA_ENTRY_ERRS
!
SYSTEM INTRINSIC HPDREAD
!
INTEGER*4 GLOBALPAK(79)
!
INTEGER*4 RETURNPAK(79)
INTEGER*4 RETURNSTATUS
INTEGER*4 LASTITEMTYPE
INTEGER*4 LASTITEMNUM
EQUIVALENCE (RETURNPAK(1), RETURNSTATUS),
+ (RETURNPAK(68), LASTITEMTYPE),
+ (RETURNPAK(69), LASTITEMNUM)
!
INTEGER*4 MSGFORWINDOW(21)
INTEGER*4 MSGLEN
CHARACTER*79 MSGAREA
EQUIVALENCE (MSGFORWINDOW(1), MSGLEN),
+ (MSGFORWINDOW(2), MSGAREA)
!
INTEGER*4 DATADESCRPT(3)
!
INTEGER*4 UNUSED_PARM
!
INTEGER*2 STOP_NOW
INTEGER*2 DONE_WITH_TXNS
INTEGER*2 NBR_TXN_COLLECTED
CHARACTER*70 ERROR_LOCATION
INTEGER*2 DATA_ENTRY_ERRS
!
INTEGER*4 READPAK(3)
INTEGER*4 ENABLEREFORMAT
EQUIVALENCE (READPAK(2), ENABLEREFORMAT)
!
INTEGER*4 DATABUF(50)
CHARACTER*200 DATAAREA
EQUIVALENCE (DATABUF(1), DATAAREA)
!
! Enable data finishing.
!
ENABLEREFORMAT = 1
!
! No other special Read instructions.
!
READPAK(1) = 0
READPAK(3) = 0
!
! Indicate that all data in form, up to 200 bytes, is to
! be copied into application work space.
!
DATADESCRPT(1) = 10
DATADESCRPT(2) = 200
!
! Read form.
!
CALL HPDREAD (GLOBALPAK,
+ RETURNPAK,
+ READPAK,
+ UNUSED_PARM,
+ UNUSED_PARM,
+ DATADESCRPT,
+ DATABUF,
+ UNUSED_PARM)
!
IF (RETURNSTATUS.LT.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Read Edit and File - Terminal Read"
CALL UNBLOCK_MSG
END IF
!
! Determine if operator wants to stop transaction collection.
!
IF (STOP_NOW.EQ.0
+ .AND.RETURNSTATUS.EQ.0) THEN
IF (LASTITEMTYPE.EQ.0
+ .AND.LASTITEMNUM.EQ.8) THEN
DONE_WITH_TXNS = 1
END IF
END IF
!
! Determine if edit errors detected.
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
IF (RETURNSTATUS.EQ.0) THEN
DATA_ENTRY_ERRS = 0
ELSE
DATA_ENTRY_ERRS = 1
END IF
END IF
!
! Do we have a transaction that can be filed?
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
IF (DATA_ENTRY_ERRS.EQ.0
+ .AND.LASTITEMTYPE.EQ.0
+ .AND.LASTITEMNUM.EQ.0) THEN
!
! Write Databuf to Transaction File.
!
WRITE (UNIT = 10,
+ ERR = 310) DATAAREA
!
GOTO 320
!
310 STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Read Edit and File - File Write"
MSGAREA =
+ "**** Write to Transaction File failed!"
!
320 IF (STOP_NOW.EQ.0) THEN
NBR_TXN_COLLECTED = NBR_TXN_COLLECTED + 1
END IF
END IF
END IF
!
! Do we need to prompt the operator to correct errors?
!
IF (STOP_NOW.EQ.0
+ .AND.DONE_WITH_TXNS.EQ.0) THEN
!
IF (DATA_ENTRY_ERRS.EQ.1) THEN
IF (LASTITEMTYPE.EQ.0
+ .AND.LASTITEMNUM.EQ.0) THEN
!
CALL PROMPT_OPERATOR
!
ELSE
!
! Operator pressed some key other than ENTER or EXIT so,
! clear data error flag to break loop (display refresh results).
!
DATA_ENTRY_ERRS = 0
!
END IF
END IF
END IF
!
END
$TITLE ' Prompt Operator'
!***************************************************************!
! !
! Prompt Operator !
! !
!***************************************************************!
!
SUBROUTINE PROMPT_OPERATOR
!
IMPLICIT NONE
!
COMMON /COM01/ GLOBALPAK
COMMON /COM02/ RETURNPAK
COMMON /COM07/ MSGFORWINDOW
COMMON /COM10/ UNUSED_PARM
COMMON /COM102/ STOP_NOW
COMMON /COM101/ ERROR_LOCATION
!
SYSTEM INTRINSIC HPDPROMPT
!
INTEGER*4 GLOBALPAK(79)
!
INTEGER*4 RETURNPAK(79)
INTEGER*4 RETURNSTATUS
INTEGER*4 RETURNMSGLEN
EQUIVALENCE (RETURNPAK(1), RETURNSTATUS),
+ (RETURNPAK(3), RETURNMSGLEN)
!
INTEGER*4 MSGFORWINDOW(21)
!
INTEGER*4 UNUSED_PARM
!
INTEGER*2 STOP_NOW
CHARACTER*70 ERROR_LOCATION
!
INTEGER*4 PROMPTPAK(4)
!
! Get error message.
!
CALL UNBLOCK_MSG
!
!
! No special Prompt instructions.
!
PROMPTPAK(1) = 0
PROMPTPAK(2) = 0
PROMPTPAK(3) = 0
PROMPTPAK(4) = 0
!
! Display form with highlighted fields and error message
in window.
!
CALL HPDPROMPT (GLOBALPAK,
+ RETURNPAK,
+ PROMPTPAK,
+ UNUSED_PARM,
+ MSGFORWINDOW,
+ UNUSED_PARM,
+ UNUSED_PARM,
+ UNUSED_PARM)
!
IF (RETURNSTATUS.NE.0) THEN
STOP_NOW = 1
ERROR_LOCATION =
+ "**** Routine: Prompt Operator - Display Updates"
CALL UNBLOCK_MSG
END IF
!
END
$TITLE ' Cleanup After Work'
!***************************************************************!
! !
! Cleanup After Work !
! !
!***************************************************************!
!
SUBROUTINE CLEANUP_AFTER_WORK
!
IMPLICIT NONE
!
COMMON /COM01/ GLOBALPAK
COMMON /COM02/ RETURNPAK
COMMON /COM03/ FORMSFILE
COMMON /COM04/ TERMPAK
COMMON /COM10/ UNUSED_PARM
!
SYSTEM INTRINSIC HPDCLOSEFORMS,
+ HPDDISABLETERM
!
INTEGER*4 GLOBALPAK(79)
INTEGER*4 RETURNPAK(79)
INTEGER*4 FORMSFILE(22)
INTEGER*4 TERMPAK(23)
INTEGER*4 UNUSED_PARM
!
! Note that this routine unconditionally attempts to close
! the Forms File and Terminal
!
CLOSE (UNIT = 10)
!
CALL HPDCLOSEFORMS (GLOBALPAK,
+ RETURNPAK,
+ FORMSFILE)
!
! Function keys were not save thus not restored here.
!
CALL HPDDISABLETERM (GLOBALPAK,
+ RETURNPAK,
+ TERMPAK,
+ UNUSED_PARM)
!
END
$TITLE ' Unblock Message'
!***************************************************************!
! !
! Unblock Message !
! !
!***************************************************************!
!
SUBROUTINE UNBLOCK_MSG
!
IMPLICIT NONE
!
COMMON /COM02/ RETURNPAK
COMMON /COM07/ MSGFORWINDOW
!
INTEGER*4 RETURNPAK(79)
INTEGER*4 RETURNMSGLEN
CHARACTER*1 RETURNMSG(254)
EQUIVALENCE (RETURNPAK(3), RETURNMSGLEN),
+ (RETURNPAK(4), RETURNMSG)
!
INTEGER*4 MSGFORWINDOW(21)
INTEGER*4 MSGLEN
CHARACTER*1 MSGAREA(79)
EQUIVALENCE (MSGFORWINDOW(1), MSGLEN),
+ (MSGFORWINDOW(2), MSGAREA)
!
!
INTEGER*2 ARRAY_INDEX
!
ARRAY_INDEX = 1
DO WHILE (ARRAY_INDEX.LE.RETURNMSGLEN)
MSGAREA(ARRAY_INDEX) = RETURNMSG(ARRAY_INDEX)
ARRAY_INDEX = ARRAY_INDEX + 1
END DO
!
MSGLEN = RETURNMSGLEN
!
END
$TITLE ' Display System Error'
!***************************************************************!
! !
! Display System Error !
! !
!***************************************************************!
!
SUBROUTINE DISPLAY_SYSTEM_ERROR
!
IMPLICIT NONE
!
COMMON /COM07/ MSGFORWINDOW
COMMON /COM101/ ERROR_LOCATION
!
INTEGER*4 MSGFORWINDOW(21)
CHARACTER*79 MSGAREA
EQUIVALENCE (MSGFORWINDOW(2), MSGAREA)
!
CHARACTER*70 ERROR_LOCATION
!
PRINT *,
+ "**** Transaction entry facility detected system error at:"
PRINT *, ERROR_LOCATION
PRINT *,
+ "**** The error message returned is:"
PRINT *, MSGAREA
!
END