MICROSOFT FORTRAN COMPILER ASSEMBLER ENHANCMENTS V 1.16 08/26/86
(C) John R. Petrocelli 01/16/86
3890 Carman Rd.
Schenectady, N.Y. 12303

HISTORY:
Rev. 04/01/86 V 1.02
Rev. 04/02/86 V 1.03
Rev. 04/03/86 V 1.04
Rev. 04/07/86 V 1.05
Rev. 04/08/86 V 1.06
Rev. 04/13/86 V 1.07
Rev. 04/14/86 V 1.08
Rev. 04/15/86 V 1.09
Rev. 04/16/86 V 1.10
Rev. 04/17/86 V 1.11
Rev. 04/23/86 V 1.12
Rev. 04/24/86 V 1.13
Rev. 04/25/86 V 1.14
Rev. 06/09/86 V 1.15
Rev. 08/26/86 V 1.16 - Added BUFLOD
Rev. 09/16/86 V 1.17 - Added KEYCHK

------------------------------------------------------------------------
***********
All of the following routines are included in the file STJRP01.LIB
***********
------------------------------------------------------------------------


Permission is granted to copy and incorporate these routines in any
user written code. As such no fee may be associated with their individual
copying and use. This DOES NOT PRECLUDE fees associated with user written
software which may incorporate these routines. In all cases, however, all
copyright notes must remain intact.

The author makes no waranties of any kind and assumes no respons-
ability for loss of data or time associated with their use.

All of the routines have been tested and performed as specified in
each of the tests. Any problems, suggestions or comments should be
fowarded to the author.

------------------------------------------------------------------------
------------------------------------------------------------------------

All of the following routines are included in the file STJRP01.LIB

Should you need to alter any of the routines you merely have to enter
it as an .OBJ file at LINK time. The LINKER will accept the first
name matched for a call or function.

------------------------------------------------------------------------
------------------------------------------------------------------------

1. Date and Time--------------object module "TOD.OBJ"
CALL PCDATE(YEAR,MONTH,DAY)
Note: Arguments should be declared integer*2

CALL PCTIME(HOUR,MINUTE,SECOND,MILSEC)
Note: Arguments should be declared integer*2

CALL TAD(MO1,MO2,DA1,DA2,YEAR,YR1,YR2,HR1,HR2,MIN1,MIN2,SEC1,SEC2)
Note: 1. Arguments should be declared integer*2
2. this is a FORTRAN LANGUAGE SUBROUTINE which will
interface with PCDATE and PCTIME
3. The variables xx1 and xx2 are the 10's and 1's
digit for each of the various parameters(MO=month
DA=day etc) while the variable YEAR is the full
4 digit YEAR value.

------------------------------------------------------------------------

2. Day of Week ---------------object module "DOW.OBJ"
CALL WEEKDY(MONTH,DAY,YEAR,DOFWK)
Note: 1. Arguments should be declared Integer*2
2. Year must be the full 4 digit year(1980,1985 etc)
and may range from 1901 to 2099. Leap years are
properly handled since the year 2000 is a turn of
the century divisible by 400 and it is in fact also
divisible by 4 like the normal leap years
3. The variable DOFWK is the integer specifying the
DAY OF WEEK where: 1=Sunday 2=Monday 3=Tuesday
4=Wednesday 5=Thursday 6=Friday
7=Saturday

------------------------------------------------------------------------

3. Video Display control------object module "VIDEO.OBJ"
CALL VIDCOL(COLOR)
Note: 1. Argument COLOR must be declared character*2
2. COLOR is a value as defined on page 13-9 of
the DOS manual
3. This routine requires that your "CONGIG.SYS" file
contains the parameter "DEVICE=ANSI.SYS"

CALL VIDCLR
Note: 1. This will clear the screen
2. This routine DOES NOT REQUIRE that your "CONFIG.SYS"
file contains the parameter "DEVICE=ANSI.SYS"

CALL VIDCLZ
Note: 1. This will clear the screen
2. This routine REQUIRES that your "CONGIG.SYS" file
contains the parameter "DEVICE=ANSI.SYS"

CALL VIDLCR(ROW,COL)
Note: 1. Arguments ROW and COL must be declared integer*2
2. this routine will determine what row and column the
cursor is located on the display

CALL VIDMCR(ROW,COL)
Note: 1. Arguments ROW and COL must be declared integer*2
2. this routine will move the cursor to the specified
row and column on the display
3. Backslash (\) editing may be needed in your FORMAT
statements

