#%%A-RCB-0047-SL-18-5     THE RATFOR LIBRARY
INCLUDE DEFN
 
# RETURN YES IF S1==S2, NO OTHERWISE
 
INTEGER FUNCTION EQUAL(S1,S2)
CHAR S1(ARB), S2(ARB)
INTEGER I
FOR (I=1; S1(I)==S2(I); I=I+1)
   IF (S1(I)==EOS) RETURN (YES)
RETURN (NO)
END
# RETURN NUMBER OF CHARACTERS IN STR
 
INTEGER FUNCTION LENGTH(STR)
CHAR STR(ARB)
 
FOR (I=0; STR(I+1)~=EOS; I=I+1)
   ;
RETURN (I)
END
# COPY UP TO MAX CHARACTERS FROM "FROM" TO "TO"
 
SUBROUTINE SCOPY (FROM,START1,TO,START2,MAX)
CHAR FROM(ARB), TO(ARB)
INTEGER START1, START2, K1, K2, MAX, COUNT
 
K1 = START1
K2 = START2
FOR ( COUNT=1; FROM(K1)~=EOS & COUNT<<MAX; COUNT=COUNT+1) {
   TO(K2) = FROM(K1)
   K2 = K2+1
   K1 = K1+1
}
TO(K2) = EOS
RETURN
END
# RETURN NUMERIC IF C IS DIGIT, ALPHABETIC IF C IS A LETTER, 
# ELSE RETURN CHARACTER C ITSELF.
 
CHAR FUNCTION TYPE(C)
CHAR C
 
IF (C>="060 & C<="071)
   RETURN (NUMERIC)
ELSE IF ((C>="101 & C<="132) |
         (C>="141 & C<="172)) 
   RETURN (ALPHABETIC)
ELSE
   RETURN (C)
END
# MAKE IN(I) A BASE BASE INTEGER AND BUMP I TO NEXT DELIMITER
 
INTEGER FUNCTION CTOI(IN,I,BASE)
CHAR IN(ARB), DIGITS(11)
INTEGER BASE,I,D
DATA DIGITS /'0','1','2','3','4','5','6','7','8','9',EOS/
 
WHILE (IN(I)==BLANK | IN(I)==TAB) I=I+1
FOR (CTOI=0; IN(I)~=EOS; I=I+1) {
   D = INDEX(DIGITS, IN(I))
   IF (D == 0)
      BREAK
   CTOI = BASE*CTOI + D-1
}
RETURN
END
# FIND CHAR C IN STRING STR; RETURN 0 IF IT IS NO THERE
 
INTEGER FUNCTION INDEX(STR,C)
CHAR C,STR(ARB)
FOR (INDEX=1; STR(INDEX)~=EOS; INDEX=INDEX+1)
   IF (STR(INDEX)==C)
      RETURN
 
RETURN (0)
END
# PUT OUT ERROR MESSAGE MESS ON LUN LUN IDENTIFIED BY PRGNAM
 
SUBROUTINE MCRERR(LUN,PRGNAM,MESS)
CHAR PRGNAM(3),MESS(ARB)
INTEGER LENGTH,LUN,I
WRITE(LUN,10) PRGNAM,(MESS(I),I=1,LENGTH(MESS))
10 FORMAT ('0', 3A1, ' -- ', 255A1)
RETURN
END
# UNOPENABLE FILE MESSAGE
 
SUBROUTINE CANT(LUN,PRGNAM,FNAME)
CHAR PRGNAM(3), FNAME(ARB)
INTEGER LENGTH,L,I
 
L=LENGTH(FNAME)
IF (L <= 0)
   WRITE(LUN,10) PRGNAM
ELSE
   WRITE(LUN,20) PRGNAM, (FNAME(I),I=1,L)
RETURN
10 FORMAT('0',3A1, ' -- NULL FILE NAME')
20 FORMAT('0',3A1,' -- CAN''T OPEN THIS FILE:  ',255A1)
END
# STOP F4P OTS FROM PRINTING MESSAGES FOR SOME FILE OPEN ERRORS
 
SUBROUTINE KILFER             #KILL FILE ERRORS
CALL ERRSET(29,,.FALSE.,,.FALSE.)
CALL ERRSET(43,,.FALSE.,,.FALSE.)
RETURN
END
DEFINE MAXINPUT 132
 
# GETC RETURN THE NEXT INPUT CHAR FROM LUN STDLUNIN IN C AND IN GETC
 
CHAR FUNCTION GETC(C)
CHAR C,BUF(MAXINPUT)
INTEGER N,GETL,POS
DATA POS/1/, N/0/
 
