FORTRAN Example 1

Disable ERROR ABORT option so control will return to the terminal if the program aborts due to a fatal error. (Control would be returned to the terminal with ERROR ABORT option enabled anyway if no command module was specified in System Field @ABORT_CM.)

*DISABLE ERROR ABORT

Define the System File (SF) that will contain the Fortran source code. Insert the code below.

*DEFINE SF FORD1.FOR

(Depending on the editor used, the command "INSERT" may need to be entered.)

[Beginning of FORTRAN Example 1.]

=====================================================================

program ford1

C This program is used to INSERT and UPDATE Data Sets. Assorted HLI features are

C demonstrated: ACCINI, ACCLOA, ACCOPN, ACCSTO, ACCCLS, ACCGET, ACCCMD,

C ACCPUT, ACCRDY, ACCCRE, ACCEND, ACCDBL

C Set up variables

integer*4 err, set0, set1, bds, sds, dds, stds, qty, lo, hi

integer*4 pdate, odate

character*40 text, distyp

character*4 shost, pub, salst, disst, stst

character*1 ans

character*20 ono, city, kuntry

character*12 pterm, boktyp

character*6 shotit, boktit, saltit

character*5 aux, zip

character*2 state

character*30 name, addr

character*200 notes

double precision sales, price, ytd, disc, roy, adv

set0 = 0

set1 = 1

C Formats used in program

70 format(' Price: $', F5.2)

71 format(' YTD sales before update: $', F7.2)

72 format(' YTD sales after update: $', F7.2)

91 format(a1)

92 format(i9)

93 format(a12)

94 format(a4)

95 format(a20)

96 format(a6)

C Set up environment

C Call #1 (ACCINI) - initialize HLI for Fortran

CALL ACCINI (%descr(err), 'trace', 'fortran')

C Call #2 (ACCSTO)-store values into ACCENT R variables,set up trace for all calls

CALL ACCSTO (%descr(err), 'trace', %descr(set0), '@HLI_TRACE',

1 %descr(set1))

C Call #3 (ACCDBL) - declare which DBL to be used

CALL ACCDBL (%descr(err), %descr(set0), 'books')

C Call #4 (ACCOPN) declare DIs to be used (series), host fields are lined up to

C have data stored

C into Data Set fields (ACCSTO) or to receive data from the

C Data Set fields (ACCLOA)

if (err .EQ. 0) then

CALL ACCOPN (%descr(err), 'update', 'di',

1 'nisdemo:sales_dbm2', %descr(sds))

CALL ACCSTO (%descr(err), 'create+defer', %descr(sds),

1 'store_code', %descr(salst),

2 'ord_num', %descr(ono),

3 'ord_date', %descr(odate),

4 'qty', %descr(qty),

5 'pay_terms', %descr(pterm),

6 'title_code', %descr(saltit))

end if

if (err .EQ. 0) then

CALL ACCOPN (%descr(err), 'input', 'di',

1 'nisdemo:stores_dbm2', %descr(stds))

C Call #5 (ACCLOA) - specify DS fields that will have its values copies to host fields

CALL ACCLOA (%descr(err), 'defer', %descr(stds),

1 'store_code', %descr(stst),

2 'store_name', %descr(name),

3 'store_address', %descr(addr),

4 'city', %descr(city),

5 'state', %descr(state),

6 'zip', %descr(zip),

7 'country', %descr(kuntry))

end if

if (err .EQ. 0) then

CALL ACCOPN (%descr(err), 'update', 'di',

1 'nisdemo:books_dbm2', %descr(bds))

end if

if (err .EQ. 0) then

CALL ACCSTO (%descr(err), 'defer', %descr(bds),

1 'ytd_sales', %descr(ytd))

end if

if (err .EQ. 0) then

CALL ACCOPN (%descr(err), 'input', 'di',

1 'nisdemo:discounts_dbm2', %descr(dds))

CALL ACCLOA (%descr(err), 'defer', %descr(dds),

1 'discount_type', %descr(distyp),

2 'store_code', %descr(disst),

3 'low_qty', %descr(lo),

4 'high_qty', %descr(hi),

5 'discount', %descr(disc))

end if

C Begin order processing / set date

if (err .EQ. 0) then

CALL ACCLOA (%descr(err), %descr(set0), %descr(set0),

1 '@date', %descr(odate))

print *, 'Enter STOP to exit application.'

25 print *, ' '

shost = ' '

print *, 'Enter store code or STOP.'

accept 94, shost

if (shost .EQ. 'stop' .OR. shost .EQ. 'STOP') then

go to 50

end if

if (shost .EQ. ' ') then

go to 50

end if

C Call #6 (ACCGET) - verify store code entered by user; check value of status

