Article 4373 of vmsnet.misc:
Path: nntpd.lkg.dec.com!pa.dec.com!news1.digital.com!ames!merlin.arc.nasa.gov!RAGOSTA
From: ragosta@merlin.arc.nasa.gov
Newsgroups: vmsnet.misc
Subject: Sorted Directoy 2 of 3
Date: 18 Sep 1995 20:27:28 GMT
Organization: Aeroflightdynamics Directorate
Lines: 383
Message-ID: <43kkng$1mj@news.arc.nasa.gov>
Reply-To: ragosta@merlin.arc.nasa.gov
NNTP-Posting-Host: merlin.arc.nasa.gov

c
c  Part 2 of 3...
c
c  The routines in this file are from the MERLIB library.  If you already
c   have the MERLIB library installed on your system, you don't need this
c   file.
c
c  The whole MERLIB release is on our web site 
c  (http://afdd-ast.arc.nasa.gov/code-asc.htm)
c
c
	SUBROUTINE DEFAULT (DIR_STRING)
*
*	Returns, in the character string DIR_STRING, the name of the  cur-
*	rent  default device and directory.  The string DIR_STRING must be
*	long enough to contain the name, or this routine will abort.
*
*	Alan L. Zirkle     Naval Surface Warfare Center
*			   Code K53
*	9 Nov 1983	   Dahlgren, Virginia  22448
*
	IMPLICIT INTEGER (A-Z)
	CHARACTER*(*) DIR_STRING
C
	STATUS = SYS$TRNLOG('SYS$DISK',LEN1,DIR_STRING,,,)
	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))
C
	STATUS = SYS$SETDDIR(,LEN2,DIR_STRING(LEN1+1:))
	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))
C
	LEN1 = LEN1 + LEN2
	IF (LEN1.LT.LEN(DIR_STRING)) DIR_STRING(LEN1+1:) = ' '
C
      RETURN
	END
      SUBROUTINE GETFILE ( INFILE, OUTFILE )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          GETFILE          **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          GETFILE
C*
C*     AUTHOR :
C*          Arthur E. Ragosta
C*          MS 219-3
C*          NASA Ames Research Center
C*          Moffett Field, Ca.  94035
C*          (415) 604-5558
C*
C*     PURPOSE :
C*          RETRIEVE THE NEXT FILE NAME FROM A LIST (INCLUDING 
C*           WILDCARDS).  
C*
C*     INPUT ARGUMENTS :
C*          INFILE - THE STRING CONTAINING THE LIST
C*
C*     OUTPUT ARGUMENTS :
C*          OUTFILE - NEXT NAME FROM THE LIST
C*                    (IF "INFILE" CHANGES, WE START OVER AT FIRST FILE)
C*
C*     SUBPROGRAM REFERENCES :
C*          LENGTH, LIB$FIND_FILE
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          ONLY TEN FILESPECS MAY BE INCLUDED IN A LIST
C*          EACH FILESPEC MUST BE 127 CHARACTERS OR LESS
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     CHANGE HISTORY :
C*          10-MAY-1988  -  INITIAL VERSION
C*
C***********************************************************************
C*
      CHARACTER *(*) INFILE, OUTFILE
      CHARACTER *127 WFILE, LIST(10)
      INCLUDE '($RMSDEF)'
      DATA WFILE/'????????'/
C
C --- NEW FILE NAME?
C
      IF (INFILE .NE. WFILE ) THEN
         LENFILE = LENGTH (INFILE)
         IF (LENFILE .EQ. 0) RETURN
         WFILE = INFILE
         NL    = 0
         IL    = 1
         ICON  = 0
C
C --- IF ITS A LIST, PARSE INPUT LINE INTO INDIVIDUAL FILE SPECS
C
         IF ((INDEX(INFILE,',') .NE. 0) .OR.
     $       (INFILE(1:1) .EQ. '(')) THEN
            IF (INFILE(1:1) .EQ. '(') THEN
               IPTR = 2
            ELSE
               IPTR = 1
            ENDIF
            NPTR = IPTR
10          IPTR = IPTR + 1
            IF (INFILE(IPTR:IPTR) .EQ. ',') THEN
               NL = NL + 1
               LIST(NL) = INFILE(NPTR:IPTR-1)
               NPTR = IPTR + 1
               IPTR = NPTR
            ELSE IF (INFILE(IPTR:IPTR) .EQ. ')') THEN
               NL = NL + 1
               LIST(NL) = INFILE(NPTR:IPTR-1)
               IPTR = LENFILE + 1
               NPTR = IPTR
            ENDIF
            IF (IPTR .LE. LENFILE) GO TO 10