CALL VIDCSR(START,END,CODE,RC)
Note: 1. Arguments START, END, CODE, and RC should be
declared integer*2
2. Arguments START and END reference the cursor lines
(0 to 4 for the monochrome display and 0 to 7 for
the color graphics display) from top to bottom. if
START is greater than END then the cursor is split
3. Argument CODE may be 0 to get the cursor START and
END lines or 1 to set the lines
4. Argument RC is the return code from the call

CALL VIDSCN(SCREEN)
Note: 1. Argument SCREEN should be declared integer*2
2. Argument SCREEN is the active screen on the display
(0 to 7 in 40 column text mode and 0 to 3 in 80
column text mode)

CALL VIDMOD(MODE)
Note: 1. Argument MODE should be declared integer*2
2. Argument MODE is the current video mode as follow:
0=40x25 b/w alpha 4=320x200 color graphics
1=40x25 color alpha 5=320x200 b/w graphics
2=80x25 b/w alpha 6=640x200 b/w graphics
3=80x25 color alpha


CALL VIDSCL(DIRECT,SCRAMT,UPLROW,UPLCOL,LRTROW,LRTCOL,ATTR)
Note: 1. This routine will scroll a window up or down
based on the value of DIRECT(0=up, 1=down).
2. All arguments should be declared integer*2
3. the argument DIRECT defines the DIRECTion to
scroll(0=up, 1=down)
4. The argument SCRAMT defines the number of
lines to scroll.
5. The arguments UPLROW and UPLCOL define the upper
left corner of the window respectively.
6. The arguments URTROW and URTCOL define the lower
right corner of the window respectively.
7. The argument ATTR defines the attribute to use on
the blanked lines.
8. Note that for an 80x25 display the rows are numbered
0 thru 24 and the columns are numbered 0 thru 79.

------------------------------------------------------------------------

4. Keyboard Input Control-----object module "KEYPGM.OBJ"
CALL KEYBUF(BUFFER,KEYSIN,CHARIN)
Note: 1. Arguments BUFFER and KEYSIN should be declared
integer*2
2. Argument CHARIN must be declared character*n
where n is the maximum number of characters that
will be read in
3. Argument BUFFER is the maximum number of characters
(not including ) that may be typed in before
the speaker will beep
4. Argument KEYSIN is the number of characters actually
input (not including )
5. Argument CHARIN will return the characters actually
input (not including )
6. This routine is useful in limiting the length of
data entry vs using a read which may truncate input
characters
7. If the requested character count (BUFFER) is greater
than 80 or less than 1 then the returned value of
KEYSIN is set to 255

CALL KEYIN(CHARIN)
1. Argument CHARIN should be declared character*1
2. This routine will cause the program to wait for
a key stroke before continuing and return the
actual key typed in CHARIN


CALL KEYCOD(ASCII,SCAN)
1. Arguments ASCII and SCAN should be declared
integer*2
2. This routine will return the ASCII code and
keyboard SCAN code when a key is struck on the
keyboard. it doen not clear the keyboard buffer
and thus multiple key presses will be processed
in sequence. this routine will enable the user to
have access to all key combinations from the keyboard
such as F1-F10, Home, End, PgUp, PgDn etc.
3. To determine the ASCII and SCAN codes for a particular
key or combination of keys, just write a short
fortran program to call KEYCOD and print the values.
make the call in an infinite loop and use CTRL-Break
to exit. Example follows:
INTEGER*2 ASCII
INTEGER*2 SCAN
1 CALL KEYCOD(ASCII,SCAN)
WRITE(*,2) ASCII,SCAN
2 FORMAT(' ASCII=',I2,' SCAN=',I2,\)
GO TO 1
END

CALL KEYCHK(STATUS)
1. Argument STATUS should be declared integer*2
2. This routine will return the STATUS of the KEYBOARD
BUFFER. 0 = no character available
255 = character is available
If a character is available a user may use the
KEYCOD routine to check the ASCII and SCAN CODE value
of the key in the KEYBOARD BUFFER.

------------------------------------------------------------------------

5. Sound----------------------object module "SOUND.OBJ"
CALL SOUND(FREQ,HSEC)
Note: 1. Arguments FREQ and HSEC should be declared integer*2
2. Argument FREQ is the frequency in HERTZ ranging
from 21 to 25000
3. Argument HSEC is the duration in hundredths(.01)
seconds ranging from 1 to 25000

------------------------------------------------------------------------