C field @AUX to determine if store code exists. If this is a

C new store code, offer the option of adding a new store.

CALL ACCGET (%descr(err), 'match+hush', %descr(stds),' ',

1 %descr(shost))

CALL ACCLOA (%descr(err), %descr(set0), %descr(set0),

1 '@aux', %descr(aux))

if (aux .EQ. 'YES') then

print *, 'Store name: ', name

endif

if (aux .NE. 'YES') then

40 print *, ' '

print *, '*** Store code entered did not match in file. ***'

print *, 'Should it be added to the Store file? (Y/N)'

accept 91, ans

if (ans .EQ. 'n' .OR. ans .EQ. 'N') then

go to 50

end if

if (ans .NE. 'y' .AND. ans .NE. 'Y') then

go to 40

end if

C Call #7a (ACCCLS) - close STORES DS before adding store with OSQL window

CALL ACCCLS (%descr(err), %descr(set0), %descr(stds))

print *, ' '

print *, '!! Building screen to add new store !!'

print *, ' '

C Call #8 (ACCCMD) - OSQL is invoked through ACCENT R's commands; a screen is

C generated to add a new store to STORES DS

CALL ACCCMD (%descr(err), 'command', 'OSQL INSERT

1 NISDEMO:SALES_DBM2 WITH WINDOW',

2 'QUIT')

print *,'<<New store has been added >>'

C Redeclare DBL and DI which were closed as a result of OSQL operations; display

last entry into

C STORES DS

CALL ACCDBL (%descr(err), %descr(set0), 'books')

CALL ACCOPN (%descr(err), 'input', 'di',

1 'nisdemo:stores_dbm2', %descr(stds))

CALL ACCLOA (%descr(err), 'defer', %descr(stds),

1 'store_code', %descr(stst),

2 'store_name', %descr(name),

3 'store_address', %descr(addr),

4 'city', %descr(city),

5 'state', %descr(state),

6 'zip', %descr(zip),

7 'country', %descr(kuntry))

print *, ' '

print *, 'The following store has been added:'

CALL ACCGET(%descr(err), 'last+notindexed', %descr(stds),

1 ' ')

print *, 'Store code: ', stst

print *, 'Store name: ', name

end if

C Enter order number after store code confirmed

55 print *, ' '

print *, 'Enter order number or END to start over.'

ono = ' '

accept 95, ono

if (ono .EQ. 'END' .OR. ono .EQ. 'end') then

go to 50

end if

if (ono .EQ. ' ') then

go to 55

end if

C Enter title code after order number entered

45 shotit = ' '

print *, ' '

print *, 'Enter title code or <CR> if order complete.'

accept 96, shotit

if (shotit .EQ. ' ') then

print *, ' '

print *, '<< Order Complete >>'

go to 60

end if

price = 0

ytd = 0

bokktit = ' '

text = ' '

C Verify title code entered, check field @AUX

CALL ACCGET (%descr(err), 'match+hush', %descr(bds),' ',

1 %descr(shotit))

CALL ACCLOA (%descr(err), 'defer', %descr(bds),

1 'title_code', %descr(boktit),

2 'title_text', %descr(text),

3 'type_code', %descr(boktyp),

4 'pub_code', %descr(pub),

5 'price', %descr(price),

6 'advance_amt', %descr(adv),

7 'royalty', %descr(roy),

8 'ytd_sales', %descr(ytd),

9 'notes', %descr(notes),

a 'pub_date', %descr(pdate))

CALL ACCLOA (%descr(err), %descr(set0), %descr(set0),

1 '@aux', %descr(aux))

if (aux .NE. 'YES') then

print *, ' '

print *, 'Title code entered does not match - try again.'

go to 45

end if

C Display record / enter sales data

print *, ' '

print *, 'Title: ', text

print 70, price

print *, ' '

print *, 'Enter order quantity: '

accept 92, qty

print *, 'Enter terms of payment: (ex. net 30, net 60)'

accept 93, payterm

saltit = shotit

salst = shost

C Find discount for order

90 print *, ' '

print *, '<< Figuring discount for order >>'

distyp = ' '

disst = ' '

lo = 0

hi = 0

disc = 0

CALL ACCGET (%descr(err), 'match+hush', %descr(dds), ' ',

1 %descr(shost))

CALL ACCLOA (%descr(err), %descr(set0), %descr(set0),

'@aux', %descr(aux))

if (aux .NE. 'YES') then

disc = 0

end if

if (aux .EQ. 'YES') then

if (qty .LT. lo .OR. qty .GT. hi) then

go to 90

end if

disc = disc/100

print *, ' '

print 71, ytd

sales = qty * price - (qty*price) *disc

ytd = ytd + sales

print 72, ytd

