C File- FIORTN.FLX I/O Routines for FLECS programs KL Danneil 16-June-83 SUBROUTINE IWRITE(LUR,STRNG) C Line mode output. Write a line of characters from STRNG to logical unit LU. C INTEGER*2 LUR !Logical unit to WRITE requested BYTE STRNG(1) !String to return characters in INTEGER Slen !String Function C ILU= LUR IF (LUR .EQ. 0) ILU= 7 !Assume terminal output RT11 ILEN= Slen(STRNG) D WRITE (7,1) LUR,(STRNG(I),I=1,ILEN+2) D1 FORMAT ('$','IWRITE- LUR,STRNG= ',3I5,'"',132A1) D WRITE (7,3) D3 FORMAT ('+','"') WRITE (ILU,10,ERR=20) (STRNG(I),I=3,ILEN+2) 10 FORMAT (' ',132A1) RETURN C Error 20 CONTINUE C TYPE *,'IWRITE- Error on output. LUR,ILU=',LUR,ILU CALL ERRSNS(IERR,ILU) WRITE (7,22) LUR,ILU,IERR 22 FORMAT (' ','IWRITE- Error on output. LUR,ILU, error code=',3I7) RETURN END C C SUBROUTINE Linput(LUR,STRNG,PROMPT,EOF) C Line mode input. Read a line of characters from logical unit LU into STRNG. C If end of file set EOF .True., otherwise return .False. C PROMPT is only used for Terminal input on logical unit 5, it is ignorred for C any other LU. PROMPT is used in strictly RT11 format (ie. doesn't expect C FLECS length parameter). C INTEGER*2 EOF !End Of File flag INTEGER*2 LUR !Logical unit to READ requested BYTE STRNG(1) !String to return characters in BYTE PROMPT(1) !String to Prompt for input BYTE S200(4) !Suppress ie. "200 terminator DATA S200/1,1,"200,0/ !an RT11 FLECS string KLD mod INTEGER Slen,Smaxln,Cpystr C String STMP(134) !Temporary input string C 1 CONTINUE EOF= .FALSE. !Assume not EOF LUL= LUR IF (LUR .EQ. 0) LUL= 5 !Assume terminal input RT11 D Type *,'Linput- LUR,LUL=',LUR,LUL C If input from terminal, use GTLIN so input can be from .COM file When (LUL .EQ. 5) D Type *,'Terminal input' D Type * ILEN= LEN(PROMPT) !RT11 func IF (ILEN .GT. 0) IF (ILEN .GT. 79) ILEN=79 !kld 22jun84 IERR= .FALSE. !kld 22jun84 CALL SCOPY(PROMPT,STMP(3),ILEN,IERR) !RT11 func STMP(ILEN+3)=S200(3) !kld 11jun84 STMP(ILEN+4)=S200(4) !kld 11jun84 CALL Slenpt(ILEN+1,STMP) !kld 22jun84 Fin !if CALL GTLIN(STMP(3),STMP(3)) !RT11 func NN= LEN(STMP(3)) !RT11 func D Type *,'NN=',NN C CALL ISCCA !kld 11jun84 !Check for 2 Ctrl-C's Fin !when Else D Type *,'File input' READ (LUL,10,END=20,ERR=30) NN,(STMP(II),II=3,NN+2) 10 FORMAT (Q,132A1) D Type *,'II,NN=',II,NN STMP(NN+3)= 0 !kld 22jun84 Fin If (NN .GT. 132) Type *,'Linput- Too many characters. Corruption possible! NN=',NN Type * Fin !if LL= Smaxln(STRNG) !kld 22jun84 If (NN .GT. LL) Type *,'Too many characters. Only ',LL, & ' are allowed. NN=',NN Type * GOTO 1 Fin !if CALL Slenpt(NN,STMP) !kld 12jun84 CALL Cpystr(STRNG,STMP) D Type 11,NN,(STMP(I),I=1,NN+2) D11 FORMAT ('$','Linput- NN,GTLIN=',3I7,' "',132A1) D Type 13 D13 FORMAT ('+','"'/) RETURN C End Of File 20 CONTINUE EOF= .TRUE. C KLD 11JUN84 Future Feature!!! C Type *,'End of File detected. Reverting to terminal input mode!' C Type * C IF (LUR .GT. 0) CLOSE (UNIT= LUR) C LUR= 0 C GOTO 1 D Type *,'Linput- EOF detected.' RETURN C Error on input 30 CONTINUE EOF= .TRUE. D Type *,'Linput- File Error' RETURN END C C SUBROUTINE RINPUT(ILU,REALIN,PROMPT,EOF) C C CALL RINPUT(0,I5real,'What is the Rated Current? ',EOF) C INTEGER ILU !Logical Unit for Input REAL REALIN !Real variable to return input number in BYTE PROMPT(1) !String to Prompt for Input INTEGER*2 EOF !End Of File flag INTEGER Slen !String Function String STRNG(80) !Temp Input string C 10 CONTINUE EOF= .FALSE. !kld 11jun84 CALL Linput(ILU,STRNG,PROMPT,EOF) IF (EOF) RETURN LLEN= Slen(STRNG) !kld 11jun84 IF (LLEN .EQ. 0) GOTO 10 When (INDEX(STRNG(3),',;:') .EQ. 0) DECODE (LLEN,20,STRNG(3),ERR=30) REALIN 20 FORMAT (1F12.0) Fin Else 30 Type *,'Illegal Input - Real number expected.' Type * GOTO 10 Fin RETURN END C CORELS subroutines for OPENing files. SUBROUTINE IFLNAM(Filnam,Filext,Istat) !Check-File-Name C Taken from CORELS.BAS KL DANNEIL 24-Mar-82 C Check syntax for file names & fill in any missing parts. C Parameters are-- C IFLNAM(Filename to check, default extension, status of check) c$NOLIST C TYPICAL FILES ARE -- BERTHD.TXT SELECTED DATA FROM FILES (IE. .9=>1.1) C BERTHD.NEW RAW DATA FROM FILES + EMPTY FILE HEADERS C INTEGER Catsub,Cpystr,Cpysub,Slen,StrEq !String Functions used C BYTE Filnam(1) !File name temp. BYTE Filext(1) !File extension temp. INTEGER Istat !Status return of filename check C String SCAT(20) !String Copy,Concat, ect. temp C String D5str 'DAT:' !Default file Device name String Ldot '.' String Lnull '' String Lcoln ':' $LIST c TO Check-File-Name C CHECK SYNTAX FOR FILE NAMES & FILL IN ANY MISSING PARTS D Type *,'Check-File-Name' Istat=0 L1= Slen(Filnam) !kld 11jun84 IF ((L1 .LE. 0) .OR. (L1 .GT. 14)) Istat= 1 D Type *,'L1,ISTAT=',L1,ISTAT D CALL IWRITE(0,Filnam) D CALL IWRITE(0,Filext) IF (Istat .EQ. 0) DO (I=1,L1) CALL Cpysub(SCAT,Filnam,I,1) IF (StrEq(SCAT,Ldot)) Istat= Istat+20 !Flag '.' found. Istat<>20 may be ERROR Next Fin !if IF (StrEq(SCAT,Lcoln)) Istat= Istat+100 !Device ':' is OK Next Fin !if ICH= SCAT(3) D Type *,'ICH=',ICH IF (ChTyp(ICH) .GT. 2) !Legal filespec chars are A-Z & 0-9 Istat= Istat+1 !Flag illegal character error Fin !if D Type *,'Istat=',Istat FIN !do Fin !if D Type *,'IFLNAM- Istat=',Istat D Type * If (Istat .LT. 100) Then !If true, no ':' found so supply CALL Cpystr(SCAT,D5str) !Default device of ??? (DAT: for now) CALL Catstr(SCAT,Filnam) CALL Cpystr(Filnam,SCAT) !Default device + filename back to caller Fin !if then Else Istat= Istat-100 !At least 1 ':' found, if only 1 then OK Fin !else D CALL IWRITE(0,Filnam) If (Istat .LT. 20) Then !If no extension found, put one in L1= Slen(Filext) !kld 25jul84 -start- If ((L1 .LE. 1) .OR. (L1 .GT. 4)) Then C Bad filename extension D Type *,'IFLNAM- Bad filename extension!' D CALL IWRITE(0,Filext) ISTAT= ISTAT+1 Fin !if then Else C Filename extension looks OK CALL Catstr(Filnam,Filext) Fin !else kld 25jul84 -end- Fin !if Else Istat= Istat-20 !At least 1 '.' found, if only 1 then OK Fin !else C OK status is Istat=0 If (ISTAT .NE. 0) Type * Type *,'IFLNAM- Bad Filename spec.' Type * Fin !if D Type *,'Istat=',Istat CALL IWRITE(0,Filnam) Type * RETURN END