C
C --- MISSING RIGHT PARENTHESIS?
C
            IF (IPTR .GT. NPTR) THEN
               NL = NL + 1
               LIST(NL) = INFILE(NPTR:IPTR)
            ENDIF
C
C --- OTHERWISE, A SINGLE FILESPEC
C
         ELSE
            NL = 1
            LIST(NL) = INFILE
         ENDIF
      ENDIF
C
C --- GET NEXT NAME FOR THE CURRENT FILESPEC
C
20    ISTAT = LIB$FIND_FILE (LIST(IL), OUTFILE, ICON,,,,)
      IF ((ISTAT .EQ. RMS$_NMF) .OR. (ISTAT .EQ. RMS$_FNF)) THEN
C
C --- ALL DONE FOR THIS FILESPEC, SEE IF THERE IS ANOTHER
C
         ISTAT = LIB$FIND_FILE_END (ICON)
         ICON = 0
         IF (IL .GE. NL) THEN
            OUTFILE = ' '
         ELSE
            IL = IL + 1
            GO TO 20
         ENDIF
      ENDIF
C
      RETURN
      END
C
C---END GETFILE
C
      SUBROUTINE GETFOR ( NQ, QUALS, NP, PARAMS )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          GETFOR           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          GET FOREIGN
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 219-3
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF  94035
C*          (415) 604-5558
C*
C*     PURPOSE :
C*          TO RETURN ANY PARAMETERS AND/OR QUALIFIERS ENTERED ON A
C*          FOREIGN COMMAND LINE.
C*
C*     METHODOLOGY :
C*          USE VMS GET_FOREIGN ROUTINE THEN PARSE USING ' ' AND '/'
C*          AS VALID DELIMITERS.
C*
C*     OUTPUT ARGUMENTS :
C*          NQ     - NUMBER OF QUALIFIERS FOUND
C*          QUALS  - THE LIST OF QUALIFIERS(LESS SLASH)
C*          NP     - NUMBER OF PARAMETERS FOUND
C*          PARAMS - THE LIST OF PARAMETERS
C*
C*     SUBPROGRAM REFERENCES :
C*          LIB$GET_FOREIGN
C*
C*     TRANSPORTABILITY LIMITATIONS :
C*          UNLIKELY TO BE TRANSPORTABLE TO ANY SYSTEM BUT VMS.
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          ANYTHING ENCLOSED IN QUOTES IS A PARAMETER
C*          SLASHES AND BLANKS ARE DELIMITERS UNLESS ENCLOSED IN QUOTES
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     CHANGE HISTORY :
C*          22-MAR-91    Parameters enclosed in double quotes added
C*          18-NOV-86    COMMAND LINE INCREASED TO 255 FROM 80
C*          24-JAN-85    INITIAL VERSION
C*
C***********************************************************************
C*
      INCLUDE '($SSDEF)'
      CHARACTER *255 COMMAN
      CHARACTER *(*) QUALS(1),PARAMS(1)
      LOGICAL QUOTED
C
      IP    = 0
      NQ    = 0
      NP    = 0
      LS    = LEN(QUALS(1))
      LP    = LEN(PARAMS(1))
C
C --- RETURN COMMAND LINE (LESS FOREIGN COMMAND)
C
      IF (LIB$GET_FOREIGN(COMMAN,,IP) .NE. SS$_NORMAL) RETURN
      IF (IP .LE. 0) RETURN
      I = 1             ! NEXT LOCATION IN INPUT LINE
C
C --- LOOP WHILE LINE STILL HAS CHARACTERS IN IT
C --- SKIP LEADING SPACES
C
90    IF (COMMAN(I:I) .EQ. ' ') THEN
         I = I + 1
         IF (I .GT. IP) GO TO 300
         GO TO 90
      ENDIF
C
C --- OK, NONBLANK CHARACTER.  IS IT A QUALIFIER OR PARAMETER?
C
100   IF ( COMMAN(I:I) .EQ. '/' ) THEN
C
C --- A QUALIFIER... DO NOT INCLUDE SLASH
C
         I = I + 1
         IF (I .GT. IP) GO TO 300
         IF (COMMAN(I:I) .EQ. ' ') GO TO 90
         NQ = NQ + 1
         NC = 1
         QUALS(NQ) = ' '