IF (POS <= N) {                         # STILL MORE CHARS IN INPUT BUFFER
   C = BUF(POS)
   POS = POS+1
}
ELSE {
   N = GETL(BUF, MAXINPUT, STDLUNIN)
   IF (N == EOF) 
      C = EOF
   ELSE {
      N=N+1
      BUF(N) = NEWLINE
      POS = 2
      C = BUF(1)
   }
}
RETURN (C)
END
# GETL RETURNS THE NEXT MAXLIN CHARS OF THE NEXT LINE FROM LUN LUNIN.
 
INTEGER FUNCTION GETL(LINE, MAXLIN, LUNIN)
INTEGER N,MAXLIN,LUNIN
CHAR LINE(MAXLIN)
 
READ (LUNIN,10,END=100) N,LINE
10 FORMAT (Q, 255A1)
IF (N >= MAXLIN) N = MAXLIN-1
LINE(N+1) = EOS
RETURN (N)                             # RETURNS THE LINE LENGTH
 
100 RETURN (EOF)
END
# PUTC PUTS NEXT CHAR IN OUTPUT BUFFER, FLUSHING BUFFER IF CHAR == NEWLINE
 
DEFINE MAXOUTPUT 132       # FOLD LINES LONGER THAN THIS
SUBROUTINE PUTC(C)
CHAR C,BUF(MAXOUTPUT)
INTEGER POS
DATA POS /1/
 
IF (C==EOF) RETURN
IF (C==NEWLINE | POS>=MAXOUTPUT) {
   BUF(POS) = EOS
   CALL PUTL(BUF,STDLUNOUT)
   POS=1
}
IF (C~=NEWLINE) {
   BUF(POS) = C
   POS = POS+1
}
RETURN
END
# PUTL WRITES STRING LINE TO LUN LUNOUT
 
SUBROUTINE PUTL(LINE, LUNOUT)
CHAR LINE(ARB)
INTEGER L,LENGTH,I,LUNOUT
 
L = LENGTH(LINE)
IF (L>>0)
   WRITE(LUNOUT,10) (LINE(I),I=1,L)
ELSE
   WRITE(LUNOUT,10)                        # WRITE A NULL RECORD FOR EMPTY LINES
10 FORMAT( 255A1)
RETURN
END
# GET NEXT MCR LINE: FROM GETMCR, INDIRECT FILE (1 LEVEL), OR PROMPTING.
# PROMPT ON LUNPMT.  LUN LUNIND ~=0 IF INDIRECT FILE LUN AVAILABLE.
# PRE-SCAN MCR LINE, AND SET NUMOUT=NUMBER OF (POSSIBLY NULL) OUTPUT FILES.
 
INTEGER FUNCTION NXTMCR(LUNPMT,PROMPT,LUNIND,NUMOUT)
CHAR PROMPT(3),MCR(82),CJUNK,FN(41),TYPE
INTEGER NUMOUT,DONE,I,N,POS,LUNIND,FIRST,NBRCK,ININD,GETL
COMMON /MCRNFO/ MCR,POS
DATA DONE/NO/, FIRST/YES/, ININD/NO/
 
IF (LUNPMT<<0) {
   CLOSE (UNIT=LUNIND)
   ININD=NO
   RETURN (YES)
}
#%^
REPEAT {          # UNTIL NON-BLANK MCR LINE OR END OF MCR INPUT
   IF (DONE==YES & ININD==NO) RETURN (NO)
   IF (FIRST==YES) {
      CALL GETMCR(MCR,N)
      FOR (POS=1; POS<=N && MCR(POS)~=BLANK & MCR(POS)~=TAB; POS=POS+1) {}
      WHILE (POS<=N && MCR(POS)==BLANK | MCR(POS)==TAB) POS=POS+1
      IF (POS<=N) DONE=YES
      FIRST = NO
   }
   ELSE {
      IF (ININD==YES & LUNIND>>0) {
         N = GETL(MCR,80,LUNIND)
         IF (N==EOF) {
            ININD = NO
            CLOSE (UNIT=LUNIND)
         }
      }
      ELSE {
         WRITE(LUNPMT,10) PROMPT
         10 FORMAT ('$',3A1,'>')
         READ (LUNPMT,20,END=1000) N,MCR
         20 FORMAT(Q,82A1)
      }
      FOR (POS=1; POS<=N && MCR(POS)==BLANK | MCR(POS)==TAB; POS=POS+1) {}
   }
   IF (POS<<N && MCR(POS)=='@') {
      MCR(N+1) = EOS
      N = -1            # FORCE N<<POS TO GET ANOTHER READ
      IF (ININD==YES | LUNIND <=0)
         CALL MCRERR(LUNPMT,PROMPT,'COMMAND FILE INVALID HERE')
      ELSE {
         POS = POS+1
         JUNK = NXTFIL('.CMD',FN,41,CJUNK,1)
         OPEN(UNIT=LUNIND,NAME=FN,TYPE='OLD',ERR=30,READONLY)
         ININD = YES
         BREAK GROUP
         30 CALL MCRERR(LUNPMT,PROMPT,'CAN''T OPEN INDIRECT COMMAND FILE')
     }
   }
} UNTIL (POS<=N)
#%^
NUMOUT = 1
NBRCK = 0
MCR(N+1) = EOS
 
