SUBROUTINE STRCMP(NAME,LENGTH,RETCD) C COPYRIGHT (C) 1983 GLENN EVERHART C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY. INCLUDE 'VKLUGPRM.FTN' C PARAMETER RRW = 32 C PARAMETER RCL = 32 C RRW=MAX REAL ROWS C RCL=MAX REAL COLS C RRW MUST BE 1 LARGER TO HANDLE 1ST 27 VARIABLES IN AVBLS C VBLS AND TYPE DIMENSIONED RRW,RCL C ************************************************** C * * C * SUBROUTINE STRCMP(NAME,LENGTH,RETCD) * C * * C ************************************************** C C C STRCMP LOOKS PAST BLANKS FOR THE NAME HELD BY NAME(1),...,NAME(LENGTH) C THE RETURN CODE RETCD INDICATES SUCCESS OR FAILURE: C C 1=MATCH C 2=FAILURE C C UPON EXIT, COMMON VARIABLE NONBLK C IF SUCCESSFUL, POINTS TO ONE BEYOND THE LAST CHARACTER SCANNED C FOR MATCH C IF FAILURE, UNCHANGED C C C C MODIFICATION CLASSES: M2 C C C C STRCMP CALLS GETNNB TO GET THE NEXT NON-BLANK FROM LINE(80) C C STRCMP IS CALLED BY CMND C C C C C VARIABLE USE C C I2 INDEXES NAME(LENGTH). C IS HOLDS VALUE OF NONBLANK IN CASE AN ERROR OCCURS C AND IT IS NECESSARY TO RESTORE THE VALUE. C LENGTH HOLDS THE LENGTH OF VECTOR NAME. C NONBLK POINTER FOR COMMAND LINE HELD BY LINE(80). C RETCD HOLDS RETURN CODE. 1=MATCH, 2=FAILURE C C C C C SUBROUTINE STRCMP(NAME,LENGTH,RETCD) INTEGER*2 LENGTH INTEGER*2 LEVEL,NONBLK,LEND INTEGER*2 RETCD,VIEWSW,BASED C LOGICAL*1 LINE(80),NAME(LENGTH) LOGICAL*1 ALPHA(27),COMMA,BLANK,RPAR,LPAR,EQ C COMMON /CONS/ALPHA,COMMA,BLANK,RPAR,LPAR,EQ COMMON LEVEL,LINE,NONBLK,LEND,VIEWSW,BASED C C UPON ENTRANCE, NONBLK POINTS TO THE FIRST CHARACTER C IN NAME, COMPARE LOOKS PAST THIS TO THE NEXT CHARACTER C SINCE CMND HAS ALREADY IDENTIFIED THAT FIRST CHARACTER C IN THE COMMAND NAME (AFTER THE ASTERISK). IS=NONBLK CALL GETNNB(IPT,RETCD) GO TO (10,999),RETCD C ON EXIT NONBLK POINTS TO LAST CHARACTER IN NAME C C 10 DO 100 I2=1,LENGTH CALL GETNNB(IPT,RETCD) GO TO (20,999),RETCD STOP 20 20 NONBLK=IPT IF(NAME(I2).NE.LINE(NONBLK))GOTO 999 100 CONTINUE RETCD=1 RETURN C C C NO MATCH 999 RETCD=2 C IF ERROR, RESTORE VALUE OF NONBLK NONBLK=IS RETURN END