C
C ----  ADD CHARACTERS UNTIL A SPACE OR SLASH FOUND, OR END OF LINE
C
110      IF (COMMAN(I:I) .EQ. '/') GO TO 100
         IF (COMMAN(I:I) .EQ. ' ') GO TO 90
         IF (NC .LE. LS ) QUALS(NQ)(NC:NC) = COMMAN(I:I)
         I = I + 1
         IF (I .GT. IP) GO TO 300
         NC = NC + 1
         GO TO 110
      ELSE
C
C --- PARAMETER... FIRST CHARACTER IS ALREADY NON-BLANK
C
         NP = NP + 1
         NC = 1
         PARAMS(NP) = ' '
         QUOTED = COMMAN(I:I) .EQ. '"'
         IF (QUOTED) THEN
            I = I + 1
            IF (I .GT. IP) GO TO 300
         ENDIF
C
C --- ADD CHARACTERS UNTIL A BLANK OR SLASH IS FOUND (IF UNQUOTED)
C --- ADD CHARACTERS UNTIL A QUOTE IS FOUND (IF QUOTED)
C
210      IF (QUOTED) THEN
            IF (COMMAN(I:I) .EQ. '"') THEN
               I = I + 1
               IF (I .GT. IP) GO TO 300
               GO TO 90
            ENDIF
         ELSE
            IF ((COMMAN(I:I) .EQ. ' ') .OR. (COMMAN(I:I) .EQ. '/'))
     $            GO TO 90 
         ENDIF
C
         IF (NC .LE. LP) PARAMS(NP)(NC:NC) = COMMAN(I:I)
         NC = NC + 1
         I = I + 1
         IF (I .GT. IP) GO TO 300
         GO TO 210
      ENDIF
      GO TO 100
C
C --- END OF LOOP WHILE LINE STILL HAS CHARACTERS
C
300   RETURN
      END
C
C---END GETFOR
C
      SUBROUTINE ISORTI ( ARRAY, NUM, INDX )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **           ISORT           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 219-3
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CALIF 94035
C*          (415) 604-5558
C*
C*     PURPOSE :
C*          PRODUCE A SORTED INDEX POINTER ARRAY
C*          THE INPUT ARRAY IS SORTED AS WELL AS THE ARRAY
C*          'INDX'. THEREFORE, INDX CAN BE USED TO PRINT
C*          ANY NUMBER OF RELATED ARRAYS.
C*
C*
C*     METHODOLOGY :
C*          SHELLSORT
C*
C*     INPUT ARGUMENTS :
C*          NUM    - NUMBER OF ELEMENTS IN ARRAY
C*          ARRAY  - ARRAY TO BE SORTED
C*
C*     OUTPUT ARGUMENTS :
C*          INDX   - INDEX ARRAY
C*
C*     INTERNAL WORK AREAS :
C*          TEMPA - USED DURING SWAPS
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          THE TYPE OF THE ARRAY 'ARRAY' AND THE VARIABLE 'TEMPA'
C*          MUST BE SET FOR EACH TYPE OF SORT.  FOR THIS PARTICULAR
C*          IMPLEMENTATION, THE ARRAY IS CHARACTER WITH LENGTH <= 255.
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     CHANGE HISTORY :
C*          03/12/84     INITIAL VERSION
C*
C***********************************************************************
C*
      DIMENSION INDX(1)
      INTEGER ARRAY(1)
      INTEGER TEMPI, tempa
      LOGICAL DONE
C
      DO 10 I = 1, NUM
         INDX(I) = I
10       CONTINUE
      IF (NUM .LE. 1) RETURN
      JUMP = NUM
20    JUMP = JUMP / 2
30    DONE = .TRUE.
      NJ = NUM-JUMP
      DO 40 J = 1, NJ
         I = J + JUMP
         IF (ARRAY(J) .GT. ARRAY(I))THEN
            DONE = .FALSE.
            TEMPA = ARRAY(J)
            ARRAY(J) = ARRAY(I)
            ARRAY(I) = TEMPA
            TEMPI = INDX(J)
            INDX(J) = INDX(I)
            INDX(I) = TEMPI
         ENDIF
40       CONTINUE
      IF (.NOT. DONE) GO TO 30
      IF (JUMP .GT. 1) GO TO 20
      RETURN
      END
C
C---END ISORTI
C