FOR (I=1; MCR(I)~=EOS; I=I+1)
   IF (MCR(I)=='[')                 NBRCK = NBRCK+1
   ELSE IF (MCR(I)==']')            NBRCK = NBRCK-1
   ELSE IF (MCR(I)==',' & NBRCK==0) NUMOUT = NUMOUT+1
   ELSE IF (MCR(I)=='=')            BREAK
IF (MCR(I) ~= '=')
   NUMOUT = 0                           # NO = ON MCR LINE
RETURN (YES)     
 
1000 DONE=YES
RETURN (NO)
END
# PICK UP NEXT FILE NAME FROM MCR AND PUT IN FNAME WITH EXTENSION EXT
# IF NONE THERE.  SWITCHES GO INTO SWITCH.  ONLY FIRST MAXFNM CHARS OF 
# FILE NAME KEPT; ONLY FIRST MAXSW CHARS OF SWITCHES KEPT.
 
INTEGER FUNCTION NXTFIL(EXT, FNAME, MAXFNM, SWITCH, MAXSW)
CHAR EXT(4),FNAME(MAXFNM),SWITCH(MAXSW), MCR(82)
INTEGER MAXFNM,MAXSW,POS,GOTDOT,I,J,NBRK
COMMON /MCRNFO/ MCR, POS
 
WHILE (MCR(POS)==BLANK | MCR(POS)==TAB) POS = POS+1
IF (MCR(POS)==EOS) RETURN (NO)
FNAME(1) = EOS
SWITCH(1) = EOS
I = 1
GOTDOT = NO
 
FOR (NBRAK=0; MCR(POS)~=EOS & MCR(POS)~='/' & MCR(POS)~='=' &
              (MCR(POS)~=',' | NBRK >> 0);   POS = POS+1) {
   IF (MCR(POS)>="141 & MCR(POS)<="172) MCR(POS) = MCR(POS) - "040 
   ELSE IF (MCR(POS) == '.') GOTDOT = YES
   ELSE IF (MCR(POS) == '[') NBRK = NBRK+1
   ELSE IF (MCR(POS) == ']') NBRK = NBRK-1
   ELSE IF (MCR(POS)==';' & GOTDOT==NO) {
      FOR (J=1; I<<MAXFNM & J<=4; J=J+1) {
         FNAME(I) = EXT(J)                    #COPY IN EXTENSION BEFORE ;
         I = I+1
      }
      GOTDOT = YES
   }
   IF (I<<MAXFNM & MCR(POS)~=BLANK & MCR(POS)~=TAB) {
      FNAME(I) = MCR(POS)
      I=I+1
   }
}
#%^
IF (GOTDOT==NO & I>>1)
   FOR (J=1; I<<MAXFNM & J<=4; J=J+1) {
      FNAME(I) = EXT(J)
      I=I+1
   }
FNAME(I) = EOS
J = 1
IF (MCR(POS)=='/')
   FOR (POS=POS+1; MCR(POS)~='=' & MCR(POS)~=EOS &
                                   MCR(POS)~=','     ; POS=POS+1)
      IF (J << MAXSW) {
         SWITCH(J) = MCR(POS)
         J = J+1
      }
SWITCH(J) = EOS
IF (MCR(POS)~=EOS) POS = POS+1
RETURN (YES)                                # YES, I GOT A FILE NAME
END
 
# SET UP LISTING PROGRAM - MCR LINE CONTAINS ONLY INPUT FILE & SWITCHES.
# IF NO INPUT, DEFAULT TO PIPE.LYN & OPEN FILE AS DELETE DISPOSITION.
 
INTEGER FUNCTION SETOTL (LUNPMT,PROMPT,EXTIN,LUNIND)
CHAR EXTIN(4),SWITCH(80),FIN(41),DEFILE(9),PROMPT(3)
INTEGER NXTFIL,I,DELETE,EQUAL,LUNPMT,LUNIND,NXTMCR
COMMON /SWITCH/ SWITCH
DATA DEFILE/'P', 'I', 'P', 'E','.','L','Y','N',EOS/
 
CALL KILFER
 
