Article 4374 of vmsnet.misc:
Path: nntpd.lkg.dec.com!pa.dec.com!news2.digital.com!news1.digital.com!ames!merlin.arc.nasa.gov!RAGOSTA
From: ragosta@merlin.arc.nasa.gov
Newsgroups: vmsnet.misc
Subject: Sorted Directory 3 of 3
Date: 18 Sep 1995 20:32:48 GMT
Organization: Aeroflightdynamics Directorate
Lines: 491
Message-ID: <43kl1g$1mj@news.arc.nasa.gov>
Reply-To: ragosta@merlin.arc.nasa.gov
NNTP-Posting-Host: merlin.arc.nasa.gov

c
c   Part 3 of 3
c
c   This file contains subprograms from the Merlib library.  If you have
c    already installed MERLIB, you don't need this file.
c
      SUBROUTINE ISORTI8 ( 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(num)
      INTEGER *8 ARRAY(num)
      INTEGER *8 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 ISORTI8
C
cc        .title  length
cc;
cc;   Author:  Arthur E. Ragosta
cc;
cc;   Return the true length of a string; i.e., the location of the last
cc;   non-blank character.  Since FORTRAN's strings are non-dynamic, the
cc;   function skips ONLY spaces (not NULs, control characters, etc.).
cc;
cc;      LS = LENGTH( 'A STRING     ' )   ! Note, LS is 8
cc;
cc        .entry  length,^m<>
cc
cc        movl    4(ap),r1        ;location of descriptor to r1
cc        movzwl  (r1),r0         ;length to r0
cc        subl3   #1,4(r1),r1     ;location to r1
ccLOOP:   cmpb    (r1)[r0],#32    ;space ?
cc;
cc        bneq    done
cc;
cc;	beql	next		;replace previous line with these
cc;	cmpb    (r1)[r0],#09    ;to skip tabs too
cc;       bneq    done
cc;NEXT:
cc;
cc        sobgtr  r0,loop         ;check for zero length string
ccDONE:   ret
cc        .end
cc;
cc;  Portable FORTRAN version
cc;
      FUNCTION LENGTH ( STRING )
c*                   *******************************
C*                  *******************************
C*                  **                           **
C*                  **          LENGTH           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          LENGTH
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 219-3
C*          AMES RESEARCH CENTER
C*          MOFFETT FIELD, CA  94035
C*          (415) 604-5558
C*
C*     PURPOSE :
C*          RETURNS THE LENGTH OF A STRING WHERE LENGTH IS DEFINED
C*          TO BE THE LOCATION OF THE LAST NON-BLANK CHARACTER
C*          IN THE STRING.  RETURNS 0 FOR AN EMPTY STRING.
C*          NOTE: THIS ROUTINE IS REPLACED BY A MACRO ROUTINE IN MERLIB.
C*
C*     INPUT ARGUMENTS :
C*          STRING - THE STRING TO BE CHECKED
C*
C*     OUTPUT ARGUMENTS :
C*          LENGTH - THE LENGTH OF THE STRING
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0     15-OCT-84
C*
C*     CHANGE HISTORY :
C*          15-OCT-84    INITIAL VERSION
C*
C***********************************************************************
C*
      CHARACTER *(*) STRING
C
      LENGTH = LEN(STRING)
10    IF (STRING(LENGTH:LENGTH) .EQ. ' ') THEN
         LENGTH = LENGTH-1
         IF ( LENGTH .GT. 0 )GO TO 10
      ENDIF
      RETURN
      END
C
C---END LENGTH
C
      INTEGER FUNCTION PARSE (SPEC, DEFAULT, PART, OUT)
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **           PARSE           **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          PARSE
C*
C*     AUTHOR :
C*          Arthur E. Ragosta
C*          MS 219-1
C*          NASA Ames Research Center
C*          Moffett Field, Ca.  94035-1000
C*          (415) 604-5558
C*
C*     PURPOSE :
C*          PARSE A FILE SPECIFICATION (OR PART OF ONE)
C*          EMULATES THE LEXICAL FUNCTION F$PARSE
C*
C*     INPUT ARGUMENTS :
C*          SPEC    - INPUT (PARTIAL) FILE SPEC
C*          DEFAULT - DEFAULT SPEC FOR MISSING PARTS (IF BLANK, USE
C*                      CURRENT NODE, ETC.)
C*          PART    - THE PART WANTED:
C*                      'NODE',   'DEVICE',  'DIRECTORY', 'NAME',
C*                      'TYPE',   'VERSION', 'FULL',      'LONGNAME'
C*
C*     OUTPUT ARGUMENTS :
C*          OUT     - THE PART REQUESTED
C*
C*     SUBPROGRAM REFERENCES :
C*          TRANSL8,  SYS$PARSE,  EXIT,  LIB$MOVC5
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NOT TRANSPORTABLE.
C*          ASSUMES CURRENT DIRECTORY AND FILE TYPE '.DAT' IF NONE GIVEN
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0  -  20-JUN-1988
C*
C*     CHANGE HISTORY :
C*          20-JUN-1988  -  INITIAL VERSION
C*          29-JUN-1990  -  BUG FIXED WHILE REUSING "OUT" AS WORK BUFFER
C*           8-FEB-1991  -  CHANGED TO INTEGER FUNCTION TO RETURN ISTAT
C*          15-AUG-1995  -  Internal work area increased to 255
C*
C***********************************************************************
C*
      INCLUDE '($FABDEF)'
      INCLUDE '($NAMDEF)'
      RECORD /FABDEF/ FAB
      RECORD /NAMDEF/ NAM
      CHARACTER *255 WORK
      CHARACTER *(*) SPEC, DEFAULT, PART, OUT
      INTEGER SYS$PARSE
      INTEGER *2 II
C
      parse = 0
      CALL CAPS(PART)
      IF (PART(1:2) .EQ. 'NO') THEN                 ! NODE
         I = INDEX(SPEC,'::')
         IF (I .NE. 0) THEN
            OUT = SPEC(1:I+1)
         ELSE
            I = INDEX(DEFAULT,'::')
            IF (I .NE. 0) THEN
               OUT = DEFAULT(1:I+1)
            ELSE
               CALL TRANSL8('SYS$NODE',OUT)
            ENDIF
         ENDIF
      ELSE
         NAM.NAM$L_ESA = %LOC ( WORK )
         NAM.NAM$B_ESS = LEN ( WORK )
         NAM.NAM$B_NOP = NAM$V_SYNCHK
         NAM.NAM$B_BID = NAM$C_BID
         NAM.NAM$B_BLN = NAM$C_BLN
C
         FAB.FAB$L_DNA = %LOC ( DEFAULT )
         FAB.FAB$B_DNS = LENGTH ( DEFAULT )
         FAB.FAB$L_FNA = %LOC ( SPEC )
         FAB.FAB$B_FNS = LENGTH ( SPEC )
         FAB.FAB$L_NAM = %LOC ( NAM )
         FAB.FAB$B_BID = FAB$C_BID
         FAB.FAB$B_BLN = FAB$C_BLN
C
         ISTAT = SYS$PARSE ( FAB )
         IF (.NOT. ISTAT) go to 1000
         WORK (NAM.NAM$B_ESL+1:) = ' '
C
         IF (PART(1:2) .EQ. 'DE') THEN                 ! DEVICE
            II = NAM.NAM$B_DEV
            II = MIN0(II,LEN(OUT))
            I  = NAM.NAM$L_DEV
         ELSE IF (PART(1:2) .EQ. 'DI') THEN            ! DIRECTORY
            II = NAM.NAM$B_DIR
            II = MIN0(II,LEN(OUT))
            I  = NAM.NAM$L_DIR
         ELSE IF (PART(1:2) .EQ. 'NA') THEN            ! NAME
            II = NAM.NAM$B_NAME
            II = MIN0(II,LEN(OUT))
            I  = NAM.NAM$L_NAME
         ELSE IF (PART(1:1) .EQ. 'T') THEN             ! TYPE
            II = NAM.NAM$B_TYPE
            II = MIN0(II,LEN(OUT))
            I  = NAM.NAM$L_TYPE
         ELSE IF (PART(1:1) .EQ. 'V') THEN             ! VERSION
            II = NAM.NAM$B_VER
            II = MIN0(II,LEN(OUT))
            I  = NAM.NAM$L_VER
         ELSE IF (PART(1:1) .EQ. 'L') THEN             ! LONG NAME
            J = NAM.NAM$B_DEV + NAM.NAM$B_DIR
            II = MIN0(LEN(OUT),(LEN(WORK)-J))
            I  = %LOC(WORK) + J
         ELSE IF ((PART(1:1) .EQ. 'F') .OR.
     $            (PART(1:1) .EQ. ' ')) THEN           ! FULL 
            II = MIN0(LEN(OUT),LEN(WORK))
            I  = %LOC(WORK)
         ELSE
            RETURN
         ENDIF
         CALL LIB$MOVC5 ( II, %VAL(I), 32, LEN(OUT), %REF(OUT))
      ENDIF
      RETURN
1000  parse= istat
      out = ' '
      return
      END
C
C---END PARSE
C
c        .title caps
c;
c;   Author:  Arthur E. Ragosta
c;
c;   Make all lowercase characters capitals.
c;
c;       STRING = 'This Is A String.'
c;       CALL CAPS ( STRING )
c;
c;   Results in STRING = 'THIS IS A STRING.'
c;
c        .entry  caps,^m<>
c
c        movl    4(ap),r1                ;loc of descriptor to r1
c        movzwl  (r1),r0                 ;length to r0
c        subl3   #1,4(r1),r1             ;location to r1
c
cloop:   cmpb    (r1)[r0],#96
c        bleq    next                    ;Less than "a"?
c        cmpb    (r1)[r0],#122
c        bgtr    next                    ;Greater than "z"?
c        subb2   #32,(r1)[r0]            ;Its LC... CAP it!
cnext:   sobgtr  r0,loop                 ;check for end of string
c
c        ret
c        .end
c;
c;  Portable FORTRAN version
c;
      SUBROUTINE CAPS ( STRING )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          CAPS             **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          CAPITALIZE
C*
C*     AUTHOR :
C*          ART RAGOSTA
C*          MS 219-3
C*          NASA AMES RESEARCH CENTER
C*          MOFFETT FIELD, CA  94035
C*          (415) 604-5558
C*
C*     PURPOSE :
C*          TO REPLACE A STRING WITH THE SAME STRING BUT ONLY CAPITAL
C*          LETTERS.
C*
C*     INPUT ARGUMENTS :
C*          STRING - THE STRING TO BE CAPITALIZED
C*
C*     OUTPUT ARGUMENTS :
C*          STRING - THE CAPITALIZED STRING
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          THE COLLATING SEQUENCE MUST HAVE 'Z' > 'A' AND ALL CHARACTERS
C*          IN THE UPPER CASE ALPHABET AND LOWER CASE ALPHABET CONTIGUOUS
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     VERSION AND DATE :
C*          VERSION I.0      1-OCT-84
C*
C*     CHANGE HISTORY :
C*           1-OCT-84    INITIAL VERSION
C*
C***********************************************************************
C*
      CHARACTER *(*) STRING
C
      IC = ICHAR('A') - ICHAR('a')
      DO 10 I = 1, LEN(STRING)
         IF ((STRING(I:I) .GE. 'a') .AND. (STRING(I:I) .LE. 'z'))
     $      STRING(I:I) = CHAR( IC + ICHAR(STRING(I:I)) )
10       CONTINUE
      RETURN
      END
C
C---END CAPS
C
      SUBROUTINE TRANSL8 ( LOGIC, PHYSIC )
C*
C*                  *******************************
C*                  *******************************
C*                  **                           **
C*                  **          TRANSL8          **
C*                  **                           **
C*                  *******************************
C*                  *******************************
C*
C*     SUBPROGRAM :
C*          TRANSLATE LOGICAL
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*          TRANSLATE A LOGICAL NAME INTO A PHYSICAL NAME
C*
C*     INPUT ARGUMENTS :
C*          LOGIC - LOGICAL NAME
C*
C*     OUTPUT ARGUMENTS :
C*          PHYSIC - PHYSICAL NAME (TRANSLATION)
C*
C*     SUBPROGRAM REFERENCES :
C*          CAPS,  LENGTH,  SYS$TRNLNM
C*
C*     ASSUMPTIONS AND RESTRICTIONS :
C*          NOT TRANSPORTABLE
C*          RETURNS ONLY THE MOST USER SPECIFIC TRANSLATION
C*
C*     LANGUAGE AND COMPILER :
C*          ANSI FORTRAN 77
C*
C*     CHANGE HISTORY :
C*          20-JUN-1988  -  INITIAL VERSION
C*
C***********************************************************************
C*
      INCLUDE '($LNMDEF)'
      INCLUDE '($SSDEF)'
      CHARACTER *(*) LOGIC, PHYSIC
      CHARACTER *80 LOGC
      DIMENSION ITMLST(4)
      INTEGER*2 ITEM(2)
      EQUIVALENCE (ITEM(1),ITMLST(1))
      INTEGER SYS$TRNLNM
C
      LOGC = LOGIC
      CALL CAPS (LOGC)
      ITEM(1)   = LEN(PHYSIC)
      ITEM(2)   = LNM$_STRING
      ITMLST(2) = %LOC(PHYSIC)
      ITMLST(3) = %LOC(LP)
      ITMLST(4) = 0
C
C --- SEARCH USER-SPECIFIC (E.G., PROCESS, JOB) TABLES AT THE
C ---  HIGHEST PRIORITY, THEN GROUP AND SYSTEM
C
10    LL = LENGTH ( LOGC )
      IF (LOGC(LL:LL) .EQ. ':') LL = LL - 1
      ISTAT = SYS$TRNLNM ( , 'LNM$PROCESS', LOGC(1:LL),, ITMLST )
      IF (ISTAT .EQ. SS$_NOLOGNAM) THEN
         ISTAT = SYS$TRNLNM ( , 'LNM$JOB', LOGC(1:LL),, ITMLST )
         IF (ISTAT .EQ. SS$_NOLOGNAM) THEN
            ISTAT = SYS$TRNLNM ( , 'LNM$GROUP', LOGC(1:LL),, ITMLST )
            IF (ISTAT .EQ. SS$_NOLOGNAM) THEN
               ISTAT = SYS$TRNLNM ( , 'LNM$SYSTEM', LOGC(1:LL),,
     $                     ITMLST )
               IF (ISTAT .EQ. SS$_NOLOGNAM) THEN
                  PHYSIC = LOGC
                  RETURN
               ENDIF
            ENDIF
         ENDIF
      ENDIF
      PHYSIC (LP+1:) = ' '
C
C --- DO MULTIPLE TRANSLATIONS
C
      IF (ISTAT .EQ. SS$_NORMAL) THEN
         LOGC = PHYSIC
         GO TO 10
      ENDIF
      RETURN
      END
C
C---END TRANSL8
C


