SUBROUTINE OPENF (CALLNO,DONE,SVER,SWITCH,MAKFIN) IMPLICIT INTEGER (A-Z) INTEGER*2 WICHBF,CHSTAT,BFPTR,INBLK,MXINLV,MXINPL BYTE INBUF COMMON /FLXSY3/ INBUF (512,2,4),WICHBF(4),CHSTAT(4),BFPTR(4) 1 ,INBLK(4),MXINLV,MXINPL DATA MXINLV /4/ DATA MXINPL /100/ INTEGER*2 FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN(4),INLEVL COMMON /FLXSY3/FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN ,INLEVL INTEGER*2 INPLIN,FORLIN,LASTLN,PAGLIN COMMON /FLXSY3/ INPLIN,FORLIN,LASTLN,PAGLIN BYTE OUTBUF INTEGER*2 OPTR,WICHOB,OSTAT,OCHAN,OBLK,MXOLUN COMMON /FLXSY3/ OUTBUF(512,2,3),OPTR(3),WICHOB(3), 1 OSTAT(3),OCHAN(3),OBLK(3),MXOLUN DATA MXOLUN /3/ INTEGER TITLN1(68) COMMON /FLXSY3/ TITLN1 INTEGER*2 EREADE, EWRITE, ECLOSE, EWAITE DATA EREADE /1/, EWRITE /2/, ECLOSE /3/, EWAITE /4/ COMMON /FLXSY3/ EREADE, EWRITE, ECLOSE, EWAITE BYTE SSCRAT (200) COMMON /FLXSY3/ SSCRAT LOGICAL*1 NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM COMMON /FLXSY3/ NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM LOGICAL*1 LSTFLG COMMON /FLXSY3/ LSTFLG INTEGER SB(2) DATA SB/1,2H / INTEGER DATSTR(6) DATA DATSTR/9,2HXX,2H-M,2HON,2H-X,2HX / INTEGER TIMSTR(6) DATA TIMSTR/8,2HXX,2H:X,2HX:,2HXX,1H / INTEGER SSTARS(6) DATA SSTARS/8,2H ,2H**,2H**,2H ,1H / INTEGER SEQUAL(2) DATA SEQUAL/1,2H= / INTEGER SWITCH(2) INTEGER*2 CALLNO,FILSPC(39),DEFTYP(4),SWT(4,4) INTEGER*2 D,N,TMPSPC(3),TT0,TTSPC,LEN BYTE SVER(1),PROMPT(2),CSILIN(82),EOF LOGICAL*1 DONE,ALLOK,MAKFIN DATA EOF /26/ DATA PROMPT /'*',"200/ DATA DEFTYP /3RFLX,3RFTX,3RFLL,3RFIN/ DATA FOREXT /3RFOR/ DATA TT0,TTSPC /3RTT0,3RTT / DATA D,N,C,L,F /1,2,3,4,5/ DATA SWT(1,1),SWT(1,2),SWT(1,3),SWT(1,4) 1 /'D','N','C','L'/ IF(.NOT.(CALLNO .EQ. 1 )) GO TO 32766 ASSIGN 32764 TO I32765 GO TO 32765 32764 CONTINUE 32766 CALL CLEAR !RESETS LINE NUMBERS ASSIGN 32762 TO I32763 GO TO 32763 32762 ASSIGN 32760 TO I32761 GO TO 32761 32760 DONE = .FALSE. ALLOK = .FALSE. GO TO 32758 32759 IF( DONE .OR. ALLOK) GO TO 32757 32758 ALLOK = .TRUE. ASSIGN 32755 TO I32756 GO TO 32756 32755 IF(DONE) GO TO 32754 ASSIGN 32752 TO I32753 GO TO 32753 32752 IF(.NOT.(ALLOK)) GO TO 32751 ASSIGN 32749 TO I32750 GO TO 32750 32749 CONTINUE 32751 CONTINUE 32754 GO TO 32759 32757 ASSIGN 32747 TO I32748 GO TO 32748 32747 RETURN 32761 CONTINUE NOFORT = .FALSE. LSTFLG = .TRUE. NOLIST = .FALSE. TTYLST = .FALSE. MAKFIN = .FALSE. FINLST = .FALSE. DEBUG = .FALSE. LSTCOM = .FALSE. NOLNUM = .TRUE. GO TO I32761 32763 CONTINUE FORLUN = 1 LSTLUN = 2 ERRLUN = 7 NEWLUN = 3 DO 32745 I=1,3 OCHAN (I) = -1 !MUST MAKE NON-(ZERO OR POSITIVE) 32745 CONTINUE 32746 DO 32743 I=1,4 FLXLUN(I) = -1 32743 CONTINUE 32744 GO TO I32763 32742 CONTINUE INLEVL = 1 TMPSPC(1) = FILSPC(16) TMPSPC(2) = FILSPC(17) TMPSPC(3) = FILSPC(18) CHAN = IGETC () IF(.NOT.(IFETCH (FILSPC(16)) .NE. 0)) GO TO 32740 ALLOK = .FALSE. CALL PRINT (' FLECS-F- Cannot fetch input device') GO TO 32741 32740 IF(.NOT.(LOOKUP(CHAN,FILSPC(16)).GE.0)) GO TO 32738 CHSTAT(1) = IREAD(256,INBUF(1,1,1),0,CHAN) WICHBF(1) = 2 BFPTR(1) = 513 INBLK (1) = 1 FLXLUN (1) = CHAN GO TO 32739 32738 CONTINUE 999 ALLOK = .FALSE. CALL PRINT (' FLECS-F-Input file not found') 32739 IF(.NOT.((FILSPC(1).EQ.0).AND.(FILSPC(6).EQ.0))) GO TO 32737 IF(FILSPC(11) .NE. 0) GO TO 32736 DO 32734 I=1,3 FILSPC(I) = TMPSPC(I) FILSPC(I+5) = TMPSPC(I) IF (FINLST) FILSPC (I+10) = TMPSPC (I) 32734 CONTINUE 32735 FILSPC(4) = DEFTYP (2) FILSPC(9) = DEFTYP (3) IF (FINLST) FILSPC (14) = DEFTYP (4) 32736 CONTINUE 32737 CONTINUE 32741 GO TO I32742 32733 CONTINUE IF(.NOT.(FILSPC(1) .EQ. 0)) GO TO 32731 NOFORT = .TRUE. GO TO 32732 32731 IF(.NOT.(IFETCH (FILSPC(1)) .NE. 0)) GO TO 32730 CALL PRINT (' FLECS-F-Cannot fetch FORTRAN file device') GO TO 32732 32730 CONTINUE 32732 IF((.NOT. ALLOK) .OR. NOFORT) GO TO 32729 IF(.NOT.(SLOOPN (FORLUN,FILSPC(1)) .LT. 0)) GO TO 32728 ALLOK = .FALSE. CALL PRINT (' FLECS-F-Can not open FORTRAN file') 32728 CONTINUE 32729 GO TO I32733 32727 CONTINUE IF(.NOT.((FILSPC(6).EQ.TT0).OR.(FILSPC(6).EQ.TTSPC))) GO TO 32726 TTYLST = .TRUE. 32726 IF(.NOT.(FILSPC(6).EQ.0)) GO TO 32724 NOLIST = .TRUE. 32724 CONTINUE 32725 IF(.NOT.(NOLIST)) GO TO 32722 GO TO 32723 32722 IF(.NOT.(IFETCH (FILSPC (6)) .NE. 0)) GO TO 32721 ALLOK = .FALSE. CALL PRINT (' FLECS-F-Can not fetch device for FLECS listing') GO TO 32723 32721 IF(.NOT.(SLOOPN (LSTLUN,FILSPC(6)) .LT. 0)) GO TO 32720 ALLOK = .FALSE. CALL PRINT (' FLECS-F-Can not open FLECS listing file') GO TO 32723 32720 CONTINUE 32723 GO TO I32727 32719 CONTINUE IF (FILSPC (12) .NE. 0) FINLST = .TRUE. IF(.NOT.(FINLST)) GO TO 32717 IF(.NOT.(FILSPC (11) .EQ. 0)) GO TO 32716 FILSPC(11) = TMPSPC (1) FILSPC(12) = TMPSPC (2) FILSPC(13) = TMPSPC (3) FILSPC(14) = DEFTYP (4) 32716 IF(.NOT.(IFETCH (FILSPC (11)) .NE. 0)) GO TO 32714 ALLOK = .FALSE. CALL PRINT (' FLECS-F-Cannot fetch new source device') GO TO 32715 32714 IF(.NOT.(SLOOPN (NEWLUN,FILSPC(11)) .LT. 0)) GO TO 32713 ALLOK = .FALSE. CALL PRINT (' FLECS-F-Can not create new indented source file') GO TO 32715 32713 MAKFIN = .TRUE. !TELL FLECS THAT WE ARE MAKING FIN FILE 32715 GO TO 32718 32717 CONTINUE 32718 GO TO I32719 32748 CONTINUE CALL CPYSTR (TITLN1,SSTARS) !PAD LEFT OF STRING W/ *'S EQPTR = FLNDEX (CSILIN,SEQUAL) !FIND "=" CALL CATSUB (TITLN1,CSILIN,EQPTR+1,CSILEN-EQPTR) CALL CATSTR (TITLN1,SSTARS) 32712 IF(TITLN1(1) .GE. 50) GO TO 32711 CALL CATSTR (TITLN1,SB) GO TO 32712 32711 CALL DATE (DATSTR(2)) CALL CATSTR (TITLN1,DATSTR) 32710 IF(TITLN1(1) .GE. 70) GO TO 32709 CALL CATSTR (TITLN1,SB) GO TO 32710 32709 CALL TIME (TIMSTR (2)) CALL CATSTR (TITLN1,TIMSTR) 32708 IF(TITLN1(1) .GE. 80) GO TO 32707 CALL CATSTR (TITLN1,SB) GO TO 32708 32707 CALL CATSTR (TITLN1,SVER) GO TO I32748 32756 CONTINUE CALL GTLIN (CSILIN(3),PROMPT) CSILEN = LEN (CSILIN (3)) CALL PUTINT (CSILEN,CSILIN(1)) IF((0).NE.(CSILIN(3))) GO TO 32705 ALLOK = .FALSE. GO TO 32706 32705 IF((EOF).NE.(CSILIN(3))) GO TO 32704 DONE = .TRUE. GO TO 32706 32704 CALL CPYSTR (SWITCH,CSILIN) !GIVE FLECS ENTIRE CMD LINE 32706 GO TO I32756 32750 CONTINUE IF(.NOT.(FILSPC(17) .NE. 0)) GO TO 32702 ASSIGN 32701 TO I32742 GO TO 32742 32701 ASSIGN 32700 TO I32733 GO TO 32733 32700 ASSIGN 32699 TO I32727 GO TO 32727 32699 ASSIGN 32698 TO I32719 GO TO 32719 32698 GO TO 32703 32702 ALLOK = .FALSE. CALL PRINT (' FLECS-F- No input filename') 32703 IF(ALLOK) GO TO 32697 ASSIGN 32695 TO I32696 GO TO 32696 32695 CONTINUE 32697 GO TO I32750 32696 CONTINUE DO 32693 LUN=1,3 ICHAN = OCHAN(LUN) IF(.NOT.(ICHAN .GE. 0)) GO TO 32692 CALL PURGE (CHAN) CALL IFREEC (CHAN) 32692 CONTINUE 32693 CONTINUE 32694 ICHAN = FLXLUN (1) IF(.NOT.(ICHAN .GE. 0)) GO TO 32691 CALL PURGE (ICHAN) CALL IFREEC (ICHAN) 32691 GO TO I32696 32753 CONTINUE ICSIST= ICSI(FILSPC,DEFTYP,CSILIN(3),SWT,4) IF((0).NE.(ISCIST)) GO TO 32689 GO TO 32690 32689 ALLOK = .FALSE. CALL PRINT (' FLECS-F-Illegal command line') 32690 IF (SWT(2,D) .NE. 0) DEBUG = .TRUE. !PROCESS DEBUG LINES? IF (SWT(2,N) .NE. 0) FINLST = .TRUE. IF (SWT(2,C) .NE. 0) LSTCOM = .TRUE. IF (SWT(2,L) .NE. 0) NOLNUM = .FALSE. GO TO I32753 32765 CONTINUE ILEN = BY2INT (SVER(1)) ENCODE (ILEN+10,100,CSILIN) (SVER(I),I=3,3+ILEN) 100 FORMAT (10X,100A1) CSILIN (ILEN+11)=0 CALL PRINT (CSILIN) GO TO I32765 END SUBROUTINE CLOSEF (MINERR,MAJERR) IMPLICIT INTEGER (A-Z) INTEGER*2 WICHBF,CHSTAT,BFPTR,INBLK,MXINLV,MXINPL BYTE INBUF COMMON /FLXSY3/ INBUF (512,2,4),WICHBF(4),CHSTAT(4),BFPTR(4) 1 ,INBLK(4),MXINLV,MXINPL DATA MXINLV /4/ DATA MXINPL /100/ INTEGER*2 FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN(4),INLEVL COMMON /FLXSY3/FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN ,INLEVL INTEGER*2 INPLIN,FORLIN,LASTLN,PAGLIN COMMON /FLXSY3/ INPLIN,FORLIN,LASTLN,PAGLIN BYTE OUTBUF INTEGER*2 OPTR,WICHOB,OSTAT,OCHAN,OBLK,MXOLUN COMMON /FLXSY3/ OUTBUF(512,2,3),OPTR(3),WICHOB(3), 1 OSTAT(3),OCHAN(3),OBLK(3),MXOLUN DATA MXOLUN /3/ INTEGER TITLN1(68) COMMON /FLXSY3/ TITLN1 INTEGER*2 EREADE, EWRITE, ECLOSE, EWAITE DATA EREADE /1/, EWRITE /2/, ECLOSE /3/, EWAITE /4/ COMMON /FLXSY3/ EREADE, EWRITE, ECLOSE, EWAITE BYTE SSCRAT (200) COMMON /FLXSY3/ SSCRAT LOGICAL*1 NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM COMMON /FLXSY3/ NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM LOGICAL*1 LSTFLG COMMON /FLXSY3/ LSTFLG DO 32765 LUN = 1,3 CHAN = OCHAN (LUN) IF(CHAN .LT. 0) GO TO 32764 IF(.NOT.(SLOCLS (LUN) .LT. 0)) GO TO 32763 CALL FERROR (ECLOSE) 32763 CONTINUE 32764 CONTINUE 32765 CONTINUE 32766 DO 32761 I =1,4 CHAN = FLXLUN (I) IF(.NOT.(CHAN .GE. 0)) GO TO 32760 CALL PURGE (CHAN) CALL IFREEC (CHAN) 32760 CONTINUE 32761 CONTINUE 32762 IF(.NOT.((MINERR + MAJERR) .GT. 0)) GO TO 32759 DO 32757 I=1,100 SSCRAT(I)=0 32757 CONTINUE 32758 ENCODE (50,100,SSCRAT) MAJERR,MINERR 100 FORMAT (' FLECS-I-ERRORS: Major -',I3,' Minor -',I3) CALL PRINT (SSCRAT) 32759 RETURN END SUBROUTINE CLEAR INTEGER*2 WICHBF,CHSTAT,BFPTR,INBLK,MXINLV,MXINPL BYTE INBUF COMMON /FLXSY3/ INBUF (512,2,4),WICHBF(4),CHSTAT(4),BFPTR(4) 1 ,INBLK(4),MXINLV,MXINPL DATA MXINLV /4/ DATA MXINPL /100/ INTEGER*2 FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN(4),INLEVL COMMON /FLXSY3/FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN ,INLEVL INTEGER*2 INPLIN,FORLIN,LASTLN,PAGLIN COMMON /FLXSY3/ INPLIN,FORLIN,LASTLN,PAGLIN BYTE OUTBUF INTEGER*2 OPTR,WICHOB,OSTAT,OCHAN,OBLK,MXOLUN COMMON /FLXSY3/ OUTBUF(512,2,3),OPTR(3),WICHOB(3), 1 OSTAT(3),OCHAN(3),OBLK(3),MXOLUN DATA MXOLUN /3/ INTEGER TITLN1(68) COMMON /FLXSY3/ TITLN1 INTEGER*2 EREADE, EWRITE, ECLOSE, EWAITE DATA EREADE /1/, EWRITE /2/, ECLOSE /3/, EWAITE /4/ COMMON /FLXSY3/ EREADE, EWRITE, ECLOSE, EWAITE BYTE SSCRAT (200) COMMON /FLXSY3/ SSCRAT LOGICAL*1 NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM COMMON /FLXSY3/ NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM LOGICAL*1 LSTFLG COMMON /FLXSY3/ LSTFLG INPLIN = 0 FORLIN = 0 PAGLIN = 0 RETURN END FUNCTION SLOOPN (LUN,FILSPC) IMPLICIT INTEGER (A-Z) INTEGER*2 FILSPC(1) INTEGER SNOFIL(15) DATA SNOFIL/26,2HSL,2HOO,2HPN,2H N,2HO ,2HOU,2HTP,2HUT,2H F,2HIL,2 1HE ,2HNA,2HME,1H / INTEGER*2 WICHBF,CHSTAT,BFPTR,INBLK,MXINLV,MXINPL BYTE INBUF COMMON /FLXSY3/ INBUF (512,2,4),WICHBF(4),CHSTAT(4),BFPTR(4) 1 ,INBLK(4),MXINLV,MXINPL DATA MXINLV /4/ DATA MXINPL /100/ INTEGER*2 FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN(4),INLEVL COMMON /FLXSY3/FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN ,INLEVL INTEGER*2 INPLIN,FORLIN,LASTLN,PAGLIN COMMON /FLXSY3/ INPLIN,FORLIN,LASTLN,PAGLIN BYTE OUTBUF INTEGER*2 OPTR,WICHOB,OSTAT,OCHAN,OBLK,MXOLUN COMMON /FLXSY3/ OUTBUF(512,2,3),OPTR(3),WICHOB(3), 1 OSTAT(3),OCHAN(3),OBLK(3),MXOLUN DATA MXOLUN /3/ INTEGER TITLN1(68) COMMON /FLXSY3/ TITLN1 INTEGER*2 EREADE, EWRITE, ECLOSE, EWAITE DATA EREADE /1/, EWRITE /2/, ECLOSE /3/, EWAITE /4/ COMMON /FLXSY3/ EREADE, EWRITE, ECLOSE, EWAITE BYTE SSCRAT (200) COMMON /FLXSY3/ SSCRAT LOGICAL*1 NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM COMMON /FLXSY3/ NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM LOGICAL*1 LSTFLG COMMON /FLXSY3/ LSTFLG INTEGER*2 DUMNAM(2) DATA DUMNAM /3RDUM,3RMY / IF ((LUN .GT. MXOLUN) .OR. (LUN .LT. 1)) STOP 'SLOOPN-- BAD LUN' IF(.NOT.(FILSPC (2) .EQ. 0)) GO TO 32766 FILSPC(2) = DUMNAM(1) FILSPC(3) = DUMNAM(2) 32766 CHAN = IGETC () OCHAN(LUN) = CHAN ISTAT = IENTER (CHAN,FILSPC(1),FILSPC(5)) IF(.NOT.(FILSPC(5) .GT. ISTAT)) GO TO 32764 ISTAT = -5 GO TO 32765 32764 IF(.NOT.(ISTAT .GE. 0)) GO TO 32763 OPTR (LUN) = 1 OBLK (LUN) = 0 WICHOB (LUN) = 1 OSTAT (LUN) = 1 GO TO 32765 32763 CALL PURGE (CHAN) CALL IFREEC (CHAN) 32765 SLOOPN = ISTAT RETURN END FUNCTION SLOCLS (LUN) IMPLICIT INTEGER (A-Z) INTEGER*2 WICHBF,CHSTAT,BFPTR,INBLK,MXINLV,MXINPL BYTE INBUF COMMON /FLXSY3/ INBUF (512,2,4),WICHBF(4),CHSTAT(4),BFPTR(4) 1 ,INBLK(4),MXINLV,MXINPL DATA MXINLV /4/ DATA MXINPL /100/ INTEGER*2 FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN(4),INLEVL COMMON /FLXSY3/FORLUN,LSTLUN,ERRLUN,NEWLUN,FLXLUN ,INLEVL INTEGER*2 INPLIN,FORLIN,LASTLN,PAGLIN COMMON /FLXSY3/ INPLIN,FORLIN,LASTLN,PAGLIN BYTE OUTBUF INTEGER*2 OPTR,WICHOB,OSTAT,OCHAN,OBLK,MXOLUN COMMON /FLXSY3/ OUTBUF(512,2,3),OPTR(3),WICHOB(3), 1 OSTAT(3),OCHAN(3),OBLK(3),MXOLUN DATA MXOLUN /3/ INTEGER TITLN1(68) COMMON /FLXSY3/ TITLN1 INTEGER*2 EREADE, EWRITE, ECLOSE, EWAITE DATA EREADE /1/, EWRITE /2/, ECLOSE /3/, EWAITE /4/ COMMON /FLXSY3/ EREADE, EWRITE, ECLOSE, EWAITE BYTE SSCRAT (200) COMMON /FLXSY3/ SSCRAT LOGICAL*1 NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM COMMON /FLXSY3/ NOFORT,NOLIST,TTYLST,DEBUG,FINLST,LSTCOM,NOLNUM LOGICAL*1 LSTFLG COMMON /FLXSY3/ LSTFLG BYTE FORMFD !FORM FEED CHARACTER DATA FORMFD /12/ IF(.NOT.((LUN .GE. 1) .OR. (LUN .LE. MXOLUN))) GO TO 32765 CHAN = OCHAN (LUN) IF(CHAN .LT. 0) GO TO 32764 ISTAT = IWAIT (CHAN) IF(.NOT.(ISTAT .EQ. 0)) GO TO 32762 PTR = OPTR (LUN) WBF = WICHOB (LUN) IF(.NOT.(PTR .LT. 512)) GO TO 32760 OUTBUF (PTR,WBF,LUN) = FORMFD DO 32758 I=PTR+1,512 OUTBUF (I,WBF,LUN) = 0 32758 CONTINUE 32759 GO TO 32761 32760 OUTBUF (512,WBF,LUN) = FORMFD !CLOBBERS LAST LINE FEED 32761 BLK = OBLK (LUN) ISTAT = IWRITW (256,OUTBUF(1,WBF,LUN),BLK,CHAN) CALL CLOSEC (CHAN) CALL IFREEC (CHAN) IF(.NOT.(ISTAT .GE. 0)) GO TO 32756 SLOCLS = ISTAT GO TO 32757 32756 SLOCLS = -5 RETURN 32757 GO TO 32763 32762 SLOCLS = -5 RETURN 32763 CONTINUE 32764 GO TO 32766 32765 CALL PRINT (' FLECS-W-Attempt to close invalid LUN in SLOCLS') SLOCLS = -6 RETURN 32766 RETURN END SUBROUTINE FLEXIT CALL EXIT RETURN END