CLOSE (UNIT=STDLUNIN)
REPEAT {         # UNTIL GOOD MCR LINE OR NO MORE MCR INPUT
   IF (NXTMCR(LUNPMT,PROMPT,LUNIND,NUMOUT)==NO) RETURN (NO)
   IF (NUMOUT>>0) {
      CALL MCRERR(LUNPMT,PROMPT,'EXACTLY ONE INPUT FILE NEEDED')
      NEXT
   }
   JUNK = NXTFIL(EXTIN,FIN,41,SWITCH,80)
   IF (FIN(1) == EOS) CALL SCOPY(DEFILE,1,FIN,1,41)
   IF (EQUAL(DEFILE,FIN)==YES)
      OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',ERR=1000,DISP='DELETE')
   ELSE
      OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',ERR=1000,READONLY)
   RETURN (YES)
    
   1000  CALL MCRERR(LUNPMT,PROMPT,'CAN''T OPEN INPUT FILE')
}
END
INTEGER FUNCTION SETFLT(LUNPMT,PROMPT,EXTIN,EXTOUT,LUNIND)
INTEGER MAXSW,FIRST,NXTMCR,NXTFIL,JUNK,LUNIND,EQUAL
CHAR SWITCH(80),PROMPT(3),EXTIN(4),EXTOUT(4),FIN(41),FOUT(41),DEFILE(9)
COMMON /SWITCH/ SWITCH
DATA  DEFILE/'P','I','P','E','.','L','Y','N',EOS/
 
CALL KILFER
CLOSE(UNIT=STDLUNIN)
CLOSE(UNIT=STDLUNOUT)
REPEAT {             # UNTIL GOOD MCR LINE OR END OF MCR INPUT
   IF (NXTMCR(LUNPMT,PROMPT,LUNIND,NUMOUT)==NO) RETURN (NO)
   IF (NUMOUT>>1)  {
      CALL MCRERR(LUNPMT,PROMPT,'BAD MCR LINE')
      NEXT
   }
   ELSE IF (NUMOUT==1) 
      JUNK = NXTFIL(EXTOUT,FOUT,41,SWITCH,80)
   ELSE 
      FOUT(1) = EOS
   IF (NXTFIL(EXTIN,FIN,41,SWITCH,80)==NO)
      FIN(1) = EOS
   ELSE 
      IF (NXTFIL (EXTIN,FIN,41,SWITCH,80)==YES) {
         CALL MCRERR(LUNPMT,PROMPT,'BAD MCR LINE')
         NEXT
      }
   IF (FIN(1)==EOS) CALL SCOPY(DEFILE,1,FIN,1,41)
   IF (FOUT(1)==EOS) CALL SCOPY(DEFILE,1,FOUT,1,41)
   IF (EQUAL(DEFILE,FIN)==YES)
      OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',DISPOSE='DELETE',ERR=1000)
   ELSE
      OPEN (UNIT=STDLUNIN,NAME=FIN,TYPE='OLD',ERR=1000,READONLY)
   OPEN (UNIT=STDLUNOUT,NAME=FOUT,CARRIAGECONTROL='LIST',ERR=1001,TYPE='NEW')
   RETURN (YES)
 
   1000  CALL CANT(LUNPMT,PROMPT,FIN)
         NEXT
   1001  CALL CANT(LUNPMT,PROMPT,FOUT)
         CLOSE (UNIT=STDLUNIN,DISPOSE='SAVE')    #  IF BAD OUTPUT, KEEP INPUT
}
END
# GET SLASH DELIMITED ARGUMENT NUMBER ARGNUM PLACING FIRST MAXARG CHARS
# IN ARG. SLASHES LOSE DELIMITER FUNCTION IF PRECEDED BY ESCAPECHAR.
# ARGS NOW STORED IN ARRAY SWITCH SET BY SETFLT OR SETOTL. 
 
INTEGER FUNCTION GETARG(ARGNUM,ARG,MAXARG)
CHAR SWITCH(80), ARG(MAXARG)
INTEGER ARGNUM,MAXARG,I,CNTARG,J
DEFINE DELIMITER '/'
COMMON /SWITCH/ SWITCH
 
ARG(1) = EOS
IF (ARGNUM<=0 | MAXARG<=1 | SWITCH(1)==EOS) RETURN (EOF) # NO SUCH ARGUMENT
 
I=1
CNTARG=1
WHILE (CNTARG<<ARGNUM) {
   IF (SWITCH(I)==EOS)
      RETURN (EOF)
   IF (SWITCH(I)==DELIMITER)
      CNTARG=CNTARG+1
   IF (SWITCH(I)==ESCAPECHAR && SWITCH(I+1)~=EOS)
      I=I+2
   ELSE
      I=I+1
}
 
J=1
FOR (; J<<MAXARG & SWITCH(I)~=DELIMITER & SWITCH(I)~=EOS; I=I+1) {
   IF (SWITCH(I)==ESCAPECHAR && SWITCH(I+1)~=EOS)
      I=I+1
   ARG(J) = SWITCH(I)
   J=J+1
}
ARG(J)=EOS
RETURN (J-1)    # DON'T COUNT EOS IN RETURNED LENGTH
END