PROGRAM RASTERPOST C RASTERIZES ONE PAGE OF A VERSATEC PLOT FILE AND MAKES A RASTER C FILE FOR AN 11X17 IMAGEN C C RASTERIZES A PLOT FILE READ FROM UNIT 70 C FOR EACH PAGE GENERATES A POOL FILE 'PIDGLOSYM'.PS;N ON UNIT 75 C SUBMITS A PRINT JOB ON PSP1 C C THE EXECUTE LINE IS ONE OF THE FOLLOWING C C $RASTERPLOT C $RASTERPLOT PLOT C $RASTERPLOT FILENAME C $RASTERPLOT FILENAME FIRSTPAGE C $RASTERPLOT FILENAME FIRSTPAGE LASTPAGE C $RASTERPLOT FILENAME FIRSTPAGE LASTPAGE LEFT RIGHT BOTTOM TOP C C THE DEFAULT VALUES ARE EQUIVALENT TO C $RASTERPLOT PLOT 1 999 0 5087 0 3263 C C THE UNITS ARE IN VERSATEC PLOT SPACE WHICH RUNS FROM 0 TO A LARGE INTEGER C IN X AND FROM 0 TO A LARGE INTEGER? IN Y C LEFT 0 RIGHT=5087, BOTTOM=0, TOP= 3263 C C TO MAKE A LONG CONTINUOUS PLOT SAY C RASTERPLOT FILE 1 1 0 5087 C RASTERPLOT FILE 1 1 5088 10165 C RASTERPLOT FILE 1 1 10166 15253 C ETC. C IMPLICIT INTEGER*4 (A-Z) PARAMETER (SS$_NORMAL='0001'X) DIMENSION WORD(3264),BITS(3264),WORDBITS(32) c DIMENSION WORD(3296),BITS(3296),WORDBITS(32) C 5088 BY 3296 IMAGE 17 BY 11 IN PAPER 300 DOTS/IN LARGEST MULTIPLE OF 32 DIMENSION RASTER(102,5088) c DIMENSION RASTER(103,5088) COMMON /ABC/A(3000000),B(3000000),C(4),BLACK,WHITE BYTE A,B,C,BLACK,WHITE INTEGER MA(750000),MB(750000),MC EQUIVALENCE (A(1),RASTER(1,1),MA(1)) EQUIVALENCE (B(1),MB(1)),(C(1),MC) REAL*8 PLOTOUT,USERID(2),FILENAME(2) COMMON /BUFF/BUFFER(512),NBUFF COMMON /VECTOR/X,Y,DX,Y2 REAL*8 BUFFER CHARACTER*13 FILENAME13 CHARACTER*9 FILENAME9,USERID9 CHARACTER*40 WHOLEFILENAME,RASTERFILE CHARACTER*60 COMMAND_STRINGS(7),INFILENAME DATA WORDBITS/"200,"100,"40,"20,"10,"4,"2,"1, 1"100000,"40000,"20000,"10000,"4000,"2000,"1000,"400, 2"40000000,"20000000,"10000000,"4000000, 3"2000000,"1000000,"400000,"200000, 4"20000000000,"10000000000,"4000000000,"2000000000, 5"1000000000,"400000000,"200000000,"100000000/ C INFILENAME='PLOT.VEC' FIRSTPAGE=0 LASTPAGE=0 LEFT=0 RIGHT=5087 BOTTOM=0 TOP=3295 top=3263 IFYMAX=0 IFYMIN=0 IFXMAX=0 IFXMIN=0 C CALL GET_COMMAND_STRINGS(COMMAND_STRINGS,7,N_STRINGS_FOUND) C IF(N_STRINGS_FOUND.GE.7)THEN IF(COMMAND_STRINGS(7)(1:3).EQ.'MAX')IFYMAX=1 IF(IFYMAX.EQ.0)TOP=INTEGERSTRING(COMMAND_STRINGS(7)) ENDIF C IF(N_STRINGS_FOUND.GE.6)THEN IF(COMMAND_STRINGS(6)(1:3).EQ.'MIN')IFYMIN=1 IF(IFYMIN.EQ.0)BOTTOM=INTEGERSTRING(COMMAND_STRINGS(6)) ENDIF C IF(N_STRINGS_FOUND.GE.5)THEN IF(COMMAND_STRINGS(5)(1:3).EQ.'MAX')IFXMAX=1 IF(IFXMAX.EQ.0)RIGHT=INTEGERSTRING(COMMAND_STRINGS(5)) ENDIF C IF(N_STRINGS_FOUND.GE.4)THEN IF(COMMAND_STRINGS(4)(1:3).EQ.'MIN')IFXMIN=1 IF(IFYMIN.EQ.0)LEFT=INTEGERSTRING(COMMAND_STRINGS(4)) ENDIF C IF(N_STRINGS_FOUND.GE.3)LASTPAGE= 1INTEGERSTRING(COMMAND_STRINGS(3)) IF(N_STRINGS_FOUND.GE.2)FIRSTPAGE= 1INTEGERSTRING(COMMAND_STRINGS(2)) IF(FIRSTPAGE.EQ.0)THEN FIRSTPAGE=1 LASTPAGE=999 ENDIF IF(LASTPAGE.EQ.0)LASTPAGE=FIRSTPAGE IF(FIRSTPAGE.GT.LASTPAGE)LASTPAGE=FIRSTPAGE C IF(N_STRINGS_FOUND.GE.1)INFILENAME=COMMAND_STRINGS(1) IFDOT=INDEX(INFILENAME,'.') IF(IFDOT.EQ.0)INFILENAME=INFILENAME(1:N_CHARS(INFILENAME))//'.VEC' C OPEN(UNIT=70,TYPE='OLD',FORM='UNFORMATTED',READONLY, 1NAME=INFILENAME(1:N_CHARS(INFILENAME))) INQUIRE(UNIT=70,NAME=WHOLEFILENAME) PRINT 2,WHOLEFILENAME 2 FORMAT(16H0VECTOR FILE IS ,A40) READ(70)BUFFER PLOTOUT=BUFFER(1) IF(PLOTOUT.NE.8HPLOTFILE)STOP 'NOT A VAXPLOT FILE' USERID(1)=BUFFER(2) USERID(2)=BUFFER(3) FILENAME(1)=BUFFER(4) FILENAME(2)=BUFFER(5) NBUFF=5 C USERID IS THE NAME OF THE PERSON WHO IS PLOTTING THE PLOT FILE C THE ORIGINAL USERNAME IS THE NAME OF THE PERSON WHO WROTE THE PLOT FILE C CALL USERNAME(USERID) WRITE(FILENAME9,'(A8,A1)')FILENAME C WRITE(USERID9,4)USERID C 4 FORMAT(A8,A1) C FILENAME13=FILENAME9//'.RAS' C USERID9=USERID9(1:INDEX(USERID9,' ')-1) C RASTERFILE='GPOOL:['//USERID9//']'//FILENAME13 RASTERFILE='SYS$SCRATCH:'//FILENAME9//'.PS' C DO 6 YBIT=1,3264 c DO 6 YBIT=1,3296 WORD(YBIT)=(YBIT+31)/32 I=MOD(YBIT,32) IF(I.EQ.0)I=32 6 BITS(YBIT)=WORDBITS(I) C DO 500 PAGE1=1,LASTPAGE+1 C C PAGE 0 IS THE HEADER C SKIP UP TO FIRST PAGE TO BE PLOTTED IF(PAGE1.LT.FIRSTPAGE+1)THEN CALL SKIPBUF C CALL READBUF(X,Y,DX,Y2) IF(X.EQ.-1)GO TO 500 IF(X.EQ.-2)GO TO 600 ENDIF C IF(.NOT.LIB$INIT_TIMER())CALL FATAL C XMAX=-1 C XMIN=10000000 C YMAX=-1 C YMIN=99999 DO 8 IRASTER=1,5088 DO 8 I=1,102 8 RASTER(I,IRASTER)=0 C C XMIN=MIN0(X,XMIN) C XMAX=MAX0(X2,XMAX) C YMIN=MIN0(Y,Y2,YMIN) C 100 YMAX=MAX0(Y,Y2,YMAX) C IF(IFXMAX.EQ.1)RIGHT=XMAX C IF(IFXMIN.EQ.1)LEFT=XMIN C IF(IFYMAX.EQ.1)TOP=YMAX C IF(IFYMIN.EQ.1)BOTTOM=YMIN C DO 300 IVECT=1,20000000 CALL READBUF C CALL READBUF(X,Y,DX,Y2) C X = -1 MARKS END OF PAGE C Y = -2 MARKS END OF PLOT IF(X.EQ.-1)GO TO 400 IF(X.EQ.-2)GO TO 600 DY=Y2-Y IF(X.GT.RIGHT)GO TO 300 X2=X+DX IF(X2.LT.LEFT)GO TO 300 YMIN=MIN0(Y,Y2) IF(YMIN.GT.TOP)GO TO 300 YMAX=MAX0(Y,Y2) IF(YMAX.LT.BOTTOM)GO TO 300 IF(X.GE.LEFT.AND.X2.LE.RIGHT.AND.YMIN.GE.BOTTOM.AND.YMAX.LE.TOP) 1GO TO 9 IF(DX.EQ.0)THEN Y=MAX0(BOTTOM,YMIN) Y2=MIN0(YMAX,TOP) DY=Y2-Y GO TO 9 ENDIF IF(DY.EQ.0)THEN X=MAX0(LEFT,X) X2=MIN0(RIGHT,X2) DX=X2-X GO TO 9 ENDIF IF(X.LT.LEFT)THEN Y=Y+((LEFT-X)*(DY+DY)+DX)/(DX+DX) X=LEFT ENDIF IF(X2.GT.RIGHT)THEN Y2=Y+((RIGHT-X)*(DY+DY)+DX)/(DX+DX) X2=RIGHT ENDIF IF(Y.GT.TOP)THEN X=X+((TOP-Y)*(DX+DX)+DY)/(DY+DY) Y=TOP ENDIF IF(Y.LT.BOTTOM)THEN X=X+((BOTTOM-Y)*(DX+DX)+DY)/(DY+DY) Y=BOTTOM ENDIF IF(Y2.GT.TOP)THEN X2=X+((TOP-Y)*(DX+DX)+DY)/(DY+DY) Y2=TOP ENDIF IF(Y2.LT.BOTTOM)THEN X2=X+((BOTTOM-Y)*(DX+DX)+DY)/(DY+DY) Y2=BOTTOM ENDIF DX=X2-X DY=Y2-Y YMIN=MIN0(Y,Y2) YMAX=MAX0(Y,Y2) IF(X.LT.LEFT.OR.X2.GT.RIGHT.OR.YMIN.LT.BOTTOM.OR.YMAX.GT.TOP) 1GO TO 300 9 X=X+1-LEFT Y=Y+1-BOTTOM IF(DY.EQ.0)GO TO 20 ONE=1 IF(DY.LT.0)ONE=-1 IF(DX.EQ.0)GO TO 10 ABSDY=ABS(DY) IF(DX.EQ.ABSDY)GO TO 30 IF(DX.LT.ABSDY)GO TO 40 C IF(DX.GT.ABSDY)GO TO 50 GO TO 50 C C Y-VECTOR 10 DO 11 YBIT=Y,Y+DY,ONE 11 RASTER(WORD(YBIT),X)=IOR(RASTER(WORD(YBIT),X),BITS(YBIT)) GO TO 300 C C X-VECTOR 20 DO 21 IRASTER=X,X+DX 21 RASTER(WORD(Y),IRASTER)=IOR(RASTER(WORD(Y),IRASTER),BITS(Y)) GO TO 300 C C 45 DEGREE VECTOR 30 YBIT=Y-ONE DO 31 IRASTER=X,X+DX YBIT=YBIT+ONE 31 RASTER(WORD(YBIT),IRASTER)=IOR(RASTER(WORD(YBIT),IRASTER), 1BITS(YBIT)) GO TO 300 C C STEEP VECTOR (ONE OR MORE BITS PER RASTER) C IF(DX/ABS(DY)*ABS(YBIT-Y).GT.(IRASTER-X)+1/2)IRASTER=IRASTER+1 OR C IF(DX/ABS(DY)*ABS(YBIT-Y)-(IRASTER-X).GT.1/2)IRASTER=IRASTER+1 OR C IF(DX*ABS(YBIT-Y)-(IRASTER-X)*ABS(DY).GT.ABS(DY)/2)IRASTER=IRASTER+1 OR C IF(DX*2*ABS(YBIT-Y)-(IRASTER-X)*ABS(DY)*2.GT.ABS(DY))IRASTER=IRASTER+1 40 DX2=DX+DX DY2=ABSDY+ABSDY DD=-DX2 IRASTER=X DO 41 YBIT=Y,Y+DY,ONE DD=DD+DX2 IF(DD.LE.ABSDY)GO TO 41 IRASTER=IRASTER+1 DD=DD-DY2 41 RASTER(WORD(YBIT),IRASTER)=IOR(RASTER(WORD(YBIT),IRASTER), 1BITS(YBIT)) GO TO 300 C C SHALLOW VECTOR (ALWAYS ONLY ONE BIT PER RASTER) C IF(DY/DX*(IRASTER-X).GT.YBIT-Y+1/2)YBIT=YBIT+1 OR C IF(DY/DX*(IRASTER-X)-(YBIT-Y).GT.1/2)YBIT=YBIT+1 OR C IF(DY*(IRASTER-X)-(YBIT-Y)*DX.GT.DX/2)YBIT=YBIT+1 OR C IF(DY*2*(IRASTER-X)-(YBIT-Y)*DX*2.GT.DX)YBIT=YBIT+1 C IF(DY.LT.0) C IF(-DY/DX*(IRASTER-X).GT.-(YBIT-Y)+1/2)YBIT=YBIT-1 ETC. 50 DX2=DX+DX DY2=ABSDY+ABSDY DD=-DY2 YBIT=Y DO 51 IRASTER=X,X+DX DD=DD+DY2 IF(DD.LE.DX)GO TO 51 YBIT=YBIT+ONE DD=DD-DX2 51 RASTER(WORD(YBIT),IRASTER)=IOR(RASTER(WORD(YBIT),IRASTER), 1BITS(YBIT)) C 300 CONTINUE 400 NVECT=IVECT-1 IF(NVECT.EQ.0)GO TO 600 PAGE=PAGE1-1 PRINT 401,PAGE,NVECT,LEFT,RIGHT,BOTTOM,TOP 401 FORMAT('0PAGE',I3,I10,' VECTORS',' LEFT=',I7,' RIGHT=',I7, 1' BOTTOM=',I5,' TOP=',I5) IF(.NOT.LIB$SHOW_TIMER())CALL FATAL IF(.NOT.LIB$INIT_TIMER())CALL FATAL C INVERT BLACK AND WHITE FOR POSTSCRIPT DO 402 I=1,518976 402 MA(I)=NOT(MA(I)) C CALL LZWA85(A,2075904,B,NCOMPRESSED) C CALL RUNLENGTH(A,2075904,B,NCOMPRESSED) OPEN(UNIT=75,NAME=RASTERFILE,STATUS='NEW',CARRIAGECONTROL='LIST') INQUIRE(UNIT=75,NAME=WHOLEFILENAME) PRINT 452,WHOLEFILENAME 452 FORMAT(' POSTSCRIPT FILE IS ',A40) PRINT 453,NCOMPRESSED 453 FORMAT(' BITMAP COMPRESSED FROM 2075904 TO ',I7,' BYTES') WRITE(75,'(A)')'%!PS-Adobe-2.0' WRITE(75,'(A)')'gsave' WRITE(75,'(A)')'/pixs {0.24 mul} def' WRITE(75,'(A)')'/drawimage {' WRITE(75,'(A)')'3264 5088 1 [3264 0 0 -5088 -18 5061]' WRITE(75,'(A)')'currentfile' C WRITE(75,'(A)')'/ASCII85Decode filter /RunLengthDecode filter' WRITE(75,'(A)')'/ASCII85Decode filter /LZWDecode filter' WRITE(75,'(A)')'image showpage grestore} bind def' WRITE(75,'(A)')'matrix currentmatrix' WRITE(75,'(A)')'3264 pixs 5088 pixs scale' WRITE(75,'(A)')'drawimage' C LZW OUTPUTS TO B RUNLENGTH OUTPUTS TO A C WRITE(75,'(80A1)')(A(I),I=1,NCOMPRESSED) WRITE(75,'(80A1)')(B(I),I=1,NCOMPRESSED) CLOSE(UNIT=75,STATUS='SAVE') C ALTERNATE PRINTERS IF(MOD(ICHAR(FILENAME9(9:9)),2).EQ.0)THEN IF(LIB$SPAWN( 1 '$PRINT/Q=PSP2/DEL/PAR=(SHEET_SIZE=LEDGER)/PRIO=1/NOFLAG '// 2 WHOLEFILENAME,,,,,,,,,,,).NE.SS$_NORMAL)CALL FATAL ELSE IF(LIB$SPAWN( 1 '$PRINT/Q=PSP1/DEL/PAR=(SHEET_SIZE=LEDGER)/PRIO=1/NOFLAG '// 2 WHOLEFILENAME,,,,,,,,,,,).NE.SS$_NORMAL)CALL FATAL IF(.NOT.LIB$SHOW_TIMER())CALL FATAL ENDIF 500 CONTINUE 600 CONTINUE CALL EXIT END SUBROUTINE RUNLENGTH(AA,NBYTES,BB,NCOMPRESSED) COMMON /ABC/A(3000000),B(3000000),C(4),BLACK,WHITE BYTE A,B,C,BLACK,WHITE INTEGER MA(1000000),MB(1000000),MC EQUIVALENCE (A(1),MA(1)),(B(1),MB(1)),(C(1),MC) A(NBYTES+1)=13 A(NBYTES+2)=13 BLACK=0 WHITE=-1 NBLACK=0 NWHITE=0 ISTART=1 IB=0 NRUN=0 DO 440 I=1,NBYTES IF(A(I).NE.BLACK)GO TO 420 C IF(NBLACK.EQ.0.AND.A(I+2).NE.BLACK)GO TO 430 IF(NBLACK.EQ.1.AND.A(I+1).NE.BLACK)THEN NBLACK=0 NRUN=NRUN+1 IF(NRUN.LT.128)GO TO 430 GO TO 412 ENDIF C NBLACK=NBLACK+1 IF(NRUN.EQ.0)GO TO 414 412 IB=IB+1 B(IB)=NRUN-1 DO 413 IRUN=ISTART,ISTART+NRUN-1 IB=IB+1 413 B(IB)=A(IRUN) NRUN=0 ISTART=ISTART+NRUN IF(NBLACK.EQ.0)GO TO 430 C 414 IF(NBLACK.EQ.128.OR.I.EQ.NBYTES)GO TO 415 IF(A(I+1).EQ.BLACK)GO TO 440 415 IB=IB+1 B(IB)=1-NBLACK IB=IB+1 B(IB)=BLACK NBLACK=0 ISTART=I+1 GO TO 440 C 420 IF(A(I).NE.WHITE)GO TO 430 IF(NWHITE.EQ.0.AND.A(I+2).NE.WHITE)GO TO 430 IF(NWHITE.EQ.1.AND.A(I+1).NE.WHITE)THEN NWHITE=0 NRUN=NRUN+1 IF(NRUN.LT.128)GO TO 430 GO TO 422 ENDIF C NWHITE=NWHITE+1 IF(NRUN.EQ.0)GO TO 424 422 IB=IB+1 B(IB)=NRUN-1 DO 423 IRUN=ISTART,ISTART+NRUN-1 IB=IB+1 423 B(IB)=A(IRUN) NRUN=0 ISTART=ISTART+NRUN IF(NWHITE.EQ.0)GO TO 430 C 424 IF(NWHITE.EQ.128.OR.I.EQ.NBYTES)GO TO 425 IF(A(I+1).EQ.WHITE)GO TO 440 425 IB=IB+1 B(IB)=1-NWHITE IB=IB+1 B(IB)=WHITE NWHITE=0 ISTART=I+1 GO TO 440 C 430 NRUN=NRUN+1 IF(NRUN.LT.128.AND.I.LT.NBYTES)GO TO 440 IB=IB+1 B(IB)=NRUN-1 DO 432 IRUN=ISTART,ISTART+NRUN-1 IB=IB+1 432 B(IB)=A(IRUN) ISTART=ISTART+NRUN NRUN=0 440 CONTINUE NB=IB+1 B(NB)=-128 B(NB+1)=0 B(NB+2)=0 B(NB+3)=0 C C ASCII85 COMPRESSION IA=1 NB4=(NB+3)/4 IB=-3 DO 450 IB4=1,NB4 IB=IB+4 C BYTE ROTATION MC=MB(IB4) B(IB)=C(4) B(IB+1)=C(3) B(IB+2)=C(2) B(IB+3)=C(1) C IF(MB(IB4).EQ.0)THEN IF(MOD(NB,4).NE.0.AND.IB4.EQ.NB4)GO TO 448 A(IA)=122 IA=IA+1 GO TO 450 ENDIF C 448 IFNEG=0 IF(MB(IB4).LT.0)IFNEG=1 K=IAND(MB(IB4),'7FFFFFFF'X) K1=K/52200625 K=K-K1*52200625 K2=K/614125 K=K-K2*614125 K3=K/7225 K=K-K3*7225 K4=K/85 K5=K-K4*85 IF(IFNEG.EQ.0)GO TO 449 C ADD 2**31 K1=K1+41 K2=K2+11 K3=K3+69 K4=K4+48 K5=K5+43 IF(K5.GT.84)THEN K5=K5-85 K4=K4+1 ENDIF IF(K4.GT.84)THEN K4=K4-85 K3=K3+1 ENDIF IF(K3.GT.84)THEN K3=K3-85 K2=K2+1 ENDIF IF(K2.GT.84)THEN K2=K2-85 K1=K1+1 ENDIF 449 A(IA)=K1+33 A(IA+1)=K2+33 A(IA+2)=K3+33 A(IA+3)=K4+33 A(IA+4)=K5+33 IA=IA+5 450 CONTINUE N=MOD(NB,4) IF(N.GT.0)IA=IA-5+N+1 A(IA)=126 IA=IA+1 A(IA)=62 NCOMPRESSED=IA RETURN END SUBROUTINE READBUF C SUBROUTINE READBUF(I,J,K,L) COMMON /BUFF/BUFFER(4,512),NBUFF COMMON /VECTOR/I,J,K,L INTEGER*2 BUFFER NBUFF=NBUFF+1 I=BUFFER(1,NBUFF) J=BUFFER(2,NBUFF) K=BUFFER(3,NBUFF) L=BUFFER(4,NBUFF) I30000=K/1000 K=K-I30000*1000 I=I+I30000*30000 IF(NBUFF.LT.512)RETURN READ(70)BUFFER NBUFF=0 RETURN ENTRY SKIPBUF 1 NBUFF=NBUFF+1 I=BUFFER(1,NBUFF) IF(NBUFF.EQ.512)THEN READ(70)BUFFER NBUFF=0 ENDIF IF(I.LT.0.)RETURN GO TO 1 END SUBROUTINE USERNAME(NAME) COMMON /USERLST/USERNAME_LEN,JPI_USERNAME_ID,USERNAME_ADR,ZERO BYTE NAME(12) INTEGER*4 USERNAME_ADR,SYS$GETJPI,ZERO(2),JPI$_USERNAME INTEGER*2 USERNAME_LEN,JPI_USERNAME_ID DATA JPI$_USERNAME/'202'X/ DATA USERNAME_LEN,ZERO/12,0,0/ JPI_USERNAME_ID=JPI$_USERNAME USERNAME_ADR=%LOC(NAME) IF(SYS$GETJPI(,,,USERNAME_LEN,,,).NE.1)STOP 'USERNAME ERROR' RETURN END FUNCTION INTEGERSTRING(STRING) IMPLICIT INTEGER*4 (A-Z) CHARACTER STRING*(*) STATUS=OTS$CVT_TI_L(STRING(1:N_CHARS(STRING)),N) IF(STATUS.NE.1)CALL FATAL INTEGERSTRING=N RETURN END FUNCTION N_CHARS(STRING) CHARACTER*(*) STRING DO 1 N_CHARS=LEN(STRING),1,-1 ICH=ICHAR(STRING(N_CHARS:N_CHARS)) IF(ICH.NE.ICHAR(' ').AND.ICH.NE.0)RETURN 1 CONTINUE N_CHARS=0 RETURN END SUBROUTINE GET_COMMAND_STRINGS(COMMAND_STRINGS,MAX_STRINGS, + N_STRINGS_FOUND) IMPLICIT INTEGER*4 (A-Z) CHARACTER COMMAND_STRINGS(MAX_STRINGS)*(*) CHARACTER COMMAND_LINE*(500) LOGICAL QUOTE_FOUND 201 FORMAT(/' Invalid status returned by LIB$GET_FOREIGN:',Z9.8/) 202 FORMAT(/' GET_COMMAND_STRINGS found string longer than',I4, + ' characters:'//1X,A/) LEN_STRINGS=LEN(COMMAND_STRINGS(1)) ISTAT=LIB$GET_FOREIGN(COMMAND_LINE,,LEN_COMMAND_LINE) IF(ISTAT.NE.1)THEN PRINT 201,ISTAT CALL FATAL ENDIF START=1 ! remove any quotation marks put in to prevent DCL's up-casing QUOTE_FOUND=.TRUE. DO WHILE(QUOTE_FOUND) LOC_QUOTE=INDEX(COMMAND_LINE(START:LEN_COMMAND_LINE),'"') IF(LOC_QUOTE.GT.0)THEN LINE_PT=LOC_QUOTE+START-1 COMMAND_LINE(LINE_PT:LINE_PT)=' ' START=LINE_PT+1 ELSE QUOTE_FOUND=.FALSE. ENDIF ENDDO N_STRINGS_FOUND=0 IF(LEN_COMMAND_LINE.EQ.0)RETURN LINE_PT=1 DO WHILE (.TRUE.) DO WHILE (COMMAND_LINE(LINE_PT:LINE_PT).EQ.' ') IF(LINE_PT.EQ.LEN_COMMAND_LINE)RETURN LINE_PT=LINE_PT+1 ENDDO IF(N_STRINGS_FOUND.EQ.MAX_STRINGS)RETURN N_STRINGS_FOUND=N_STRINGS_FOUND+1 COMMAND_STRINGS(N_STRINGS_FOUND)=' ' STR_PT=0 DO WHILE (COMMAND_LINE(LINE_PT:LINE_PT).NE.' ') IF(STR_PT.EQ.LEN_STRINGS)THEN PRINT 202,LEN_STRINGS, + COMMAND_STRINGS(N_STRINGS_FOUND)(1:LEN_STRINGS) CALL FATAL ENDIF STR_PT=STR_PT+1 COMMAND_STRINGS(N_STRINGS_FOUND)(STR_PT:STR_PT)= + COMMAND_LINE(LINE_PT:LINE_PT) IF(LINE_PT.EQ.LEN_COMMAND_LINE)RETURN LINE_PT=LINE_PT+1 ENDDO ENDDO RETURN END ! GET_COMMAND_STRINGS SUBROUTINE FATAL PARAMETER (SS$_ABORT ='002C'X) CALL LIB$STOP(%VAL(SS$_ABORT)) END ! FATAL