C Update Data Sets - SALES, BOOKS

C Call #9 (ACCPUT) - update BOOKS DS, data is automatically transferred because

of the

C DEFER option on the ACCSTO calls

C Call #10 (ACCRDY) - clear, initialize record area for ACCCRE

C Call #11 (ACCCRE) - create/append new record to SALES DS; data is

automatically transferred

C because of the DEFER option on the ACCSTO calls

CALL ACCPUT (%descr(err), %descr(set0), %descr(bds))

CALL ACCRDY (%descr(err), %descr(set0), %descr(sds))

CALL ACCCRE (%descr(err), %descr(set0), %descr(sds))

qty = 0

saltit = ' '

pterm = ' '

salst = ' '

C Loop Control

60 if (shotit .NE. ' ') then

go to 45

end if

50 if (shost .NE. 'stop' .AND. shost .NE. 'STOP) then

go to 25

end if

C Display error message

if (err .NE. 0 .AND. aux .NE. 'MISSI') then

print *, '*** Program failed due to an error. ***'

end if

C Normal end - close all Data Sets, review sales records, end session

CALL ACCCLS (%descr(err), 'all')

print *, ' '

print *, '!! Building screen to review sales records !!'

print *, ' '

CALL ACCCMD (%descr(err), 'command', 'OSQL SELECT * FROM

1 NISDEMO:SALES_DBM2 WITH WINDOW', 'QUIT')

C Call #12 (ACCEND) - terminate HLI session

CALL ACCEND (%descr(err))

end

=============================================================================

[End of FORTRAN Example 1.]

Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the program by entering "SAVE". The editor will return control to the command level prompt.
Compile and LINK the Fortran program through a System File (SF). Enter commands below.

(Depending on the editor used, the command "INSERT" may need to be entered.)

*DEFINE SF HLIF_1.COM

$purge ford1.for

$delete ford1.obj;*

$delete ford1.exe;*

$define nisdemo [user_directory]

$define nis [accent_r_directory]

$define acchli nis:acchli

$Fortran ford1

$link ford1,nis:accvax,nis:acchli/lib

Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the command file by entering "SAVE". The editor will return control to the command level prompt.
Initiate the link then exit ACCENT R or link at the DCL command level.

*LINK TO DCL WITH '@HLIF_1.' AND RETURN

*QUIT

(or)

*QUIT

$@HLIF_1

Run application at the VAX DCL prompt. (See note in section introduction.)

$RUN FORD1

FORTRAN Example 2

Disable ERROR ABORT option so control will return to the terminal if the program aborts due to a fatal error. (Control would be returned to the terminal with ERROR ABORT option enabled anyway if no command module was specified in System Field @ABORT_CM.)

*DISABLE ERROR ABORT

Define the System File (SF) that will contain the Fortran source code. Insert the code below.

*DEFINE SF FORD2.FOR

(Depending on the editor used, the command "INSERT" may need to be entered.)

[Beginning of FORTRAN example 2.]

============================================================================

program ford2

C This program is used to DELETE sales data from the SALES_DBM2 Data Set.

Assorted HLI

C procedures are demonstrated: ACCVER, ACCLOK, ACCFRE, ACCKWD, ACCDEL, ACCGET

C (DBL object)

C Set up variables

integer err, set0, set1, xhush, xmatch, xlok, xopt

integer ds, dbl, qty, etime, odate

character*3 etype

character*40 ename

character*4 scode

character*20 ono

character*12 pterm

character*6 tcode, dcode

character*5 aux

character*1 ans

set0 = 0

set1 = 1

C Formats used in program

91 format(a1)

94 format(a4)

96 format(a6)

C Set up environment

CALL ACCINI (%descr(err), 'trace', 'fortran')

CALL ACCSTO (%descr(err), 'trace', %descr(set0), 'HLI_trace',

1 %descr(set1))

C Call #13 (ACCVER) - display the version of ACCENT R being used

print *, ' '

CALL ACCVER (%descr(err), 'trace')

print *, ' '

print *, '<< Press RETURN to continue >>'

accept 91, ans

C Declare DBL

CALL ACCDBL (%descr(err), %descr(set0), 'books')

C Declare DI

if (err .EQ. 0) then

CALL ACCOPN (%descr(err), 'update', 'di',

1 'nisdemo:sales_dbm2', %descr(ds), 'update')

CALL ACCLOA (%descr(err), 'defer', %descr(ds),

1 'store_code', %descr((scode),

2 'ord_num', %descr(ono),

3 'ord_date', %descr(odate),

4 'qty', %descr(qty),

5 'pay_terms', %descr(pterm),

6 'title_code', %descr(tcode))

end if

C Call #14 (ACCGET) - Get information on DBL object (SALES_DBM2 SD). The ACCOPN

C call specifies the "GET" option and the "DBL" object type.

C The ACCGET call requires the DBL option.

if (err .EQ. 0) then

print *, ' '

print *, '<< Searching BOOKS DBL for SALES SD info >>'

print *, ' '

CALL ACCOPN (%descr(err), 'get', 'dbl', 'books', %descr(dbl))

CALL ACCGET (%descr(err), 'dbl+trace+entry', %descr(dbl),

1 ' ', 'sd', 'sales_dbm2')

CALL ACCLOA (%descr(err), 'trace', %descr(dbl),

1 'entry.type', %descr(etype),

2 'entry.name', %descr(ename),

3 'create.time', %descr(etime))

print *, 'DBL Object Type: ', etype

print *, 'DBL Object Name: ', ename

print *, 'Create Time: ', etime

print *, ' '

print *, 'Press RETURN to continue'

accept 91, ans

end if

C Call #15 (ACCKWD) - Set up keyword for more efficient processing.

if (err .EQ. 0) then

CALL ACCKWD (%descr(err), 'trace', 'match', %descr(xmatch),

1 'hush', %descr(xhush), 'locked', %descr(xlok))

xopt = xmatch + xhush + xlok

end if

C Review / delete process

if (err .EQ. 0) then

print *, 'Enter STOP to exit application'

25 dcode = ' '

print *, ' '

print *, 'Enter title code or STOP'

accept 96, dcode

if (dcode .EQ. 'stop ' .OR. dcode .EQ. 'STOP ') then

go to 50

end if

if (dcode .EQ. ' ') then

go to 50

end if

C Verify title code entered, check status message

CALL ACCGET (%descr(err), %descr(xopt), %descr(ds), ' ',

1 %descr(dcode))

C Call #16 (ACCLOK) - The "locked" option for ACCGET is used in place of ACCLOK.

C This way, only the record to be deleted is locked vs the

C whole Data Set. The call for ACCLOK is shown below

C (as a comment).

C CALL ACCLOK (%descr(err), 'all', %descr(ds))

CALL ACCLOA (%descr(err), %descr(set0), %descr(set0),

1 '@aux', %descr(aux))

if (aux .NE. 'YES') then

print *, ' '

print *, 'Title code does not match in file - try again.'

go to 50

end if

C Display order to be deleted

print *, ' '

print *, 'Order #: ', ono

print *, 'Store Code: ',scode

print *, 'Order Date: ', odate

print *, 'Order Qty: ', qty

print *, 'Pay Terms: ', pterm

print *, 'Title Code: ', tcode

40 print *, ' '

print *, 'Is this the order to be deleted? (Y/N)'

accept 91, ans

if (ans .EQ. 'n' .OR. ans .EQ. 'N') then

go to 50

end if

if (ans .NE. 'y' .AND. and .NE. 'Y') then

print *, 'You must answer Y or N.'

go to 40

end if

C Call #17 (ACCDEL) - delete data set record

CALL ACCDEL (%descr(err), 'immediate', %descr(ds))

C Clear host fields for new record

qty = 0

odate = 0

tcode = ' '

pterm = ' '

ono = ' '

scode = ' '

C Loop Control

50 if (dcode .NE. 'stop' .AND. decode .NE. 'STOP') then

go to 25

end if

C Display error message

if (err .NE. 0 .AND. aux .NE. 'MISSI') then

print *, '*** Program failed due to an error. ***'

end if

C Normal end

C Call #18 (ACCFRE) - release locked records

CALL ACCFRE (%descr(err), 'all', %descr(ds))

CALL ACCCLS (%descr(err), 'all')

CALL ACCEND (%descr(err))

end

=========================================================

[End of FORTRAN Example 2.]

Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the program by entering "SAVE". The editor will return control to the command level prompt.
Compile and LINK the Fortran program through a System File (SF). Enter commands below.

(Depending on the editor used, the command "INSERT" may need to be entered.)

*DEFINE SF HLIF_2.COM

$purge ford2.for

$delete ford2.obj;*

$delete ford2.exe;*

$define nisdemo [user_directory]

$define nis [accent_r_directory]

$define acchli nis:acchli

$Fortran ford2

$link ford2,nis:accvax,nis:acchli/lib

Exit the insert mode. Enter "END" or use CTRL-Z depending on the editor used.
Save the command file by entering "SAVE". The editor will return control to the command level prompt.
Initiate the link then exit ACCENT R or link at the DCL command level.

*LINK TO DCL WITH '@HLIF_2' AND RETURN

*QUIT

(or)

*QUIT

$@HLIF_2

Run application at the VAX DCL prompt. (See note in section introduction.)

$RUN FORD2