File: USRTST.FT of Tape: Various/ETH/fc-files
(Source file text)
C
C TEST USR-ROUTINE IN F4
C
C URSPRUNG: ROBERT PHELPS, ROCHESTER, USA
C VERTRIEB: DATAPLAN GMBH, LAUDA, BRD
C
C USR ERMOEGLICHT DEN FILE-ZUGRIFF UNTER FORTRAN IV
C OHNE FRTS IRGENDWELCHE ANGABEN UEBER FILES ZU MACHEN.
C DAMIT WIRD DASSELBE ERREICHT WIE IN FORTRAN II MIT
C DEN ROUTINEN CALL OOPEN,IOPEN,OCLOSE.
C BEACHTEN SIE BITTE,DASS ES KEIN CALL CHAIN GIBT !!
C
C HANDHABUNG VON USR :
C
C 1.ALLGEMEINER AUFRUF
C
C CALL USR (IDEV,NAME,IFUNC,IFEHL)
C
C 2. PARAMETER
C IDEV : LOGISCHE GERAETE-# WIE NORMALERWEISE FRTS
C ANGEGEBEN,ZULAESSIG NUR 5-9.
C NAME : GERAETE-NAME,FILENAME,EXTENSION NACH OS/8
C -KONVENTION,ABGESPEICHERT IM 3A6-FORMAT.
C STRINGS SIND ZULAESSIG,'@' UND SPACES
C WERDEN IGNORIERT.WIRD KEIN GERAET ANGEGEBEN,
C SO WIRD 'DSK:' ANGENOMMEN.
C IFUNC : VON USR AUSZUFUEHRENDE FUNKTION
C 2 : FILE OEFFNEN FUER LESEN (=IOPEN)
C 3 : FILE OEFFNEN FUER AUSGABE (=OOPEN)
C 4 : AUSGABE-FILE SCHLIESSEN (=OCLOSE)
C DIE FILE NAME DIE FUER EIN <CLOSE> OPERATION
C VERWENDET WIRD MUSS MIT DERJENIGE DER FUER
C EIN <OPEN> VERWENDET WURDE UEBEREINSTIMMEN.
C EIN <CLOSE> MIT LAENGE 0 ODER AN EIN EINGABE
C FILE (IFUNC=2) WIRD DIESER FILE NAME VOM
C DIRECTORY ENTFERNEN.
C IFEHL : FEHLERERKENNUNG NACH RUECKKEHR AUS DER
C SUBROUTINE
C 0 : KEIN FEHLER,ALLES OK.
C 1 : ILLEGALES OS/8-GERAET
C 2 : ILLEGALER FILE-NAME
C 3 : ILLEGALE LOGISCHE GERAETE-#,D.H.
C NICHT ZWISCHEN 5 UND 9,AUCH KERNSPEICHER
C UEBERSCHREITUNG.
C 4 : ILLEGALER FUNKTIONSWERT (NUR 2,3,4)
C
C INTERNE 3.FEHLERMELDUNG
C USER ERROR 0002 : BENUTZER DEFINIERTE EINEN NICHT RESI-
C DENTEN HANDLER,DER USR NICHT ANGEGEBEN WURDE.
C
C 4. BEMERKUNG
C JEDEM LOGISCHEN GERAET WERDEN 512 KERNSPEICHERPLAETZE
C ZUEGEWIESEN,JE 256 FUER HANDLER UND PUFFER,IM HOECH-
C STEN ZUR VERFUEGUNG STEHENDEN KERNSPEICHERFELD.DA DIE
C ZUWEISUNG STARR AN DIE LOGISCHEN GERAETE-NUMMERN GE-
C KOPPELT IST UND MIT DER HOECHSTEN NUMMER BEGINNT,SOLLTEN
C DIE NUMMERN VON DER HOECHSTEN ANB BENUTZT WERDEN.WIRD
C Z.B. NUR EINE NUMMER BENOETIGT UND DAFUER DIE 7 ANGEGEBEN,
C BLEIBEN DIE FUER DIE NUMMERN 8 UND 9 BENOETIGTEN PLAETZE
C IM KERNSPEICHER FREI UND KOENNEN NICHT VOM PROGRAMM BE-
C LEGT WERDEN,VERLUST :1024 PLAETZE.
C SELBSTVERSTAENDLICH SCHLIESST DIE VERWENDUNG EINER GERAETE-
C NUMMER INNERHALB VON USR DEREN VERWENDUNG ALS ZUWEISUNG
C AN FRTS AUS.WENN IN EINEM PROGRAMM USR BENUTZT WIRD
C SOLLTEN FRTS UEBERHAUPT KEINE ANGABEN UEBER LOGI-
C SCHE GERAETE-NUMMERN GEMACHT WERDEN,SONDERN ALLES INTERN
C UEBER USR LAUFEN.
C DIE <FRTS> INTERNE GERAETEN (WIE #3:LPT) , SYS: UND
C GERAETE KORESIDENT MIT SYS: DUERFEN WEITERHIN
C VERWENDET WERDEN.
C
C 5. USR KANN SELBSTVERSTAENDLICH UEBER DIE UEBLICHEN
C BEFEHLE AN LIBRA DER FORLIB EINVERLEIBT WERDEN :
C .R LIBRA
C *FORLIB<USR
C *^C
C
C MOEGLICHERWEISE INDEX DER FORLIB VERGROESSERN :
C *FORLIB[10]<FORLIB,USR/Z=50
C
C 6. PATCH AN FRTS (NOETIG WEGEN PUFFER-ZUWEISUNG )
C
C ES GIBT EINE VERSION VON <FRTS> DER DIESEN PATCH
C ENTHAELT: VERSION MUSS DIE BUCHSTABE U ENTHALTEN.
C Z.B. FRTS V 5A M8 U
C -
C
C
C
C GERAETE# =9 (MOEGLICHST HOCH ,NICHT UNTER 5 !!)
NDEV=9
WRITE(4,1)
1 FORMAT(//,' TEST USR-ROUTINE',//)
500 WRITE(4,67)
67 FORMAT(/,' LESEN(=1),SCHREIBEN(=2) ODER LOESCHEN(=3) ? '$)
READ(4,69)JGO
69 FORMAT(I1)
GOTO (200,300,400),JGO
300 CONTINUE
C FILE AUFMACHEN & SCHREIBEN
WRITE(4,5)
5 FORMAT(' GERAETE- UND FILENAME :'$)
READ(4,7)F1,F2,F3
7 FORMAT(3A6)
WRITE(4,47)
47 FORMAT(/,' WIEVIELE WERTE SCHREIBEN ?'$)
READ(4,19)IANZ
19 FORMAT(I4)
C FILE AUFMACHEN
CALL USR(NDEV,F1,3,IERR)
IF(IERR)22,24,22
22 WRITE(4,23)IERR
23 FORMAT(/,' USR-FEHLER#',I1,/)
CALL EXIT
24 CONTINUE
WRITE(NDEV,19)IANZ
DO 20 K=1,IANZ
T=K**2
WRITE(NDEV,31)T
31 FORMAT(F8.0)
20 CONTINUE
C FILE DICHTMACHEN
CALL USR(NDEV,F1,4,IERR)
IF(IERR)40,50,40
40 WRITE(4,23)IERR
CALL EXIT
50 CONTINUE
GOTO 500
C FILE LESEN & DRUCKEN
200 WRITE(4,5)
READ(4,7)G1,G2,G3
C FILE INPUT
CALL USR(NDEV,G1,2,IERR)
IF(IERR)101,103,101
101 WRITE(4,105)
105 FORMAT(/,' FILE LEIDER NICHT GEFUNDEN,WAS TUN ?g)
GOTO 500
103 CONTINUE
READ(9,19)IANZ
DO 120 K=1,IANZ
READ(NDEV,31)T
WRITE(4,31)T
120 CONTINUE
GOTO 500
C MIT BLOCKLAENGE 0 DICHTMACHEN=LOESCHEN
400 WRITE(4,5)
READ(4,7)H1,H2,H3
CALL USR(NDEV,H1,3,IERR)
IF(IERR)406,404,406
406 WRITE(4,23)IERR
CALL EXIT
404 CALL USR(NDEV,H1,4,IERR)
GOTO 500
CALL EXIT
END