6. peak n poke----------------object module "PEAKPOKE.OBJ"
CALL PEAK(SEGMNT,OFFSET,VALUE)
Note: 1. Arguments SEGMNT, OFFSET, and VALUE should be
declared integer*2
2. This routine will return VALUE with the contents of
memory address SEGMNT:OFFSET

CALL POKE(SEGMNT,OFFSET,VALUE)
Note: 1. Arguments SEGMNT, OFFSET, and VALUE should be
declared integer*2
2. This routine will load VALUE into the contents of
memory address SEGMNT:OFFSET

------------------------------------------------------------------------

7. dos functions -------------object module "DOSFOR.OBJ"
CALL DOSVER(MAJOR,MINOR)
Note: 1. Arguments MAJOR AND MINOR should be declared
integer*2
2. This routine will return MAJOR and MINOR components
of the DOS version. Thus for DOS 3.10 MAJOR would
be equal to 3 and MINOR would be equal to 10.

------------------------------------------------------------------------

8. set dos return code--------object module "SETRC.OBJ"
CALL SETRC(RC)
Note: 1. Argument RC should be declared integer*2
and can range from 0 to 255.
2. This routine will set the return code. This should
be called just before a "STOP" statement in your
FORTRAN source. The RETURN CODE may be retrieved
by:
A) testing the return code value in the
SPAWN and SYSTEM functions in Microsoft
Fortran V3.30 or later.
B) testing the ERRORLEVEL in BATCH files
C) using DOS function 4Dh in assembler

------------------------------------------------------------------------

9. get free memory -----------object module "MEMFRE.OBJ"
CALL MEMFRE(MPARA)
Note: 1. Argument MPARA should be declared integer*2
2. this routine will return the number of PARAGRAPHS
(16 byte blocks) of memory available/free above
executing program. This is the memory available
to the SPAWN and SYSTEM calls in MS FORTRAN V3.30
or later.
3. To compute the memory available:
FREE BYTES = MPARA * 16
FREE K BYTES = (MPARA * 16)/1024

4. Note that DOS 3.1 COMMAND.COM requires approximately
3776 BYTES. Thus if you are going to be loading
COMMAND.COM, you should subtract 3776 BYTES from
the available memory(in BYTES) to determine the
memory available after loading COMMAND.COM.

------------------------------------------------------------------------

10. get default drive ---------object module "GETDRV.OBJ"
CALL GETDRV(DRIVE)
Note: 1. Argument DRIVE should be declared character*1

------------------------------------------------------------------------

11. set default drive ---------object module "SETDRV.OBJ"
CALL SETDRV(DRIVE,IRC)
Note: 1. Argument DRIVE should be declared character*1
argument IRC should be declared integer*2
2. This routine will attempt to change the default
drive to the specified letter (A,B,c,d, etc).
if successful IRC will be set to "0" or if it
fails IRC will be set to "1".

------------------------------------------------------------------------

11. get default directory------object module "GETDIR.OBJ"
CALL GETDIR(DRIVE,DIR,IRC)
Note: 1. Argument DRIVE should be declared character*1
argument DIR should be declared CHARACTER*64
argument IRC should be declared integer*2
2. This routine will return the default directory(DIR)
for the specified DRIVE (A,B,c,d, etc).
if successful IRC will be set to "0" or if it

fails IRC will be set to "1" (ie. DRIVE invalid).
the value of DIR returned will not contain the
DRIVE specifier. thus if the current directory is
"D:\MYDIR\SOURCE" the value of DIR will be
"MYDIR\SOURCE".

------------------------------------------------------------------------

