C tru - truncate files PROGRAM TRU BYTE CMDLIN(80), PROMPT(7) INTEGER NC DATA PROMPT/13, 10, 'T', 'R', 'U', '>', ' '/ 2000 CONTINUE CALL GTLIN(CMDLIN, NC, 1, PROMPT, 7, .TRUE., .FALSE.) IF (.NOT.(NC .LE. 0)) GOTO 2030 GOTO 2020 2030 CONTINUE CMDLIN(NC + 1) = 0 CALL TRUFIL(2, CMDLIN) 2010 GOTO 2000 2020 CONTINUE END C C THIS ROUTINE CALLS RUNSYS, WHICH SUBTASKS PIP TO CREATE C A FILE, @remclak.166, WITH THE FILES SELECTED BY PIP IN IT. C IF THE FILE FORMAT PRODUCED BY YOUR PIP IS DIFFERENT, THIS C ROUTINE WILL HAVE TO BE MODIFIED. C SUBROUTINE TRUFIL(LUN, PIPFIL) BYTE PIPFIL(134), PIP(134), TMP(134), FILENM(19) INTEGER LUN, NC, L, IER, DIG, SL, DOT INTEGER CONCAT, INDEX, BKSCAN REAL SECNDS LOGICAL EQ Crefer to REMCLAK.DOC ENCODE(18, 2050, FILENM) SECNDS(0.0) 2050 FORMAT('LB:[12,1]'F9.3) FILENM(19) = 0 CALL SCOPY('PIP ', 1, PIP, 1) L = CONCAT(PIP, FILENM, 134) L = CONCAT(PIP, '=', 134) L = CONCAT(PIP, PIPFIL, 134) L = CONCAT(PIP, '/DI/FU', 134) CALL RUNSYS(PIP, L, IER) IF (.NOT.(IER .NE. 0)) GOTO 2060 GOTO 10 2060 CONTINUE CLOSE(UNIT = LUN) CALL WAITSY OPEN(UNIT = LUN, NAME = FILENM, DISPOSE = 'delete', TYPE = 'old', *ERR = 10) L = 0 2080 CONTINUE 2110 CONTINUE CALL GET(LUN, TMP, 134 - 1, NC) IF (.NOT.(NC .LE. 0)) GOTO 2140 GOTO 2130 2140 CONTINUE IF (.NOT.(TMP(1) .EQ. '(')) GOTO 2160 GOTO 2130 2160 CONTINUE 2120 GOTO 2110 2130 CONTINUE IF (.NOT.(NC .GE. 3)) GOTO 2180 TMP(NC + 1) = 0 NC = INDEX(TMP, ')') DIG = BKSCAN(TMP, '0123456789', NC) SL = BKSCAN(TMP, '/', DIG) DOT = BKSCAN(TMP, '.', SL) TMP(SL - 1) = 0 TMP(DOT) = 0 IF (.NOT.(.NOT.EQ(TMP(DIG), TMP(SL+1)))) GOTO 2200 IF (.NOT.(L .EQ. 0)) GOTO 2220 CALL SCOPY('PIP /TR', 1, PIP, 1) GOTO 2230 2220 CONTINUE L = CONCAT(PIP, ',', 134) 2230 CONTINUE L = CONCAT(PIP, '/FI:', 134) TMP(INDEX(TMP, ',')) = ':' TMP(NC) = 0 L = CONCAT(PIP, TMP(1 + 1), 134) IF (.NOT.(L .GT. 63)) GOTO 2240 C write(5,(1x,a1)) (pip(j),j=1,l) CALL RUNSYS(PIP, L, IER) L = 0 2240 CONTINUE 2200 CONTINUE GOTO 2190 2180 CONTINUE IF (.NOT.(NC .LT. 0)) GOTO 2260 GOTO 2100 2260 CONTINUE 2190 CONTINUE 2090 GOTO 2080 2100 CONTINUE IF (.NOT.(L .NE. 0)) GOTO 2280 CALL RUNSYS(PIP, L, IER) C write(5,(1x,a1)) (pip(j),j=1,l) 2280 CONTINUE CALL WAITSY RETURN 10 CONTINUE N = - 1 RETURN END C index - find character c in string str INTEGER FUNCTION INDEX(STR, C) BYTE C, STR(1) INDEX = 1 2300 IF (.NOT.(STR(INDEX) .NE. 0)) GOTO 2320 IF (.NOT.(STR(INDEX) .EQ. C)) GOTO 2330 RETURN 2330 CONTINUE 2310 INDEX = INDEX + 1 GOTO 2300 2320 CONTINUE INDEX = 0 RETURN END C scopy - copy string at from(i) to to(j) SUBROUTINE SCOPY(FROM, I, TO, J) BYTE FROM(1), TO(1) INTEGER I, J, K1, K2 K2 = J K1 = I 2350 IF (.NOT.(FROM(K1) .NE. 0)) GOTO 2370 TO(K2) = FROM(K1) K2 = K2 + 1 2360 K1 = K1 + 1 GOTO 2350 2370 CONTINUE TO(K2) = 0 RETURN END C concat - concatenate two strings INTEGER FUNCTION CONCAT(S1, S2, LIM) BYTE S1(1), S2(1) INTEGER LIM, I, LENGTH, L L = LENGTH(S1) I = L + 1 2380 IF (.NOT.(I .LT. LIM .AND. S2(I-L) .NE. 0)) GOTO 2400 S1(I) = S2(I - L) 2390 I = I + 1 GOTO 2380 2400 CONTINUE S1(I) = 0 CONCAT = I - 1 RETURN END C bkscan - return index of first break char in str INTEGER FUNCTION BKSCAN(STR, BRK, I) BYTE STR(1), BRK(1) INTEGER INDEX, I BKSCAN = I 2410 IF (.NOT.(STR(BKSCAN) .NE. 0)) GOTO 2430 IF (.NOT.(INDEX(BRK, STR(BKSCAN)) .NE. 0)) GOTO 2440 GOTO 2430 2440 CONTINUE 2420 BKSCAN = BKSCAN + 1 GOTO 2410 2430 CONTINUE RETURN END C eq - compare str1 to str2; return .true. if equal, .false. if not LOGICAL FUNCTION EQ(STR1, STR2) BYTE STR1(1), STR2(1) INTEGER I I = 1 2460 IF (.NOT.(STR1(I) .EQ. STR2(I))) GOTO 2480 IF (.NOT.(STR1(I) .EQ. 0)) GOTO 2490 EQ = (.TRUE.) RETURN 2490 CONTINUE 2470 I = I + 1 GOTO 2460 2480 CONTINUE EQ = (.FALSE.) RETURN END