subroutine W3AS00(nch_parm,cparm,iret_parm) C$$$ SUBPROGRAM DOCUMENTATION BLOCK C . . . . C SUBPROGRAM: W3AS00 GET PARM FIELD FROM COMMAND-LINE C PRGMMR: SHIMOMURA ORG: W/NMC41 DATE: 95-05-23 C C ABSTRACT: TO GET THE ONE COMMAND-LINE ARGUMENT WHICH STARTS WITH C "PARM="; RETURNING THE PARM FIELD (WITHOUT THE KEYWORD "PARM=") C AS A NULL-TERMINATED STRING IN THE CHARACTER STRING:CPARM. C C PROGRAM HISTORY LOG: C 95-05-23 DAVID SHIMOMURA C 98-03-10 B. VUONG REMOVE THE CDIR$ INTEGER=64 DIRECTIVE C C USAGE: CALL W3AS00(NCH_PARM, CPARM, iret_parm) C 1 2 3 C C OUTPUT ARGUMENT LIST: (INCLUDING WORK ARRAYS) C (1.) NCH_PARM - NO. OF CHARACTERS IN THE PARM FIELD C (2.) CPARM - C*(*) CPARM -- THE DESTINATION FOR THE PARMFIELD C OBTAINED FROM THE COMMAND LINE; C USER SHOULD DEFINE THE CHARACTER STRING FOR C A SIZE .LE. 101-BYTES, WHICH WOULD BE C BIG ENOUGH FOR THE 100-CHAR IBM LIMIT PLUS C ONE EXTRA BYTE FOR MY NULL-TERMINATOR. C C (3.) iret_parm - RETURN CODE C = 0; NORMAL RETURN C = -1; ABNORMAL EXIT. THE USER HAS FAILED C TO DEFINE THE CPARM DESTINATION C AS A CHARACTER STRING. C C = +1; A WARNING: C THE GIVEN ARG IN THE COMMAND LINE WAS C TOO LONG TO FIT IN THE DESTINATION: CPARM, C SO I HAVE TRUNCATED IT. C C = +2; A WARNING: NO ARGS AT ALL ON COMMAND LINE, C SO I COULD NOT FETCH THE PARM FIELD. C C = +3; A WARNING: NO "PARM="-ARGUMENT EXISTS C AMONG THE ARGS ON THE COMMAND LINE, C SO I COULD NOT FETCH THE PARM FIELD. C C OUTPUT FILES: C FT06F001 - SOME CHECKOUT PRINTOUT C C REMARKS: C C TO EMULATE THE IBM PARM FIELD, THE USER SHOULD KEY_IN ON THE C COMMAND LINE: C PARM='IN BETWEEN THE SINGLE_QUOTES IS THE PARM FIELD' C WHAT IS RETURNED FROM W3AS00() FROM THE PARM= ARG IS C THE PARM FIELD: WHICH STARTS WITH THE LOCATION BEYOND THE C EQUAL_SIGN OF THE KEYWORD "PARM=", AND INCLUDES EVERYTHING C WHICH WAS WITHIN THE BOUNDS OF THE SINGLE-QUOTE SIGNS. C BUT THE QUOTE SIGNS THEMSELVES WILL DISAPPEAR; AND A NULL- C TERMINATOR WILL BE ADDED. C THE STARTING "PARM=" IS A KEY WORD FOR THE PARMS, AND SHOULD C NOT BE USED TO START ANY OTHER ARGUMENT. C C CAUTION: I HAVE CHANGED THE CALL SEQUENCE BY ADDING A RETURN CODE C C C ATTRIBUTES: C LANGUAGE: CRAY FORTRAN77 C MACHINE: CRAY2 C C$$$ C integer kbytpwrd parameter (kbytpwrd=8) integer maxnbyt parameter (maxnbyt=112) C ... WHERE 112 CHARACTERS IS SIZE OF CWORK FOR 100 CHARACTERS C ... WITHIN QUOTES + 'PARM=' + BACKSLASHES + LINEFEEDS integer maxnwrds parameter (maxnwrds=maxnbyt/kbytpwrd) C ... call seq. args ... INTEGER NCH_PARM CHARACTER*(*) CPARM integer iret_parm C C ... FUNCTIONS ... external lastch integer lastch external notrail integer notrail C ------------------------------------------------------------- integer jwork(maxnwrds) character*112 cwork equivalence (jwork,cwork) integer(4) nargsinline,iargc,iar integer nchars integer lmt_txt integer non_parm LOGICAL LPARMQQ character*1 KLF character*1 NULLCHR character*1 lonech C . . . . . . . . S T A R T . . . . . . . . . . . . . . . . NULLCHR = char(0) KLF = char(10) C iret_parm = 0 non_parm = 0 LPARMQQ = .FALSE. NCH_PARM = 0 lmt_dest = len(cparm) write(6,103)lmt_dest 103 format(1h ,'W3AS00: dimensioned size (in bytes) of dest strng=', 1 I11) if(lmt_dest .le. 0) then write(6,105) 105 format(1h ,'W3AS00:FAILED on undefined destination ', 1 'character string: CPARM') iret_parm = -1 nch_parm = 0 go to 999 else if (lmt_dest .gt. 101) then lmt_dest = 101 endif lmt_txt = lmt_dest - 1 cparm(1:lmt_dest) = ' ' narg_got = 0 C nargsinline = iargc() write(6,115) nargsinline 115 format(1h ,'W3AS00: count of args found in command line =', I3) if(nargsinline .gt. 0) then C ... to scan every argument, looking only for the Arg which C ... starts with "PARM=" do iar = 1,nargsinline LPARMQQ = .FALSE. cwork(1:) = ' ' call getarg(iar,cwork) narg_got = narg_got + 1 nchars = lastch(cwork) if(nchars .le. 0) then write(6,125)iar 125 format(1h ,'W3AS00:getarg() returned an empty arg for', A ' no.',I3 ) else C ... SOME TEXT EXISTS IN THIS ARG ... C ... DOES IT START WITH "PARM=" ??? if((cwork(1:5) .EQ. 'PARM=') .OR. 1 (cwork(1:5) .EQ. 'parm=') ) then LPARMQQ = .TRUE. C ... this arg is special case of PARM= C ... which can include blanks, so cannot lastch() it ... nchars = notrail(cwork) endif C ... iwdss = ((nchars-1)/kbytpwrd) + 1 C ... where iwdss points to last word so I could hex dump C ... that last word, to see if NULL is there C ... There was no NULL; only blank fill. IF(LPARMQQ) THEN C ... FILTER OUT ANY BACKSLASH or LINE_FEED ... ioutc = 0 do inc = 6,nchars if(ioutc .LT. lmt_txt) then lonech = cwork(inc:inc) if((lonech .EQ. '\\') .OR. 1 (lonech .EQ. KLF)) then else ioutc = ioutc + 1 cparm(ioutc:ioutc) = lonech endif else C ... comes here if ioutc .GE. lmt_txt, C ... so I cannot increment ioutc for this inc char C ... so truncate the string at (1:ioutc) C ... a warning be return-coded ... iret_parm = +1 go to 155 endif enddo 155 continue nch_parm = ioutc np1 = nchars+1 cparm(np1:np1) = NULLCHR go to 999 C ... jump out of DO when PARM has been processed ... else C ... this is .not. a PARM field, do nothing w/ those, non_parm = non_parm + 1 endif endif enddo C ... IF IT FALLS THRU BOTTOM OF DO, THEN IT DID NOT FIND C ... THE PARM FIELD AMONG THE EXISTING ARGS iret_parm = 3 nch_parm = 0 ELSE C ... COMES HERE IF nargsinline = 0, so there were no args at all iret_parm = 2 nch_parm = 0 endif go to 999 999 continue return end integer function lastch(str) C ... lastch() ... to point to the last character of a character C ... string C ... String terminators are first BLANK or NULL character C ... encountered. C ... Caution: I will limit scan on LEN(str) C so you must give me a character string. C character*(*) str character*1 NULLCHR character*1 BLANK C integer i integer limit C NULLCHR = char(0) BLANK = ' ' limit = len(str) i = 0 do while(i .LT. limit .AND. str(i+1:i+1) .NE. NULLCHR 1 .AND. str(i+1:i+1) .NE. BLANK) i = i + 1 enddo lastch = i return end integer function notrail(str) C ... mods for CRAY version 8-Dec-1994/dss C C ... notrail() ... to point to the last non-blank character of a C ... character string (which can have leading C blanks and intermediate blanks); but after C ignoring all trailing blank characters. C ... String terminators are last BLANK or first NULL C ... character encountered. C C ... This differs from LASTCH() which stops on first C ... BLANK encountered when scanning from the start; C ... NOTRAIL() will scan backwards from the end of the C ... string, skipping over trailing blanks, until the C ... last non-blank character is hit. C ... C ... Caution: I will limit scan on LEN(str) C so you must give me a character string. C character*(*) str character*1 BLANK parameter (BLANK = ' ') C integer i integer limit integer limitnl character*1 NULLCHR C NULLCHR = char(0) i = 0 limitnl = 0 limit = len(str) if(limit .le. 0) go to 999 C ... otherwise, at least one char len string ... limitnl = index(str(1:limit),NULLCHR) if(limitnl .le. 0) then C ... no NULLCHR exists in str(1:limit) ... C ... so go scan from limit go to 300 else if(limitnl .eq. 1) then go to 999 C ... which jumped out w/ pointer=0 if NULL in first position else C ... a NULLCHR existed within str(1:limit); so C ... I want to scan backwards from before that NULLCHR C ... which is located at limitnl limit = limitnl - 1 endif if(limit .le. 0) go to 999 300 continue C ... otherwise, we have a string of at least one char to look at C ... which has no NULLCHR in interval (1:limit) i = limit do while((i .GT. 0) .AND. (str(i:i) .EQ. BLANK)) i = i - 1 enddo 999 continue notrail = i return end