File: USRTST.FT of Tape: Various/ETH/f4
(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