12. set default directory------object module "SETDIR.OBJ"
CALL SETDIR(DIR,IRC)
Note: 1. Argument DIR should be declared CHARACTER*64
argument IRC should be declared integer*2
2. This routine will attempt to change the
directory for the specified DRIVE (A,B,c,d, etc).
the value of DIR must be in the form
"drive:\dir1\dir2".
if successful IRC will be set to "0" or if it
fails IRC will be set to "1" (ie. DRIVE invalid
or DIRECTORY not found.

------------------------------------------------------------------------

13. 8087/80287 installed ? ----object module "Q8087.OBJ"
CALL Q8087(STATUS)
Note: 1. Argument STATUS should be declared integer*2
2. This routine will verify the existance of
the MATH CO-PROCESSOR (8087 OR 80287).
If it is installed and functioning the value
of "STATUS" will be set to "1", otherwise it
will be set to "0".

------------------------------------------------------------------------

14. get COMSPEC ---------------object module "GETCOM.OBJ"
CALL GETCOM(COMSPC,IRC)
Note: 1. Argument COMSPC should be declared character*64
argument IRC should be declared integer*2
2. This routine will search the ENVIRONMENT for
the COMSPEC (where COMMAND.COM is loaded from)
and if successful will set the variable COMSPC
to that value. if successful IRC will be set to
"0" and if unsuccessful IRC will be set to "1".

------------------------------------------------------------------------

15. UPer CASE CONVERSION-------object module "UPCASE.OBJ"
CALL UPCASE(STRING,LENGTH)
Note: 1. Argument STRING should be declared character*NN
where 1 <= nn <= 127 .
2. This routine will scan the STRING for the number
of characters in LENGTH and convert all lower case
characters to upper case.

------------------------------------------------------------------------

15. FILE NAME BUILD -----------object module "FNBLD.OBJ"
CALL FNBLD(DRIVE,DIR,FILE,FULNAM,IRC)
Note: 1. Argument DRIVE should be declared character*1
argument DIR should be declared character*64
argument FILE should be declared character*12
argument FULNAM should be declared character*64
argument IRC should be declared INTEGER*2
2. This routine will take the DRIVE, DIRectory, and
FileNAME and return the FULNAME (fully qualified with
drive, path and file name.
3. IRC will be set to "0" unless truncation occurs,
when it will be set to "1".
4. The DIR may or may not contain leading and/or
trailing "\". they will be placed as required.
5. The validity of DIR and FILE is not checked. that
is left to the user.

------------------------------------------------------------------------

16. DISK FREE SPACE IN BYTES ---object module "DSKFRE.OBJ"
CALL DSKFRE(DRIVE,BYTES,IRC)
Note: 1. Argument DRIVE should be declared character*1
argument BYTES should be declared integer*4
argument IRC should be declared integer*2
2. This routine will return the free BYTES for the
specified DRIVE.
3. IRC will be set to "0" if the drive is valid, or
"1" if the DRIVE is not valid.

------------------------------------------------------------------------

17. DISK SIZE IN BYTES --------object module "DSKSIZ.OBJ"
CALL DSKSIZ(DRIVE,BYTES,IRC)
Note: 1. Argument DRIVE should be declared character*1
argument BYTES should be declared integer*4
argument IRC should be declared integer*2
2. This routine will return the total BYTES(ie. size)
for the specified DRIVE.
3. IRC will be set to "0" if the drive is valid, or
"1" if the DRIVE is not valid.

------------------------------------------------------------------------

18. LEFT JUSTIFY A CHARACTER STRING --object module "LFJUST.OBJ"
CALL LFJUST(STRING,LENGTH)
Note: 1. Argument STRING should be declared character*NN
where NN is the LENGTH of the string.
argument LENGTH should be declared integer*2
2. This routine will left justify the character
STRING specified.
3. If LENGTH is GREATER than the decalred value of
the character string, unpredictable results will
occurr. LENGTH may be less than or equal to the
length of the character string and may range
from 1 to 127.

------------------------------------------------------------------------

19. RIGHT JUSTIFY A CHARACTER STRING --object module "RTJUST.OBJ"
CALL RTJUST(STRING,LENGTH)
Note: 1. Argument STRING should be declared character*NN
where NN is the LENGTH of the string.
argument LENGTH should be declared integer*2
2. This routine will right justify the character
STRING specified.
3. If LENGTH is GREATER than the decalred value of
the character string, unpredictable results will
occurr. LENGTH may be less than or equal to the
length of the character string and may range
from 1 to 127.

------------------------------------------------------------------------

20. CENTER A CHARACTER STRING --object module "CENTER.OBJ"
CALL CENTER(STRING,LENGTH)
Note: 1. Argument STRING should be declared character*NN
where NN is the LENGTH of the string.
argument LENGTH should be declared integer*2
2. This routine will center the character
STRING specified.
3. If LENGTH is GREATER than the decalred value of
the character string, unpredictable results will
occurr. LENGTH may be less than or equal to the
length of the character string and may range
from 1 to 127.

------------------------------------------------------------------------

21. get memory used by program-----object module "MEMUSE.OBJ"
CALL MEMUSE(UPARA)
Note: 1. Argument UPARA should be declared integer*2
2. this routine will return the number of PARAGRAPHS
(16 byte blocks) of memory used by the executing
program.
3. To compute the memory used:
USED BYTES = UPARA * 16
USED K BYTES = (UPARA * 16)/1024

------------------------------------------------------------------------

22. buffered file read ------------object module "BUFLOD.OBJ"
CALL BUFLOD(FUNCT,FILE,BUFFER,BUFLEN,HANDLE,CHRSIN,RC)
Note: 1. All arguments except BUFFER should be declared
integer*2.
2. The argument BUFFER should be declared character*1
and should be dimensioned to the size of BUFLEN
3. Valid functions are:
0 = open file and return a file HANDLE
1 = read BUFLEN number of characters from
the FILE via the file HANDLE into BUFFER.
2 = close the FILE via the file HANDLE
4. Error codes are:
0 = OK
2 = file not found
3 = path not found
4 = to many open files (no HANDLES left)
5 = access denied
6 = invalid file HANDLE
32767 = invalid function # to BUFLOD subroutine
5. This routine will read a file into a user specified
file into a user specified BUFFER. The buffer may be
scanned by the user's code for string matches or
whatever.
Reading may continue until the characters read in
(CHRSIN) is less than the size of the buffer(BUFLEN)
at which time the file should be closed via function
# 2.
Essentially this routine allows a user to read a
sequential file regardless of line length and being
written in assembler shows significant improvement
in performance over similar code in fortran.
6. Sample code fillows:
Ruler====>----------1----------2---------3---------4---------5---------6
Ruler====>1-----7---0----------0---------0---------0---------0---------0
C *****************************************************
C * SAMPLE BUFFERED READ *
C *****************************************************
C ********* DECLARE VARIABLES **********
INTEGER*2 FUNCT,BUFLEN,HANDLE,CHRSIN,RC,ICHIN,TOTAL
CHARACTER*64 FILE
CHARACTER*1 BUFFER(256)
C ********* SET BUFFER LENGTH VARIABLE *
BUFLEN=256
C ********* GET FILE NAME **************
WRITE(*,*) 'ENTER FILE NAME'
READ(*,1002) FILE
1002 FORMAT(A64)
C ********* PUT ASCII ZERO AT END OF FILE NAME
FILE(64:64)=CHAR(0)
C ********* OPEN FILE ******************
FUNCT=0
CALL BUFLOD(FUNCT,FILE,BUFFER,BUFLEN,HANDLE,CHRSIN,RC)
IF (RC .NE. 0 ) THEN
WRITE(*,*) 'OPEN FUNCTION RETURN CODE NE 0 ===>',RC
GO TO 999
ENDIF
C ********* SKIP A LINE AND START AT ***
C ********* THE BEGINNING OF THE NEXT **
C ********* LINE ***********************
WRITE(*,2000)
2000 FORMAT(/,\)
2 CONTINUE
C ********* READ FILE UNTIL END ********
FUNCT=1
CALL BUFLOD(FUNCT,FILE,BUFFER,BUFLEN,HANDLE,CHRSIN,RC)
IF (RC .NE. 0 ) THEN
WRITE(*,*) 'READ FUNCTION RETURN CODE NE 0 ===>',RC
GO TO 88
ENDIF
TOTAL=TOTAL+CHRSIN
ICHIN=CHRSIN
C ********* CHECK FOR END AND IF SO ****
C ********* ALSO CHECK FOR HEX 1A - ****
C ********* END OF FILE MARKER ****
IF ((ICHIN .LT. BUFLEN) .AND.
* (BUFFER(ICHIN:ICHIN) .EQ. CHAR(26))) ICHIN=ICHIN-1
C ********* WRITE OUT BUFFER TO SCREEN *
C ********* 1 CHARACTER AT A TIME ******
DO 50 J=1,ICHIN
WRITE(*,2001) BUFFER(J)
2001 FORMAT(A1,\)
50 CONTINUE
C ********* LOOP IF NOT END ************
IF (CHRSIN .EQ. BUFLEN) GO TO 2
88 CONTINUE
C ********* CLOSE FILE *****************
FUNCT=2
CALL BUFLOD(FUNCT,FILE,BUFFER,BUFLEN,HANDLE,CHRSIN,RC)
IF (RC .NE. 0 )
* WRITE(*,*) 'CLOSE FUNCTION RETURN CODE NE 0 ===>',RC
99 CONTINUE
C ********* REPORT STATISTICS **********
WRITE(*,*)
WRITE(*,*) 'FILE HANDLE WAS ==========>',HANDLE
WRITE(*,*) 'TOTAL CHARACTERS READ IN =>',TOTAL
999 CONTINUE
END

------------------------------------------------------------------------