c----------------------------------------------------------------------------- C C Importable Fortran Routines C for cleaner input/output C C----------------------------------------------------------------------------- C***************************************************************************** C C NOTE: C All routines that accept string input are expecting a string less C than or equal to 80 characters long and must be terminated by a C back slash character '\' or a Null. If neither is seen then the C string is assumed to be 80 characters long. C C***************************************************************************** C--------------------------- Page Data Storage ------------------------------- C C This routine stores the paging information between page affected calls. C============================================================================= Subroutine PagDat( l,p,lp,po,F ) Integer*4 Lcnt,Pcnt,l,p Character*80 PageTitle,lp Logical*2 Pgon,po,F IF (F .eq. .FALSE.) THEN l = Lcnt p = Pcnt lp = PageTitle po = Pgon ELSE Lcnt = l Pcnt = p PageTitle = lp Pgon = po END IF END C----------------------------------------------------------------------------- C----------------------------------- SLen ------------------------------------ C C Establishes the length of a string. Looks first for the '\' terminator C Then looks for the null terminator and if all of these fail then it C returns the length of the string as specified by the first last C non-space. C============================================================================= Function Slen( Strng ) Byte Strng(80) Integer*2 i, int Integer*2 Slen, Len External Len, Index i = Index( Strng, '\' ) - 1 IF ((i .ge. 1).and.(i .le. 80)) THEN Slen = i RETURN END IF i = Len( Strng ) IF ((i .gt. 0).and.(i .lt. 80)) THEN Slen = i RETURN END IF C This will not produce reliable results!! Please terminate your strings. Do 10 i = 80, 1, -1 IF (Strng(i) .ne. 32) THEN Slen = i RETURN END IF 10 Continue Slen = 0 END C----------------------------------------------------------------------------- C------------------------------ Query to Continue ---------------------------- C C This routine prints a message and waits for the return key to be pressed. C Nothing is returned to the calling process. C============================================================================= SUBROUTINE Query( Message ) Character inp Integer*2 lnth Integer*2 Slen Character*80 message Call WriteString(message,0,0) Read(3,20,err=30,end=30) inp 20 Format( A1 ) 30 END C----------------------------------------------------------------------------- C------------------------------ Clear the Screen ----------------------------- C C This routine clears the screen on VT1xx series terminals. C============================================================================= SUBROUTINE CLS Call WriteChar( 155 ) Call WriteText( '[H', 2 ) Call WriteChar( 155 ) Call WriteText( '[J', 2 ) END C----------------------------------------------------------------------------- C-------------------------------- WriteString -------------------------------- C C This routine accepts a string, and column number and a field width for the C string. It then prints the string at with a width of . C The parameters start and field may be supplied as zero which causes C the string to be printed at column 1, with a length of Slen( Strng ). C============================================================================= SUBROUTINE WriteString( Strng, start, field ) Integer*2 start, field, endmark, Slen, lnth, diff Byte Strng(80) diff = 0 lnth = Slen( Strng ) IF (lnth .lt. 1) RETURN IF ((field .gt. lnth).or.(field .lt. 1)) THEN endmark = lnth diff = field - lnth ELSE endmark = field END IF IF (endmark .gt. 80) endmark = 80 DO 5 i = 1, start Call WriteChar( ' ' ) 5 Continue Call WriteText(Strng,endmark) DO 15 i = 1, diff Call WriteChar( ' ' ) 15 Continue END C----------------------------------------------------------------------------- C-------------------------------- WriteText ---------------------------------- C C This routine accepts a string, and prints it to unit 3. C============================================================================= SUBROUTINE WriteText( Strng, endmark ) Integer*2 endmark Byte Strng(endmark) IF (endmark .eq. 0) Return Write(3,50) Strng 50 Format( A1 ) END C----------------------------------------------------------------------------- C-------------------------------- WriteChar ---------------------------------- C C This routine accepts a char and then prints it to unit. C============================================================================= SUBROUTINE WriteChar( Inchar ) Byte Inchar Write(3,20) InChar 20 Format( A1 ) END C----------------------------------------------------------------------------- C--------------------------------- WriteInt ---------------------------------- C C This routine writes a integer valued variable, and accepts a Field C parameter. C============================================================================= SUBROUTINE WriteInt( Value, field ) Integer*2 field Integer*4 Value Write(3,10) Value 10 Format( I ) END C----------------------------------------------------------------------------- C-------------------------------- Write2Int ---------------------------------- C C This routine writes a integer valued variable, and accepts a Field C parameter. C============================================================================= SUBROUTINE Write2Int( Value, field ) Integer*2 field Integer*2 Value Write(3,10) Value 10 Format( I ) END C----------------------------------------------------------------------------- C-------------------------------- Write1Int ---------------------------------- C C This routine writes a integer valued variable, and accepts a Field C parameter. C============================================================================= SUBROUTINE Write1Int( Value, field ) Integer*2 field Byte Value Write(3,10) Value 10 Format( I ) END C----------------------------------------------------------------------------- C--------------------------------- WriteHex ---------------------------------- C C This routine writes an integer valued variable in hex, and accepts a C Field parameter. C============================================================================= SUBROUTINE WriteHex( Value, field ) Integer*2 field Integer*4 Value Write(3,10) Value 10 Format( Z ) END C----------------------------------------------------------------------------- C--------------------------------- WriteOct ---------------------------------- C C This routine writes an integer valued variable in octal, and accepts a C Field parameter. C============================================================================= SUBROUTINE WriteOct( Value, field ) Integer*2 field Integer*4 Value Write(3,10) Value 10 Format( O ) END C----------------------------------------------------------------------------- C--------------------------------- Writ2Oct ---------------------------------- C C This routine writes an integer valued variable in octal, and accepts a C Field parameter. C============================================================================= SUBROUTINE Writ2Oct( Value, field ) Integer*2 field Integer*2 Value Write(3,10) Value 10 Format( O ) END C----------------------------------------------------------------------------- C--------------------------------- WriteBool --------------------------------- C C This routine writes a logical valued variable, and accepts a C Field parameter. C============================================================================= SUBROUTINE WriteBool( Value, field ) Integer*2 field Logical Value Write(3,10) Value 10 Format( L ) END C----------------------------------------------------------------------------- C--------------------------------- WBinary ----------------------------------- C C This routine writes the binary value of a variable, and accepts a C bit size parameter. C============================================================================= SUBROUTINE WBinary( Vab, size ) Integer*2 i, indx, size Byte outv( 80 ), Vab( * ), vlb( 10 ) Integer*2 Value(5), tmp1, test Equivalence (Vlb(1), Value(1)) DO 1 i = 1, size / 8 + 1 Vlb(i) = Vab(i) 1 Continue DO 5 i = 1, size indx = IIshft( i, -8 ) tmp1 = Value( indx+1 ) test = IIAND( tmp1, 1 ) IF (test .eq. 1) THEN outv(size-i+1)='1' ELSE outv(size-i+1)='0' END IF Value( indx+1 ) = IIshft( tmp1, -1 ) 5 Continue Call WriteString( outv, 0, size ) END C----------------------------------------------------------------------------- C--------------------------------- WriteReal --------------------------------- C C This routine writes a real valued variable, and accepts Field and decimal C parameters. C============================================================================= SUBROUTINE WriteReal( Value, field, dec ) Integer*2 field, dec Real*4 Value Write(3,10) Value 10 Format( F. ) END C----------------------------------------------------------------------------- C-------------------------------- WriteDfloat -------------------------------- C C This routine writes a Dfloat valued variable, and accepts Field and C decimal parameters. C============================================================================= SUBROUTINE WriteDfloat( Value, field, dec ) Integer*2 field, dec Real*8 Value Write(3,10) Value 10 Format( F. ) END C----------------------------------------------------------------------------- C--------------------------------- WriteLn ----------------------------------- C C The routine causes output to be continued on the next line, since the C other routines do not cause linefeeds by default. It also handles C page counting and automatic page termination and numbering when paging C is turned on via a setpage. C============================================================================= SUBROUTINE WriteLn Integer*4 Lcnt, Pcnt Integer*2 i, Slen Character*80 PageTitle Logical*2 Pgon Call WriteChar( 13 ) Call WriteChar( 10 ) Call Pagdat( Lcnt, Pcnt, PageTitle, Pgon, .False. ) IF (Pgon) THEN IF (Lcnt .eq. 58) THEN Lcnt = 0 Pcnt = Pcnt + 1 i = Slen( PageTitle ) IF (i .gt. 0) THEN Call WriteChar( 12 ) Call WriteChar( 13 ) Call WriteChar( 10 ) Call WriteString( 'Page \', 0, 0 ) Call Write2Int( Pcnt, 2 ) Call WriteString( ' - \', 0, 0 ) Call WriteString( PageTitle, 0, 0 ) Call WriteChar( 13 ) Call WriteChar( 10 ) Call WriteChar( 13 ) Call WriteChar( 10 ) END IF END IF Lcnt = Lcnt + 1 Call Pagdat( Lcnt, Pcnt, PageTitle, Pgon, .TRUE. ) END IF END C----------------------------------------------------------------------------- C--------------------------------- SetPage ----------------------------------- C C The routine sets the page title, and also turns on the automatic C paging feature. Automatic paging is handled by the writeln routine. C============================================================================= SUBROUTINE SetPage( q, pnum ) Character*80 q, PageTitle Integer*4 Lcnt, Pcnt, Pnum Integer*2 i, Slen Logical*2 Pgon pnum = pnum + 1 Call Pagdat( Lcnt, Pcnt, PageTitle, Pgon, .False. ) IF ((pnum .eq. -1).and.(Pcnt .lt. 100)) Pnum = Pcnt PageTitle = q Pgon = .True. i = Slen( PageTitle ) IF (i .gt. 0) THEN Call WriteChar( 12 ) Call WriteChar( 13 ) Call WriteChar( 10 ) Call WriteString( 'Page \', 0, 0 ) Call Write2Int( Pnum, 2 ) Call WriteString( ' - \', 0, 0 ) Call WriteString( PageTitle, 0, 0 ) Call WriteChar( 13 ) Call WriteChar( 10 ) Call WriteChar( 13 ) Call WriteChar( 10 ) END IF Lcnt = 1 Call Pagdat( Lcnt, Pnum, PageTitle, Pgon, .True. ) END C----------------------------------------------------------------------------- C--------------------------------- GetPage ----------------------------------- C C The routine gets the current page number. C============================================================================= SUBROUTINE GetPage( v ) Integer*4 Pcnt,Lcnt,v Character*80 PageTitle Logical*2 Pgon Call Pagdat( Lcnt, Pcnt, PageTitle, Pgon, .False. ) v = Pcnt END C----------------------------------------------------------------------------- C------------------------------ Convert Status ------------------------------) C C Converts a packed I/O status into its components for easy use. C============================================================================ Subroutine ConSts( st, ap, pg, pgnum ) Integer*4 st,t Integer*4 pgnum Logical*2 ap,pg ap = .False. pg = .False. pgnum = st / 100000 t = st - (pgnum * 100000) IF (t .ge. 10) THEN pg = .True. t = t - 10 END IF IF (t .eq. 1) THEN ap = .True. END IF END C----------------------------------------------------------------------------) C------------------------------ Convert Status ------------------------------) C C Converts components into a packed I/O status block C============================================================================ Subroutine StsCon( ap, pg, pgnum, st ) Integer*4 st Integer*4 pgnum Logical*2 ap,pg st = 0 st = st + (pgnum * 100000) IF (ap) st = st + 1 IF (pg) st = st + 10 END C----------------------------------------------------------------------------) C--------------------------------- Uppercase --------------------------------- C C Converts a string of any length to uppercase. Only characters are effected. C============================================================================= SUBROUTINE UpperCase( strng, ln ) Byte strng(*) Integer*2 ln, i DO 10 i = 1, ln IF (strng(i) .gt. 96) THEN strng(i) = strng(i) - 32 END IF 10 Continue END C----------------------------------------------------------------------------- C------------------------------- CenterString -------------------------------- C C This routine causes a string to be centered on the screen. C============================================================================= SUBROUTINE CenterString( Strng ) Byte Strng(80) Integer*2 Slen Integer*2 lnth, cent lnth = Slen( Strng ) IF ( lnth .eq. 0 ) Return cent = 40 - ( lnth / 2 ) Call WriteString( Strng, cent, lnth ) END C----------------------------------------------------------------------------- C CentLn writes a centered string and performs carriage return C----------------------------------------------------------------------------- Subroutine CentLn( Strng) Byte Strng(80) Call CenterString( Strng) Call WriteLn Return END C----------------------------------------------------------------------------- C 'Correct' centers a string that reports a correct return value C----------------------------------------------------------------------------- Subroutine Correct( Strng) Byte Strng(80) Byte Local(80) Character*19 intro Data Intro /'Correct return for '/ Encode( len(intro), 1001, Local) Intro 1001 Format( A) i = 1 k = len(Intro) + 1 Do 100 j=k,80 Local(j) = Strng(i) i = i+1 100 Continue Call CentLn( Local) Return END C--------------------------------- BoldCenter -------------------------------- C C This routine causes a string to be centered boldly on the screen. C============================================================================= SUBROUTINE BoldCenter( Strng ) Byte Strng(80) Integer*2 Slen Integer*2 lnth, cent lnth = Slen( Strng ) IF ( lnth .eq. 0 ) Return cent = 20 - ( lnth / 2 ) Call WriteChar( 155 ) Call WriteString( '#3', 0, 0 ) Call WriteString( Strng, cent, lnth ) Call WriteLn Call WriteChar( 155 ) Call WriteString( '#4', 0, 0 ) Call WriteString( Strng, cent, lnth ) END C----------------------------------------------------------------------------- C--------------------------------- ReadInt ----------------------------------- C C This routine reads in an integer which it returns. C============================================================================= Function ReadInt Integer*4 ReadInt Accept 20, ReadInt 20 Format( I6 ) END C----------------------------------------------------------------------------- C-------------------------------- ReadReal ----------------------------------- C C This routine reads in a Real value which it returns. C============================================================================= Function ReadReal Real*4 ReadReal Accept 20, ReadReal 20 Format( F ) END C----------------------------------------------------------------------------- C-------------------------------- ReadDfloat --------------------------------- C C This routine reads in a Dfloat value which it returns. C============================================================================= Function ReadDfloat Real*8 ReadDfloat Accept 20, ReadDFloat 20 Format( F ) END C----------------------------------------------------------------------------- C--------------------------------- ReadHex ----------------------------------- C C This routine reads in a hex value which it returns as an integer. C============================================================================= Function ReadHex Integer*4 ReadHex Accept 20, ReadHex 20 Format( Z6 ) END C----------------------------------------------------------------------------- C--------------------------------- ReadOct ----------------------------------- C C This routine reads in a octal value which it returns as an integer. C============================================================================= Function ReadOct Integer*4 ReadOct Accept 20, ReadOct 20 Format( O6 ) END C----------------------------------------------------------------------------- C--------------------------------- OpenOutput -------------------------------- C C This routine redirects the output from the above routines to any device. C It also handles simulated file extension through the append parameter. C The append is simulated via creating a larger file area and copying the C old as well as the new data into it. C The paging information is also reset in this routine. The assumption C being that page numbers are not to be preserved across devices. C C Dest - 14 character device or filename. C App - A logical indicating if appending is desired or not. C C Note: If dest does not contain a valid device or filename, no error C will be flagged, instead the output will be sent to a default C file based on the output logical unit. C============================================================================= Subroutine OpenOutput( dest, app ) Character*80 st Character*14 dest, txq2 Integer*2 i, Slen Logical*1 app Real*8 name(2) Character*12 dat, txq1 Logical*2 Pgon Integer*4 Lcnt, Pcnt Character*80 PageTitle i = 0 IF (app) Goto 5 1 Close(Unit=3) Open(Unit=3,File=dest,CarriageControl='None',Err=100,Type='New') Goto 40 5 Open(Unit=3,File=dest,Status='Old',ReadOnly,Err=1) Close(Unit=3) 10 Ichan = Igetc() IF (Ichan .lt. 0) Goto 10 dat = ' ' Txq1 = ' TXQ DAT' dat(1:3) = dest(1:index(dest,':')-1) Txq1(1:3) = dest(1:index(dest,':')-1) dat(4:9) = dest(index(dest,':')+1:Index(dest,'.')-1) dat(10:12) = dest(Index(dest,'.')+1:) Call Irad50(12,dat,name(1)) Call irad50(12,txq1,name(2)) Call Irenam( Ichan, name ) Call Ifreec( Ichan ) Open(Unit=3,File=dest,CarriageControl='None') txq2(1:Index(dest,':')) = dest(1:index(dest,':')) txq2(Index(dest,':')+1:) = 'TXQ.DAT ' Open(Unit=2,File=txq2,Status='Old',ReadOnly) 20 Read(2,50,end=30) st Call SetTrm( st, 80 ) Call Trim( st ) i = Slen( st ) IF (i .gt. 0) Write(3,25) st 25 Format( A ) Write(3,26) 13, 10 26 Format( 2A1 ) Goto 20 30 Close(Unit=2) 35 Ichan = Igetc() IF (Ichan .lt. 0) Goto 35 Call Idelet( Ichan, name(2) ) Call Ifreec( Ichan ) 40 i = i 50 Format( A80 ) PageTitle = ' ' Pcnt = 0 Lcnt = 1 Pgon = .FALSE. Call Pagdat( Lcnt, Pcnt, PageTitle, Pgon, .True. ) RETURN 100 dest = 'DK:' Goto 1 END C----------------------------------------------------------------------------- C--------------------------------- CloseOutput ------------------------------- C C This routine redirects the output to the screen from any device. C============================================================================= Subroutine CloseOutput Close( Unit=3 ) END C----------------------------------------------------------------------------- C---------------------------------- SetTrm ----------------------------------- C C This routine allows a Null to be placed at any location in a character C string without the use of equivalence statements, and string copying. C============================================================================= Subroutine SetTrm( val1, ln ) Integer*2 ln BYTE Val1(ln) Val1(ln) = 0 END C-----------------------------------------------------------------------------