% Librarian A09-16p~㥚U&Z[ EoL(` ACOLORADAM APPLICATION!ASCII)BCOLOR>CATEGHCENTERM CLEANSE_DATEWCLEAR[COMPRESSaCONTROLfCOPYpCTIMEtCTLYyCURSOR}DASCII DAY_OF_YEARDECHEXDECOCTDEFAULTDELETEDIR DISK_SPACEEDITEXISTS FID_TO_NAME FILE_BDATES FILE_DATESFIRSTFOPENMAC_ANY/ MAC_BLANKS6 MAC_CAPITAL8MAC_CAPS MAC_DELAY[ FILE_BDATES FILE_DATESFIRSTFOPENFPACKOUTG4ALFAG4GRAFGAUSSGETCGETCHARGETCPRVGETFDEV GETFDIRGETFILEGETFILEX#GETFNAME'GETFOR0GETFTYPE`GETFVERS7GETIME;GETLINGETOKESGETPRV[GETSTMj GETSTRINGnGETTERMw GETTERMSIZEsGETUSER{GETXYMAC_ANY/ MAC_BLANKS6 MAC_CAPITAL8MAC_CAPS MAC_DELAYW FID_TO_NAME GETSTRINGKURV2 MLIB_MISCRECALLYESNOMATCHnGETTERMw GETTERMSIZEsGETUSER GETUSRPRV{GETXY GET_DEFAULTGET_PASSGOTOXYGPALFA GRAF_XORYGRAF_XYGRAF_ZGRALFA HASH_PASSHAS_PRIVHELPHEXHEXDECIDIGIT IMAGE_NAMEINTRPL ISALPHAISDIGITISLETTERISORTBIS_PASSKEYHITKURV1KURV2 MAC_BLANKS6 MAC_CAPITAL8MAC_CAPS MAC_DELAY MAC_ICOUNTMAC_LEFTLAST_DAYMLEAPM2IMAC_ANY/ MAC_BLANKS6 MAC_CAPITAL8MAC_CAPS MAC_DELAY MAC_ICOUNTMAC_LEFT MAC_LENGTHMAC_LENXr MAC_LOWERrMAC_MLIB_RECALLMAC_PEEK MAC_PEEKLMAC_POKE MAC_POKEL MAC_RIGHT MAC_VERIFY MAIL,MAILBOXMATCHMBELLMENU#MENU2MMERGERMERGEIWMERGER\MESSAGEg MLIB_MISCORDINALPACKOUTPARSEdMODEy NAME_TO_PID~NDEXNUMERICOCTDECOPEROPERWORDINALPACKOUTPARSEPAY_DAYPCALFA PRINT_FILEPROMPTPUTCPUTCHARPUTSTM PUTSTRINGQSORTQSORTIQSORTRQUOTAREADINTREADKEYLREADQREADT RECALLRENAMEREPLACREVLFSCALE&SCOLOR-SCROLL2SEARCH;SEARCH1?SENDESENDWSETIMERENAMEREPLACREVLFSCALE&SCOLOR-SCROLLSEARCH;SEARCH1?SENDESENDWSETIMEMSLEEPQSORTUSORTIYSORTR]SRESETaSTATeSTATUSj STRIP_EXCpSTRPSTMtSUBMITzSUBMITPRTHISCENTTIMERTOUCHTRANSL8TRIMUNIQUE2UNITSUNTAB VT340ALFA, VT340GRAF VT_CURSORWEKDAY WILD_MATCHYESNO 9q*䥚) SUBROUTINE ACOLOR (CIN, COUT, IERR)C*3C* *******************************3C* *******************************3C* ** **3C* ** ACOLORS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* ARTA COLORSC*C*  AUTHOR :C* L JURGELEITC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*C* PURPOSE :EC* VERIFY AN ARTA STANDARD COLOR AND RETURN THE DISSPLA NAMEC* FOR IT.C*C* INPUT ARGUMENTS :4C* CIN - THE (ARTA) STANDARD NAME TO VERIFYC*C* OUTPUT ARGUMENTS :6C* COUT - THE EQUIVALENT DISSPLA NAME FOR CIN!C* IERR = 1 ==> NO ERROR!C* = 0 ==> NO MATCH)C* = 2 ==> AMBIGUOUS CHOICEC*C* SUBPROGRAM REFERENCES :C* SEARCHC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 9-FEB-1990C*C* CHANGE HISTORY :+C* 9-FEB-1990 - INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (NCOL = 41) CHARACTER *(*) CIN CHARACTER *8 COLRS(NCOL) %  CHARACTER *4 COUT, DCOLRS(NCOL) LOGICAL AMBIG, MATCH CC --- ARTA STANDARD COLORSCF DATA COLRS/ 'BCYAN ', 'BEIGE ', 'BLACK ', 'BLUE ',F $ 'BMAGENTA', 'BURGUNDY', 'CBLUE ', 'CGREEN ', 'CHARCOAL',F $ 'CHARTREU', 'CHESTNUT', 'CREAM ', 'CYAN ', 'EGGPLANT',H $ 'EVERGREE', 'GCYAN ', 'GOLD ', 'GRAY ', 'GREEN ', F $ 'GYELLOW ', 'KELLY ', 'KHAKI ', 'LAVENDER', 'MAGENTA ',F $ 'MBLUE ', 'MRED ', 'MU STARD ', 'OLIVE ', 'ORANGE ',F $ 'PINK ', 'PURPLE ', 'RED ', 'RMAGENTA', 'RYELLOW ',F $ 'SKY ', 'TAN ', 'TURQUOIS', 'WHITE ', 'YELLOW ', $ 'YGREEN ', 'YRED '/C%C --- DISSPLA NAMES FOR ABOVE COLORS C DATA DCOLRS/ D $ 'GHBL', 'BEIG', 'BLAC', 'BLUE', 'PUBL', 'BURG', 'GHBL',D $ 'BHGR', 'CHAR', 'GHYE', 'CHES', 'CREA', 'CYAN', 'PHBL',D $ 'EVER', 'BHGR', 'GOLD', 'GRAY', 'GREE', 'YEGR', 'KELL',D $ 'KHAK', 'LAVE', 'MAGE', 'PUBL', 'REPU', 'MUST', 'OLIV',D $ 'ORAN', 'PINK', 'MAGE', 'RED ', 'REPU', 'ORAN', 'SKY ',; $ 'TAN ', 'TURQ', 'WHIT', 'YELL', 'YEGR', 'ORAN'/C9 CALL SEARCH (COLRS, NCOL, CIN, INDEX, MATCH, AMBIG) IF (.NOT. MATCH) THEN IERR = 0 COUT = 'BLAC' ELSE IF (AMBIG) THEN IERR = 2 COUT = 'BLAC' ELSE IERR = 1" COUT = ( DCOLRS (INDEX) ) ENDIF RETURN ENDCC---END ACOLORCww +2祚C SUBROUTINE FOPEN ( NUNIT, FNAME, DEFNAME, PROMP, NEW, ERROR )OC*3C* *******************************3C* *******************************T3C* ** **3C* ** FOPEN ** 3C* ** **E3C* *******************************A3C* *******************************LC*C* SUBPROGRAM :AC* 5䥚' SUBROUTINE ADAM (INFILE, OUTFILE)C*3C* *******************************3C* *******************************3C* ** **3C* ** ADAM **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* ADAMC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :.C* ALLOW USER'S PROGRAMS TO CALL ADAMC*C* INPUT ARGUMENTS :$C* INFILE - INPUT FILE NAME1C* OUTFILE - OUTPUT FILE NAME (OR BLANK)C*C* SUBPROGRAM REFERENCES :C* TPU$TPU, LENGTHC*%C* ASSUMPTIONS AND RESTRICTIONS :C* LET'S GET SERIOUSDC*  YOU MUST LINK TO THE SHAREABLE TPU IMAGE WITH AN OPTIONSC* FILE:C*.C* SYS$SHARE:TPUSHR.EXE/SHAREABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 15-APR-1988C*C* CHANGE HISTORY :+C* 15-APR-1988 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *150 COMMAND$ CHARACTER *(*) INFILE, OUTFILEC" COMMAND = 'TPU/SECTION=ADAM' LC = 17c;c --- Check to see if the caller has an initialization filec? OPEN (UNIT=0, FILE='SYS$LOGIN:TPUINI.TPU', STATUS='OLD',  $ READONLY, ERR=100) CLOSE (UNIT=0)0 COMMAND(LC:) = '/COMMAND=SYS$LOGIN:TPUINI' LC = LC + 25c 100 IF (OUTFILE .NE. ' ') THEN+ COMMAND(LC:) = '/OUTPUT='//OUTFILE! LC = LENGTH(COMMAND) + 1 ENDIF COMMAND(LC:) = ' '//INFILE CALL TPU$TPU(COMMAND) RETURN ENDC C---END ADAMCww+Z?奚 .title ANY;; Author: Arthur E. Ragosta;G; Determine if any of the characters in string 1 are also in string 2;>; LOG = ANY( '0123456789','ABC ' ) ! Note, LOG is false; .entry any,^mF movl 4(ap),r1 ;location of descriptor1 to r15 movzwl (r1),r0 ;length to r0A subl3 #1,4(r1),r1 ;location of string to r1F movl 8(ap),r2 ;locat ion of descriptor2 to r25 movzwl (r2),r3 ;length to r37 movl r3,r4 ;copy for laterA subl3 #1,4(r2),r2 ;location of string to r2?LOOP: cmpb (r1)[r0],(r2)[r3] ;compare each character@ beql out ;this character in list?K sobgtr r3,loop ;NO - try next character in string2;$; this character not found, try next;>NEXT: movl r4,r3 ;reset string2 pointerH sobgtr r0,loop ;if more characters, do it again< clrl r0 ;none found, failure ret;3OUT: movl #1,r0 ;you betcha ret .end;; Portable FORTRAN version;*; logical function any (list, target)"; character *(*) list, target;c; any = .true.; do 10 i = 1,len(list) ; do 5 j = 1,len(target)3; if (target(j:j) .eq. list(i:i)) return;5 continue;10 continue; any = .false. ; return ; endww*^奚 SUBROUTINE APPLICATION C*3C* *******************************3C* *******************************3C* ** **3C* ** APPLICATION **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta .C* RAGO STA%MRL.span@AMES.ARC.NASA.GOV0C* RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION ::C* SET AN ANSI TERMINAL TO USE APPLICATION KEYPADC*C* SUBPROGRAM REFERENCES :C* LIB$PUT_OUTPUTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC* HC***********************************************************************C*- CALL LIB$PUT_OUTPUT ( CHAR(27) // '=' ) RETURN ENDCC---END APPLICATIONCww"5Cj奚! SUBROUTINE ASCII ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** ASCII **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* ASCIIC*C* AUTHOR :#C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :EC* TO REPLACE TEXT STRINGS OF THE TYPE CREATED BY SUBROUTINE6C* DASCII WITH ASCII CHARACTERS (SEE DASCII).5C* (E.G., BECOMES AN ESCAPE CHARACTER)C*C* INPUT ARGUMENTS :,C* STRING - STRING TO BE ASCIIFIED.C*C* OUTPUT ARGUMENTS :3C* STRING - ASCIIFIED STRING ( $IN PLACE ).C*C* INTERNAL WORK AREAS :BC* TABLE - ASCII MNEMONIC STRINGS FOR CONTROL CHARACTERS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.1 1-DEC-1987C*C* CHANGE HISTORY :9C* 9-MAY-1988 STRING UPDATE CHANGED TO INPLACEGC* 1-DEC-1987 STRING LENGTH PARAMETERIZED AND RAISED TO 1000(C* 30-JAN-85 INITIAL VERSIONC*HC*****************************************%******************************C* CHARACTER *(*) STRING% CHARACTER *3 TABLE(0:32), THREE@ DATA TABLE /'NUL', 'SOH', 'STX', 'ETX', 'EOT', 'ENQ',@ $ 'ACK', 'BEL', ' BS', ' HT', ' LF', ' VT', ' FF',@ $ ' CR', ' SO', ' SI', 'DLE', 'DC1', 'DC2', 'DC3',@ $ 'DC4', 'NAK', 'SYN', 'ETB', 'CAN', ' EM', 'SUB',9 $ 'ESC', ' FS', ' GS', ' RS', ' US', 'DEL' /C L = LEN ( STRING ) IW = 0 IS = 0CLC --- &DO WHILE NUMBER OF CHARACTERS IN WORK < NUMBER OF CHARACTERS IN STRINGC100 IS = IS + 1& IF (STRING(IS:IS) .EQ. '<') THEN IT = IS + 4= IF ((IT .LE. L) .AND. (STRING(IT:IT) .EQ. '>')) THENC4C ------ IT APPEARS TO BE AN ASCII REPRESENTATIONC IS = IS + 1# THREE = STRING(IS:IT-1)CAC ------ SEE IF THE TEXT STRING IS AN ASCII CHARACTER MNEMONICC DO 110 I = 0,32, IF (THREE .EQ. TABLE(I)) THEN ' IW = IW + 1% IF (I .EQ. 32) THEN. STRING(IW:IW) = CHAR(127) ELSE, STRING(IW:IW) = CHAR(I) ENDIF IS = IS + 3* IF (IS .LT. L) GO TO 100 GO TO 1000 ENDIF110 CONTINUEC(C ------ NOT IN TABLE, SEE IF NUMERICC DO 120 I = 1,3G IF((THREE(I:I) .LT. '0') .OR. (THREE(I:I) .GT. '9('))THEN IW = IW + 1% STRING(IW:IW) = '<' GO TO 200 ENDIF120 CONTINUECC ------ ALL DIGITSC! READ ( THREE, 900 ) I5 IF ((I .LE. 255) .AND. (I .GE. 128)) THENCC ------ OK, ITS NUMERICC IS = IS + 3 IW = IW + 1& STRING(IW:IW) = CHAR(I)' IF (IS .LT. L) GO TO 100 GO TO 1000 ENDIFC>C ----- NOT NUMERIC, MUST BE COINCIDENCE... SEND IT VERBATIMC IW = IW + 1 STRING(IW:IW) = '<' ENDIF ENDIF200 IW = IW + 1# STRING(IW:IW) = STRING(IS:IS) IF ( IS .LT. L ) GO TO 100CC --- END DO WHILEC1C --- OUTPUT STRING FULL OR INPUT STRING DEPLETEDC1000 STRING(IW+1:) = ' ' RETURN900 FORMAT (I3) ENDC C---END ASCIICww*4t奚! SUBROUTINE BCOLOR ( COLOR )C*3C* *******************************3C* *******************************3C* ** **3C* ** BCOLOR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* BCOLORC*C* AUTHOR :+C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :AC* SET THE BACKGROUND COLOR ON A TEKTRONIX 41XX TERMINAL4C* (ALSO WORKS ON TEK 4207 AND GRAPHON 407)1C* NOTE: TERMINAL MUST BE IN "RGB" MODE!C*C* INPUT ARGUMENTS :IC* COLOR - THE COLOR TO SET (SEE ARRAY "COLRS" BELOW FOR VALUES)C*C* SUBPROGRAM REFERENCES :$C* , CAPS, SEARCH, MLIB_GETC*%C* ASSUMPTIONS AND RESTRICTIONS :.C* "$" EDIT DESCRIPTOR IS NONSTANDARDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 9-AUG-1988C*C* CHANGE HISTORY :+C* 9-AUG-1988 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) COLOR PARAMETER (NCOLOR=28) CHARACTER *8 COLRS(N -COLOR) CHARACTER *6 CSTRG(NCOLOR) CHARACTER *1 ESC LOGICAL MAT,AM DATA ESC / 27 /F DATA COLRS / 'BCYAN ', 'BEIGE ', 'BLACK ', 'BLUE ',F $ 'BMAGENTA ', 'CBLUE ', 'CGREEN ', 'CHARCOAL', 'CREAM ',F $ 'CYAN ', 'GCYAN ', 'GRAY ', 'GREEN ', 'GYELLOW ',F $ 'KHAKI ', 'MAGENTA ', 'MBLUE ', 'MRED ', 'ORANGE ',F $ 'PURPLE ', 'RED ', 'RMAGENTA', 'RYELLOW ', 'TAN ',9 $ 'WHITE ', 'YELLOW ', ' .YGREEN ', 'YRED '/D DATA CSTRG / '0C9F4 ', 'E4D6B8', '000 ', '00F4 ',D $ 'C90F4 ', '0C9F4 ', '0F4C9 ', 'A=A=7 ', 'F4E7C?',K $ '0F4F4 ', '0F4C9 ', 'C1C1C1', '0F40 ', 'C9F40 ', K $ 'C9B=7 ', 'F40F4 ', 'C90F4 ', 'F40C9 ', 'F4C20 ', D $ 'F40F4 ', 'F400 ', 'F40C9 ', 'F4C20 ', 'B8B00 ',7 $ 'F4F4F4', 'F4F40 ', 'C9F40 ', 'F4C20 '/C CALL CAPS ( COLOR ): CALL SEARCH ( COLR S, NCOLOR, COLOR, INDEX, MAT, AM )( IF (AM .OR. (.NOT. MAT)) INDEX = 1$ CALL MLIB_GET('NWRITE',NWRITE)3 WRITE(NWRITE,900) ESC // 'TB' // CSTRG(INDEX)900 FORMAT(' ',A) RETURN ENDCC---END BCOLORCww0奚 .title blanks;; Author: Arthur E. Ragosta;A; Remove all embedded blanks from a string (left justifies) and*; returns the resulting string's length.;; INTEGER BLANKS$; STRING = 'This is a string.'; I = BLANKS ( STRING );(; Results in STRING = 'Thisisastring.'; and I = 14;; Also used as:; CALL BLANKS ( STRING );) .entry blanks,^m@ movl 4(ap),r2 1 ;loc of descriptor to r25 movzwl (r2),r3 ;length to r3D movl r3,r4 ;copy to r4 for later length7 movl 4(r2),r1 ;location to r18 clrl r2 ;input pointer=09 clrl r6 ;output pointer=0Bloop: cmpb (r1)[r2],#32 ;space in original string? beql next= movb (r1)[r2],(r1)[r6] ;move non-blank bytes@ incl 2 r6 ;output increased by one=next: incl r2 ;next input character@ sobgtr r3,loop ;check for end of string9 subl2 r6,r4 ;remaining length8 movc5 #0,(sp),#32,r4,(r1)[r6] ;pad with blanksB movl r6,r0 ;length of squeezed string ret .end ;#; Portable FORTRAN version follows;); INTEGER FUNCTION BLANKS ( STRING );C*4;C* 3 *******************************4;C* *******************************4;C* ** **4;C* ** BLANKS **4;C* ** **4;C* *******************************4;C* *******************************;C*;C* SUBPROGRAM :5;C* REMOVE BLANKS ;C*;C* AUTHOR :5;C* ART RAGOSTA 4 ;C* MS 219-35;C* AMES RESEARCH CENTER 5;C* MOFFETT FIELD, CA 94035 5;C* (415) 604-5558 ;C*;C* PURPOSE :I;C* REPLACE A STRING WITH THE SAME STRING LESS LEADING AND I;C* EMBEDDED BLANKS. ;C*;C* INPUT ARGUMENTS :@;C* STRING - STRING FROM WHICH BLANKS ARE TO BE REMOVED;C*;C* 5 OUTPUT ARGUMENTS :=;C* STRING - STRING WITHOUT EMBEDDED BLANKS(INPLACE);C*;C* RESTRICTIONS :D;C* THIS ROUTINE IS NOT USED ON VAX SYSTEMS, IT IS REPLACED.;C* BY A MACRO ROUTINE IN MERLIB.MAR.;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*I;C***********************************************************************;C*; CHARACTER *(*) STRING;C; L = LEN(STRING); BLANKS = 0; DO 10 J = 1, L(; IF (STRING(J:J) .NE. ' ') THEN ; BLANKS = BLANKS + 10; STRING(BLANKS:BLANKS) = STRING(J:J); ENDIF;10 CONTINUE;C>;C --- IF THE OUTPUT STRING IS LESS THAN FULL, PAD WITH BLANKS;C4; IF ( BLANKS .LT. L ) STRING(BLANKS+1:L) = ' ' ; RETURN ; END;C;C---END BLANKS;Cww7z奚 .title CAPITAL;; Author: Arthur E. Ragosta;9; Capitalize first character of a string (fast version);; STRING = 'abc.'; CALL CAPITAL ( STRING );; Results in STRING = 'Abc.'; .entry capital,^m<>@ movl 4(ap),r0 ;loc of descriptor to r07 movl 4(r0),r1 ;location to r1- cmpb (r1),#97 ; 'a'9 blss out ; nope... get out- cmpb (r1),#122 ; 'z'9 bgtr out ; nope... get out; subb2 #32,(r1) ; zero that cap bit out: ret .end ww9D̠奚 .title caps;; Author: Arthur E. Ragosta;+; Make all lowercase characters capitals.;$; STRING = 'This Is A String.'; CALL CAPS ( STRING );+; Results in STRING = 'THIS IS A STRING.'; .entry caps,^m<>@ movl 4(ap),r1 ;loc of descriptor to r15 movzwl (r1),r0 ;length to r07 subl3 #1,4(r1),r1 ;location to r1loop: cmpb (r1)[r0],#967 bl:eq next ;Less than "a"? cmpb (r1)[r0],#122: bgtr next ;Greater than "z"?: subb2 #32,(r1)[r0] ;Its LC... CAP it!@next: sobgtr r0,loop ;check for end of string ret .end;; Portable FORTRAN version;!; SUBROUTINE CAPS ( STRING );C*4;C* *******************************4;C* *******************************4;C* *;* **4;C* ** CAPS **4;C* ** **4;C* *******************************4;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* PURPOS<E :F;C* TO REPLACE A STRING WITH THE SAME STRING BUT ONLY CAPITAL;C* LETTERS.;C*;C* INPUT ARGUMENTS :2;C* STRING - THE STRING TO BE CAPITALIZED;C*;C* OUTPUT ARGUMENTS :,;C* STRING - THE CAPITALIZED STRING;C*&;C* ASSUMPTIONS AND RESTRICTIONS :J;C* THE COLLATING SEQUENCE MUST HAVE 'Z' > 'A' AND ALL CHARACTERSJ;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*I;C***********************************************************************;C*; CHARACTER *(*) STRING;C#; IC = ICHAR('A') - ICHAR('a'); DO 10 I = 1, LEN(STRING)B; 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;Cww ?g 奚- SUBROUTINE CATEG ( STRING, TYPE, FORM )C*3C* *******************************3C* *******************************3C* ** **3C* ** CATEG **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :%C* FIND THE TYPE OF A@ STRINGC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER%C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :JC* TO CATEGORIZE A STRING AS EITHER A LOGICAL, INTEGER, FLOATING,4C* E-FLOATING, D-FLOATING, OR ALPHANUMERIC.:C* ALTHOUGH QUITE ACCURATE, IT IS NOT FOOL-PROOF.C*C* INPUT ARGUMENTS :>C* STRING - THE STRING CONTAINING THE STRING TO CHECKC*C* OUTPUT AARGUMENTS :1C* TYPE - 'L', 'I', 'F', 'E', 'D', 'A'AC* FORM - A VALID FORTRAN FORMAT FIELD FOR THIS STRINGC*C* SUBPROGRAM REFERENCES : C* BLANKS, CAPS, LENGTHC*%C* TRANSPORTABILITY LIMITATIONS :9C* NON-STANDARD VARIABLE FIELD FORMAT STATEMENTSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 8-FEB-85C*C* CHANGE HISTORY :(C* 8-FEB-85 INITIBAL VERSIONC*HC***********************************************************************C*! CHARACTER *(*) STRING, FORM CHARACTER *1 TYPE, LET INTEGER BLANKSC L = BLANKS ( STRING ) IF (L .EQ. 0) THEN TYPE = 'B' RETURN ENDIF CALL CAPS ( STRING )C;C --- DEFAULT TYPE IS ALPHANUMERIC, DEFAULT FORMAT IS 'Ann'C TYPE = 'A'$ IFM = (LOG10(FLOAT(L)) + 1.1) WRITE ( FORM, 900 ) L IS = 1 MC C = 0CC --- CHECK FOR LOGICAL TYPEC& IF (STRING(IS:IS) .EQ. '.') THEN. IF ((STRING(IS:IS+2) .EQ. '.T.') .OR./ $ (STRING(IS:IS+2) .EQ. '.F.')) THEN IF (L .EQ. 3) THEN TYPE = 'L' FORM = 'L3' ENDIF RETURN ENDIF0 IF (STRING(IS:IS+5) .EQ. '.TRUE.') THEN IF (L .EQ. 6) THEN TYPE = 'L' FORM = 'L6' ENDIF RETURN D ENDIF1 IF (STRING(IS:IS+6) .EQ. '.FALSE.') THEN IF (L .EQ. 7) THEN TYPE = 'L' FORM = 'L7' ENDIF RETURN ENDIF ENDIFCC --- CHECK FOR NUMERICCA IF ((STRING(IS:IS) .EQ. '+') .OR. (STRING(IS:IS) .EQ. '-')) $ IS = IS + 1C,C --- SIGN AND DIGITS ONLY... ITS AN INTEGERC10 IF (IS .GT. L) THEN TYPE = 'I' IS = IS - 1 IFM = 1 IEF (IS .GT. 9) IFM = 2 WRITE (FORM, 910) IS RETURN ENDIFH IF ((STRING(IS:IS) .LT. '0') .OR. (STRING(IS:IS) .GT. '9'))GOTO 20 IS = IS + 1 GO TO 10CFC --- IN ORDER TO BE A NUMBER THE NEXT CHARACTER MUST BE '.', 'E', 'D'C&20 IF (STRING(IS:IS) .NE. '.') THEND IF ((STRING(IS:IS) .EQ. 'E') .OR. (STRING(IS:IS) .EQ. 'D')) $ GO TO 40 RETURN ENDIF IS = IS + 1C6C --- 'INTEGER' '.' 'INTEGER' ONLY... IT'SF FIXED POINTC30 IF (IS .GT. L) THEN TYPE = 'F' IS = IS - 1 IFM = 1 IF (IS .GT. 9) IFM = 2 IFM1 = 1 IF (MC .GT. 9) IFM1 = 2! WRITE (FORM, 920) IS, MC RETURN ENDIFH IF ((STRING(IS:IS) .LT. '0') .OR. (STRING(IS:IS) .GT. '9'))GOTO 40 MC = MC + 1 IS = IS + 1 GO TO 30C;C --- THE NEXT CHARACTER MUST BE AN EXPONENT TO BE FLOATINGC&40 IF (STRING(IS:IS) .EQ. 'E') THENG LET = 'E'* ELSE IF(STRING(IS:IS) .EQ. 'D') THEN LET = 'D' ELSE RETURN ENDIF IS = IS + 1A IF ((STRING(IS:IS) .EQ. '-') .OR. (STRING(IS:IS) .EQ. '+')) $ IS = IS + 1C4C --- IF THE REST IS AN EXPONENT, ITS FLOATING POINTC50 IF (IS .GT. L) THEN IS = IS - 1 IFM = 1 IF (IS .GT. 9) IFM = 2 IFM1 = 1 IF (MC .GT. 9) IFM1 = 2# WRITE (FORM,930) LET,IS,MC TYPE = LET RETURN ENDIFG IF ((STRING(IS:IS) .GE. '0') .AND. (STRING(IS:IS) .LE. '9')) THEN IS = IS + 1 GO TO 50 ENDIF RETURN900 FORMAT ( 'A',I )910 FORMAT ( 'I',I )'920 FORMAT ( 'F',I,'.',I )&930 FORMAT ( A1,I,'.',I ) ENDC C---END CATEGCwwIe奚" SUBROUTINE CENTER ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** CENTER **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* CENTERC*C* AUTHOR :JC* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :>C* TO REPLACE A STRING WITH THE SAME STRING, CENTERED(C* AROUND THE POINT (LENGTH/2).C*C* INPUT ARGUMENTS :!C* STRING - INPUT STRINGC*C* OUTPUT ARGUMENTS :,C* STRING - OUTPUT STRING (INPLACE)C*C* INTERNAL WORK AREAS :/C* LINE - TEMPORARY STORAGE FOR STRINGC*KC* SUBPROGRAM REFERENCES :C* LEFTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 15-OCT-84 INITIAL VERSIONAC* 26-JUN-90 REMOVED LENGTH LIMITATION, USED NEW LEFTC*HC***********************************************************************C* CHARACTER *(*) STRINGC3C --- 'LL' IS THE LENGTH OF THE TEXT TO BE CENTERED@C --- 'N' IS THE NUMBER OF BLANKS TO BE INSERTED BEFORE THE TEXTC LL = LEFT ( STRING )% N = ( LEN(STRING) - LL ) / 2 IF ( N .EQ. 0 ) RETURNC$C --- COPY TEXT INTO PROPER LOCATIONC STRING(N+1:) = STRINGCC --- CLEAR LEADING SPACESC STRING(1:N) = ' ' RETURN ENDCC---END CENTERCww%ͣ) GALVAS CLEANSE_DATEl٪) GALVAS LEAP!;Ų) GALVAS THISCENTå, GALVAS LEAP GALVAS LEAPN* Logical Function Leap_year ( iyear )C*3C* *******************************J3C* *******************************n3C* ** **H3C* ** Leap_year **A3C* ** **H3C* *******************************Y3C* *******************************DC*C* AUTHOR :LC* Arthur E. Ragosta M2C* O RAGOSTA@MERLIN.ARC.NASA.GOV (Internet) C* C* MS 219-1%C* NASA Ames Research Center,%C* Moffett Field, Ca. 94035NC* (415) 604-5558C*C* DESCRIPTION :/C* Is the specified year a leap year ?AC*@C* Years divisible by 4 are leap years, unless they are fullGC* century years (i.e., "00"). Full century years evenly divisible AC* by 400 are leap years (2000), others are not (1900, 2100).aC*C* INPUT ARGUMENTSP :IC* iyear - The year (note: 2 digits defaults to current century)eC*C* OUTPUT ARGUMENTS : 1C* leap_year - .true. if its a leap year C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77IC*C* CHANGE HISTORY :G+C* 4-NOV-1992 - INITIAL VERSIONTDC* 27-JUL-1998 - Modified to correctly use 4 digit years;AC* now uses rules described above - LEG C*HC*********************************************************Q**************C*c* if (iyear .lt. 100) thenc--c --- two digits passed - use current centuryac2 call thiscent (icent)0 iyear = icent + iyear endif(co( if ( mod(iyear, 100) .eq. 0 ) thenchEc --- full century year - only a leap year if evenly divisible by 400lch* if (mod (iyear, 400) .eq. 0) then leap_year = .true. elses leap_year = .false.m endif+ else if ( mod(iyear, 4) .eq. 0 ) then cpc --- "regular" leap yearec= leap_year = .true.( elsec.c --- all others NOTcl leap_year = .false. endif cl RETURN900 format(i4) ENDaC4C---END Leap_yearTC wwregular" leap year cE leap_year = .true.0 elsec c --- all others NOTc  leap_year = .false. endif c RETURN900 format(i4) ENDTCYC---END Leap_year C wwMAX0(1,I) WRITE(DAY,910SŲ)# subroutine THISCENT (INTCENT)EC*3C* ******************************* 3C* *******************************23C* ** ** 3C* ** THISCENT **03C* ** ** 3C* *******************************Y3C* *******************************EC*C* SUBPROGRAM :IC* THIS CENTURYC*C* AUTTHOR :2C* LAURA GALVASC* MS 219-1 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-6588&C* GALVAS@MERLIN.ARC.NASA.GOVC*C* PURPOSE :AC* RETURN THE CURRENT CENTURY AS AN INTEGER (E.G., 2000) C*C* OUTPUT ARGUMENTS :N"C* INTCENT - RETURN VALUEC*C* SUBPROGRAM REFERENCES :.C* LIB$DATE_TIME (VMS SYSTEM ROUTINE)C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* VERSION AND DATE :='C* VERSION I.0 - 30-JUL-1998EC*C* CHANGE HISTORY :(+C* 30-JUL-1998 - INITIAL VERSION C*HC***********************************************************************C*C: character *23 dtstrS character *4 centurycT call lib$date_time (dtstr)" century = dtstr(8:9) // '00'! read (century, 900) intcentNc return900 format (i4)' end ww YEAR = TEMP(8:9)( CALL MLIB_FIX_YVE,* Logical Function Leap_year ( iyear )C*3C* *******************************E3C* *******************************(3C* ** ** 3C* ** Leap_year ** 3C* ** **I3C* *******************************3C* *******************************_C*C* AUTHOR : C* Arthur E. Ragosta Y2C* G RAGOSTA@MERLIN.ARC.NASA.GOV (Internet) C* C* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 940350C* (415) 604-5558C*C* DESCRIPTION :/C* Is the specified year a leap year ? C*@C* Years divisible by 4 are leap years, unless they are fullMC* century years (i.e., "00"). Millenium years are an exception to this HC* rule. In other words, 1900 and 2100 are NOT leap years, 2000 IS.C*C* INPXͅ[奚 SUBROUTINE CLEARC*3C* *******************************3C* *******************************3C* ** **3C* ** CLEAR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* CLEAR SCREENC*C* AUTHOR :C* Y ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :IC* CLEAR A CRT SCREEN OR ADVANCE THE PAGE ON A HARDCOPY TERMINALC*C* METHODOLOGY :HC* USES VMS UTILITY. COMMENTED, TRANSPORTABLE(?) VERSION SENDSC* .C*C* FILE REFERENCES :;C* NWRITE - OUTPUT UNIT FOR TRANSPORTABLE VERSION.C*C* SUBPROGRAM REFERENCES :$C* LIZB$ERASE_PAGE, MLIB_SETC*%C* TRANSPORTABILITY LIMITATIONS :LC* THE PRESENT VERSION USES THE VAX-SPECIFIC ROUTINE,LIB$ERASE_PAGEKC* A MORE TRANSPORTABLE, BUT LESS INFALLIBLE, VERSION IS COMMENTEDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION :C* VERSION I.1C*C* CHANGE HISTORY :-C* 09-MAY-88 INSERT MLIB_GET CALL(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C*C CHARACTER *1 ESCC DATA ESC/27/! ISTAT = LIB$ERASE_PAGE(1,1)C$C CALL MLIB_GET("NWRITE",NWRITE)#C WRITE(NWRITE,900)ESC,CHAR(12)C900 FORMAT(2A1)C RETURN ENDC C---END CLEARCww\&w奚 SUBROUTINE COMPRESS (S)C*3C* *******************************3C* *******************************3C* ** **3C* ** COMPRESS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* COMPRESSC*C* AUTHOR :C*] Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :DC* TO COMPRESS A TEXT STRING, REPLACING MULTIPLE SPACES ANDBC* TABS WITH A SINGLE SPACE, EXCEPT WITHIN QUOTED STRINGSC*C* INPUT ARGUMENTS :(C* S - STRING TO BE COMPRESSEDC*C* OUTPUT ARGUMENTS :,C* S - (INPLACE) COMPRESSED STRINGC*C* LANGUAGE AND COMPILER :^C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 1-SEP-1988 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) S CHARACTER *1 C LOGICAL PREVIOUSC LS = LEFT (S) PREVIOUS = .FALSE. I = 0 IT = 0 T = ' 'C+C --- LOOP OVER NUMBER OF CHARACTERS IN 'S'C10 I = I + 1C C --- COPY TEXT STRINGS VERBATIMC9 IF ((S(I:I) .EQ. '''') .OR. (S(I_:I) .EQ. '"')) THEN PREVIOUS = .FALSE. C = S(I:I)20 IT = IT + 1 S(IT:IT) = S(I:I) I = I + 1 IF (I .LE. LS) THEN# IF (S(I:I) .EQ. C) THEN IT = IT + 1 S(IT:IT) = C ELSE GO TO 20 ENDIF ENDIFCC --- SPACE FOUND...CA ELSE IF ((S(I:I) .EQ. ' ') .OR. (S(I:I) .EQ. CHAR(9))) THENC9C ----- IF HAVEN'T ALREADY COPIED A SPACE, OK TO COPY ONEC! IF (.NOT. PREVIOUS) THEN IT = IT + 1 S(IT:IT) = ' ' ENDIF PREVIOUS = .TRUE.C)C --- NEITHER A SPACE OR A QUOTE, COPY ITC ELSE IT = IT + 1 S(IT:IT) = S(I:I) PREVIOUS = .FALSE. ENDIF IF (I .LT. LS) GO TO 10C$ IF (IT .LT. LS) S(IT+1:) = ' ' RETURN ENDCC---END COMPRESSCww48襚) SUBROUTINE GETFVERS (IUNIT, FVERS )TC*3C* *******************************3C* *******************************O3C* ** **A3C* ** GETFVERS **C3C* ** ** 3C* *******************************D3C* *******************************C*C* SUBPROGRAM :C* GET FILE VERSIONC*b Y奚/ SUBROUTINE CONTROL (CHARACTER, ROUTINE)C**C*KC* Sets up linkage for subroutine ROUTINE to get control when ASCII2C* character 'control-CHARACTER' is entered.C*KC* The argument CHARACTER must be a single alphabetic character, not@C* including 'C' OR 'Y'. It must be an UPPER-CASE letter.C*KC* The argument ROUTINE must be declared EXTERNAL in the calling pro-C* gram.C*C* For example:,C* c CALL CONTROL('B',X)C*@C* causes routine X to be called when a is typed.C*KC* CONTROL can be called multiple times, with different CHARACTER and9C* ROUTINE arguments, to set up different linkages.C*;C* Reference: VAX/VMS I/O User's Guide (Volume 1)KC* Terminal Driver Chapter (Chapter 9 in 6/83 edition)KC* Out-of-band AST Function Modifier (9.4.3.5 in 6/83)C*C*8C* Alan L. Zirkle Naval Surfacde Weapons Center%C* Code K1055C* 4 Feb 1983 Dahlgren, Virginia 22448C* IMPLICIT INTEGER (A-Z)* PARAMETER ( IO$_SETMODE = '23'X )+ PARAMETER ( IO$M_OUTBAND = '400'X )C CHARACTER*(*) CHARACTER CHARACTER*1 C INTEGER MASK(2) INTEGER*2 CHAN,IOSB(4) EXTERNAL ROUTINEC DATA MASK / 2*0 /C C = CHARACTER call caps(c)' IF (C.EQ.'C' .OR. C.EQ.'Y' . eOR.* $ C.LT.'A' .OR. C.GT.'Z') return0 MASK(2) = ISHFT(1,ICHAR(C)-ICHAR('A')+1)CM STATUS = SYS$ASSIGN('TT',CHAN,,) ! Must assign new channel forMC ! each call to CONTROL4 IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))CE STATUS = SYS$QIOW(,%VAL(CHAN),%VAL(IO$_SETMODE+IO$M_OUTBAND),E $ IOSB,,,ROUTINE,MASK,,,,)4 IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))6 IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1))) ENDwwg奚. SUBROUTINE COPY (Infile, Outfile, ISTAT)C++CC Author: Jonathan Welch#C MODIFIED: ART RAGOSTA JUNE 1988CC Functional Description:COC Copies one file to another. Currently works for sequential files only.CC Formal Arguments:CC Infile"C VMS Usage : char_string'C type : character string C access : read only$C mechanism : by descriptorC0C The name of the input file to be copiehd.CC Outfile"C VMS Usage : char_string'C type : character string C access : read only$C mechanism : by descriptorC.C The name of the output file to create.CC Completion Status:C8C SS$_NORMAL Function completed successfully.C>C Any RMS value returned by the following RMS functions:CC $CONNECTC $CREATE C $GET C $OPEN C $PUTCC-- INCLUDE '($FABDEF)'i INCLUDE '($RABDEF)' INCLUDE '($RMSDEF)' INCLUDE '($SSDEF)'CK BYTE Buffer(65535) ! Buffer to hold each record as it is read in7 BYTE Header(2) ! Holds 2 byte VFC header2 BYTE In(255) ! Name of input file3 BYTE Out(255) ! Name of output fileC1 CHARACTER*(*) Infile ! Passed parameters CHARACTER*(*) OutfileC INTEGER*2 IsiCA INTEGER SYS$CREATE, SYS$CONNECT, SYS$GET, SYS$OPEN, SYS$ jPUTC7 RECORD /Fabdef/ Fab_in ! Input File Access Block* RECORD /Fabdef/ Fab_out ! Output FAB9 RECORD /Rabdef/ Rab_in ! Input Record Access Block* RECORD /Rabdef/ Rab_out ! Output RABCE Fab_in.FAB$B_BLN = FAB$C_BLN ! Identify Fab as a valid FAB" Fab_in.FAB$B_BID = FAB$C_BID; Fab_in.FAB$L_FNA = %LOC(In) ! File Name Address8 Fab_in.FAB$B_FNS = LEN(Infile) ! File Name SizeCE Rab_in.RAB$B_BLN = RAB$C_BLN ! Identify Rab k as a valid RAB" Rab_in.RAB$B_BID = RAB$C_BID? Rab_in.RAB$L_FAB = %LOC(Fab_in) ! Location of input FAB@ Rab_in.RAB$L_RHB = %LOC(Header) ! Location of VFC headerI Rab_in.RAB$L_UBF = %LOC(Buffer(1))! Where to put an inputted record? Rab_in.RAB$W_USZ = 65535 ! max. size of a recordCK DO Loop = 1, LEN(Infile) ! Make character string descriptors, In(Loop) = ICHAR(Infile(Loop:Loop)); END DO ! into byt le arrays.C DO Loop = 1, LEN(Outfile). Out(Loop) = ICHAR(Outfile(Loop:Loop)) END DOC= ISTAT = SYS$OPEN(Fab_in) ! Open the input file< IF (.NOT. ISTAT) RETURN ! Return on an errorCP Fab_out = Fab_in ! Make the output fab equal to the inputD Fab_out.FAB$B_FAC = FAB$M_PUT ! fab with a few exceptions.B Fab_out.FAB$L_FNA = %LOC(Out) ! Output file name address7 Fab_out.FAB$B_FNS = LEN(Outfile) m! and its size.O Fab_out.FAB$W_IFI = 0 ! A different Internal File Identifier M ! will be created when output opened.C@ ISTAT = SYS$CREATE(Fab_out) ! Create the output fileF IF (.NOT. ISTAT) RETURN ! Return if there is an error.CP ISTAT = SYS$CONNECT(Rab_in) ! Connect the input Record Access Block.F IF (.NOT. ISTAT) RETURN ! Return if there is an error.CI Rab_out = Rab_in n ! Make the output RAB = input RABC Rab_out.RAB$L_FAB = %LOC(Fab_out) ! but don't mix up the FABsN Rab_out.RAB$W_ISI = 0 ! The Internal Stream Identifier will G ! be created with the connect.CL ISTAT = SYS$CONNECT(Rab_out) ! Connect the output RAB to its FAB.= IF (.NOT. ISTAT) RETURN ! Return on an error.CN Isi = Rab_out.RAB$W_Isi ! Make a local copy of the output ISI. oC6 ISTAT = SYS$GET(Rab_in) ! Get a recordJ DO WHILE (ISTAT) ! Loop while $GET returns success.O Rab_out = Rab_in ! Make the output RAB = the input RAB.E Rab_out.RAB$L_FAB = %LOC(Fab_out) ! but keep the FAB and theB Rab_out.RAB$W_ISI = Isi ! Isi from being mangled.CO ISTAT = SYS$PUT(Rab_out) ! Write the record to the output file.G IF (.NOT. ISTAT) RETURN ! Return if there is an error.CG ISTAT = SYS$GET(Rab_in) ! Get another record and loop. END DOCDC End Of File is expected, so convert that into a success, otherwise"C return the error code from $GET.C5 IF (ISTAT .OR. (ISTAT .EQ. RMS$_EOF)) ISTAT = 0C RETURN ENDC C---END COPYCwwq奚 SUBROUTINE CTIME ( ATIME )C*3C* *******************************3C* *******************************3C* ** **3C* ** CTIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* CLOCK TIMEC*C* AUTHOR :rC* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :9C* RETURN THE PRESENT WALL CLOCK TIME IN 12 HOUR*C* FORMAT WITH AM/PM DESIGNATION.C*C* METHODOLOGY :0C* USES THE DEC BUILTIN 'TIME' ROUTINE.C*C* OUTPUT ARGUMENTS :HC* ATIME - THE PRESENT CLOCK TIME IN "HH:MM AM/PM" (A8) FORMAT.C*C* SUBPROGRAM REFERENCES :C* sTIMEC*%C* TRANSPORTABILITY LIMITATIONS :6C* TIME IS A NON-STANDARD BUILTIN SUBROUTINE.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *8 ATIMEC CALL TIME ( ATIME )$ IF (ATIME(1:2) .GT. '12') THEN& IF (ATIME(1:1) .EQ. '1') THEN ATIME(1:1) = ' ' I = - 2+ ELSE IF (ATIME(2:2) .LE. '1') THEN ATIME(1:1) = ' ' I = 8 ELSE ATIME(1:1) = '1' I = -2 ENDIF/ ATIME(2:2) = CHAR(ICHAR(ATIME(2:2))+I) ATIME(6:8) = ' PM') ELSE IF (ATIME(1:2) .EQ. '12') THEN ATIME(6:8) = ' PM' ELSE ATIME(6:8) = ' AM' ENDIF RETURN ENDC C---END CTIMECwwu+L楚& SUBROUTINE STOP_Y (USER_ROUTINE)C*3C* *******************************3C* *******************************3C* ** **3C* ** STOP_Y **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STOP_YC*C* AUTHOR v:C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :BC* MAKE IT EASY FOR USER TO ESTABLISH A CONTROL/Y HANDLER?C* ROUTINE "MLIB_CTLY" IS QUEUED FOR A CTRL/Y AST WITH.C* THE USER'S ROUTINE AS A PARAMETER.C*C* INPUT ARGUMENTS :DC* USER_ROUTINE - THE ROUTINE TO BE CALLED WHEN A CONTROL/Y*C* IS INTERCwEPTED.C*C* SUBPROGRAM REFERENCES :#C* LIB$DISABLE, MLIB_ESTABC*%C* ASSUMPTIONS AND RESTRICTIONS :2C* DON'T EVEN THINK ABOUT TRANSPORTING ITC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 25-APR-1988 - INITIAL VERSIONC*HC***********************************************************************C* EXTERNAL USER_ROUTINECC --- SET UP CONTROL/Y HANDLINGC) CALL LIB$DISABLE_CTRL('021x00000'X,)& CALL MLIB_ESTAB ( USER_ROUTINE ) RETURN ENDCC---END STOP_YC$ SUBROUTINE MLIB_ESTAB ( USER )C*GC* ROUTINE CALLED BY "STOP_Y" AND "INTERNAL_Y" TO QUEUE THE CTRL/Y ASTC* INCLUDE '($IODEF)' EXTERNAL USER, MLIB_CTLYC, CALL SYS$ASSIGN ('SYS$INPUT', ICHAN,,)- ICODE = IO$_SETMODE .OR. IO$M_CTRLYASTB CALL SYS$QIO(,%VAL(ICHAN),%VAL(ICODE),,,,MLIB_CTLY,USER,,,,) RETURN ENDC# SUBROUTINE MLIB_CTLY ( USER )C*DC* THE ROUTINE ACTUALLY CALLED BY THE AST. CALLS THE USER ROUTINE.C* EXTERNAL USERCC --- REQUEUE THE ASTC CALL MLIB_ESTAB ( USER ) CALL USER RETURN ENDCC---END MLIB_CTLYC SUBROUTINE START_YC*&C* REENABLE NORMAL CONTROL/Y HANDLINGC*) CALL LIB$ENABLE_CTRL ('02100000'X,) RETURN ENDCC---END START_YCwwzrJG楚% SUBROUTINE CURSOR (IX, IY, CHR)C*3C* *******************************3C* *******************************3C* ** **3C* ** CURSOR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* CURSORC*C* AUTHOR {:C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE : >C* RETURN THE CURSOR LOCATION FOR A TEK 4014 EMULATORC*C* OUTPUT ARGUMENTS :(C* IX - X COORDINATE (0-1024)'C* IY - Y COORDINATE (0-780)+C* CHAR - CHARACTER TYPED (IF ANY)C*C* SUBPROGRAM REFERENCES :C* READTC*%C* ASSUMPTIONS AND RESTRIC|TIONS :@C* THE TERMINAL SHOULD BE IN GRAPHICS MODE WHEN CALLED.8C* IT IS LEFT IN GRAPHICS MODE UPON COMPLETION.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 27-MAY-1988 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *8 STRING CHARACTER *2 GIN CHARACTER *1 CHRC GIN = CHAR(27) // CHAR(26)% CALL MLIB_GET ('NWRITE',NWRITE)cc --- query the terminalc WRITE(NWRITE,900) GINcc --- wait for responsec% CALL READT(999,STRING,NUM,IRET)5 IF (NUM .EQ. 0) CALL READT(999,STRING,NUM,IRET)9 IF (NUM .GT. 4) STRING = STRING(2:5) // STRING(1:1)C IX = (ICHAR(STRING(2:2)) - 32) + 32*(ICHAR(STRING(1:1)) - 32)C IY = (ICHAR(STRING(4:4)) - 32) + 32*(ICHAR(STRING(3:3)) - 32) CHR = STRING(5:5) RETURN900 FORMAT(' ',A2,$) ENDCC---END CURSORCww~M楚" SUBROUTINE DASCII ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** DASCII **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* DEASCIIC*C* AUTHOR : C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :CC* REPLACE ALL NON-PRINTABLE CHARACTERS WITH A TEXT STRINGGC* DENOTING THE CHARACTER. FOR THE CHARACTERS FROM ASCII 0 TOEC* ASCII 31 AND ASCII 127, THE STRING IS THE THREE CHARACTERFC* MNEMONIC IN BRACKETS (EG, ). FOR THE CHARACTERS FROMFC* ASCII 128 TO ASCII 255, THE STRING IS A THREE DIGIT NUMBER$C* IN BRACKETS (EG, <164>).C*C* INPUT ARGUMENTS :;C* STRING - A CHARACTER STRING TO BE DE-ASCIIFIED.C*C* OUTPUT ARGUMENTS :8C* STRING - THE DE-ASCIIFIED STRING (IN PLACE).C*C* INTERNAL WORK AREAS :;C* WORK - TEMPORARY VARIABLE FOR BUILDING 'STRING'C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :*C* 1-DEC-87 MAX PARAMETERIZED(C* 30-JAN-8 5 INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (MAX=1000) CHARACTER *(MAX) WORK CHARACTER *(*) STRING% CHARACTER *3 TABLE(0:32), THREE@ DATA TABLE /'NUL', 'SOH', 'STX', 'ETX', 'EOT', 'ENQ',@ $ 'ACK', 'BEL', ' BS', ' HT', ' LF', ' VT', ' FF',@ $ ' CR', ' SO', ' SI', 'DLE', 'DC1', 'DC2', 'DC3',@ $ 'DC4', 'NAK', 'SYN', 'ETB', 'CAN', ' EM', 'SUB',9 $ 'ESC', ' FS', ' GS', ' RS', ' US', 'DEL' /C& L = MIN0(MAX, LEN ( STRING )) IW = 0 WORK = ' ' DO 100 I = 1, LCC --- TEST FOR PRINTABILITYC IW = IW + 1E IF ((STRING(I:I) .LT. ' ') .OR. (STRING(I:I) .GT. '~')) THEN& IC = ICHAR ( STRING(I:I) )) IF ( IW+4 .GT. L ) GO TO 1000C*C ------ SEE IF THERE IS AN ASCII MNEMONICC" IF ( IC .LE. 31 ) THEN THREE = TABLE(IC)( ELSE IF ( IC .EQ. 127 ) THEN THREE = TABLE(32) ELSEC,C ------ NO MNEMONIC, USE THREE DIGIT NUMBERC! WRITE(THREE,900)IC ENDIF/ WORK(IW:IW+4) = '<' // THREE // '>' IW = IW + 4 ELSE% IF (IW .GT. L) GO TO 1000% WORK(IW:IW) = STRING(I:I) ENDIF100 CONTINUE1000 STRING = WORK RETURN900 FORMAT(I3) ENDCC---END DASCIICww>T楚" INTEGER FUNCTION DAY_OF_YEARC*3C* *******************************3C* *******************************3C* ** **3C* ** DAY_OF_YEAR **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* RAGOSTA@MERLIN.ARC.NASA.GOV (Internet) C* C* MS 219-1%C* NASA Ames Research Center*C* Moffett Field, Ca. 94035-1000C* (415) 604-5558C*C* DESCRIPTION :-C* Return the day number of the yearC*C* SUBPROGRAM REFERENCES :%C* DATE, SYS$BINTIM, LIB$DAYC*%C* ASSUMPTIONS AND RESTRICTIONS :5C* IF THE CURRENT YEAR IS >= 50, ASSUME 19005C* ELSE, ASSUME 2000C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 26-JAN-1993 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *23 FIRST INTEGER IDATE(2)C6C --- ALL WE REALLY NEED FROM CURRENT DATE IS THE YEARC CALL DATE (FIRST) FIRST (10:11) = FIRST(8:9) FIRST (1:6) = '01-JAN'% READ(FIRST(10:11),'(I2)') IYEAR IF (IYEAR .LT. 50) THEN FIRST(8:9) = '20' ELSE FIRST(8:9) = '19' ENDIF$ FIRST (12:23) = ' 12:00:00.00'C4C --- FIRST NOW LOOKS LIKE '01-JAN-1999 12:00:00.00'C$ CALL SYS$BINTIM (FIRST, IDATE)F CALL LIB$DAY (JDAY, IDATE) ! JDAY IS DAY NUMBER FOR FIRST 8 ! DAY OF YEAR8 CALL LIB$DAY (IDAY) ! AND CURRENT DAY# DAY_OF_YEAR = IDAY - JDAY + 1 RETURN ENDCC---END DAY_OF_YEARCwwiY楚 SUBROUTINE DECHEX ( I, H )C*3C* *******************************3C* *******************************3C* ** **3C* ** DECHEX **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :"C* DECIMAL TO HEXADECIMALC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :@C* TO CONVERT A DECIMAL INTEGER TO A HEXADECIMAL STRING%C* REPRESENTING THAT NUMBER.C*C* INPUT ARGUMENTS :4C* I - THE INTEGER TO BE CONVERTED TO HEX.C*C* OUTPUT ARGUMENTS :>C* H - THE STRING CONTAINING THE HEX REPRESENTATION.C*%C* TRANSPORTABILITY LIMITATIONS :9C* USES THE NON-STANDARD FORMAT DESCRIPTOR, 'Z'.C*%C* ASSUMPTIONS AND RESTRICTIONS :<C* 'I' MUST BE FOUR BYTES AND 'H' EIGHT CHARACTERS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *8 HC WRITE(H,900)I RETURN900 FORMAT(Z8) ENDCC---END DECHEXCwwY^楚 SUBROUTINE DECOCT ( I, O )C*3C* *******************************3C* *******************************3C* ** **3C* ** DECOCT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* DECIMAL TO OCTALC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :@C* TO CONVERT A DECIMAL INTEGER TO A HEXADECIMAL STRING%C* REPRESENTING THAT NUMBER.C*C* INPUT ARGUMENTS :"C* I - THE DECIMAL NUMBERC*C* OUTPUT ARGUMENTS :(C* O - THE OCTAL REPRESENTATIONC*%C* TRANSPORTABILITY LIMITATIONS :9C* USES THE NON-STANDARD FORMAT DESCRIPTOR, 'O'.C*%C* ASSUMPTIONS AND RESTRICTIONS :CC* 'I' MUST BE 4 BYTES LONG AND 'O' MUST BE 16 CHARACTERS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *16 OC WRITE(O,900)I RETURN900 FORMAT(O16) ENDCC---END DECOCTCwwYc楚 SUBROUTINE DEFAULT (DIR_STRING)*D* Returns, in the character string DIR_STRING, the name of the cur-D* rent default device and directory. The string DIR_STRING must be>* long enough to contain the name, or this routine will abort.*1* Alan L. Zirkle Naval Surface Warfare Center* Code K53)* 9 Nov 1983 Dahlgren, Virginia 22448* IMPLICIT INTEGER (A-Z) CHARACTER*(*) DIR_STRINGC3 STATUS = SYS$TRNLOG('SYS$DISK',LEN1,DIR_STRING,,,)- IF (.NOT. STATUS) CALL LIB$STOP(%VAL(STATUS))C0 STATUS = SYS$SETDDIR(,LEN2,DIR_STRING(LEN1+1:))- IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))C LEN1 = LEN1 + LEN27 IF (LEN1.LT.LEN(DIR_STRING)) DIR_STRING(LEN1+1:) = ' 'C RETURN ENDww oNt楚 .TITLE DELAYH;----------------------------------------------------------------------;H; SUBROUTINE: DELAY ;H;----------------------------------------------------------------------;H; LANGUAGE: VAX-11 MACRO ASSEMBLY LANGUAGE ;H; SYSTEM: VAX-11/780 ;H; MOSTEK CORPORATION ;H;  COMPUTER AIDS TO DESIGN DIVISION ;H; 1215 WEST CROSBY ROAD ;H; CARROLLTON, TEXAS 75006 ;H; (214) 323-8813 ;H;----------------------------------------------------------------------;H; PROGRAMMER: KEVIN KLUGHART ;H;----------------------------------------------------------------------;H;  DATE: 05-21-81 @ 13:00 CDST ;H;----------------------------------------------------------------------;H; PURPOSE: THIS SUBROUTINE DELAYS THE EXECUTION OF A ;H; PROCESS A SPECIFIED AMOUNT OF TIME. THIS ;H; EXECUTION DELAY IS COMPUTED AS FOLLOWS: ;H; ;H;  ;H; 1. IF (TIME_DELAY <= 0) THEN THE PASSED ;H; PARAMETER REPRESENTS THE NUMBER OF 100- ;H; NANOSECOND UNITS TO ELAPSE BEFORE ;H; PROGRAM EXECUTION IS RESUMED. ;H; ;H; 2. IF (TIME_DELAY > 0) THEN THE PASSED ;H; PARAMETER REPRESENTS THE NUMBER OF ;H; MILLISECOND UNITS TO ELAPSE BEFORE ;H; PROGRAM EXECUTION IS RESUMED. ;H;----------------------------------------------------------------------;H; NOTES: THIS SUBROUTINE ASSUMES THAT THE SYSTEM CLOCK ;H; HAS UNIT INCREMENTS OF 100-NANOSECONDS, WHICH ;H; IS CONSISTENT WITH THE VAX-11/780 SYSTEM ;H; TIME QUADWORD FORMAT S TANDARD. ;H;----------------------------------------------------------------------;H; REFERENCES: VAX-11/780 SYSTEM SERVICES REFERENCE ;H;----------------------------------------------------------------------; .PAGE5 .SBTTL DATA: SYSTEM DELTA-TIME QUADWORDSH;----------------------------------------------------------------------;H; ;H; DATA AREA ;H; ;H;----------------------------------------------------------------------;H; DEFINE THE SYSTEM DELTA-TIME QUADWORD DATA AREAS ;H;----------------------------------------------------------------------; .PSECT DELAY$DATA,QUAD .ALIGN QUADKDELTIM: .QUAD 0 ; NORMAL PROCESS LEVEL DELTA-TIME QUADWORD ?DELAST: .QUAD 0 ; AST LEVEL DELTA-TIME QUADWORD .PAGE2 .SBTTL CODE: DELAY PROCESS EXECUTION H;----------------------------------------------------------------------;H; ;H; DELAY: DELAY PROCESS EXECUTION THE SPECIFIED TIME INTERVAL ;H; ;H;----------------------------------------------------------------------;H; THIS ENTRYPOINT IS INTENDED FOR EXECUTION IN NORMAL PROCESS ;H; MODE. THIS ENTRYPOINT IS NOT REENTRANT. ;H;----------------------------------------------------------------------; .PSECT DELAY$CODE9 .ENTRY DELAY,^MJ MOVL @4(AP),R0 ; GET FIRST PARAMETER (TIME_DELAY)H BGEQ MS_DLY ; IF >= 0, USE MILLISECOND DELAYG MOVL R0,DELTIM ; CONVERT TO SYSTEM TIME (QUAD)H MOVL #-1,DELTIM+4 ; INITIALIZE DELTA-TIME LONGWORDF JMP HIBNML ; DELAY SET: NOW EXECUTE WAITGMS_DLY: EMUL R0,#-10000,#0,DELTIM ; CONVERT DELAY TO MILLISECONDSJHIBNML: $SCHDWK_S ,,DELTIM, ; SCHEDULE PROCESS WAKE-UP (DELAY)@ $HIBER_S ; HIBERNATE UNTIL AWOKEN BRB EXIT .PAGE; .SBTTL CODE: AST LEVEL DELAY PROCESS EXECUTIONH;----------------------------------------------------------------------;H; ;H; DELAY_AST: DELAY AST EXECUTION THE SPECIFIED TIME INTERVAL ;H; ;H;----------------------------------------------------------------------;H; THIS ENTRYPOINT IS INTENDED FOR EXECUTION AT AST LEVEL. ;H; THIS ENTRYPOINT IS NOT REENTRANT. ;H;------------------------------- ---------------------------------------;= .ENTRY DELAY_AST,^MJ MOVL @4(AP),R0 ; GET FIRST PARAMETER (TIME_DELAY)H BGEQ MS_AST ; IF >= 0, USE MILLISECOND DELAYG MOVL R0,DELAST ; CONVERT TO SYSTEM TIME (QUAD)H MOVL #-1,DELAST+4 ; INITIALIZE DELTA-TIME LONGWORDF JMP HIBAST ; DELAY SET: NOW EXECUTE WAITGMS_AST: EMUL R0,#-100 00,#0,DELAST ; CONVERT DELAY TO MILLISECONDSJHIBAST: $SCHDWK_S ,,DELAST, ; SCHEDULE PROCESS WAKE-UP (DELAY)@ $HIBER_S ; HIBERNATE UNTIL AWOKENH;----------------------------------------------------------------------;H; END OF SUBROUTINE DELAY ;H;----------------------------------------------------------------------; EXIT: RET .ENDww楚( SUBROUTINE DELETE ( FNAME, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** DELETE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* DELETE FILEC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :BC* DELETE A FILE FROM THE DEFAULT OR SPECIFIED DIRECTORY.C*C* METHODOLOGY :>C* USES THE NON-TRANSPORTABLE LIB$DELETE_FILE ROUTINEC*C* INPUT ARGUMENTS :7C* FNAME - THE NAME OF THE FILE TO BE DELETED.C*C* OUTPUT ARGUMENTS :GC* ERROR - SET TRUE IF AN ERROR OCCURRED (EG, THE FILE DOESN'TC* EXIST).C*C* ERROR PROCESSING :9C* ERR= IS CHECKED ON OPEN AND CLOSE STATEMENTS.C*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :8C* 12-AUG-88 CHANGED OVER TO LIB$DELETE_FILE(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FNAME LOGICAL ERRORC: ERROR = LIB$DELETE_FILE ( FNAME, '*;',,,,,,,) .NE. 1 RETURN ENDCC---END DELETECwwu]楚& SUBROUTINE DIR ( STRING, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** DIR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* DIRECTORY DISPLAYC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :2C* DISPLAY THE DIRECTORY AT THE TERMINAL.C*C* METHODOLOGY :8C* SPAWNS A SUBTASK WITH THE DIRECTORY COMMAND.C*C* INPUT ARGUMENTS :JC* STRING - A COMMAND OR QUALIFIER STRING THAT IS APPENDED TO THE;C* DIRECTORY COMMAND (EG, "/DATE *.FOR").C*C* OUTPUT ARGUMENTS :IC* ERROR - SET TRUE IF AN ERROR OCCURS. PLEASE NOTE... THIS FLAGGC* SHOULD NEVER BECOME SET AS NORMAL ERRORS (SUCH AS AGC* MISSPELLED QUALIFIER) ARE CAUGHT BY DCL AND ARE NOT&C* RETURNED TO ISTAT.C*C* FILE REFERENCES :;C* SYS$OUTPUT - USED FOR DISPLAY OF THE DIRECTORY.C*C* SUBPROGRAM REFERENCES :C* LIB$SPAWNC*%C* TRANSPORTABILITY LIMITATIONS :@C* USES HIGHLY NON-TRANSPORTABLE OPERATING SYSTEM CALL.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING LOGICAL ERROR EXTERNAL SS$_NORMALCA ERROR = (LIB$SPAWN ( 'DIRECTORY '//STRING,,,,,,,,,,, ) .NE. $ %LOC(SS$_NORMAL)) RETURN ENDC C---END DIRCww >楚1 SUBROUTINE DISK_SPACE (DEVICE, TOTAL, FREE)*J* Determines the number of free blocks remaining on the disk unitG* whose logical name is DEVICE. The argument must be a characterJ* string containing the logical name of the pack; a trailing colon* is optional.*A* The routine will return 0 if an incorrect logical name is1* specified, or if the pack is not mounted.*7* Alan L. Zirkle Naval Surface Warfare Center#* Code K534* 16 Nov 1983 Dahlgren, Virginia 22448** mods: Art Ragosta* IMPLICIT INTEGER (A-Z) INCLUDE '($DVIDEF)' CHARACTER *(*) DEVICE CHARACTER *63 FILE_NAME INTEGER ITMLST(7) INTEGER *2 ITEMLST(12)( EQUIVALENCE (ITEMLST(1),ITMLST(1))C FILE_NAME = DEVICEC ITEMLST(1) = 4" ITEMLST(2) = DVI$_FREEBLOCKS ITMLST(2) = %LOC(FREE) ITMLST(3) = %LOC(LF)  ITEMLST(7) = 4 ITEMLST(8) = DVI$_MAXBLOCK ITMLST(5) = %LOC(TOTAL) ITMLST(6) = %LOC(LT) ITMLST(7) = 0CG STATUS = SYS$GETDVIW(,,FILE_NAME(1:LENGTH(FILE_NAME)),ITMLST,,,,) IF (.NOT.STATUS) THEN FREE = 0 TOTAL = 0 ENDIFC RETURN ENDww}楚( SUBROUTINE Edit (string, ixx, iyy)C*3C* *******************************3C* *******************************3C* ** **3C* ** Edit **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 'C*  RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :FC* EDIT A TEXT STRING ON THE SCREEN USING VMS EDIT CHARACTERSC*3C* The keys with special significance are:4C* ^A - Toggle Insert/Overstrike mode)C* ^C - Cancel all changes*C* ^E - Go to end of string4C* ^G - Delete character un der cursor,C* ^H(BS) - Go to start of string&C* ^I(Tab) - Go to next word$C* ^M(Ret) - Return string%C* ^R - Repaint string>C* ^U - Delete all characters to left of cursor%C* ^W - Repaint string$C* ^Z - Return string:C* Del - Delete character to left of cursor 4C* Remove - Delete character under cursor"C* Left Arrow - Move left$C* Right Arrow - Move rightC*C* INPUT ARGUMENTS :,C* STRING - INITIAL VALUE OF STRING0C* IX - STARTING COLUMN FOR STRING 6C* =0 TO USE CURRENT CURSOR LOCATION7C* IY - ROW (COUNTING FROM TOP) FOR STRINGC*C* OUTPUT ARGUMENTS :$C* STRING - MODIFIED STRINGC*C* SUBPROGRAM REFERENCES :BC* GETXY, GOTOXY, READKEY, CURSOR_RIGHT, CURSOR_LEFT,(C* SAVE_CURSOR, RESTORE_CURSORC*%C* ASSUMPTIONS AND RESTRICTIONS :'C*  USES ANSI CONTROL SEQUENCESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 28-FEB-1990 - INITIAL VERSIONGC* 16-Jul-1992 - changed insert/overstrike to match terminal6C* bug fixed when "^" entered(C* ^U bug fixedC*HC***********************************************************************C* include '($dvidef)' character *(*) string character *132 temp character *3 key character *1 k(3) logical insert equivalence (k(1),key)c5 istat = lib$getdvi (dvi$_tt_insert,,'TT:',io,,) insert = (io .eq. 1)% call mlib_get ('NWRITE',nwrite) if (ixx .eq. 0) then call getxy (ix, iy) else ix = ixx iy = iyy endifc%c --- make sure it will fit on screenc( call get_term_size (nwterm,nlterm). ls = MIN0(len(string),(nwterm-ix+1))  temp = string5 icol = 0cc Display initial stringc call gotoxy (ix, iy)$ write(nwrite,900) string(1:LS) call gotoxy (ix, iy)c/c Loop until user enters ^Z or to exitc10 call readkey ( key )CC --- CONTROL KEYSC: if ((k(1) .eq. '^') .and. (length(key) .gt. 1)) thencc ----- "A" Insert/Overstrikec if (k(2) .eq. 'A') then# insert = (.not. insert)c*c ----- "C" Cancel changes to this fieldc% else if (k(2) .eq. 'C') then string = temp go to 5cc ----- "E" End of this fieldc% else if (k(2) .eq. 'E') then( ic = min0(length(string),ls)" if (icol .lt. ic) then, call cursor_right (ic - icol)' else if (icol .gt. ic) then+ call cursor_left (icol - ic) endif icol = icc3c ----- "G" Delete right (same as Remove, below)c% else if (k(2) .eq. 'G') then" if (ls .ge. icol) then7 string(icol+1:) = string(icol+2:) // ' ' call save_cursor2 write(nwrite,900) string(icol+1:ls)" call restore_cursor endifc$c ----- "H" Begining of this fieldc% else if (k(2) .eq. 'H') then# call cursor_left (icol) icol = 0c,c ----- "I" Go to next word in text stringc% else if (k(2) .eq. 'I') then. itemp = index(string(icol+1:),' ')/ if (itemp .eq. 0) itemp = ls - icol% call cursor_right (itemp) icol = icol + itempcc ----- "M","Z" returnc< else if ((k(2) .eq. 'M') .or. (k(2) .eq. 'Z')) then& write(nwrite,900) char(13) returnc c ----- "R"/"W" Repaint screenc< else if ((k(2) .eq. 'R') .or. (k(2) .eq. 'W')) then call gotoxy (ix, iy)* write(nwrite,900) string(1:LS) call gotoxy (ix, iy)& call cursor_right ( icol )c*c ----- "U" Delete to beginning of fieldc% else if (k(2) .eq. 'U') then& string = string(icol+1:ls)# call cursor_left (icol)* write(nwrite,900) string(1:ls) call gotoxy (ix, iy) icol = 0 endifCC --- OTHER LABELED KEYSCc --- DELete leftc# else if (key .eq. 'DEL') then if (icol .gt. 0) then2 string(icol:) = string(icol+1:) // ' ' icol = icol - 1 call cursor_left(1) call save_cursor/ write(nwrite,900) string(icol+1:ls) call restore_cursor endifc1c --- Remove (delete right) ... same as ^G, abovec# else if (key .eq. 'REM') then if (ls .ge. icol) then4 string(icol+1:) = string(icol+2:) // ' ' call save_cursor/ write(nwrite,900) string(icol+1:ls)  call restore_cursor endifc$c --- LEFt arrow, move left in fieldc# else if (key .eq. 'LEF') then if (icol .gt. 0) then call cursor_left (1) icol = icol - 1 endifc&c --- RIGht arrow, move right in fieldc# else if (key .eq. 'RIG') then if (icol .lt. ls) then! call cursor_right (1) icol = icol + 1 endifcFc --- typing key - insert it (ignore other control keys, keypad, etc.)c' else if (length(key) .le. 1) thenc2c ------ if not trying to type beyond end of fieldc if (icol .lt. ls) then icol = icol + 1c6c ------------ insert the character in the TEMP stringc if (insert) then4 string(icol:) = k(1) // string(icol:) call save_cursor0 write(nwrite,900) string(icol:ls)" call restore_cursor# call cursor_right(1)c5c ------------ overstrike the character in the stringc else' string(icol:icol) = k(1)% write(nwrite,900) k(1) endifc+c ------ end of field, annoy user with bellc else% write(nwrite,900) char(7) endif endif go to 10900 format('+',A,$) endc c---end editcwwc饚" SUBROUTINE GOTOXY ( IX, IY )C*3C* *******************************3C* ******************************* 3C* ** **3C* ** GOTOXY ** 3C* ** **3C* ******************************* 3C* *******************************C*C* SUBPROGRAM : C* GO TO X,Y LOCATIONC*C* qEp楚' LOGICAL FUNCTION EXISTS ( FNAME )C*3C* *******************************3C* *******************************3C* ** **3C* ** EXISTS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* FILE EXISTANCEC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* TO DETERMINE IF A FILE EXISTS ON THE SPECIFIED OR DEFAULTC* DIRECTORY.C*C* METHODOLOGY :CC* OPENS THE FILE AS AN OLD FILE AND CHECKS TO SEE IF THISDC* CREATES AN ERROR. IF IT DOES, THE FILE PROBABLY DOESN'T C* EXIST. CLOSES FILE.C*C* INPUT ARGUMENTS :7C* FNAME - THE NAME OF THE FILE TO BE CHECKED.C*C* OUTPUT ARGUMENTS :JC* FUNCTION VALUE EXISTS - SET TRUE IF THE FILE WAS FOUND WITHOUT-C* ERROR, SET FALSE OTHERWISE.C*C* FILE REFERENCES :BC* 0 - DUMMY UNIT USED FOR THE OPEN AND CLOSE STATEMENTS.C*C* ERROR PROCESSING :7C* ERR= USED ON THE OPEN AND CLOSE STATEMENTS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C*  31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FNAMEC EXISTS = .FALSE.= OPEN (UNIT=0,STATUS='OLD',READONLY,FILE=FNAME,ERR=1000) CLOSE (UNIT=0) EXISTS = .TRUE.C 1000 RETURN ENDCC---END EXISTSCww)祚4 SUBROUTINE Fid_To_Name (Device, Fid, Filename)C*;C* Author: Jonathan Welch Creation Date: 27-Jul-1987 12:20C* MODIFIED BY : ART RAGOSTAC*C* FUNCTIONAL DESCRIPTION:DC* THE FILENAME ASSOCIATED WITH A FILE ID (FID) IS DETERMINED ANDC* RETURNED TO THE CALLER.C*C* FORMAL ARGUMENTS:6C* DEVICE : NAME OF THE DEVICE THE FILE RESIDES ON.9C* FID : THE FILE ID (FID) TO GENERATE A FILENAME FOR.?C* FILENAME : THE FILENAME ASSOCIATED WITH THE SUPPLIED FID.C* INCLUDE '($ATRDEF)' INCLUDE '($FIBDEF)' INCLUDE '($IODEF)'C CHARACTER*(*) DEVICE CHARACTER*(*) FILENAME CHARACTER *512 FILESPEC" INTEGER*2 FID(3), CHAN, FLEN INTEGER IOSB(2). INTEGER SYS$ASSIGN, SYS$DASSGN, SYS$QIOW! EQUIVALENCE (FLEN,FILESPEC)C STRUCTURE /DSC/ INTEGER*2 LENGTH BYTE NULL1, NULL2 INTEGER*4 ADDR END STRUCTUREC RECORD /ATRDEF/ ATR(2) RECORD /DSC/ DESCR RECORD /FIBDEF/ FIBC FIB.FIB$W_FID_NUM = FID(1) FIB.FIB$W_FID_SEQ = FID(2) FIB.FIB$W_FID_RVN = FID(3)C FILENAME = ' ' FILESPEC = ' ' FLEN = 0C( ISTAT = SYS$ASSIGN(DEVICE, CHAN,,) IF (.NOT. ISTAT) RETURNC) ATR(1).ATR$W_SIZE = ATR$S_FILE_SPEC) ATR(1).ATR$W_TYPE = ATR$C_FILE_SPEC( ATR(1).ATR$L_ADDR = %LOC(FILESPEC) ATR(2).ATR$W_SIZE = 0 ATR(2).ATR$W_TYPE = 0C" DESCR.LENGTH = FIB$C_ACCDATA DESCR.ADDR = %LOC(FIB)C> ISTAT = SYS$QIOW (,%VAL(CHAN), %VAL(IO$_ACCESS), IOSB,,,' $ DESCR,,,, ATR,) IF (.NOT. ISTAT) RETURNC# FILENAME = FILESPEC(3:FLEN+2)$ ISTAT = SYS$DASSGN(%VAL(CHAN))C RETURN ENDCC---END FID_TO_NAMECww HJ祚B SUBROUTINE FILE_BDATES ( FNAME, CDATE, RDATE, EDATE, BDATE )C*3C* *******************************3C* *******************************3C* ** **3C* ** FILE_DATES **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :FC* RETURNS VALUES FOR THE CREATION, REVISION, EXPIRATION, AND#C* BACKUP DATES FOR A FILEC*C* INPUT ARGUMENTS :!C* FNAME - THE FILE NAMEC*C* OUTPUT ARGUMENTS :7C* CDATE - CREATION DATE INTERNAL FORMAT (2I4)7C* RD ATE - REVISION DATE INTERNAL FORMAT (2I4)9C* EDATE - EXPIRATION DATE INTERNAL FORMAT (2I4)5C* BDATE - BACKUP DATE INTERNAL FORMAT (2I4)C*C* COMMON BLOCKS :FC* MLIB$DATES (DON'T CHANGE MLIB$DATES WITHOUT ALSO CHANGING2C* "FILE_DATES" AND "TOUCH")C*C* SUBPROGRAM REFERENCES :=C* LIB$SYS_ASCTIM, LIB$FILE_SCAN, LIB$FILE_SCAN_END,!C* SYS$DASSGN, LIB$MOVC5<C* SYS$QIOW, SYS$ASSGN, MLIB_DATE_OK, MLIB_DATE_ERRC*%C* ASSUMPTIONS AND RESTRICTIONS :&C* SERIOUSLY NONTRANSPORTABLEBC* ERRORS (SUCH AS NONEXISTANT FILE) RETURN STRANGE DATESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :*C* 16-MAR-90 - INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($FABDEF)' RECORD /FABDEF/ FAB INCLUDE '($NAMDEF)' RECORD /NAMDEF/ NAMC character *255 copy CHARACTER *20 DEFAULT_NAME CHARACTER *(*) FNAME4 INTEGER CDATE(2), RDATE(2), EDATE(2), BDATE(2)E CHARACTER *255 Es, Rs ! Expanded string, Resultant string INTEGER SYS$DASSGN, INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2)* EXTERNAL MLIB_DATE_OK, MLIB_DATE_ERRC copy = fname DEFAULT_NAME = '.'D FAB.FAB$B_BLN = FAB$C_BLN ! I dentify Fab as a valid FAB FAB.FAB$B_BID = FAB$C_BID ( FAB.FAB$L_DNA = %LOC(DEFAULT_NAME)' FAB.FAB$B_DNS = LEN(DEFAULT_NAME) FAB.FAB$L_FNA = %LOC(copy) FAB.FAB$B_FNS = LEN(copy)L FAB.FAB$L_NAM = %LOC(NAM) ! Tell the Fab where to find the NAM CC CALL LIB$MOVC5 (0,, 0, NAM$C_BLN, NAM) ! Initialize NAM to 0CD NAM.NAM$B_BLN = NAM$C_BLN ! Identify Nam as a valid NAM NAM.NAM$B_BID = NAM$C_BID O NAM.NAM$L_ESA = %LOC(Es)  ! Tell it where to find the Expanded and: NAM.NAM$L_RSA = %LOC(Rs) ! Resultant strings6 NAM.NAM$B_ESS = 255 ! Their lengths NAM.NAM$B_RSS = 255C ICON = 0D ISTAT = LIB$FILE_SCAN (FAB, MLIB_DATE_OK, MLIB_DATE_ERR, ICON)C IF (ICHAN .NE. 0) then( ISTAT = SYS$DASSGN(%VAL(ICHAN)) ichan = 0 endifC+ ISTAT = LIB$FILE_SCAN_END (FAB, ICON) DO 10 I = 1,2 CDATE(I) = TCDATE(I)  RDATE(I) = TRDATE(I)  EDATE(I) = TEDATE(I)  BDATE(I) = TBDATE(I) 10 CONTINUE RETURN ENDCC---END FILE_BDATESCww ks祚A SUBROUTINE FILE_DATES ( FNAME, CDATE, RDATE, EDATE, BDATE )C*3C* *******************************3C* *******************************3C* ** **3C* ** FILE_DATES **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :FC* RETURNS VALUES FOR THE CREATION, REVISION, EXPIRATION, AND#C* BACKUP DATES FOR A FILEC*C* INPUT ARGUMENTS :!C* FNAME - THE FILE NAMEC*C* OUTPUT ARGUMENTS :1C* CDATE - CREATION DATE (CHARACTER *23)1C* RDATE - REVISION DATE (CHARACTER *23)3C* EDATE - EXPIRATION DATE (CHARACTER *23)/C* BDATE - BACKUP DATE (CHARACTER *23)C*C* COMMON BLOCKS :<C* MLIB$DATES (SEE ALSO "FILE_BDATES" AND "TOUCH")C*C* SUBPROGRAM REFERENCES :=C* LIB$SYS_ASCTIM, LIB$FILE_SCAN, LIB$FILE_SCAN_END,!C* SYS$DASSGN, LIB$MOVC5<C* SYS$QIOW, SYS$ASSGN, MLIB_DATE_OK, MLIB_DATE_ERRC*%C* ASSUMPTIONS AND RESTRICTIONS :&C* SERIOUSLY NONTRANSPORTABLEBC* ERRORS (SUCH AS NONEXISTANT FILE) RETURN STRANGE DATESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 1-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($FABDEF)' RECORD /FABDEF/ FAB INCLUDE '($NAMDEF)' RECORD /NAMDEF/ NAMC CHARACTER *20 DEFAULT_NAME CHARACTER *(*) FNAME. CHARACTER *23 CDATE, RDATE, EDATE, BDATEE CHARACTER *255 Es, Rs ! Expanded string, Resultant string INTEGER SYS$DASSGN, INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2)* EXTERNAL MLIB_DATE_OK, MLIB_DATE_ERRC DEFAULT_NAME = '.'D FAB.FAB$B_BLN = FAB$C_BLN ! Identify Fab as a valid FAB FAB.FAB$B_BID = FAB$C_BID ( FAB.FAB$L_DNA = %LOC(DEFAULT_NAME)' FAB.FAB$B_DNS = LEN(DEFAULT_ NAME)! FAB.FAB$L_FNA = %LOC(FNAME) FAB.FAB$B_FNS = LEN(FNAME)L FAB.FAB$L_NAM = %LOC(NAM) ! Tell the Fab where to find the NAM CC CALL LIB$MOVC5 (0,, 0, NAM$C_BLN, NAM) ! Initialize NAM to 0CD NAM.NAM$B_BLN = NAM$C_BLN ! Identify Nam as a valid NAM NAM.NAM$B_BID = NAM$C_BID O NAM.NAM$L_ESA = %LOC(Es) ! Tell it where to find the Expanded and: NAM.NAM$L_RSA = %LOC(Rs) ! Resultant strings6 NAM.NAM$B_ESS = 255  ! Their lengths NAM.NAM$B_RSS = 255C ICON = 0D ISTAT = LIB$FILE_SCAN (FAB, MLIB_DATE_OK, MLIB_DATE_ERR, ICON)C IF (ICHAN .NE. 0) then( ISTAT = SYS$DASSGN(%VAL(ICHAN)) ichan = 0 endifC+ ISTAT = LIB$FILE_SCAN_END (FAB, ICON)1 ISTAT = LIB$SYS_ASCTIM ( , CDATE, TCDATE, )1 ISTAT = LIB$SYS_ASCTIM ( , RDATE, TRDATE, )1 ISTAT = LIB$SYS_ASCTIM ( , EDATE, TEDATE, )1 ISTAT = LIB$SYS_ASCTIM ( , BDATE, TBDATE, )C RETURN ENDCC---END FILE_DATESC# SUBROUTINE MLIB_DATE_OK (FAB)C<c *** this routine called by FILE_DATES and FILE_BDATES !!!!c INCLUDE '($ATRDEF)' INCLUDE '($FABDEF)' INCLUDE '($FIBDEF)' INCLUDE '($IODEF)' INCLUDE '($NAMDEF)' INCLUDE '($SBKDEF)'C RECORD /NAMDEF/ NAM, INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2)C STRUCTURE /Dsc/ INTEGER*4 Length INTEGER*4 Addr END STRUCTUREC RECORD /Dsc/ Descr RECORD /Atrdef/ Atr(5) RECORD /Fabdef/ Fab RECORD /Fibdef/ Fib RECORD /Sbkdef/ SbkC INTEGER*2 IOSB(4)" INTEGER SYS$ASSIGN, SYS$QIOWC IF (ICHAN. EQ. 0) THENL Descr.Length = Nam.NAM$B_DEV ! Build a Strdescr for the device name% Descr.Addr = Nam.NAM$L_DEVC IOSB(1) = 0-  ISTAT = SYS$ASSIGN (DESCR ,ICHAN,,) C) ATR(1).ATR$W_SIZE = ATR$S_EXPDAT) ATR(1).ATR$W_TYPE = ATR$C_EXPDAT) ATR(1).ATR$L_ADDR = %LOC(TEDATE)C* ATR(2).ATR$W_SIZE = ATR$S_CREDATE* ATR(2).ATR$W_TYPE = ATR$C_CREDATE) ATR(2).ATR$L_ADDR = %LOC(TCDATE)C* ATR(3).ATR$W_SIZE = ATR$S_REVDATE* ATR(3).ATR$W_TYPE = ATR$C_REVDATE) ATR(3).ATR$L_ADDR = %LOC(TRDATE)C* ATR(4).ATR$W_SIZE = ATR$S_BAKDATE*  ATR(4).ATR$W_TYPE = ATR$C_BAKDATE) ATR(4).ATR$L_ADDR = %LOC(TBDATE)C ATR(5).ATR$W_SIZE = 0 ATR(5).ATR$W_TYPE = 0C END IFCB Fib.FIB$W_FID_NUM = Nam.NAM$W_FID_NUM ! Setup File ID values+ Fib.FIB$W_FID_SEQ = Nam.NAM$W_FID_SEQ+ Fib.FIB$W_FID_RVN = Nam.NAM$W_FID_RVNJ Fib.FIB$W_DID_NUM = Nam.NAM$W_DID_NUM ! Same for Directory ID values+ Fib.FIB$W_DID_SEQ = Nam.NAM$W_DID_SEQ+ Fib.FIB$W_DID_RVN = Nam.NAM$W_DID_RVN  Descr.Length=FIB$C_ACCDATA Descr.Addr = %LOC(Fib)CC --- OK, GET THE INFOC? ISTAT = SYS$QIOW( ,%VAL(ICHAN), %VAL(IO$_ACCESS), IOSB,,,+ $ DESCR,,,, ATR,) RETURN ENDCC---END MLIB_DATE_OKC$ SUBROUTINE MLIB_DATE_ERR (FAB)C<c *** this routine called by FILE_DATES and FILE_BDATES !!!!c, INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2) c tcdate(1) = 0 tcdate(2) = -1 trdate(1) = 0 trdate(2) = -1 tedate(1) = 0 tedate(2) = -1 RETURN ENDCC---END MLIB_DATE_ERRORCwwV祚* SUBROUTINE FIRST ( STRING, CHAR, I )C*3C* *******************************3C* *******************************3C* ** **3C* ** FIRST **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* FIRST CHARACTERC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :CC* TO RETRIEVE THE FIRST NON-BLANK CHARACTER FROM A STRING"C* AND FIND ITS POSITION.C*C* INPUT ARGUMENTS :#C* STRING - THE INPUT LINEC*C* OUTPUT ARGUMENTS :0C* CHAR - THE FIRST NON-BLANK CHARACTER0C* I - THE LOCATION OF THE CHARACTERC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING CHARACTER *1 CHARC LENST = LEN(STRING) DO 10 I = 1,LENST' IF (STRING(I:I) .NE. ' ') THEN CHAR = STRING(I:I) RETURN ENDIF10 CONTINUE I = 0 CHAR = ' ' RETURN ENDC C---END FIRSTCww FOPENC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :AC* TO OPEN A FILE. THIS ROUTINE CHECKS FOR EXISTANCE OF=C* FILENAME, DEFAULT SPECIFICATIONS, PROMPTING, ETC.4C* CONSISTANT WITH MERLIN SYSTEM UTILITIES.C*C* INPUT ARGUMENTS :(C* NUNIT - LOGICAL UNIT NUMBER'C* FNAME - FILE SPECIFICATION/C* DEFNAME- DEFAULT FILE SPECIFICATION#C* PROMP - TEXT OF PROMPT+C* NEW - IS FILE TO BE CREATED?C*C* OUTPUT ARGUMENTS :GC* ERROR - SET .TRUE. IF AN ERROR OCCURS OR USER ENTERS 1C* IN RESPONSE TO THE PROMPTC*C* SUBPROGRAM REFERENCES :#C* MLIB_GET, PROMPT, PARSEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSIONC*HC***********************************************************************C** CHARACTER *(*) FNAME, DEFNAME, PROMP LOGICAL NEW, ERROR CHARACTER *128 TEMPC ERROR = .FALSE.$ CALL MLIB_GET ('NREAD', NREAD)& CALL MLIB_GET ('NWRITE', NWRITE)C IF (FNAME .EQ. ' ') THEN! IF (PROMP .EQ. ' ') THEN/ CALL PROMPT(NWRITE,'_File Name ? ') ELSE% CALL PROMPT(NWRITE,PROMP) ENDIF READ(NREAD,900) TEMP IF (TEMP .EQ. ' ') THEN ERROR = .TRUE. RETURN ENDIF ELSE TEMP = FNAME ENDIFC%C --- 'TEMP' NOW CONTAINS A FILE NAMEC0 CALL PARSE ( TEMP, DEFNAME, 'FULL', TEMP )C IF (NEW) THEN3 OPEN (UNIT=NUNIT, FILE=TEMP, STATUS='NEW',- $ CARRIAGECONTROL='LIST', ERR=1000) ELSE= OPEN (UNIT=NUNIT, FILE=TEMP, STATUS='OLD', ERR=1000) ENDIF RETURNC1000 ERROR = .TRUE. RETURN900 FORMAT(A) ENDww 祚> SUBROUTINE FPackOut (nout, in, out, iout, cstring, cend)C*3C* *******************************3C* *******************************3C* ** **3C* ** PackOut **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta .C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :HC* Pack text into an output buffer and dump it when it is full.9C* Note, CALL FLUSHOUT to force writing of line.1C* FORTRAN carriage control is not used.C*C* INPUT ARGUMENTS :,C* NOUT - UNIT NUMBER FOR OUTPUT7C* IN - TE XT TO BE ADDED TO OUTPUT BUFFER.C* OUT - OUTPUT BUFFER (PREVIOUS)EC* IOUT - LOCATION OF LAST CHARACTER IN OUT (INITIALLY 0))C* CSTRING - CONTINUATION STRINGHC* CEND - TRUE IF CSTRING IS APPENDED TO THE END OF THE LINEGC* TO BE CONTINUED, FALSE IF IT GOES ON THE START (C* OF THE NEXT LINEC*C* OUTPUT ARGUMENTS :)C* OUT - UPDATED OUTPUT BUFFER*C* IOUT - UPDATED POINTER IN OUTC*C* SUBPROGRAM REFERENCES :C* FFLUSHOUTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 16-MAR-1990 - INITIAL VERSIONC*HC***********************************************************************C*% character *(*) in, out, cstring logical cendc)c --- maximum characters in output bufferc max = len(out)( if (cend) max = max - len(cstring) lin = len(in)c8c --- if there isn't enough room in the buffer, flush itc# if ((iout+lin) .gt. max) thencDc ----- it is possible that the input string is too long to buffer, c break it into partsc if (lin .gt. max) thenI call FFlushOut (nout, out, iout) ! First, flush buffer istart = 1 iend = max@10 out = in(istart:iend) ! Print parts- iout = min0(max, (iend-istart+1))# if (iend .lt. lin) then/  call FFlushOut (nout, out, iout) istart = iend + 1& iend = istart + max - 1 go to 10 endifc1c ----- not too big, flush buffer then pack inputc elsecHc ------- does the continuation string go on the end of the string to bec continued...c if (cend) then% out(iout+1:) = cstring) iout = iout + len(cstring)/ call FFlushOut (nout, out, iout) iout = lin out = inc+c ------- or at the start of the next line?c else> call FFlushOut (nout, out, iout) " out = cstring // in( iout = lin + len(cstring) endif endifcc --- buffer input onlyc else out(iout+1:) = in iout = iout + lin endif RETURN ENDCC---END PackOutC, SUBROUTINE FFlushOut (no ut, out, iout) character *(*) outc2 if (iout .gt. 0) write(nout,900) out(1:iout) iout = 0 return900 format(' ',a) endcc---end flushoutcwwV祚 SUBROUTINE G4ALFAC*3C* *******************************3C* *******************************3C* ** **3C* ** G4ALFA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* G4ALFAC*C* AUTHOR :C*  Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :DC* TO PLACE THE GRAPHON 407 TERMINAL INTO ALPHA (ANSI) MODEC*%C* ASSUMPTIONS AND RESTRICTIONS :2C* THE "$" EDIT DESCRIPTOR IS NONSTANDARDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 9-AUG-1988 - INITIAL VERSIONC*HC******************* ****************************************************C*$ CALL MLIB_GET('NWRITE',NWRITE) WRITE(NWRITE,900) CHAR(27)900 FORMAT(' ',A1,'%!1',$) RETURN ENDCC---END G4ALFACwwҢ祚 SUBROUTINE G4GRAFC*3C* *******************************3C* *******************************3C* ** **3C* ** G4GRAF **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* G4GRAFC*C* AUTHOR :C*  Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :@C* TO PLACE THE GRAPHON 407 TERMINAL INTO GRAPHICS MODE#C* AND SELECT RGB GRAPHICSC*C* INPUT ARGUMENTS :=C* NWRITE - LOGICAL UNIT NUMBER ASSIGNED TO TERMINALC*%C* ASSUMPTIONS AND RESTRICTIONS :2C* THE "$" EDIT DESCRIPTOR IS NONSTANDARDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 9-AUG-1988 - INITIAL VERSIONC*HC***********************************************************************C*$ CALL MLIB_GET('NWRITE',NWRITE)* WRITE(NWRITE,900) CHAR(27), CHAR(27)'900 FORMAT(' ',A1,'%!0',A1,'PM400',$) RETURN ENDCC---END G4GRAFCww .祚/ SUBROUTINE GAUSS ( A, Y, COEF, N, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GAUSS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM : C* GAUSSIAN ELIMINATIONC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :=C* TO SOLVE A SET OF SIMULTANEOUS, LINEAR EQUATIONS.*C* THE FORM OF THE EQUATIONS IS :=C* Y1 = A1,1*X1 + A1,2*X2 + ... A1,N*XN$C* Y2 = A2,1*X1...C* .C* .=C* YN = AN,1*X1...  AN,N*XNC*)C* THE SOLUTION IS OF THE FORM :C* X1 = COEF(1)C* X2 = COEF(2)C* .C* .C* XN = COEF(N)C*GC* REFERENCE : "PASCAL PROGRAMS FOR ENGINEERS AND SCIENTISTS",;C* BY ALAN R. MILLER, 1981, SYBEX INC.C*C* INPUT ARGUMENTS :/C* A = N*N INPUT MATRIX(DESTROYED)-C* Y = INPUT VECTOR OF LENGTH, N'C* N = NUMBER OF EQUATIONSC*C* OUTPUT ARGUMENTS :0C* COEF = SOLUTION VECTOR OF LENGTH, N@C* ERROR = BOOLEAN ERROR FLAG (MATRIX SINGULAR IF TRUE)C*C* ERROR PROCESSING :GC* IF A ZERO APPEARS ON THE DIAGONAL AND CAN'T BE REMOVED, THEC* MATRIX IS SINGULAR.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 5-MAR-85 INITIAL VERSIONC*HC***********************************************************************C*% DIMENSION A(N,N), Y(N), COEF(N) LOGICAL ERRORC ERROR = .FALSE. N1 = N - 1 DO 50 I = 1, N1 AMAX = ABS(A(I,I)) L = I I1 = I+1C+C ----- FIND LARGEST ELEMENT IN THIS COLUMNC DO 10 J = I1, N* IF (ABS(A(J,I)) .GT. AMAX)THEN! AMAX = ABS(A(J,I)) L = J ENDIF10 CONTINUEC>C ----- IF THE LARGEST ELEMENT IS ZERO, THE MATRIX IS SINGULARC IF (AMAX .EQ. 0.0)THEN ERROR = .TRUE. RETURN ELSECHC -------- IF THE LARGEST ELEMENT IS NOT ALREADY ON THE DIAGONAL, PUT IT"C -------- THERE BY SWAPPING ROWSC IF (L .NE. I) THEN DO 20 J = 1, N TEMP = A(L,J)! A(L,J) = A(I,J) A(I,J) = TEMP20 CONTINUE TEMP = Y(L) Y(L) = Y(I) Y(I) = TEMP ENDIFC4C -------- DIVIDE EACH ELEMENT IN ROW BY THE LARGESTC DO 40 J = I1, N# TEMP = A(J,I)/A(I,I)C9C -------- NOW SUBTRACT THIS ROW FROM EACH SUBSEQUENT ROWC DO 30 K = I1, N/ A(J,K) = A(J,K) - TEMP*A(I,K)30 CONTINUE& Y(J) = Y(J) - TEMP*Y(I)40 CONTINUE ENDIF50 CONTINUEC6C --- IF A ZERO IS LEFT ON THE DIAGONAL, IT'S SINGULARC IF (A(N,N) .EQ. 0.0)THEN ERROR = .TRUE.CC --- SUBSTITUTE FOR SOLUTIONC ELSE COEF(N) = Y(N)/A(N,N) DO 70 I = N1, 1, -1 SUM = 0.0 I1 = I + 1 DO 60 J = I1, N) SUM = SUM + A(I,J)*COEF(J)60 CONTINUE' COEF(I) = (Y(I)-SUM)/A(I,I)70 CONTINUE ENDIF RETURN ENDC C---END GAUSSCww쁴祚% CHARACTER FUNCTION GETC ( NIN )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET CHARACTERC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :9C* GET A SINGLE CHARACTER FROM THE INPUT UNIT...4C* TAKE CARE OF NEW LINES AND END-OF-FILE0C* GETC DOES NOT RETURN TRAILING SPACESC*C* INPUT ARGUMENTS :#C* NIN - INPUT UNIT NUMBERC*C* OUTPUT ARGUMENTS :6C* GETC - THE NEXT CHARACTER (FUNCTION VALUE)<C*  NOTE: CHAR(26) IS RETURNED FOR ENDFILE...-C* CHAR(13) FOR ENDLINEC*C* FILE REFERENCES :C* NINC*C* SUBPROGRAM REFERENCES :C* MLIB_ERROR, LENGTHC*%C* ASSUMPTIONS AND RESTRICTIONS :0C* ALL TRAILING BLANKS ARE STRIPPED OFF=C* INPUT LINE LENGTH IS RESTRICTED TO 133 CHARACTERSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 10-SEP-85 INITIAL VERSIONC*HC***********************************************************************C*( PARAMETER (LMAX=133,NSTART=LMAX+1) CHARACTER *(LMAX) LINE LOGICAL EOF SAVE NPTR, LPTR, EOF, LINE# DATA NPTR/NSTART/, LPTR/LMAX/ DATA EOF/.FALSE./C;C --- END OF LINE WAS REACHED ON LAST ENTRY... GET NEW LINEC IF (NPTR .GT. LPTR) THEN IF ( EOF )H $ CALL MLIB_ERROR(3,'GETC','Attempted get after end of file.')$ READ(NIN,900,END=1000) LINE LPTR = LENGTH(LINE)+1 NPTR = 1 ENDIFCHC --- RETURN NEXT CHARACTER UNLESS THERE ARE NO MORE... THEN RETURN C IF (NPTR .EQ. LPTR) THEN GETC = CHAR(13) ELSE GETC = LINE(NPTR:NPTR) ENDIF NPTR = NPTR + 1 RETURNCC --- END OF FILEC1000 GETC = CHAR(26) EOF = .TRUE. RETURN900 FORMAT(A) ENDC C---END GETCCwwb祚& SUBROUTINE GETCHAR ( CH, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETCHAR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET CHARACTERC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :CC* THIS ROUTINE WAITS UNTIL A SINGLE KEYSTROKE IS ENTERED.C*C* OUTPUT ARGUMENTS :AC* CH - THE ASCII INTEGER CHARACTER THAT WAS ENTERED..C* ERROR - TRUE IF AN ERROR OCCURRED.C*C* SUBPROGRAM REFERENCES :7C* SYS$ASSIGN, LIB$GET_EF, SYS$CLREF, SYS$QIOWC*C*  ERROR PROCESSING :AC* PASSES ALONG THE ERROR CODES FROM THE SYSTEM SERVICESC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :,C* THIS ROUTINE WORKS ONLY TO 'TT:'DC* THE USER SHOULD ALWAYS CHECK THE VALUE OF 'ERROR' IN THE#C* CALLING PROGRAM.6C* THE READ TIMES OUT AFTER ABOUT 15 MINUTES.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 28-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* IMPLICIT INTEGER (A-Z) INCLUDE '($IODEF)' INCLUDE '($SSDEF)'2 SAVE INIT, TERM_CHAN, KEYBOARD_EF, READ_FUNC LOGICAL ERROR, INIT BYTE CH INTEGER*2 IOSB(4)- INTEGER NO_TERMINATORS(2), TERM_MASK(8)1 DATA NO_TERMINATORS /32,0/, TERM_MASK /8*0/ DATA INIT/.FALSE./C) NO_TERMINATORS(2) = %LOC(TERM_MASK) ERROR = .FALSE. IF (.NOT. INIT) THENC"C --- ASSIGN AN IO CHANNEL FOR TT:C/ ISTAT = SYS$ASSIGN ('TT', TERM_CHAN,,) IF (.NOT. ISTAT) THEN ERROR = .TRUE. RETURN ENDIFC)C --- ALLOCATE AN EVENT FLAG AND CLEAR ITC( ISTAT = LIB$GET_EF(KEYBOARD_EF) IF (.NOT. ISTAT) THEN ERROR = .TRUE. RETURN ENDIF. ISTAT = SYS$CLREF (%VAL(KEYBOARD_EF))) IF (ISTAT .NE. SS$_WASCLR .AND.( $ ISTAT .NE. SS$_WASSET) THEN ERROR = .TRUE. RETURN ENDIF8 READ_FUNC = IO$_TTYREADALL .OR. IO$M_TIMED .OR. $ IO$M_NOECHO INIT = .TRUE. ENDIFC&C --- INITIATE A SINGLE CHARACTER READC; ISTAT = SYS$QIOW (%VAL(KEYBOARD_EF), %VAL(TERM_CHAN),= $ %VAL(READ_FUNC), IOSB,,, CH, %VAL(1),4 $ %VAL(999), NO_TERMINATORS,,)? IF ((IOSB(1).NE.SS$_NORMAL) .OR. (IOSB(2) .NE. 1)) CH = 0 RETURN ENDCC---END GETCHARCww~祚$ SUBROUTINE GETCPRV ( N, PRIV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETCPRV **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :"C* GET CURRENT PRIVILEGESC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* TO CHECK THE PRIVILEGES CURRENTLY ACTIVE FOR THE PROCESS.C*C* OUTPUT ARGUMENTS :2C* N - THE NUMBER OF PRIVILEGES FOUNDDC* PRIV - THE ARRAY CONTAINING THE NAMES OF THE PRIVILEGESC*C* INTERNAL WORK AREAS :;C* MASK1, MASK2 - THE MASK BITS FOR THE PRIVILEGESIC* ALL1, ALL2 - THE ASCII NAMES CORRESPONDING TO MASK1 AND MASK2C*C* SUBPROGRAM REFERENCES :%C* JPI$_CURPRIV, SYS$GETJPIWC*%C* TRANSPORTABILITY LIMITATIONS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 12-APR-85 INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($JPIDEF)' CHARACTER *(*) PRIV(1)% CHARACTER *10 ALL1(32), ALL2(7) INTEGER *2 ITEM(2)8 INTEGER *4 MASK1(32), MASK2(7), ITMLST(4), QUAD(2)% EQUIVALENCE (ITEM(1),ITMLST(1))C+C --- PRIVILEGE NAMES IN THE FIRST QUADWORDC? DATA ALL1 / 'ACNT ', 'ALLSPOOL ', 'BUGCHK ',? $ 'BYPASS ', 'CMEXEC ', 'CMKRNL ', 'DETACH ',? $ 'DIAGNOSE ', 'EXQUOTA ', 'GROUP ', 'GRPNAM ',? $ 'LOG_IO ', 'MOUNT ', 'NETMBX ', 'OPER ',? $ 'P FNMAP ', 'PHY_IO ', 'PRMCEB ', 'PRMGBL ',? $ 'PRMMBX ', 'PSWAPM ', 'SETPRI ', 'SETPRV ',? $ 'SHARE ', 'SHMEM ', 'SYSGBL ', 'SYSLCK ',? $ 'SYSNAM ', 'SYSPRV ', 'TMPMBX ', 'VOLPRO ', $ 'WORLD '/C-C --- PRIVILEGE NAMES IN THE SECOND QUAD WORDC? DATA ALL2 / 'DOWNGRADE ', 'GRPPRV ', 'PRMJNL ',? $ 'READALL ', 'SECURITY ', 'TMPJNL ', 'UPGRADE '/C'C --- MASK BITS FOR THE FIRST QUAD W ORDC; DATA MASK1 / 512, 16, 8388608,6 $ 536870912, 2, 1, 32,5 $ 64, 524288, 256, 8,: $ 128, 131072, 1048576, 262144,< $ 67108864, 4194304, 1024, 16777216,9 $ 2048, 4096, 8192, 16384,> $ -2147483648, 134217728, 33554432, 1073741824,; $ 4, 268435456, 32768, 2097152, $ 65536 /C(C --- MASK BITS FOR THE SECOND QUAD WORDC6 DATA MASK2 / 2, 4, 32,6 $ 8, 64, 16, 1 /C N = 0CC --- FILL ITMLSTC ITEM(1) = 8 ITEM(2) = JPI$_CURPRIV! ITMLST(2) = %LOC( QUAD(1) ) ITMLST(3) = 0 ITMLST(4) = 00 ISTAT = SYS$GETJPIW ( ,,, ITMLST, IOSB,, )C%C --- PROCESS FIRST WORD OF QUAD WORDC DO 10 I = 1,322 IF ((QUAD(1) .AND. MASK1(I)) .NE. 0) THEN N = N + 1 PRIV(N) = ALL1(I) ENDIF10 CONTINUEC&C --- PROCESS SECOND WORD OF QUAD WORDC DO 20 I = 1,72 IF ((QUAD(2) .AND. MASK2(I)) .NE. 0) THEN N = N + 1 PRIV(N) = ALL2(I) ENDIF20 CONTINUE RETURN ENDCC---END GETCPRVCww  襚( SUBROUTINE GETFDEV ( IUNIT, FDEV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFDEV **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FILE DEVICEC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :/C* GET THE NAME OF THE DEVICE ON WHICH$C* THE FILE 'IUNIT' RESIDESC*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUMENTS :"C* FDEV - THE DEVICE NAMEC*C* INTERNAL WORK AREAS :;C* WORK - TEMP VARIABLE TO HOLD T HE FULL FILE SPECC*C* FILE REFERENCES :C* IUNITC*C* ERROR PROCESSING :1C* FDEV WILL BE ' ' IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSION/C* 29-JUN-90 CHANGED TO USE "PARSE"C*HC***********************************************************************C* CHARACTER *(*) FDEV CHARACTER *127 WORKC FDEV = ' '/  INQUIRE (UNIT=IUNIT, NAME=WORK, ERR=1000), call parse (work, ' ', 'DEVICE', fdev) 1000 RETURN ENDCC---END GETFDEVCww-c9꥚" LOGICAL FUNCTION ISALPHA (C)C*3C* *******************************3C* *******************************T3C* ** **3C* ** ISALPHA **E3C* ** **3C* *******************************T3C* ******************************* C*C* AUTHOR :"C* Arthur E. RagostaR0C* RAzA 襚( SUBROUTINE GETFDIR ( IUNIT, FDIR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFDIR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FILE DIRECTORYC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :8C* GET THE NAME OF THE DIRECTORY WHICH CONTAINSC* THE FILE 'IUNIT'C*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUMENTS :=C* FDIR - THE FULL DIRECTORY NAME INCLUDING BRACKETSC*C* INTERNAL WORK AREAS :;C* WORK - TEMPORARY VARIABLE TO HOLD THE FULL FILE C* SPECIFICATIONC*C* FILE REFERENCES :C* IUNITC*C* ERROR PROCESSING :1C* FDIR WILL BE ' ' IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSIONGC* 14-OCT-87 MODIFIED TO INCLUDE BRACKETS IN DIRECTORY NAME0C* 29-JUN-90 MODIFIED TO USE "PARSE"C*HC***********************************************************************C* CHARACTER *(*) FDIR CHARACTER *127 WORKC FDIR = ' '/ INQUIRE (UNIT=IUNIT, NAME=WORK, ERR=1000)/ CALL PARSE (WORK, ' ', 'DIRECTORY', FDIR) 1000 RETURN ENDCC---END GETFDIRCww7襚, SUBROUTINE GETFILE ( INFILE, OUTFILE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFILE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GETFILEC*C*  AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :?C* RETRIEVE THE NEXT FILE NAME FROM A LIST (INCLUDING C* WILDCARDS). C*C* INPUT ARGUMENTS :3C* INFILE - THE STRING CONTAINING THE LISTC*C* OUTPUT ARGUMENTS :-C* OUTFILE - NEXT NAME FROM THE LISTHC* (IF "INFILE" CHANGES, WE START OVER AT FIRST FILE)C*C* SUBPROGRAM REFERENCES :!C* LENGTH, LIB$FIND_FILEC*%C* ASSUMPTIONS AND RESTRICTIONS :8C* ONLY TEN FILESPECS MAY BE INCLUDED IN A LIST8C* EACH FILESPEC MUST BE 127 CHARACTERS OR LESSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 10-MAY-1988 - INITIAL VERSIONC*HC***********************************************************************C*$ CHARACTER *(*) INFILE, OUTFILE$ CHARACTER *127 WFILE, LIST(10) INCLUDE '($RMSDEF)' DATA WFILE/'????????'/CC --- NEW FILE NAME?C" IF (INFILE .NE. WFILE ) THEN" LENFILE = LENGTH (INFILE)# IF (LENFILE .EQ. 0) RETURN WFILE = INFILE NL = 0 IL = 1 ICON = 0C@C --- IF ITS A LIST, PARSE INPUT LINE INTO INDIVIDUAL FILE SPECSC, IF ((INDEX(INFILE,',') .NE. 0) .OR.) $ (INFILE(1:1) .EQ. '(')) THEN*  IF (INFILE(1:1) .EQ. '(') THEN IPTR = 2 ELSE IPTR = 1 ENDIF NPTR = IPTR10 IPTR = IPTR + 10 IF (INFILE(IPTR:IPTR) .EQ. ',') THEN NL = NL + 1- LIST(NL) = INFILE(NPTR:IPTR-1) NPTR = IPTR + 1 IPTR = NPTR5 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 10C C --- MISSING RIGHT PARENTHESIS?C$ IF (IPTR .GT. NPTR) THEN NL = NL + 1+ LIST(NL) = INFILE(NPTR:IPTR) ENDIFC"C --- OTHERWISE, A SINGLE FILESPECC ELSE NL = 1 LIST(NL) = INFILE ENDIF ENDIFC,C --- GET NEXT NAME FOR THE CURRENT FILESPECC920 ISTAT = LIB$FIND_FILE (LIST(IL), OUTFILE, ICON,,,,)@ IF ((ISTAT .EQ. RMS$_NMF) .OR. (ISTAT .EQ. RMS$_FNF)) THENC9C --- ALL DONE FOR THIS FILESPEC, SEE IF THERE IS ANOTHERC) ISTAT = LIB$FIND_FILE_END (ICON) ICON = 0 IF (IL .GE. NL) THEN OUTFILE = ' ' ELSE IL = IL + 1 GO TO 20 ENDIF ENDIFC RETURN ENDCC---END GETFILECww }xO襚= SUBROUTINE GETFILEX ( INFILE, OUTFILE, DEFILE, EXFILE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFILEX **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :"C* GETFILE WITH EXCLUSIONC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5578C*C* PURPOSE :>C* RETRIEVE THE NEXT FILE NAME FROM A LIST (INCLUDINGCC* WILDCARDS). A DEFAULT FILESPEC CAN BE USED FOR MISSINGDC* PORTIONS OF THE FILESPEC. A LIST OF FILES TO EXCLUDE ISC* ALSO PROVIDED.C*C* INPUT ARGUMENTS :3C* INFILE - THE STRING CONTAINING THE LIST,C* DEFILE - DEFAULT FILESPEC STRING&C* EXFILE - FILE EXCLUDE LISTC*C* OUTPUT ARGUMENTS :-C* OUTFILE - NEXT NAME FROM THE LISTHC* (IF "INFILE" CHANGES, WE START OVER AT FIRST FILE)C*C* SUBPROGRAM REFERENCES :2C* LENGTH, LIB$FIND_FILE, MLIB_FILE_MATCHC*%C* ASSUMPTIONS AND RESTRICTIONS :8C* ONLY TEN FILESPECS MAY BE INCLUDED IN A LIST8C* EACH FILESPEC MUST BE 127 CHARACTERS OR LESSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 10-MAY-1988 - INITIAL VERSIONAC* 07-MAR-1989 - ADDED DEFAULT SPEC AND EXCLUSION LIST;C* 08-JUN-1990 - FIXED BUG IN LISTS OF FILESPECSC*HC***********************************************************************C*4 CHARACTER *(*) INFILE, OUTFILE, EXFILE, DEFILE/ CHARACTER *127 WFILE, LIST(10), ELIST(10) INCLUDE '($RMSDEF)' LOGICAL WILD_MATCH DATA WFILE/'????????'/CC --- NEW FILE NAME?C" IF (INFILE .NE. WFILE ) THENC,C ----- INITIALIZE DEFAULT AND EXCLUDED LISTC" LENFILE = LENGTH (INFILE)# IF (LENFILE .EQ. 0) RETURN# LENEFILE = LENGTH (EXFILE) WFILE = INFILE NL = 0 IL = 1 ICON = 0C@C --- IF ITS A LIST, PARSE INPUT LINE INTO INDIVIDUAL FILE SPECSC, IF ((INDEX(INFILE,',') .NE. 0) .OR.) $  (INFILE(1:1) .EQ. '(')) THEN* IF (INFILE(1:1) .EQ. '(') THEN IPTR = 2 ELSE IPTR = 1 ENDIF NPTR = IPTR10 IPTR = IPTR + 10 IF (INFILE(IPTR:IPTR) .EQ. ',') THEN NL = NL + 1- LIST(NL) = INFILE(NPTR:IPTR-1) NPTR = IPTR + 1 IPTR = NPTR5 ELSE IF (INFILE(IPTR:IPTR) .EQ. ')') THEN NL = NL + 1-  LIST(NL) = INFILE(NPTR:IPTR-1)! IPTR = LENFILE + 1 NPTR = IPTR ENDIF+ IF (IPTR .LT. LENFILE) GO TO 10C C --- MISSING RIGHT PARENTHESIS?C$ IF (IPTR .GT. NPTR) THEN NL = NL + 1+ LIST(NL) = INFILE(NPTR:IPTR) ENDIFC"C --- OTHERWISE, A SINGLE FILESPECC ELSE NL = 1 LIST(NL) = INFILE ENDIFC/C --- NOW PARSE THE EXCLUDED LIST, I F NECESSARYC, IF ((INDEX(EXFILE,',') .NE. 0) .OR.) $ (EXFILE(1:1) .EQ. '(')) THEN* IF (EXFILE(1:1) .EQ. '(') THEN IPTR = 2 ELSE IPTR = 1 ENDIF NPTR = IPTR15 IPTR = IPTR + 10 IF (EXFILE(IPTR:IPTR) .EQ. ',') THEN NEL = NEL + 1/ ELIST(NEL) = EXFILE(NPTR:IPTR-1) NPTR = IPTR + 1 IPTR = NPTR5 ELSE I!F (EXFILE(IPTR:IPTR) .EQ. ')') THEN NEL = NEL + 1/ ELIST(NEL) = EXFILE(NPTR:IPTR-1)! IPTR = LENFILE + 1 NPTR = IPTR ENDIF, IF (IPTR .LT. LENEFILE) GO TO 15C C --- MISSING RIGHT PARENTHESIS?C$ IF (IPTR .GT. NPTR) THEN NEL = NEL + 1- ELIST(NEL) = EXFILE(NPTR:IPTR) ENDIFC"C --- OTHERWISE, A SINGLE FILESPECC ELSE NEL = 1" ELIST(NEL) = EXFILE ENDIF ENDIFC"C --- END "IF (INFILE .NE. WFILE)"C,C --- GET NEXT NAME FOR THE CURRENT FILESPECC@20 ISTAT = LIB$FIND_FILE (LIST(IL), OUTFILE, ICON, DEFILE,,,)@ IF ((ISTAT .EQ. RMS$_NMF) .OR. (ISTAT .EQ. RMS$_FNF)) THENC9C --- ALL DONE FOR THIS FILESPEC, SEE IF THERE IS ANOTHERC) ISTAT = LIB$FIND_FILE_END (ICON) ICON = 0 IF (IL .GE. NL) THEN OUTFILE = ' ' ELSE  IL = IL + 1 GO TO 20 ENDIF ENDIFC+C --- CHECK TO SEE IF THIS FILE IS EXCLUDEDC IF (OUTFILE .NE. ' ') THEN DO 30 I = 1, NEL; IF ( WILD_MATCH ( ELIST(I), OUTFILE )) GO TO 2030 CONTINUE ENDIF RETURN ENDCC---END GETFILEXCww$뎾\襚* SUBROUTINE GETFNAME ( IUNIT, FNAME )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFNAME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FILE NAMEC*C*% AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :>C* GET THE FILE NAME ASSOCIATED WITH THE UNIT 'IUNIT'C*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUMENTS :?C* FNAME - THE FILE NAME ONLY (LESS DIRECTORY NAME ANDC* '.' SUFFIX)C*C* INTERNAL WORK AREAS :AC*& WORK - TEMPORARY VARIABLE USED TO HOLD FULL FILE NAMEC*C* FILE REFERENCES :C* IUNITC*C* ERROR PROCESSING :,C* FNAME = ' ' IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSION.C* 29-JUN-90 MODIFIED TO USE PARSEC*HC***********************************************************************C* CHARACTER *(*) FNAME CHARACTER *127 WORKC FNAME = ' '/ INQUIRE (UNIT=IUNIT, NAME=WORK, ERR=1000)- CALL PARSE ( WORK, ' ', 'NAME', FNAME ) 1000 RETURN ENDCC---END GETFNAMECww(}襚1 SUBROUTINE GETFOR ( NQ, QUALS, NP, PARAMS )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFOR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FOREIGN)C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :CC* TO RETURN ANY PARAMETERS AND/OR QUALIFIERS ENTERED ON A!C* FOREIGN COMMAND LINE.C*C* METHODOLOGY :DC* USE VMS GET_FOREIGN ROUTINE THEN PARSE USING ' ' AND '/' C* AS VALID DELIMITERS.C*C* OUTPUT ARGUMENTS :/C* NQ - NUMBER OF QUALIFIERS *FOUND7C* QUALS - THE LIST OF QUALIFIERS(LESS SLASH)/C* NP - NUMBER OF PARAMETERS FOUND+C* PARAMS - THE LIST OF PARAMETERSC*C* SUBPROGRAM REFERENCES :C* LIB$GET_FOREIGNC*%C* TRANSPORTABILITY LIMITATIONS :?C* UNLIKELY TO BE TRANSPORTABLE TO ANY SYSTEM BUT VMS.C*%C* ASSUMPTIONS AND RESTRICTIONS :6C* ANYTHING ENCLOSED IN QUOTES IS A PARAMETERGC* SLASHES AND BLANKS ARE DELIMITERS UNLESS ENCLOSED IN QUO+TESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :CC* 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 VERSIONC*HC***********************************************************************C* INCLUDE '($SSDEF)' CHARACTER *255 COMMAN' CHARACTER *(*) QUALS(1),PARAMS(1) LOGICAL QUOTEDC IP = 0 , NQ = 0 NP = 0 LS = LEN(QUALS(1))C0C --- RETURN COMMAND LINE (LESS FOREIGN COMMAND)C= IF (LIB$GET_FOREIGN(COMMAN,,IP) .NE. SS$_NORMAL) RETURN IF (IP .LE. 0) RETURN5 I = 1 ! NEXT LOCATION IN INPUT LINEC0C --- LOOP WHILE LINE STILL HAS CHARACTERS IN ITC --- SKIP LEADING SPACESC$90 IF (COMMAN(I:I) .EQ. ' ') THEN I = I + 1! IF (I .GT. IP) GO TO 300 GO TO 90 ENDIFC>C --- OK, NONBLANK- CHARACTER. IS IT A QUALIFIER OR PARAMETER?C&100 IF ( COMMAN(I:I) .EQ. '/' ) THENC)C --- A QUALIFIER... DO NOT INCLUDE SLASHC 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) = ' 'CCC ---- ADD CHARACTERS UNTIL A SPACE OR SLASH FOUND, OR END OF LINEC,110 IF (COMMAN(I:I) .EQ. '/') GO TO 100+ IF (COMMAN(I:I) .EQ. ' ') GO TO 908 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 ELSEC7C --- PARAMETER... FIRST CHARACTER IS ALREADY NON-BLANKC 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 ENDIFCBC --- ADD CHARACTERS UNTIL A BLANK OR SLASH IS FOUND (IF UNQUOTED)7C --- ADD CH/ARACTERS UNTIL A QUOTE IS FOUND (IF QUOTED)C210 IF (QUOTED) THEN* IF (COMMAN(I:I) .EQ. '"') THEN I = I + 1' IF (I .GT. IP) GO TO 300 GO TO 90 ENDIF ELSEC IF ((COMMAN(I:I) .EQ. ' ') .OR. (COMMAN(I:I) .EQ. '/')) $ GO TO 90  ENDIFC8 IF (NC .LE. LS) 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 100C1C --- END OF LOOP WHILE LINE STILL HAS CHARACTERSC 300 RETURN ENDCC---END GETFORCww1$8襚* SUBROUTINE GETFTYPE ( IUNIT, FTYPE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFTYPE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FILE TYPEC*C*2 AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :,C* GET THE TYPE OF THE FILE 'IUNIT'C*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUMENTS :3C* FTYPE - THE FILE TYPE INCLUDING THE DOTC*C* INTERNAL WORK AREAS :<C* WORK - TEMPORARY VARIABLE TO HOLD FULL FILE NAMEC*3C* FILE REFERENCES :C* IUNITC*C* ERROR PROCESSING :2C* FTYPE WILL BE ' ' IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSION=C* 14-OCT-87 MODIFIED TO INCLUDE DOT IN FILE TYPE.C* 29-JUN-90 MODIFIED TO USE PARSEC*HC***********************************************************************C* CHARACTER *(*) FTYPE CHARACTER *127 WORKC FTYPE = ' '/ INQUIRE (UNIT=IUNIT, NAME=WORK, ERR=1000)+ CALL PARSE (WORK, ' ', 'TYPE', FTYPE) 1000 RETURN ENDCC---END GETFTYPECww5C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :/C* GET THE VERSION NUMBER OF THIS FILEC*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUMENTS :2C* FVERS - THE VERSION NUMBER OF THE FILE%C* INCLUDING THE ';'C*C* INTERNAL WORK AREAS :6C* WORK - VAR6IABLE TO HOLD THE FULL FILE SPECC*C* FILE REFERENCES :C* IUNITC*C* ERROR PROCESSING :4C* FVERS WILL BE BLANK IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSIONBC* 14-OCT-87 MODIFIED TO INCLUDE SEMI COLON IN VERSION.C* 29-JUN-90 MODIFIED TO USE PARSEC*HC***********************************************************************C* CHARACTER *(*) FVERS CHARACTER *127 WORKC FVERS = ' '- INQUIRE (UNIT=IUNIT,NAME=WORK,ERR=1000). CALL PARSE (WORK, ' ', 'VERSION', FVERS) 1000 RETURN ENDCC---END GETFVERSCww8襚( SUBROUTINE GETIME ( TOTAL, DELTA )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET TIMEC*C* AUT9HOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :9C* EXTRACT TOTAL CPU TIME (SINCE CALL TO SETIME):C* AND DELTA CPU TIME (SINCE LAST CALL TO GETIME)=C* NOTE: CPU TIMES ARE ONLY ACCURATE TO 1/100 SECONDC*C* OUTPUT ARGUMENTS :"C* TOTAL - TOTAL CPU TIME"C* DELTA - DELTA CPU TIMEC*C* SUBPROGRAM REFERENCES :C* : LIB$STAT_TIMERC*%C* TRANSPORTABILITY LIMITATIONS :.C* USES SYSTEM ROUTINE LIB$STAT_TIMERC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 17-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* SAVE OLDC# CALL LIB$STAT_TIMER(2,ITIME,) TOTAL = 0.01*FLOAT(ITIME) DELTA = TOTAL-OLD OLD = TOTAL RETURN ENDCC---END GETIMECww<pU襚4 SUBROUTINE GETLIN ( NREAD, ERROR, LINE, LENG )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETLIN **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET LINEC*=C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :HC* READ ONE OR MORE LINES OF INPUT, CAPITALIZE, DELETE COMMENTSAC* AND CONTINUE READING IF CONTINUATION SPECIFIED (...).C*C* INPUT ARGUMENTS :1C* NREAD - UNIT FROM WHICH TO READ INPUTC*C* OUTPUT ARGUMENTS :DC* ERROR - AN ERROR OR EOF WAS ENCOUNTERED DURING I>NPUT, OR(C* INPUT WAS TOO LONG.CC* LINE - THE CHARACTER*500 VARIABLE CONTAINING THE LINE.:C* LENG - NUMBER OF CHARACTERS RETURNED IN LINE.C*C* INTERNAL WORK AREAS :BC* STRING - 132 CHARACTER BUFFER FOR READS FROM TERMINAL.C*C* FILE REFERENCES :C* NREADC*C* SUBPROGRAM REFERENCES :C* CAPSC*C* ERROR PROCESSING :DC* THE LINE LENGTH IS NOT ALLOWED TO EXCEED 500 CHARACTERS.C*C* LANGU?AGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 3-OCT-84 INITIAL VERSION5C* 10-MAY-88 LENGTH OF LINE MADE VARIABLE2C* 5-JUL-89 ALLOWED ZERO LENGTH LINESC*HC***********************************************************************C* CHARACTER *(*) LINE CHARACTER *132 STRING LOGICAL ERROR, CONTC ERROR = .FALSE. LENG = 1 LINE = ' ' LMAX = LEN(LINE)C&C --- WHILE @CONTINUE FLAG IS SET DO...C410 READ ( NREAD, 900, END=1000, ERR=1000 ) STRING CALL CAPS ( STRING ) JJ = LENGTH ( STRING ) IF (JJ .EQ. 0) THEN LENG = 0 RETURN ENDIF DO 20 J = 1, JJC5C ------ EXCLAMATION MEANS REST OF LINE IS COMMENTARYC, IF ( STRING(J:J) .EQ. '!' )GO TO 30' IF (LENG .GT. LMAX) GO TO 1000& LINE(LENG:LENG) = STRING(J:J) LENG = LENG + 120 CONTINUE LENG = LENG - A130 CONT = .FALSE.C*C --- CHECK FOR CONTINUATION ( ELLIPSES ).C* IF ( LINE(LENG:LENG) .EQ. '.' ) THEN I1 = LENG - 1) IF ( LINE(I1:I1) .EQ. '.' ) THENC9C --- ELLIPSES FOUND, REMOVE IT AND SET CONTINUATION FLAGC CONT = .TRUE.40 LENG = LENG - 1? IF ((LINE(LENG:LENG) .EQ. '.') .AND. (LENG .GT. 1)) $ GO TO 40 ENDIFC*C --- ADD ONE SPACE AT THE END OF THE LINEC! IF (LENG .LT. LMAX) THEN LENG = LENG + 1! LINE(LENG:LENG) = ' ' LENG = LENG + 1 ENDIF ENDIF IF (CONT) GO TO 10CC --- END OF DO WHILEC RETURN1000 ERROR = .TRUE. RETURN900 FORMAT ( A ) ENDCC---END GETLINCwwCρ) logical function is_password (u, p) C*3C* ********************************3C* ********************************3C* ** ** 3C* ** Is_Password ** 3C* ** ** 3C* ********************************3C* ********************************C*C* AUTHOR :C* Arthur E. Ragosta (C* D RAGOSTA@MERLIN.ARC.NASA.GOV C* C* MS 219-1%C* NASA Ames Research CenterR*C* Moffett Field, Ca. 94035-1000C* (650) 604-5558C*C* DESCRIPTION :FC* Verifies that the password entered is the correct passwordC* for that userC*C* INPUT ARGUMENTS :&C* u - character*(*) Username&C* p - character*(*) PasswordC*C* OUTPUT ARGUMENTS : BC* function value = .true. for correct passEword, .false. (C* otherwiseC*C* LANGUAGE AND COMPILER :C* DEC FORTRAN 77C*C* CHANGE HISTORY :T+C* 19-MAR-1998 - INITIAL VERSIONEAC* 26-JUN-1998 - Ported to VAX - no INTEGER *8 ! - leg-C*HC***********************************************************************C* character *(*) u,p integer *8 p1, p2, p3Oc VAX code - leg%c integer *4 p1(2), p2(2), p3(2)R integer *2 saltI integer sys$haFsh_password  byte encrHcC call caps(p) call left(p) call caps(u) call left(u)c + call get_pass (u, p1, p2, salt, encr) c < istat = sys$hash_password (p(1:length(p)), %val(encr),' $ %val(salt), u(1:length(u)), p3) c  if (.not. istat) then  is_password = .false. else# is_password = (p1 .eq. p3) c VAX code - legGc is_password = ( (p1(1) .eq. p3(1)) .and. (p1(2) .eq. p3(2)) ) endifOcT return end CC---END Is_Password C wwLER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 3-OCT-84 INITIAL VERSION?C* 4-NOV-85 FIXED TO ALLOW NUMBERS STARTING WITH .3C* 25-MAR-86 COLON REMOVED AS DELIMITER<C* 20-MAY-87 ERROR IN END OF LINE HANDLING FIXED9C* 25-JUN-87 FIXED TO ALLOW LOWERCASE LETTERS+C* IN 'A' TYPE TOKENSFC* 10-MAY-88 TOKEN CHANGED TO CHARACTER *(*)HUT ARGUMENTS :IC* iyear - The year (note: 2 digits defaults to current century)*C*C* OUTPUT ARGUMENTS :1C* leap_year - .true. if its a leap yearEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :r+C* 4-NOV-1992 - INITIAL VERSION DC* 27-JUL-1998 - Modified to correctly use 4 digit years;AC* now uses rules described above - LEG C*HC*********************************************I**************************C*cOc --- old codec *c itwo = iyear - (100*int(iyear/100)),c leap_year = (int(itwo/4)*4 .eq. itwo) if (iyear .lt. 100) thenc5-c --- two digits passed - use current century cs call thiscent (icent)0 iyear = icent + iyear endif c c --- is it a leap year?c.) if ( mod(iyear, 1000) .eq. 0 ) thennc #c --- millenium year IS a leap year c0 leap_year = .true. - else if ( mod(iyJear, 100) .eq. 0 ) then c )c --- full century year - NOT a leap yearocr leap_year = .false.+ else if ( mod(iyear, 4) .eq. 0 ) thenucic --- "regular" leap year cL leap_year = .true. elsecRc --- all others NOTcT leap_year = .false. endifScS RETURN900 format(i4) END*C C---END Leap_yearC ww 4-NOV-1992 - INITIAL VERSION.DC* 27-JUL-1998 - Modified to correctly use 4 digit years;AC* K now uses rules described above - LEG(C*HC***********************************************************************C* character *23 cdateT character *4 cyear integer *4 idate(2)Rcc --- old codec'*c itwo = iyear - (100*int(iyear/100)),c leap_year = (int(itwo/4)*4 .eq. itwo) if (iyear .lt. 100) thencE-c --- two digits passed - use current centuryOcL istat = sys$gettim (idate) ! get system date/timeH L istat = sys$asctim ( , cdate, idate(1) , ) ! convert to asciiH cyear = cdate(8:11) ! extract the yearJ read(cyear,900) nyear ! convert to integerG icent = nyear / 100 ! get the century J iyear = (icent*100) + iyear ! add to year passed endif cLc --- is it a leap year?cH) if ( mod(iyear, 1000) .eq. 0 ) then c #c --- millenium year IS a leap yearc   leap_year = .true.=- else if ( mod(iyear, 100) .eq. 0 ) then cP)c --- full century year - NOT a leap yearLc  leap_year = .false.+ else if ( mod(iyear, 4) .eq. 0 ) thenIc:c --- "regular" leap yearc  leap_year = .true.D elsecHc --- all others NOTc leap_year = .false. endifEc' RETURN900 format(i4) ENDKC)C---END Leap_year C ww(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR N)) SUBROUTINE CLEANSE_DATE ( IN, OUT ) C*3C* CLEANUP A TIME/DATE STRING AND MAKE IT STANDARDIC*C* VALID FORMATS:C* MM/DD/YYC* MM/DD/YYYYC* DD[-]MMM[-]YYLC* DD[-]MMM[-]YYYY91C* DD-MMM-YYYY[:]HH:MM:SS.CC (OUTPUT FORMAT) C* MMM DD[,] YYC* MMM DD[,] YYYY C* "TODAY" C* "TOMORROW"C* "YESTERDAY"C* C* NOTES:FC* ALL STRINGS OF FORM "HH:MM:SS.CC" MAY BE SHORTENED ON THE RIGHT.MC* STRINGS CONTAINING HOURS, BUT NO DATE OMEAN TODAY AT THE SPECIFIED HOUR.I)C* OUT MUST BE AT LEAST CHARACTER *23.EC* C* CHANGE HISTORY:IBC* 30-JUL-1998 - Modified to use current century when passed a &C* 2-digit year - legAC* 26-JUN-90 - CHANGED YESTERDAY TO MIDNIGHT+; fixed bug in $C* repeated callsC* CHARACTER *(*) IN, OUT" CHARACTER *23 TEMP, ONE_DAY  CHARACTER *11 HOUR CHARACTER *9 MONTHS(12)G CHARACTER *3 MON CHARACTER *2 DAY PCHARACTER *4 YEAR 4 INTEGER IDATE(2), JDATE(2), SYS$BINTIM, BLANKS LOGICAL MATCH, MAT, AMBIGNB DATA MONTHS / 'JANUARY', 'FEBRUARY', 'MARCH', 'APRIL',F $ 'MAY', 'JUNE', 'JULY', 'AUGUST', 'SEPTEMBER',+ $ 'OCTOBER', 'NOVEMBER', 'DECEMBER'/.C' TEMP = IN90 IF (BLANKS ( TEMP ) .EQ. 0) TEMP = 'TODAY' CALL CAPS ( TEMP )C C --- TODAY C $ IF ( MATCH(TEMP,'TODAY')) THEN# CALL LIB$DATE_TIME ( OUT ) C C --- YESTERQDAY OR TOMORROW(C.- ELSE IF ((MATCH(TEMP,'YESTERDAY')) .OR.E- $ (MATCH(TEMP,'TOMORROW'))) THENT$ CALL LIB$DATE_TIME ( TEMP )" ONE_DAY = '1 00:00:00.00', ISTAT = SYS$BINTIM (ONE_DAY, JDATE)) ISTAT = SYS$BINTIM (TEMP, IDATE) % IF (TEMP(1:1) .EQ. 'Y') THENRB ISTAT = LIB$SUB_TIMES (IDATE, JDATE, IDATE) ! YESTER ELSEDA ISTAT = LIB$ADD_TIMES (JDATE, IDATE, IDATE) ! TOMORO ENDIF2 ISTAT =R LIB$FORMAT_DATE_TIME (OUT, IDATE)H OUT(13:) = '00:00:00.01' ! START OF DAYC C --- DATE/TIME SPECIFIED CH ELSEC /C ----- EACH PART DEFAULTS TO CURRENT DATE/TIMETC' CALL LIB$DATE_TIME ( ONE_DAY )O DAY = ONE_DAY(1:2)  MON = ONE_DAY(4:6)R YEAR = ONE_DAY(8:11)T HOUR = ONE_DAY(13:23)CT"C ----- "MM/DD/YY" OR "MM/DD/YYYY"C ) IF (INDEX(TEMP,'/') .NE. 0) THENG IS = INDEX(TEMP,'/')  IF (IS .LT. 3) THEN=' READ(TEMP,900,ERR=100) IN ELSE' READ(TEMP,910,ERR=100) IE ENDIF I = MIN0(12,I) I = MAX0(1,I)R MON = MONTHS(I)(1:3)( ISS = INDEX(TEMP(IS+1:),'/') IF (ISS .GT. 1) THEN# IF (ISS .LT. 3) THEN'5 READ(TEMP(IS+1:IS+1),900,ERR=100) I ELSEN5 READ(TEMP(IS+1:IS+2),910,ERR=100) I Tw襚# SUBROUTINE GETPRV ( N, PRIV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETPRV **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET PRIVILEGESC*C* AUUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :BC* TO CHECK THE PRIVILEGES ALLOWED BY THE SYSUAF FILE AND&C* RETURN THEM IN ASCII FORM.C*C* OUTPUT ARGUMENTS :2C* N - THE NUMBER OF PRIVILEGES FOUNDDC* PRIV - THE ARRAY CONTAINING THE NAMES OF THE PRIVILEGESC*C* INTERNAL WORK AREAS :;C* MASK1, MASK2 - THEV MASK BITS FOR THE PRIVILEGESIC* ALL1, ALL2 - THE ASCII NAMES CORRESPONDING TO MASK1 AND MASK2C*C* SUBPROGRAM REFERENCES :'C* JPI$_AUTHPRIV, SYS$GETJPIWC*%C* TRANSPORTABILITY LIMITATIONS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 12-APR-85 INITIAL VERSIONC*HC***********************************************************************C* INCLUDE W'($JPIDEF)' CHARACTER *(*) PRIV(1)% CHARACTER *10 ALL1(32), ALL2(7) INTEGER *2 ITEM(2)8 INTEGER *4 MASK1(32), MASK2(7), ITMLST(4), QUAD(2)% EQUIVALENCE (ITEM(1),ITMLST(1))C+C --- PRIVILEGE NAMES IN THE FIRST QUADWORDC? DATA ALL1 / 'ACNT ', 'ALLSPOOL ', 'BUGCHK ',? $ 'BYPASS ', 'CMEXEC ', 'CMKRNL ', 'DETACH ',? $ 'DIAGNOSE ', 'EXQUOTA ', 'GROUP ', 'GRPNAM ',? $ 'LOG_IO ', 'MOUNT ', 'NETMBX X ', 'OPER ',? $ 'PFNMAP ', 'PHY_IO ', 'PRMCEB ', 'PRMGBL ',? $ 'PRMMBX ', 'PSWAPM ', 'SETPRI ', 'SETPRV ',? $ 'SHARE ', 'SHMEM ', 'SYSGBL ', 'SYSLCK ',? $ 'SYSNAM ', 'SYSPRV ', 'TMPMBX ', 'VOLPRO ', $ 'WORLD '/C-C --- PRIVILEGE NAMES IN THE SECOND QUAD WORDC? DATA ALL2 / 'DOWNGRADE ', 'GRPPRV ', 'PRMJNL ',? $ 'READALL ', 'SECURITY ', 'TMPJNL ', 'UPGRADE '/C'C --- YMASK BITS FOR THE FIRST QUAD WORDC; DATA MASK1 / 512, 16, 8388608,6 $ 536870912, 2, 1, 32,5 $ 64, 524288, 256, 8,: $ 128, 131072, 1048576, 262144,< $ 67108864, 4194304, 1024, 16777216,9 $ 2048, 4096, 8192, 16384,> $ -2147483648, 134217728, 33554432, 1073741824,; $ 4, 268435456, 32768, Z 2097152, $ 65536 /C(C --- MASK BITS FOR THE SECOND QUAD WORDC6 DATA MASK2 / 2, 4, 32,6 $ 8, 64, 16, 1 /C N = 0CC --- FILL ITMLSTC ITEM(1) = 8 ITEM(2) = JPI$_AUTHPRIV! ITMLST(2) = %LOC( QUAD(1) ) ITMLST(3) = 0 ITMLST(4) = 00 ISTAT = SYS$GETJPIW ( ,,, ITMLST, IOSB,, )C%C --- PROCESS FIRST WORD OF QUAD WORDC DO 10 I = 1,322  IF ((QUAD(1) .AND. MASK1(I)) .NE. 0) THEN N = N + 1 PRIV(N) = ALL1(I) ENDIF10 CONTINUEC&C --- PROCESS SECOND WORD OF QUAD WORDC DO 20 I = 1,72 IF ((QUAD(2) .AND. MASK2(I)) .NE. 0) THEN N = N + 1 PRIV(N) = ALL2(I) ENDIF20 CONTINUE RETURN ENDCC---END GETPRVCww \y襚; SUBROUTINE GETSTM ( NREAD, STMT, LENST, CLABEL, EOF )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETSTM **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET ]STATEMENTC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :>C* RETRIEVE THE NEXT, FULL FORTRAN STATEMENT. GETSMT4C* DOES NOT RETURN BLANK CARDS OR COMMENTS.C*C* INPUT ARGUMENTS :?C* NREAD - LOGICAL UNIT NUMBER ASSIGNED TO SOURCE CODEC*C* OUTPUT ARGUMENTS :6C* STMT - THE STATEMENT (MINUS BLANKS, TABS)^"C* LENST - LENGTH OF STMTC*C* SUBPROGRAM REFERENCES :(C* MLIB_GETCRD, LENGTH, CAPITALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 10/13/83 INITIAL VERSION)C* 01/24/84 CONVERTED TO VAXEC* 09/15/86 MODIFIED TO NOT REMOVE BLANKS FROM CHARACTER"C* STRINGSAC* 04/26/88 CLEANED UP FOR MERLIB. FIXED ! HANDLING.4C* 07/11/88 ADDED D_EC TAB SOURCE FORMAT@C* 08/14/90 REMOVED UNUSED VARIABLED "CAP" AND "LS"C*HC***********************************************************************C* PARAMETER (LC=72) CHARACTER *(*) STMT CHARACTER *(LC) CARD CHARACTER *5 CLABEL LOGICAL NOT_INIT, EOF SAVE NOT_INIT, CARD DATA NOT_INIT/.TRUE./CAC --- FIRST TIME THROUGH WE WON'T HAVE A LOOK-AHEAD CARD, GET ONEC IF ( NOT_INIT ) THEN EOF = .FALSE.. C`ALL MLIB_GETCRD ( NREAD, CARD, EOF ) NOT_INIT = .FALSE. ENDIFC5 STMT = ' ' IPTR = 1 CLABEL = CARD(1:5)CBC --- COPY ONLY NON-BLANK CHARACTERS, EXCEPT FOR CHARACTER STRINGSC10 I = 7C13 IF ((CARD(I:I) .NE. '''') .AND. (CARD(I:I) .NE. ' ') .AND.+ $ (CARD(I:I) .NE. CHAR(9))) THENF IF (CARD(I:I) .EQ. '!') THEN ! EXCLAMATION POINT COMMENT$ IF (IPTR .GT. 1) THEN GO TO 20 a ELSE5 CALL MLIB_GETCRD (NREAD, CARD, EOF) GO TO 5 ENDIF ENDIF# CALL CAPITAL(CARD(I:I))' STMT(IPTR:IPTR) = CARD(I:I) IPTR = IPTR + 1C#C --- QUOTED STRING COPIED VERBATIMC+ ELSE IF (CARD(I:I) .EQ. '''') THEN' STMT(IPTR:IPTR) = CARD(I:I) IPTR = IPTR + 1CBC --- CHARACTER STRING, COPY, INCLUDING BLANKS, UNTIL MATCHING "'"C 15 I = I b+ 1# IF (I .EQ. (LC+1)) THEN4 CALL MLIB_GETCRD ( NREAD, CARD, EOF )* IF (CARD(6:6) .EQ. ' ')THEN- CALL MLIB_ERROR(2,'GETSTM',@ $ 'Close quote missing on character string.') GO TO 30 ENDIF I = 7 ENDIF' STMT(IPTR:IPTR) = CARD(I:I) IPTR = IPTR + 1, IF(CARD(I:I) .NE. '''') GO TO 15 ENDIFCHC ----- NOTE: IF THcERE ARE TWO CONSECUTIVE QUOTES, THEY WILL BE TREATED1C ---- AS CONCATENATED STRINGS (WHICH IS RIGHT)C17 I = I + 1! IF (I .LE. LC) GO TO 13C6C --- CONTINUE COPYING IF THERE IS A CONTINUATION CARDC+20 CALL MLIB_GETCRD ( NREAD, CARD, EOF )& IF (CARD(6:6) .NE. ' ') GO TO 1030 LENST = IPTR-1 RETURN ENDCC---END GETSTMC1 SUBROUTINE MLIB_GETCRD ( NREAD, CARD, EOF )C*3C* *******************************3C* d *******************************3C* ** **3C* ** MLIB_GETCRD **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET CARDC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035eC* (415) 604-5558C*C* PURPOSE :/C* RETRIEVE THE NEXT NON-COMMENT CARD.C*C* INPUT ARGUMENTS :?C* NREAD - THE LOGICAL UNIT NUMBER FOR THE SOURCE CODEFC* EOF - TRUE IF AN END OF FILE WAS ENCOUNTERED ON PREVIOUSC* READC*C* OUTPUT ARGUMENTS :2C* EOF - TRUE IF AN END OF FILE OCCURRED C* CARD - THE CARD READC*C* FILE REFERENCES :C* NREADC*C* SUBPROGRAM REFERENCES :C* f UNTAB, MLIB_ERRORC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 10/13/83 INITIAL VERSION$C* 01/24/84 VAX VERSION7C* 12/26/84 SAVE AND RESTORE OPTIONS ADDED/C* 04/26/88 GENERALIZED FOR MERLIBDC* 02/26/90 ADDED MORE COMPLETE DEC TAB SOURCE CHECKINGC*HC***********************************************************************C* PARAMETER (LC=72) CHARACTER g*(LC) CARD CHARACTER *5 BLANKS CHARACTER *1 C DATA BLANKS /' '/ LOGICAL EOFC IF (EOF) CALL MLIB_ERROR@ $ (3,'GETCRD','Attempt to read past end of file.')'10 READ ( NREAD, 900, END=100 ) CARDC"C --- SKIP COMMENT AND BLANK CARDSC= IF ((CARD(1:1) .EQ. 'C') .OR. (CARD(1:1) .EQ. '*') .OR.B $ (CARD(1:1) .EQ. 'c') .OR. (CARD(1:1) .EQ. '!')) GO TO 10C/C --- CHECK FOR VAX FORTRAN 'D_LINES' EXTENSIONC9 IF ((CARD(h1:1) .EQ. 'D') .OR. (CARD(1:1) .EQ. 'd')) $ CARD(1:1) = ' 'C"C --- CHECK FOR VAX TAB EXTENSIONSC I = INDEX(CARD,CHAR(9))+ IF ((I .GT. 0) .AND. (I .LT. 6)) THEN+ IF ((CARD(I+1:I+1) .GE. '1') .AND.+ $ (CARD(I+1:I+1) .LE. '9')) THENCC --- CONTINUATIONC IF (I .EQ. 1) THEN, CARD = ' $' // CARD(I+2:) ELSEE CARD = CARD(1:I-1) // BLANKS(I:5) // '$' // CARD(I+2:) ENDIF i ELSECC --- REGULAR STATEMENTC IF (I .EQ. 1) THEN, CARD = ' ' // CARD(I+1:) ELSEE CARD = CARD(1:I-1) // BLANKS(I:5) // ' ' // CARD(I+1:) ENDIF ENDIF ELSE IF (I .EQ. 6) THEN CARD(6:6) = ' ' ENDIFCC --- DON'T RETURN BLANK CARDSC! IF (CARD .EQ. ' ') GO TO 10C7C --- CHECK IF FIRST NON-BLANK CHARACTER ON CARD IS '!'C CALL FIRST (CARD, C, I) IF ( C .EQ. '!') GO TO 10 RETURNC100 EOF = .TRUE. CARD = ' ' RETURN900 FORMAT ( A ) ENDCC---END MLIB_GETCRDCwwk襚# SUBROUTINE GETSTRING (STRING)C*3C* *******************************3C* *******************************3C* ** **3C* ** GETSTRING **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GETSTRINGC*C* AUTHOlR :C* Arthur E. RagostaC* MS 219-1%C* NASA Ames Research Center*C* Moffett Field, Ca. 94035-1000C* (415) 604-5558C*C* PURPOSE :HC* TO RETRIEVE A STRING FROM A TERMINAL, WITHOUT WORRYING ABOUTEC* WHETHER A CARRIAGE RETURN WAS TYPED OR NOT. END WITH ^Z.C*C* OUTPUT ARGUMENTS :(C* STRING - THE STRING RETURNEDC*C* SUBPROGRAM REFERENCES :2C* SYS$ASSIGN, SYS$QIOW, LIB$PUT_OUTPUTC*%mC* ASSUMPTIONS AND RESTRICTIONS :'C* NOT EVEN REMOTELY PORTABLE.4C* RESTRICTEED TO 2000 CHARACTERS PER LINE.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 27-NOV-1987 - INITIAL VERSION:C* 10-MAY-1988 - MODIFIED TO USE LIB$PUT_OUTPUT5C* 29-JUN-1990 - FIXED HIGHLIGHT ON "EXIT"5C* 23-NOV-1992 - SWITCHED TO LIB$GET_INPUTC*HC***********************************************************************C* INCLUDE '($RMSDEF)' CHARACTER *(*) STRING CHARACTER *2000 STRC STRING = ' ' LS = 1CC --- READ ONE LINEC*10 ISTAT = LIB$GET_INPUT ( STR,, LSTR )# IF (ISTAT .NE. RMS$_EOF) THEN3 IF (LSTR .GE. 1) STRING(LS:) = STR(1:LSTR) LS = LS + LSTR GO TO 10 ENDIF RETURN ENDCC---END GETSTRINGCww os 饚' SUBROUTINE GETTERM ( USER, TERM )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETTERM **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :&C* GET TERMINAL NAME FOR USpERC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*C* PURPOSE :HC* CHECK TO SEE IF A USER IS LOGGED ON INTERACTIVELY, AND IF SO%C* RETURN THE TERMINAL NAME.C*C* INPUT ARGUMENTS :(C* USER - THE NAME OF THE USERC*C* OUTPUT ARGUMENTS :3C* TERM - THE TERMINAL NAME (EG, 'TTA0' )C*%C* TRANSPORTABILITY LIMITATIONqS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 12-APR-85 INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' CHARACTER *(*) USER, TERM INTEGER *2 ITEM(2)# INTEGER *4 ITMLST(4), IOSB(2)% EQUIVALENCE (ITEM(1),ITMLST(1))C%C --- USE GETJPI TO GET TERMINAL NAMEC ITEM(1) = 8 ITEM(2) = JPI$_TERMINAL ITMLST(2) = %LOC( TERM ) ITMLST(3) = 0 ITMLST(4) = 0G ISTAT = SYS$GETJPIW ( ,,USER(1:LENGTH(USER)), ITMLST, IOSB,,)/ IF ( IOSB(1) .NE. SS$_NORMAL ) TERM = ' 'C RETURN ENDCC---END GETTERMCww DE륚 .title lower;; Author: Arthur E. Ragosta;+; Make all capital characters lower case.R;S$; STRING = 'This Is A String.'; CALL LOWER ( STRING )S; +; Results in STRING = 'this is a string.'E;A .entry lower,^m<>9 movl 4(ap),r1 ;loc of descriptor to r1. movzwl (r1),r0 ;length to r05 subl3 #1,4(r1),r1 ;location(-1) to r1loop: cmpb (r1)[r0],#64# bleq next ;Less than "tHC饚! SUBROUTINE GETUSER ( USER )IC*3C* ********************************3C* ********************************3C* ** ** 3C* ** GETUSER ** 3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM :RC* GET USER NAMEEC*C* AUTuHOR :AC* ART RAGOSTAhC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :FC* RETRIEVE THE NAME OF THE USER ACCOUNT CALLING THIS ROUTINEC*C* OUTPUT ARGUMENTS :E'C* USER - THE NAME OF THE USERNC*C* SUBPROGRAM REFERENCES :C* SYS$GETJPIW C*%C* TRANSPORTABILITY LIMITATIONS :*(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :vC* ANSI FORTRAN 77*C*C* CHANGE HISTORY :*-C* 07-JUN-1985 INITIAL VERSION12c* 3-May-1991 Pad USER with blanksC*HC***********************************************************************C* INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' CHARACTER *(*) USER  INTEGER *2 ITEM(2)# INTEGER *4 ITMLST(4), IOSB(2)T% EQUIVALENCE (ITEM(1),ITMLST(1))_CEC --- FILL ITMLST$CD ITEM(1) = 12 ITEM(2) = JPI$_USE RNAME ITMLST(2) = %LOC( USER ) ITMLST(3) = %loc(luser) ITMLST(4) = 04 ISTAT = SYS$GETJPIW ( ,,, ITMLST, IOSB,, )C4 if (luser .lt. len(user)) user(luser+1:) = ' '3 IF ( IOSB(1) .NE. SS$_NORMAL ) USER = 'ERROR' RETURN ENDCC---END GETUSERwwx*$饚* SUBROUTINE GET_TERM_SIZE (WID, LENG)C*3C* *******************************3C* *******************************3C* ** **3C* ** GET_TERM_SIZE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET_TERM_SIZEC*C*y AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :6C* RETURN THE TERMINALS WIDTH AND PAGE LENGTHC*C* OUTPUT ARGUMENTS :#C* WID - WIDTH IN COLUMNS!C* LENG - LENGTH IN ROWSC*C* SUBPROGRAM REFERENCES :C* LIB$GETDVIC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* z LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 22-DEC-1987 - INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($SSDEF)' INCLUDE '($DVIDEF)' INTEGER WID C WID = 0 LENG = 0 ITEM = DVI$_DEVBUFSIZ, ISTAT = LIB$GETDVI (ITEM,,'TT:',WID,,) ITEM = DVI$_TT_PAGE- ISTAT = LIB$GETDVI (ITEM,,'TT:',LENG,,) RETURN ENDCC---END GET_TERM_SIZECww|拃S饚 SUBROUTINE GETXY (IX, IY)C*3C* *******************************3C* *******************************3C* ** **3C* ** GETXY **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET X,Y LOCATIONC*C* AUT}HOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :;C* TO RETRIEVE THE X AND Y LOCATION OF THE CURSOR.C*C* METHODOLOGY :(C* USE VT-100 CONTROL SEQUENCE.C*C* OUTPUT ARGUMENTS :9C* IX - THE COLUMN IN WHICH THE CURSOR RESIDES.6C* IY - THE ROW IN WHICH THE CURSOR RESIDES.LC* NOTE : (1,1) IS THE UPPER, L ~EFT-HAND CORNER OF THE SCREEN.C*C* SUBPROGRAM REFERENCES :C* PUTCHAR, GETCHARC*C* ERROR PROCESSING :IC* IF THE TERMINAL DOES NOT MAKE AN INTELLIGIBLE RESPONSE TO THEIC* QUERY, IX AND IY ARE SET TO ZERO; THIS MAY HAPPEN WHEN A USEREC* TRIES TO USE THESE ROUTINES ON A NON-VT100 TYPE TERMINAL.C*%C* TRANSPORTABILITY LIMITATIONS :9C* WORKS ONLY ON VT-100 OR COMPATIBLE TERMINALS.9C* USES NON-STANDARD VARIABLE SIZE FORMAT FIELDSC*%C* ASSUMPTIONS AND RESTRICTIONS :9C* THE TERMINAL MUST BE ASSIGNED TO 'SYS$INPUT'.C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSION;C* 10-MAY-88 REPLACE OLD CHARACTER I/O ROUTINESC*HC***********************************************************************C* CHARACTER *10 STRING CHARACTER *1 ESC BYTE C LOGICAL ER DATA ESC/27/C  IX = 0 IY = 0CC --- QUERY TERMINALC CALL PUTCHAR ( ESC//'[6n')CC --- GET TERMINAL'S RESPONSEC IS = 110 CALL GETCHAR ( C, ER ) STRING(IS:IS) = CHAR(C) IS = IS + 1C IF ((IS .LE. 10) .AND. (C .NE. 82) .AND. (.NOT. ER)) GO TO 10C3C --- DECODE THE TERMINAL RESPONSE ( [iy;ixR )C# I = INDEX ( STRING, '[' ) + 1# J = INDEX ( STRING, ';' ) - 1 IF (J .LT. I) RETURN READ (STRING(I:J), 920) IY I = J + 2 J = INDEX(STRING,'R') - 1 IF (J .LT. I) RETURN READ (STRING(I:J), 920) IX RETURN920 FORMAT ( I ) ENDC C---END GETXYCwwף\饚$ SUBROUTINE GET_DEFAULT (DIR_STRING)***D* Returns, in the character string DIR_STRING, the name of the cur-D* rent default device and directory. The string DIR_STRING must be>* long enough to contain the name, or this routine will abort.**1* Alan L. Zirkle Naval Surface Weapons Center* Code K105)* 9 Nov 1983 Dahlgren, Virginia 22448* IMPLICIT INTEGER (A-Z)C CHARACTER*(*) DIR_STRING LOGICAL ARG_EXISTC3 STATUS = SYS$TRNLOG('SYS$DI SK',LEN1,DIR_STRING,,,)- IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))C0 STATUS = SYS$SETDDIR(,LEN2,DIR_STRING(LEN1+1:))- IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))C LEN1 = LEN1 + LEN27 IF (LEN1.LT.LEN(DIR_STRING)) DIR_STRING(LEN1+1:) = ' ' ENDww O5|p饚D subroutine get_pass (user, password, password2, salt, encrypt)C*3C* *******************************3C* *******************************3C* ** **3C* ** Get_Pass **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* or.C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV C* C* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :FC* This routine retrieves the hashed password quadwords, SALT=C* value, and ENCRYPT value from the authorize file.C*C* INPUT ARGUMENTS :(C* USER - name of user accoutnC*C* OUTPUT ARGUMENTS :.C* PASSWORD - hashed primary password7C* PASSWORD2- hashed secondary password (or 0)!C* SALT - SALT value&C* ENCRYPT - encryption typeC*C* SUBPROGRAM REFERENCES :C* SYS$GETUAIC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT PORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 12-APR-1990 - INITIAL VERSIONC*HC***********************************************************************C* character *(*) user. integer*4 password(2), password2(2) integer*2 salt byte encryptc include '($UAIDEF)'c structure /itmlist/" integer*2 buffer_length integer*2 item_code# integer*4 buffer_address* integer*4 return_length_address end structure record /itmlist/ itmlst(5)c$ integer*4 status, sys$getuai! ! Build an itemlist for $GETUAI!I itmlst(1).buffer_length = 8 ! Hashed password$ itmlst(1).item_code = UAI$_PWD4 itmlst(1).buffer_address = %loc( password(1) )) itmlst(1).return_length_address = 0cF itmlst(2).buffer_length = 1 ! Encrypt type( itmlst(2).item_code = UAI$_ENCRYPT0 itmlst(2).buffer_address = %loc( encrypt )) itmlst(2).return_length_address = 0cD it mlst(3).buffer_length = 2 ! Salt value% itmlst(3).item_code = UAI$_SALT- itmlst(3).buffer_address = %loc( salt )) itmlst(3).return_length_address = 0cI itmlst(4).buffer_length = 8 ! Hashed password% itmlst(4).item_code = UAI$_PWD25 itmlst(4).buffer_address = %loc( password2(1) )) itmlst(4).return_length_address = 0cB itmlst(5).buffer_length = 0 ! All done itmlst(5).item _code = 0!(! Use $GETUAI to extract hashed password!0 status = sys$getuai ( ,, USER, itmlst,,, ) return endcc---end get_passcww AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :AC* TO POSITION THE CURSOR AT THE GIVEN X AND Y LOCATION.C*C* METHODOLOGY :'C* USE ANSI CONTROL SEQUENCES.C*C* INPUT ARGUMENTS :IC* IX - THE COLUMN LOCATION IN WHICH TO POSITION THE CURSOR.FC* IY - THE ROW LOCATION IN WHICH TO POSITION THE CURSOR.C*%C*  TRANSPORTABILITY LIMITATIONS :;C* WORKS ONLY WITH VT-100 OR COMPATIBLE TERMINALS..C* USES VARIABLE LENGTH FORMAT FIELDSC*%C* ASSUMPTIONS AND RESTRICTIONS :LC* IN ORDER FOR THE CURSOR TO MAINTAIN ITS LOCATION, THE NEXT WRITEJC* ISSUED AFTER A CALL TO GOTOXY MUST USE THE '+' FORMAT CONTROL;OC* OTHERWISE THE WRITE WILL START IN THE FIRST COLUMN OF THE NEXT ROW.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* IF (IX .LE. 0) IX = 1 IF (IX .GE. 133) IX = 80 IF (IY .LE. 0) IY = 1 IF (IY .GE. 66) IY = 24 M = 1 N = 1 IF (IX .GT. 9) M = 2 IF (IX .GT. 99) M = 3 IF (IY .GT. 9) N = 2 IS = 4 + M + N% CALL MLIB_GET ('NWRITE',NWRITE), WRITE ( NWRITE, 900 ) CHAR(27), IY, IX RETURN,900 FORMAT('+',A1,'[',I,';',I,'H',$) ENDww 7饚7 subroutine graf_xory (xory, array, narray, nunit)C*3C* *******************************3C* *******************************3C* ** **3C* ** GRAF_XORY **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM : C* SUBROUTINE GRAF_XORYC*C* AUTHOR :C* L JURGELEITC* MS 219-1 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*C* PURPOSE :AC* GIVEN A DATA ARRAY, WRITE IT OUT TO A FILE AS A GRAF C* X, OR Y, COMMAND.C*C* INPUT ARGUMENTS :+C* XORY - THE CHARACTER "X" OR "Y"%C* ARRAY - THE ARRAY OF DATA6C* NARRAY - THE NUMBER OF ELEMENTS IN "ARRAY"7C* NUNIT - THE LOGICAL UNIT NUMBER TO WRITE TOC*C* SUBPROGRAM REFERENCES :C* FIRSTC*$C* ASSUMPTIONS AND RESTRICTIONS:HC* THE LENGTH OF THE GRAF COMMAND IS LIMITED TO 4000 CHARACTERSC* (AS IN GRAF).C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 2-JUL-1991C*C* CHANGE HISTORY :+C* 2-JUL-1991 - INITIAL VERSIONC*HC***********************************************************************C*" parameter (mxlin=4000)  dimension array (narray) character *(mxlin) stmt character *20 temp character *1 xory, cc if (narray .le. 0) returncc Create the statementc stmt = xory // ' = ' ist = 5 do 10 i = 1, narray" write (temp,900) array(i)! call first (temp, c, il) ll = 20 - il + 1, stmt(ist:ist+ll) = temp(il:20)//',' ist = ist + ll + 110 continue ist = ist - 2cc --- Write it out in GRAF formc is = 1 ie = 7615 if (ie .gt. ist) then& write(nunit,910) stmt(is:ist) else'20 if (stmt(ie:ie) .ne. ',') then ie = ie - 1$ if (ie .gt. 10) go to 20 endif, write(nunit,910) stmt(is:ie)//'...' is = ie + 1 ie = is + 75 go to 15 endif return900 format (e20.5)910 format (' ',a) end ww š饚6 subroutine graf_xy (xarray, yarray, npts, nunit)C*3C* *******************************3C* *******************************3C* ** **3C* ** GRAF_XY **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SUBROUTINE GRAF_XYC*C* AUTHOR :C* L JURGELEITC* MS 219-1 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*C* PURPOSE :GC* GIVEN TWO DATA ARRAYS OF X AND Y POINTS, WRITE THEM OUT TO !C* AS A GRAF XY COMMAND.C*C* INPUT ARGUMENTS :&C* XARRAY - ARRAY OF X POINTS&C* YARRAY - ARRAY OF Y POINTS;C* NPTS - NUMBER OF POINTS CONTAINED IN THE ARRAYS7C* NUNIT - THE LOGICAL UNIT NUMBER TO WRITE TOC*C* SUBPROGRAM REFERENCES :C* FIRSTC*%C* ASSUMPTIONS AND RESTRICTIONS :;C* THE GRAF COMMAND IS LIMITED TO 4000 CHARACTERS C* (AS IN GRAF)C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 2-JUL-1991C*C* CHANGE HISTORY :+C* 2-JUL-1991 - INITIAL VERSIONC*HC***********************************************************************C*" parameter (mxlin=4000) , dimension xarray (npts), yarray (npts) character *(mxlin) stmt character *20 temp character *1 cc if (npts .le. 0) returncc Create the statementc stmt = 'xy = ' ist = 5 ix = 1 iy = 1 do 10 i = 1, npts*2/ if (amod (float(i),2.0) .ne. 0.0) then' write (temp,900) xarray(ix) ix = ix + 1 else' write (temp,900) yarray(iy) iy = iy + 1 endif! call first (temp, c, il) ll = 20 - il + 1- stmt (ist:ist+ll) = temp(il:20)//',' ist = ist + ll + 110 continue ist = ist - 2cc --- Write it out in GRAF formc is = 1 ie = 7615 if (ie .gt. ist) then& write(nunit,910) stmt(is:ist) else'20 if (stmt(ie:ie) .ne. ',') then ie = ie - 1$ if (ie .gt. 10) go to 20 endif , write(nunit,910) stmt(is:ie)//'...' is = ie + 1 ie = is + 75 go to 15 endif return900 format (e20.5)910 format (' ',a) end ww $X饚A SUBROUTINE graf_z (nxpts, nypts, mxpts, mypts, zmat, nunit)C*3C* *******************************3C* *******************************3C* ** **3C* ** GRAF_Z **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* L JURGELEITC* MS 219-1 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*C* DESCRIPTION :@C* OUTPUT A MATRIX OF Z DATA VALUES AS A GRAF Z COMMANDC*C* INPUT ARGUMENTS :+C* NXPTS = NUMBER OF X DATA POINTS+C* NYPTS = NUMBER OF Y DATA POINTS.C* MXPTS = ACTUAL X DIMENSION OF ZMAT.C* MYPTS = ACTUAL Y DIMENSION OF ZMATEC* ZMAT = MATRIX OF Z VALUES CORRESPONDING TO EACH X,Y POINT7C* NUNIT = THE LOGICAL UNIT NUMBER TO WRITE TOC*C* SUBPROGRAM REFERENCES :C* FIRSTC*%C* ASSUMPTIONS AND RESTRICTIONS :7C* GRAF COMMAND IS LIMITED TO 4000 CHARACTERS C* (AS IN GRAF)C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 2-JUL-1991 - INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (MXLIN=4000)# DIMENSION ZMAT (MXPTS, MYPTS) CHARACTER *(MXLIN) STMT CHARACTER *20 TEMP CHARACTER *2 NUM  CHARACTER *1 CC DO 10 I = 1, NXPTS WRITE (NUM,900) I! STMT = 'Z('//NUM//') = ' IST = 9 DO 20 J = 1,NYPTS& WRITE (TEMP,910) ZMAT(J,I)" CALL FIRST (TEMP,C,II) LL = 20 - II + 11 STMT (IST:IST+LL) = TEMP (II:20)//',' IST = IST + LL + 120 CONTINUE  IST = IST - 2cc --- Write it out in GRAF formc is = 1 ie = 7615 if (ie .gt. ist) then) write(nunit,920) stmt(is:ist) else*25 if (stmt(ie:ie) .ne. ',') then ie = ie - 1' if (ie .gt. 10) go to 25 endif/ write(nunit,920) stmt(is:ie)//'...' is = ie + 1 ie = is + 75 go to 15 endif10 CONTINUE RETURN900 FORMAT (I2)910 FORMAT (E20.5)920 FORMAT (' ',A) ENDCC---END graf_zCww*饚 SUBROUTINE GRALFAC*3C* *******************************3C* *******************************3C* ** **3C* ** GRALFA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :*C* GRAPHON TERMINAL TO ALPHA MODEC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :6C* TO RETURN A GRAPHON TERMINAL TO TEXT MODE.C*C* FILE REFERENCES :C* NWRITEC*%C* ASSUMPTIONS AND RESTRICTIONS :0C* WORKS ONLY ON GRAPHON 140 TERMINALS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 22-FEB-8 5 INITIAL VERSIONC*HC***********************************************************************C*$ CALL MLIB_GET('NWRITE',NWRITE) WRITE(NWRITE,900) CHAR(27) RETURN900 FORMAT(' ',A1,'2') ENDCC---END GRALFACww –饚@ subroutine hash_pass ( user, pass, hashed, salt, encrypt )C*3C* *******************************3C* *******************************3C* ** **3C* ** Hash_pass **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* or.C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV C* C* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :GC* This routine uses the VMS 5.x password hashing algorithm to;C* convert a password in ASCII form to a quadword.C*C* INPUT ARGUMENTS :#C* USER - the user name-C* PASS - the password to encryptJC* SALT - the SALT value from the authorize file (or GET_PASS)?C* ENCRYPT - the ENCRYPT value from the authorize file+C* (or GET_PASS)C*C* OUTPUT ARGUMENTS :6C* HASHED - the quadword encrypted password.C*C* SUBPROGRAM REFERENCES :C* LGI$HPWD, LENGTHC*%C* ASSUMPTIONS AND RESTRICTIONS :C* get realC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 12-APR-1990 - INITIAL VERSIONC*HC***********************************************************************C* include '($UAIDEF)' character *(*) user, pass integer hashed(2) integer *2 salt byte encrypt integer passout(2)c passout(1) = 8 passout(2) = %loc(hashed) lu = 12; if (encrypt .ne. %loc(uai$c_purdy)) lu = length(user)cF istat = lgi$hpwd ( passout, pass(1:length(pass)), %val(encrypt), $ %val(salt), user(1:lu)) return endcc---end hash_passcww}饚, LOGICAL FUNCTION HAS_PRIV (WHICH_PRIV)C*3C* *******************************3C* *******************************3C* ** **3C* ** HAS_PRIV **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* USER HAS PRIVILEGEC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5578C*C* PURPOSE :6C* VERIFY THAT A USER HAS A CERTAIN PRIVILEGEC*C* INPUT ARGUMENTS ::C* WHICH_PRIV - WHICH PRIVILEGE SHOULD WE VERIFY?C*C* OUTPUT ARGUMENTS :JC* HAS_PRIV(FUNCTION VALUE) - .TRUE. IF HE'S GOT IT, ELSE .FALSE.C*C* SUBPROGRAM REFERENCES :C*  GETPRVC*%C* ASSUMPTIONS AND RESTRICTIONS :C8 NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 21-JUL-1988 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) WHICH_PRIV< CHARACTER *8 PRIVS(40) ! ACTUALLY 39 IN VMS 5.3C CALL GETPRV (N, PRIVS) DO 10 I = 1, N+ IF (PRIVS(I) .EQ. WHICH_PRIV) THEN  HAS_PRIV = .TRUE. RETURN ENDIF10 CONTINUE HAS_PRIV = .FALSE. RETURN ENDCC---END HAS_PRIVCww&饚- SUBROUTINE HELP ( LIBR, STRING, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** HELP **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* HELPC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :4C* TO INTERFACE WITH A VMS-FORMAT HELP FILE*C* FROM WITHIN A FORTRAN PROGRAM.C*C* METHODOLOGY :=C* CALL THE SYSTEM-SPECIFIC ROUTINE, LBR$OUTPUT_HELPC*C* INPUT ARGUMENTS :EC* LIBR - THE NAME OF THE LIBRARY HELP FILE TO BE SEARCHED.7C* STRING - THE PARAMETER TO THE HELP COMMAND.C*C* OUTPUT ARGUMENTS :IC* ERROR - A BOOLEAN FLAG WHISH IS SET TRUE IF THERE WAS TROUBLE,C* COMPLETING THE REQUEST.C*C* SUBPROGRAM REFERENCES :;C* LBR$OUTPUT_HELP, LIB$PUT_OUTPUT, LIB$GET_OUTPUTC*C* ERROR PROCESSING :8C* CHECK THE STATUS RETURNED BY LBR$OUTPUT_HELPC*%C* TRANSPORTABILITY LIMITATIONS :'C* USES VMS-SPECIFIC ROUTINES.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 12-SEP-84 INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($SSDEF)', EXTERNAL LIB$PUT_OUTPUT, LIB$GET_INPUT! CHARACTER *(*) STRING, LIBR LOGICAL ERRORC< ERROR = (LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,STRING,LIBR,,/ $ LIB$GET_INPUT) .NE. SS$_NORMAL) RETURN ENDC C---END HELPCwwu|!쥚 SUBROUTINE MODE ( MTYPE )GC*3C* *******************************3C* ******************************* 3C* ** **R3C* ** MODE ** 3C* ** **3C* *******************************A3C* *******************************mC*C* SUBPROGRAM :IC* GET PROCESS MODEC*C* AUT!M饚% CHARACTER *2 FUNCTION HEX ( I )C*,C* CONVERT A BYTE TO THE HEX REPRESENTATIONC* CHARACTER *1 HX(0:15) DATA HX H $ /'0','1','2','3','4','5','6','7','8','9','A','B','C','D','E','F'/C J = I/16 HEX(1:1) = HX(J) J = I-16*J HEX(2:2) = HX(J) RETURN ENDC C---END HEXCwwR꥚ SUBROUTINE HEXDEC ( H, I )C*3C* *******************************3C* *******************************3C* ** **3C* ** HEXDEC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :"C* HEXADECIMAL TO DECIMALC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :DC* TO CONVERT A HEXADECIMAL STRING INTO THE DECIMAL INTEGER1C* EQUIVALENT TO THE HEXADECIMAL NUMBER.C*C* INPUT ARGUMENTS :&C* H - THE HEXADECIMAL STRINGC*C* OUTPUT ARGUMENTS :"C* I - THE INTEGER NUMBERC*%C* TRANSPORTABILITY LIMITATIONS :8C* USES THE NON-STANDARD 'Z' FORMAT DESCRIPTOR.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *8 HC CALL RIGHT (H) READ(H,900)I RETURN900 FORMAT(Z8) ENDCC---END HEXDECCwwG ꥚ .title icount;; Author: Arthur E. Ragosta;=; Count the number of occurences of a character in a string;?; IC = ICOUNT (',','This is a long, skinny, blue string.'); ! IC is 2.; .entry icount,^mG movl 4(ap),r1 ;location of character descriptor to r17 movb @4(r1),r1 ;character is now in r1D movl 8(ap),r2 ;location of string descriptor to r2- movzwl (r2),r3 ;length to r3. subl3 #1,4(r2),r2 ;address to r2+ clrl r0 ;zero count;LOOP: cmpb (r2)[r3],r1 ;the character in question?/ bneq next ;no... try next0 incl r0 ;Yes... count it/NEXT: sobgtr r3,loop ;next character ret .end ww ꥚( FUNCTION IDIGIT ( NUMBER, NDIGIT )C*3C* *******************************3C* *******************************3C* ** **3C* ** IDIGIT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* EXTRACT DIGITC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER#C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :9C* EXTRACT THE DIGIT 'NDIGIT' LOCATIONS FROM THE6C* RIGHT IN 'NUMBER'; E.G. IDIGIT(1234,3) = 2C*C* INPUT ARGUMENTS :;C* NUMBER - NUMBER FROM WHICH TO EXTRACT THE DIGIT;C* NDIGIT - LOCATION OF DIGIT FROM RIGHT IN NUMBERC*C* OUTPUT ARGUMENTS :(C* IDIGIT - THE DIGIT EXTRACTEDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 18-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* NUM = NUMBER IF ( NDIGIT .LT. 1 ) THEN NDIG = 1 ELSE NDIG = NDIGIT - 1 ENDIF DO 10 I = 1,NDIG NUM = NUM / 1010 CONTINUE IDIGIT = MOD (NUM, 10) RETURN ENDCC---END IDIGITCwwP(꥚+ subroutine image_name ( image, full ) include '($JPIDEF)' character *(*) image dimension itmlst(4) integer *2 item(8) integer sys$getjpiw equivalence (item,itmlst) logical fullc)c --- current image is a getjpi item codec item(1) = len(image) item(2) = jpi$_imagname itmlst(2) = %loc(image) itmlst(3) = %loc(li) itmlst(4) = 0c+ istat = sys$getjpiw ( ,,, itmlst,,, ) if (.not. istat) then image = ' ' else image(li+1:) = ' 'A if (.not. full) call parse ( image, ' ', 'NAME', image ) endif return endcc---end image_namecwwݣ4꥚2 SUBROUTINE INTRPL ( L, X, Y, N, U, V, IERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** INTRPL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* INTERPOLATEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER#C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* REFERENCE :<C* 'INTERPOLATION AND SMOOTH CURVE FITTING BASED ON=C* LOCAL PROCEDURES' BY H. AKIMA, COMMUNICATIONS OF1C* THE ACM, OCTOBER,1972, VOL. 15, #10.C*C* PURPOSE :=C* THIS SUBROUTINE INTERPOLATES A FUNCTION Y(X) FROM9C* A SET OF VALUES MONOTONICALLY INCREASING IN XC*C* INPUT ARGUMENTS :.C* L = NUMBER OF DATA POINTS ( >= 2 )5C* X = ARRAY OF X VALUES IN INCREASING ORDER!C* Y = ARRAY OF Y VALUES3C* N = NUMBER OF POINTS TO BE INTERPOLATED:C* U = ARRAY OF X LOCATIONS FOR OUTPUT (N VALUES)C*C* OUTPUT ARGUMENTS :1C* V = ARRAY OF INTERPOLATED Y VALUES"C* IERR = ERROR INDICATORC*C* ERROR PROCESSING :!C* IERR = 0 - NO ERROR$C* 1 - L TOO SMALL-C* 2 - N LESS OR EQUAL TO 0>C* 3 - X VALUES NOT MONOTONICALLY INCREASINGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 18-DEC-86 INITIAL VERSIONC*HC***********************************************************************C*& DIMENSION X(L), Y(L), U(N), V(N) REAL M1,M2,M3,M4,M5/ EQUIVALENCE (X2,A1,M1),(X5,A5,M5),(Q1,T3)4 EQUIVALENCE (J,SW,SA),(Y2,W2,W4,Q2),(Y5,W3,Q3)C IERR = 0CC --- CHECK VALIDITY OF INPUTC LO = L LM1 = LO - 1 LM2 = LM1 - 1 LP1 = LO + 1 IF ( LM2 .LT. 0 ) THEN IERR = 1 RETURN ENDIF IF ( N .LE. 0 ) THEN IERR = 2 RETURN ENDIF DO 11 I = 2, LO" IF(X(I-1) .GE. X(I)) THEN IERR = 3 RETURN ENDIF11 CONTINUE IPV = 0CC --- MAIN DO LOOPC DO 80 K = 1, N DX = U(K)C)C --- ROUTINE TO LOCATE THE DESIRED POINTC IF (LM2 .EQ. 0) THEN I = 2% ELSE IF (DX .GE. X(LO)) THEN I = LP1$ ELSE IF (DX .LT. X(1)) THEN I = 1 ELSE IMN = 2 IMX = LO21 I = (IMN + IMX)/2" IF (DX .LT. X(I)) THEN IMX = I ELSE IMN = I + 1 ENDIF& IF (IMX .GT. IMN) GO TO 21 I = IMX ENDIF! IF (I .EQ. IPV) GO TO 70 IPV = IC9C --- ROUTINES TO PICK UP NECESSARY X AND Y VALUES AND TO C --- ESTIMATE THEM IF NECESSARYC J = I IF (J .EQ. 1)J=2 IF (J .EQ. LP1)J=LO X3 = X(J-1) Y3 = Y(J-1) X4 = X(J) Y4 = Y(J) A3 = X4 - X3 M3 = (Y4 - Y3)/A3 IF (LM2 .EQ. 0) THEN M2 = M3 M4 = M3 GO TO 45 ENDIF IF (J .NE. 2) THEN X2 = X(J-2) Y2 = Y(J-2) A2 = X3 - X2 M2 = (Y3 - Y2)/A2 IF (J .EQ. LO) THEN M4 = 2*M3 - M2 GO TO 45 ENDIF ENDIF X5 = X(J+1) Y5 = Y(J+1) A4 = X5-X4 M4 = (Y5 - Y4)/A4# IF (J .EQ. 2) M2 = 2*M3-M445 IF (J .LE. 3) THEN M1 = 2*M2 - M3 ELSE A1 = X2 - X(J-3) M1 = (Y2-Y(J-3))/A1 ENDIF IF (J .GE. LM1) THEN M5 = 2*M4 - M3 ELSE A5 = X(J+2) - X5! M5 = (Y(J+2) - Y5)/A5 ENDIFCC --- NUMERICAL DIFFERENTIATIONC! IF (I .EQ. LP1) GO TO 52 W2 = ABS(M4-M3) W3 = ABS(M2-M1) SW = W2 + W3 IF (SW .EQ. 0) THEN W2 = .5 W3 = .5 SW = 1.0 ENDIF T3 = (W2*M2 + W3*M3)/SW IF (I .EQ. 1) GO TO 5452 W3 = ABS(M5-M4) W4 = ABS(M3-M2) SW = W3 + W4 IF (SW .EQ. 0.) THEN W3 = .5 W4 = .5 SW = 1.0 ENDIF T4 = (W3*M3 + W4*M4)/SW IF (I .EQ. LP1) THEN T3 = T4 SA = A2 + A38 T4 = .5*(M4 + M5 + A2*(A3-A2)*(M2-M3)/SA**2) X3 = X4 Y3 = Y4 A3 = A2 M3 = M4  ENDIF GO TO 6054 T4 = T3 SA = A3 + A41 T3 = .5*(M1+M2+A4*(A4-A3)*(M3-M4)/SA**2) X3 = X3 - A4 Y3 = Y3 - M2*A4 A3 = A4 M3 = M2C#C --- DETERMINATION OF COEFFICIENTSC$60 Q2 = (2.0*(M3-T3)+M3-T4)/A3! Q3 = (T3+T4-2.*M3)/A3**2CC --- COMPUTE POLYNOMIALC70 DX = DX - X3( V(K) = Y3+DX*(Q1+DX*(Q2+DX*Q3))80 CONTINUE RETURN ENDCC---END INTRPLCwwGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :4C* DETERMINE IF A CHARACTER IS ALPHANUMERIC#C* ( A..Z, 0..9, $, AND _)C*C* INPUT ARGUMENTS :C* C - THE CHARACTERC*C* OUTPUT ARGUMENTS :C* ISALPHAC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C*  28-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *1 CC ISALPHA = 0 $ (((C .GE. '0') .AND. (C .LE. '9')) .OR.0 $ ((C .GE. 'A') .AND. (C .LE. 'Z')) .OR.0 $ ((C .GE. 'a') .AND. (C .LE. 'z')) .OR., $ (C .EQ. '_') .OR. (C .EQ. '$')) RETURN ENDCC---END ISALPHACww.=꥚" LOGICAL FUNCTION ISDIGIT (C)C*3C* *******************************3C* *******************************3C* ** **3C* ** ISDIGIT **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :.C* VERIFY THAT A CHARACTER IS A DIGITC*C* INPUT ARGUMENTS :'C* C - THE CHARACTER TO CHECKC*C* OUTPUT ARGUMENTS :<C* ISDIGIT - TRUE IF "C" IS IN THE RANGE "0" TO "9"C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 28-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *1 CC1 ISDIGIT = ((C .GE. '0') .AND. (C .LE. '9')) RETURN ENDCC---END ISDIGITCwwB꥚# LOGICAL FUNCTION ISLETTER (C)C*3C* *******************************3C* *******************************3C* ** **3C* ** isletter **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :5C* CHECK TO SEE IF THE CHARACTER IS A LETTERC*C* INPUT ARGUMENTS :'C* C - THE CHARACTER TO CHECKC*C* OUTPUT ARGUMENTS :+C* ISLETTER - TRUE IF ITS A LETTERC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C*  28-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *1 CC8 ISLETTER = (((C .GE. 'A') .AND. (C .LE. 'Z')) .OR.4 $ ((C .GE. 'a') .AND. (C .LE. 'z'))) RETURN ENDCC---END isletterCww ENDIF( I = MIN0(LAST_DAY(MON),I) I = MAX0(1,I) WRITE(DAY,910) I*3 IF (LENGTH(TEMP) .GT. (IS+ISS)) THEN*( YEAR = TEMP(IS+ISS+1:)" CALL RIGHT(YEAR)) READ(YEAR,920,ERR=10) I  GO TO 20&10 YEAR = ONE_DAY(8:11) GO TO 100*C*/C --- 2 DIGIT YEAR DEFAULTS TO CURRENT CENTURY!*C*&C IF (I .LT. 50) THEN"C  I = I + 2000'C WRITE(YEAR,920) I ,C ELSE IF (I .LT. 100) THEN"C I = I + 1900'C WRITE(YEAR,920) I-C ENDIF(20 CALL THISCENT (ICENT) I = I + ICENT$ WRITE(YEAR,920) I ENDIF ENDIFrCeC ----- "MMM DD, YYYY"C . ELSE IF (INDEX(TEMP,',') .NE. 0) THEN MON = TEMP(1:3)i DO 30 I = 1, 12 4  IF (MON .EQ. MONTHS(I)(1:3)) GO TO 4030 CONTINUE MON = ONE_DAY(4:6)40 DAY = TEMP(4:5)C" READ(DAY,910,ERR=50) I% I = MIN0(LAST_DAY(MON),I)* I = MAX0(1,I)* GO TO 5550 DAY = ONE_DAY(1:2)55 YEAR = TEMP(7:10)p' CALL MLIB_FIX_YEAR ( YEAR ) 6 IF (YEAR .EQ. '0000') YEAR = ONE_DAY(8:11) GO TO 100lCfC ----- "DD-MMM-YY HH:MM:SS.CC"aCl!C ----- "DD-MMM-YYYY HH:MM:SS.CC" EC ----- THIS IS ALREADY STANDARD, SO LET'S JUST LET SYSTEM SERVICES )C ----- CLEANUP THE FORMAT!lC . ELSE IF (INDEX(TEMP,'-') .NE. 0) THEN* IF (TEMP(10:10) .EQ. ' ') THEN YEAR = TEMP(8:9)1( CALL MLIB_FIX_YEAR (YEAR)4 TEMP = TEMP(1:7) // YEAR // TEMP(10:) ENDIFN, ISTAT = SYS$BINTIM (TEMP, IDATE)5 ISTAT = LIB$FORMAT_DATE_TIME (OUT, IDATE)  RETURN ENDIF O]> SUBROUTINE GETOKE ( LINE, LL, IPTR, TOKEN, TYPE, ERROR )C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** GETOKE ** 3C* ** ** 3C* ******************************* 3C* *******************************SC*C* SUBPROGRAM : C* GED~꥚> SUBROUTINE KURV1 ( N, X, Y, SLP1, SLPN, XP, YP, TEMP, S, $ SIGMA )C*3C* ********************************3C* ******************************* 3C* ** **H3C* ** KURV1 ** 3C* ** ***3C* ********************************3C* ******************************* C*C* AUTHOR : C* ART RAGOSTARC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* REFERENCE :<C* 'SIX SUBPROGRAMS FOR CURVE FITTING USING SPLINES<C* UNDER TENSION' BY A.K. CLINE, COMMUNICATIONS OF.C* THE ACM, APRIL, 1974, VOL. 17, #4C*C* PURPOSE :BC* THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TOEC* COMPUTE A SPLINE UNDER TENSION PASSING THROUGH A SEQUENCER"C*  OF PAIRS IN THE PLANE.C*C* INPUT ARGUMENTS :.C* N - NUMBER OF POINTS TO BE FIT%C* X - ARRAY OF X VALUESN%C* Y - ARRAY OF Y VALUESRDC* SLP1 - SLOPE AT FIRST POINT (DEGREES, COUNTER-CLOCKWISE)C* FROM POSITIVE X AXIS)DC* SLPN - SLOPE AT LAST POINT (DEGREES, CCW FROM + X-AXIS)BC* SIGMA - TENSION FACTOR (IF THIS VALUE IS NEGATIVE, THEEC* END POINT SLOPES WILL BE CALCULATED; IF POSITIVE,UDC* THEY SHOULD BE INPUT IN SLP1 AND SLP2. A TYPICAL C* VALUE IS 1.)%C* TEMP - SCRATCH WORK AREA*C*C* OUTPUT ARGUMENTS :*2C* XP - CURVATURE PARAMETERS FOR KURV22C* YP - CURVATURE PARAMETERS FOR KURV2'C* S - ARC LENGTH OF CURVEDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY : (C* 18-DEC-86 INITIAL VERSIONC*HC***********************************************************************C*1 DIMENSION X(N), Y(N), YP(N), XP(N), TEMP(N)OC  DEGRAD = 0.01745329N NM1 = N - 1S NP1 = N + 1R DELX1 = X(2) - X(1)A DELY1 = Y(2) - Y(1)N* DELS1 = SQRT ( DELX1**2 + DELY1**2 ) DX1 = DELX1 / DELS1 DY1 = DELY1 / DELS1(CB IF ( SIGMA .LT. 0. ) THEN0C.C --- SECOND ORDER INTERPOLATION FOR ENDPOINTSC (IF NO SLOPES SPECIFIED)RCA IF ( N .EQ. 2 ) THENSCA-C --- TWO POINTS ONLY, RETURN A STRAIGHT LINEECL XP(1) = 0. XP(2) = 0. YP(1) = 0. YP(2) = 0.; SLP1 = ATAN2 ((Y(2)-Y(1)),(X(2)-X(1))) / DEGRAD  SLPN = SLP1F2 IF ( SLPN .LT. 0. ) SLPN = SLPN + 360. SLP1 = SLP1 + 180. RETURN ENDIF< DELS2 = SQRT ((X(3) - X(2))**2 + (Y(3) - Y(2))**2 ) DELS12 = DELS1 + DELS2U3 C1 = -(DELS12 + DELS1)/(DELS12 * DELS1)(  C2 = DELS12/ (DELS1 * DELS2), C3 = -DELS1 / ( DELS12 * DELS2 )4 SX = C1 * X(1) + C2 * X(2) + C3 * X(3)6 SY = C1 * Y(1) + C2 * Y(2) + C3 * Y(3)! SLPP1 = ATAN2 ( SY, SX )% SLP1 = SLPP1 / DEGRAD +180.F DELNM1= SQRT (( X(N-2) - X(NM1))**2 + ( Y(N-2) - Y(NM1))**2 )B DELN = SQRT (( X(NM1) - X(N))**2 + ( Y(NM1) - Y(N))**2 ) DELNN = DELNM1 + DELN4 C1 = ( DELNN + DELN ) / ( DELNN * DELN )+ C2 @m꥚' SUBROUTINE KEYHIT ( CHAR, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** KEYHIT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* KEY HITC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :EC* THIS ROUTINE CHECKS THE KEYBOARD TO SEE IF A KEY HAS BEENHC* STRUCK. IF SO, THE ASCII VALUE OF THE CHARACTER IS RETURNED6C* IN CHAR; OTHERWISE, 0 IS RETURNED IN CHAR.C*C* OUTPUT ARGUMENTS :FC* CHAR - THE ASCII INTEGER CHARACTER THAT WAS ENTERED, OR 0.C* ERROR - TRUE IF AN ERROR OCCURRED.C*C* SUBPROGRAM REFERENCES :7C* SYS$ASSIGN, SUS$GET_EF, SYS$CLREF, SYS$QIOWC*C* ERROR PROCESSING :AC* PASSES ALONG THE ERROR CODES FROM THE SYSTEM SERVICESC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :,C* THIS ROUTINE WORKS ONLY TO 'TT:'DC* THE USER SHOULD ALWAYS CHECK THE VALUE OF 'ERROR' IN THE#C* CALLING PROGRAM.C*C*  LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 28-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* IMPLICIT INTEGER (A-Z) INCLUDE '($SSDEF)' INCLUDE '($IODEF)'2 SAVE INIT, TERM_CHAN, KEYBOARD_EF, READ_FUNC- INTEGER NO_TERMINATORS(2), TERM_MASK(8) INTEGER*2 IOSB(4) LOGICAL ERROR, INIT BYTE CHAR DATA INIT/.FALSE./1 DATA NO_TERMINATORS /32,0/, TERM_MASK /8*0/C) NO_TERMINATORS(2) = %LOC(TERM_MASK) ERROR = .FALSE. IF (.NOT. INIT) THENC"C --- ASSIGN AN IO CHANNEL FOR TT:CG IF (SYS$ASSIGN ('TT', TERM_CHAN,,) .NE. SS$_NORMAL) GO TO 1000C)C --- ALLOCATE AN EVENT FLAG AND CLEAR ITC@ IF (LIB$GET_EF(KEYBOARD_EF) .NE. SS$_NORMAL) GO TO 1000. ISTAT = SYS$CLREF (%VAL(KEYBOARD_EF))) IF (ISTAT .NE. SS$_WASCLR .AND.. $ ISTAT .NE. SS$_WASSET) GO TO 10008 READ_FUNC = IO$_TTYREADALL .OR. IO$M_TIMED .OR. $ IO$M_NOECHO INIT = .TRUE. ENDIFC&C --- INITIATE A SINGLE CHARACTER READC; ISTAT = SYS$QIOW (%VAL(KEYBOARD_EF), %VAL(TERM_CHAN),? $ %VAL(READ_FUNC), IOSB,,, CHAR, %VAL(1),2 $ %VAL(0), NO_TERMINATORS,,)? IF ((IOSB(1).NE.SS$_NORMAL) .OR. (IOSB(2).NE.1)) CHAR = 0 RETURN1000 ERROR = .TRUE. RETURN ENDCC---END KEYHITCww = -DELNN / ( DELN * DELNM1 )* C3 = DELN / ( DELNN * DELNM1 ): SX = C3 * X(N-2) + C2 * X(NM1) + C1 * X(N): SY = C3 * Y(N-2) + C2 * Y(NM1) + C1 * Y(N)! SLPPN = ATAN2 ( SY, SX ) SLPN = SLPPN / DEGRAD. IF ( SLPN .LT. 0. )SLPN = SLPN + 360. ELSE SLPP1 = SLP1 * DEGRAD SLPPN = SLPN * DEGRAD ENDIFC'C --- SET UP RIGHT HAND SIDE OF TRIDIAGC! XP(1) = DX1 - COS ( SLPP1 )! YP(1) = DY1 - SIN ( SLPP1 ) TEMP(1) = DELS1 S = DELS1 DO 20 I = 2, NM1 DELX2 = X(I+1) - X(I) DELY2 = Y(I+1) - Y(I)- DELS2 = SQRT ( DELX2**2 + DELY2**2 ) DX2 = DELX2 / DELS2 DY2 = DELY2 / DELS2 XP(I) = DX2 - DX1 YP(I) = DY2 - DY1 TEMP(I) = DELS2 DELX1 = DELX2 DELY1 = DELY2 DELS1 = DELS2 DX1 = DX2 DY1 = DY2 S = S + DELS1 20 CONTINUE" XP(N) = COS ( SLPPN ) - DX1" YP(N) = SIN ( SLPPN ) - DY1C C --- DENORMALIZE TENSION FACTORC0 SIGMAP = ABS ( SIGMA ) * FLOAT ( N-1 ) / SC(C --- FORWARD ELIMINATION ON TRIDIAGONALC DELS = SIGMAP * TEMP(1) EXPS = EXP ( DELS )& SINHS = .5 * ( EXPS - 1./EXPS )% SINHIN = 1./( TEMP(1) * SINHS )B DIAG1 = SINHIN * ( DELS * .5 * ( EXPS + 1./EXPS ) - SINHS ) DIAGIN = 1./DIAG1 XP(1) = DIAGIN * XP(1) YP(1) =  DIAGIN * YP(1)( SPDIAG = SINHIN * ( SINHS - DELS ) TEMP(1) = DIAGIN * SPDIAG DO 40 I = 2, NM1" DELS = SIGMAP * TEMP(I) EXPS = EXP ( DELS )) SINHS = .5 * ( EXPS - 1./EXPS )( SINHIN = 1./( TEMP(I) * SINHS )H DIAG2 = SINHIN * ( DELS * ( .5 * ( EXPS + 1./EXPS )) - SINHS ): DIAGIN = 1./( DIAG1 + DIAG2 - SPDIAG * TEMP(I-1))6 XP(I) = DIAGIN * ( XP(I) - SPDIAG * XP(I-1))6 YP(I) = DIAGIN * ( YP(I) - SPDIAG * YP(I-1))+ SPDIAG = SINHIN * ( SINHS - DELS )! TEMP(I)= DIAGIN * SPDIAG DIAG1 = DIAG2 40 CONTINUE/ DIAGIN = 1./( DIAG1 - SPDIAG * TEMP(NM1))3 XP(N) = DIAGIN * ( XP(N) - SPDIAG * XP(NM1))3 YP(N) = DIAGIN * ( YP(N) - SPDIAG * YP(NM1))C,C --- PERFORM SUBSTITUTIONS FOR COEFFICIENTSC DO 60 I = 2, N IBAK = NP1 - I6 XP(IBAK) = XP(IBAK) - TEMP(IBAK) * XP(IBAK+1)6 YP(IBAK) = YP(IBAK) - TEMP(IBAK) * YP(IBAK+1) 60 CONTINUE RETURN ENDC C---END KURV1Cww ;yG꥚? SUBROUTINE KURV2 ( T, XS, YS, N, X, Y, XP, YP, S, SIGMA )C*3C* *******************************3C* *******************************3C* ** **3C* ** KURV2 **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* REFERNECE :<C* 'SIX SUBPROGRAMS FOR CURVE FITTING USING SPLINES)C* UNDER TENSION' BY A.K. CLINE<C* COMMUNICATIONS OF THE ACM, APRIL 1974 VOL.17 #4C*C* PURPOSE ::C* EVALUATE THE INTERMEDIATE POINTS FOR THE CURVE'C* DETERMINED BY ROUTINE KURV1C*C* INPUT ARGUMENTS :>C* T - LOCATION ON CURVE NORMALIZED FROM 0. TO 1..C* N - NUMBER OF POINTS IN ARRAYS,C* X - INDEPENDENT VALUES ARRAY*C* Y - DEPENDENT VALUES ARRAY1C* XP - INFORMATION PASSED FROM KURV11C* YP - INFORMATION PASSED FROM KURV1"C* SIGMA - TENSION FACTORC*C* OUTPUT ARGUMENTS :,C* XS - CALCULATED X VALUE FOR T,C* YS - CALCULATED Y VALUE FOR TC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 18-DEC-86 INITIAL VERSIONC*HC***********************************************************************C*( DIMENSION X(N), Y(N), XP(N), YP(N)C. SIGMAP = ABS ( SIGMA ) * FLOAT (N-1) / S TN = ABS ( T * S )C'C --- IF T < 0 CONTINUE FROM LAST POINTC IF ( T .LT. 0. ) GO TO 10 I1 = 2 XS = X(1) YS = Y(1) SUM = 0. IF ( T .LE. 0. ) RETURNC'C --- DETERMINE WHICH SEGMENT WE ARE INC 10 DO 30 I = I1, N DELX = X(I) - X(I-1) DELY = Y(I) - Y(I-1)* DELS = SQRT ( DELX**2 + DELY**2 )3 IF (( SUM + DELS - TN ) .GE. 0. ) GO TO 40 SUM = SUM + DELS 30 CONTINUEC*C --- IF T > 1, RETURN LAST POINT IN ARRAYC XS = X(N) YS = Y(N) RETURNCC --- INTERPOLATIONC 40 DEL1 = TN - SUM DEL2 = DELS - DEL1$ EXPS1 = EXP ( SIGMAP * DEL1 )( SINHD1 = .5 * ( EXPS1 - 1./EXPS1 )$ EXPS = EXP ( SIGMAP * DEL2 )& SINHD2 = .5 * ( EXPS - 1./EXPS ) EXPS = EXPS1 * EXPS& SINHS = .5 * ( EXPS - 1./EXPS )> XS = ( XP(I) * SINHD1 + XP(I-1) * SINHD2 ) / SINHS +D $ (( X(I) - XP(I)) * DEL1 + ( X(I-1) - XP(I-1)) * DEL2 ) / DELS> YS = ( YP(I) * SINHD1 + YP(I-1) * SINHD2 ) / SINHS +D $ (( Y(I) - YP(I)) * DEL1 + ( Y(I-1) - YP(I-1)) * DEL2 ) / DELS I1 = I RETURN ENDC C---END KURV2CwwnerY .title poke;S; Author: Arthur E. Ragosta;OJ; Put a byte into the specified location. Both parameters by reference.;M"; call poke (location, value); ; Example:; i = %loc(x); call poke (i, 255)O;  .entry poke,^m<>O: movl @4(ap),r1 ;address of location to r16 movl 8(ap),r0 ;address of byte to r01 movb (r0),(r1) ;move that suckerR retE .endwwAGOSTA ꥚ FUNCTION LAST_DAY ( MON )C*CC* RETURN THE NUMBER OF THE LAST DAY OF THIS MONTH (28,29,30,31)C* CHARACTER *3 MONC IF ((MON .EQ. 'APR') .OR. $ (MON .EQ. 'JUN') .OR. $ (MON .EQ. 'SEP') .OR. $ (MON .EQ. 'NOV')) THEN LAST_DAY = 30# ELSE IF (MON .EQ. 'FEB') THEN LAST_DAY = 28 ELSE LAST_DAY = 31 ENDIF RETURN ENDCC---END LAST_DAYCwwD100 OUT = DAY // '-' // MON // '-' // YEAR // ' ' // HOUR ENDIF RETURN900 FORMAT(I1)910 FORMAT(I2)920 FORMAT(I4) END*C*C---END CLEANSE_DATEC ' SUBROUTINE MLIB_FIX_YEAR ( YEAR )  CHARACTER *(*) YEARaCe LY = LEFT(YEAR)  IF (LY .LE. 2) THEN C (C --- 2 DIGIT YEAR - USE CURRENT CENTURYC* READ(YEAR,900) I  CALL THISCENT (ICENT) I = I + ICENT WRITE(YEAR,910) I ELSE IF (LY .NE. 4) THEN YEAR = '0000' ENDIF) RETURN900 FORMAT(I2)910 FORMAT(I4) ENDeCrC---END MLIB_FIX_YEAR Cfwwield, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :/C* Is the specified year a leap year ?C*C* INPUT ARGUMENTS :FC* Iyear - The year (note: 2 digit vs. 4 digit is irrelevant)C*C* OUTPUT ARGUMENTS :1C* Leap_year - .true. if its a leap yearC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 4-NOV-1992 - INITIAL VERSIONC*HC***********************************************************************C*) itwo = iyear - (100*int(iyear/100))+ leap_year = (int(itwo/4)*4 .eq. itwo) RETURN ENDCC---END Leap_yearCww꥚ .title left;; Author: Arthur E. Ragosta;; Left justify a string;,; STRING = ' This is a string.'; CALL LEFT ( STRING ); or;; LS = LEFT (STRING) ! LS contains the length;3; Results in STRING = 'This is a string. ';* .entry left,^m@ movl 4(ap),r0 ;loc of descriptor to r05 movzwl (r0),r6 ;length to r67  movl 4(r0),r7 ;location to r7< skpc #32,r6,(r7) ;skip leading spacesB bneq out ;continue if not all blankC clrl r0 ;all blank, return 0 length retJ ;r1 contains addr of nonblank charK ;r0 contains num of non-blank chars5out: movc5 r0,(r1),#32,r6,(r7) ;move and pad decl r7Ploop1: cmpb (r7)[r6],#32 ;check backwards for blanks (set length) bneq out1 sobgtr r6,loop1out1: movl r6,r0 ret .end;; Portable FORTRAN version;; FUNCTION LEFT ( STRING );C*4;C* *******************************4;C* *******************************4;C* ** **4;C* ** LEFT **4;C* **  **4;C* *******************************4;C* *******************************;C*;C* SUBPROGRAM :;C* LEFT JUSTIFY;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 :H;C* REPLACES A STRING WITH THE SAME STRING LESS LEADING BLANKS.I;C* NOTE: THIS ROUTINE IS REPLACED BY A MACRO ROUTINE IN MERLIB.;C*;C* INPUT ARGUMENTS :6;C* STRING - THE STRING TO BE LEFT JUSTIFIED.;C*;C* OUTPUT ARGUMENTS ::;C* STRING - THE LEFT JUSTIFIED STRING (INPLACE).;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*I;C***********************************************************************;C*; CHARACTER *(*) STRING;C%; IF (STRING(1:1) .NE. ' ') THEN; LEFT = LENGTH(STRING); RETURN ; ENDIF; L = LEN(STRING);C%;C --- FIND FIRST NON-BLANK CHARACTER;C; DO 10 I=1,L,; IF (STRING(I:I) .NE. ' ') GO TO 20;10 CONTINUE;C ;C --- ALL CHARACTERS WERE BLANK;C ; RETURN;C;20 STRING = STRING(I:L); LEFT = LENGTH(STRING) ; RETURN ; END;C ;C---END LEFT;Cww x/륚 .title length;; Author: Arthur E. Ragosta;F; Return the true length of a string; i.e., the location of the lastF; non-blank character. Since FORTRAN's strings are non-dynamic, theD; function skips ONLY spaces (not NULs, control characters, etc.).;7; LS = LENGTH( 'A STRING ' ) ! Note, LS is 8; .entry length,^m<>= movl 4(ap),r1 ;location of descriptor to r1- movzwl (r1),r0 ;length to r0/ subl3 #1,4(r1),r1 ;location to r1(LOOP: cmpb (r1)[r0],#32 ;space ?; bneq done;.; beql next ;replace previous line with these+; cmpb (r1)[r0],#09 ;to skip tabs too; bneq done;NEXT:;= sobgtr r0,loop ;check for zero length string DONE: ret .end;; Portable FORTRAN version;!; FUNCTION LENGTH ( STRING );C*4;C* *******************************4;C* *******************************4;C* ** **4;C* ** LENGTH **4;C* ** **4;C* *******************************4;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;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.I;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*I;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;Cww9륚 .title lenx;; Author: Arthur E. Ragosta;F; Return the true length of a string; i.e., the location of the last; non-blank character. :; Unlike LENGTH, LENX skips control chracters and 8 bits;6; LS = LENX ( 'A STRING ' ) ! Note, LS is 8; .entry lenx,^m<>= movl 4(ap),r1 ;location of descriptor to r1- movzwl (r1),r0 ;length to r0/ subl3 #1,4(r1),r1 ;location to r12LOOP: cmpb (r1)[r0],#32 ;space or control? bleq next3 cmpb (r1)[r0],#127 ;DEL or 8 bit char? bgeq nextC ret ;valid character - that's all folks;=NEXT: sobgtr r0,loop ;check for zero length string ret .endwwA"? cmpb (r1)[r0],#90 bgtr next ;Greater than "Z"?, addb2 #32,(r1)[r0] ;Its a CAP... lower it!7next: sobgtr r0,loop ;check for end of string ret .end;; Portable FORTRAN version;"; SUBROUTINE LOWER ( STRING );C*4;C* *******************************4;C* *******************************4;C* ** **4;C* ** LOWER **4;C* **  **4;C* *******************************4;C* *******************************;C*;C* SUBPROGRAM :;C* LOWER CASE;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 :F;C* TO REPLACE A STRING WITH THE SAME STRING BUT WITH CAPITAL.;C* LETTERS REPLACED WITH LOWER CASE.;C*;C* INPUT ARGUMENTS :.;C* STRING - THE STRING TO BE CHNAGED;C*;C* OUTPUT ARGUMENTS :+;C* STRING - THE LOWER CASE STRING;C*&;C* TRANSPORTABILITY LIMITATIONS :/;C* USES THE ASCII VALUE OF 32 FOR IC.;C*&;C* ASSUMPTIONS AND RESTRICTIONS :J;C* THE COLLATING SEQUENCE MUST HAVE 'Z' > 'A' AND ALL CHARACTERSJ;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*I;C***********************************************************************;C*; CHARACTER *(*) STRING; DATA IC /32/;C; DO 10 I = 1, LEN(STRING)B; 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 LOWER;Cww 2J륚 function m2i ( month )" character *3 months(12), tmpA data months /'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',6 $ 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/ character *(*) monthc tmp = month(1:3) call caps(tmp) do 10 m2i = 1,12) if (tmp .eq. months(m2i)) return10 continue m2i = 0 return endc c---end m2ic$ character*3 function i2m ( i ) character *3 months(12)A data months /'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',6 $ 'JUL', 'AUG', 'SEP', 'OCT', 'NOV', 'DEC'/c i2m = months(i) return endc c---end i2mcww [륚, SUBROUTINE Mail (fname, user, subject)C*3C* *******************************3C* *******************************3C* ** **3C* ** Mail **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C*  RAGOSTA@MERLIN.ARC.NASA.GOV (Internet) C* C* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :?C* Sends a mail message in a file to a specified user.)C* Uses callable mail interface.C*C* INPUT ARGUMENTS :1C* FNAME - Filename containing message,C* USER - User name of recipient8C* SUBJECT - Subject string (or blank f or none)C*C* SUBPROGRAM REFERENCES :<C* mail$send_begin, mail$send_add_address=C* mail$send_add_attribute, mail$send_add_bodypart4C* mail$send_message, mail$send_endC*%C* ASSUMPTIONS AND RESTRICTIONS :&C* Not even vaguely portable.C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN C*C* CHANGE HISTORY :+C* 15-JUL-1991 - INITIAL VERSIONC*HC***********************************************************************C*) character *(*) fname, user, subject include '($MAILDEF)' structure /itemlist/" integer *2 buflen, itmcod integer bufadr, retadr end structure/ record /itemlist/ in_list(2), out_list(2)c c --- setupc in_list(1).itmcod = 0 in_list(1).buflen = 0 out_list(1).itmcod = 0 out_list(1).buflen = 0: istat = mail$send_begin (context, in_list, out_list) if (.not. istat) returncc --- specify receiving userc$ in_list(1).bufadr = %loc(user)& in_list(1).buflen = length(user)- in_list(1).itmcod = MAIL$_SEND_USERNAME in_list(2).itmcod = 0 in_list(2).buflen = 0@ istat = mail$send_add_address (context, in_list, out_list) if (.not. istat) returncc --- add subjetc line (if any)c if (subject .ne. ' ') then* in_list(1).bufadr = %loc(subject), in_list(1).buflen = length(subject)/ in_list(1).itmcod = MAIL$_SEND_SUBJECTE istat = mail$send_add_attribute (context, in_list, out_list) endifcc --- name of file to sendc% in_list(1).bufadr = %loc(fname)' in_list(1).buflen = length(fname)- in_list(1).itmcod = MAIL$_SEND_FILENAMEA istat = mail$send_add_bodypart (context, in_list, out_list) if (.not. istat) returnc c --- send itc in_list(1).itmcod = 0 in_list(1).buflen = 0< istat = mail$send_message (context, in _list, out_list)cc --- free contextc in_list(1).itmcod = 0 in_list(1).buflen = 08 istat = mail$send_end (context, in_list, out_list) RETURN ENDC C---END MailCwwJg!륚- LOGICAL FUNCTION MATCH ( WORD, TARGET )IC*6C* SEE IF A WORD IS AN ABBREVIATED MATCH FOR A TARGETC*! CHARACTER *(*) WORD, TARGET*C* MATCH = .FALSE.* LW = LENGTH(WORD)& IF (LW .LE. LENGTH(TARGET)) THEN3 IF (WORD .EQ. TARGET(1:LW)) MATCH = .TRUE. ENDIF RETURN END*C C---END MATCH*C*ww********************3C* *******************************C*C* AUTHOR :C* Arthur E. &륚 SUBROUTINE MBELL SC*3C* *******************************r3C* ********************************3C* ** ***3C* ** MBELL **T3C* ** ** 3C* *******************************E3C* *******************************C*C* AUTHOR :PC* ART RAGOSTA C* MS 219-3 C*  AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :$C* RING THE TERMINALS BELL.C*C* METHODOLOGY :(C* SEND TO TERMINAL.C*C* INPUT ARGUMENTS :>C* NUNIT - THE LOGICAL UNIT TO SEND THE BELL COMMAND.C*%C* TRANSPORTABILITY LIMITATIONS :NHC* THE '$' IN THE FORMAT STATEMENT IS NON-STD, COULD BE OMITTEDC*%C* ASSUMPTIONS AND RESTRICTIONS :tEC* THE TERMINAL MUST RECOGNIZE AS THE PROPER CHARACTER C* TO RING THE BELL. C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :e(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C*$ CALL MLIB_GET('NWRITE',NWRITE)+ WRITE ( NWRITE, 900 )CHAR(27),CHAR(7)E900 FORMAT(2A1,$) RETURN ENDLC? C---END MBELL(CEwwHEN IPERM = 1 ELSE IPERM ={g륚3 SUBROUTINE MENU ( CHOICE, N, PROMPT, ANSWER )EC*3C* ******************************* 3C* *******************************T3C* ** **T3C* ** MENU **E3C* ** ** 3C* *******************************03C* *******************************(C*C* AUTHOR : C* ART RAGOSTA=C* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :FC* THIS SUBPROGRAM PRESENTS A LIST OF OPTIONS TO THE USER ANDGC* REQUESTS A CHOICE BE MADE. ALL ERROR CHECKING IS DONE, AND AC* PAGINATION FOR REQUESTS WITH MANY CHOICES IS HANDLED. C*C* INPUT ARGUMENTS :,C* CHOICE - THE TEXT OF THE CHOICES4C* N - THE NUMBER OF ENTRIES IN CHOICEEC* PROMPT - THE TEXT OF THE PROMPT TO BE PRODUCED AT THE TOP #C* OF EACH PAGE.*C*C* OUTPUT ARGUMENTS : &C* ANSWER - THE USER'S ANSWERC*C* FILE REFERENCES :C* NIN, NOUT8C*C* SUBPROGRAM REFERENCES :;C* LENGTH, CLEAR, FIRST, BLANKS, RIGHT, MBELL C*C* ERROR PROCESSING : BC* CHECK FOR ERRORS DURING CONVERSION OF INPUT TO INTEGER)C* CHECK RESPONSE AGAINST LIMITS C*%C* TRANSPORTABILITY LIMITATIONS : :C*  THE '$' FORMAT DESCRIPTOR IS NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :*FC* THE TEXT IN CHOICE SHOULD BE LESS THAN ABOUT 75 CHARACTERSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77UC*C* CHANGE HISTORY : (C* 26-NOV-85 INITIAL VERSION<C* 29-JUN-90 CLEANED UP FOR OTHER MERLIB CHANGESC*HC***********************************************************************C*& CHARACTER *(*) CHOICE(N), PROMPT CHARACTER *79 LINE CHARACTER *2 A CHARACTER *1 CCL INTEGER ANSWER, BLANKSCN IF (N .LT. 1) RETURN! CALL MLIB_GET ('NREAD',NIN)V$ CALL MLIB_GET ('NWRITE', NOUT)C%-C --- HOW MANY CHOICES WILL FIT ON 1 SCREEN ?SC) L = 0  DO 5 I=1,N& L = MAX0(L,LENGTH(CHOICE(I)))5 CONTINUE) IF (L .LT. 21) THEN) IF (N .LT. 19) THEN NS = 18N! ELSE IF (N .LT. 37) THEN  NS = 36 ELSE   NS = 54E ENDIF ELSE IF (L .LT. 34) THEN IF (N .LT. 19) THEN NS = 18) ELSE  NS = 36* ENDIF ELSE NS = 18 ENDIF*C* C --- NUMBER OF SCREENS REQUIREDC  NR = (N + NS - 1) / NSC C --- DISPLAY CHOICESCCK IW = 1 IF (N .GT. 9) IW = 2 IF (N .GT. 99) IW = 3 10 IS = 1 DO 100 I = 1, NR CALL CLEAR  WRITE(NOUT,900) PROMPT* WRITE(NOUT,910)CT/C --- PUT NEXT SCREEN FULL, WITH CHOICE NUMBERS CA IE = MIN0(IS+17,N)* DO 50 II=IS,IE C C --------- ONE COLUMN WIDEC IF (NS .EQ. 18) THEN WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS) IS = IS + 1CAC --------- TWO COLUMNS WIDECE% ELSE IF (NS .EQ. 36) THEN* WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS)' IF ((IS+18) .LE. N) THENM$  WRITE(A,990) IS+189 LINE(40:) = A // '. ' // CHOICE(IS+18)E ENDIF IS = IS + 1COC --------- THREE COLUMNS WIDEC  ELSE WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS)' IF ((IS+18) .LE. N) THEN*$ WRITE(A,990) IS+189 LINE(27:) = A // '. ' // CHOICE(IS+18)* ENDIF' IF ((IS+36) .LE. N) THENR$ WRITE(A,990) IS+369 LINE(53:) = A // '. ' // CHOICE(IS+36)' ENDIF IS = IS + 1 ENDIF  WRITE(NOUT,900)LINEY50 CONTINUECV0C ------ UPDATE STARTING POINTER FOR NEXT SCREENCI IS = IS + NS - 18C,$C ------ PROMPT FOR ANSWER OR RETURNC IF (I .EQ. NR) THEN IF (NR .NE. 1) THENN WRITE(NOUT,930) N ELSE WRITE(NOUT,920) N ENDIF  ELSE  WRITE(NOUT,940)- ENDIFCC --- GET RESPONSECI READ(NIN,950) LINE*C*C --- CHECK FOR HELP REQUESTEDC*# CALL FIRST ( LINE, CC, J )* IF (CC .EQ. '?') THEN CALL CLEAR WRITE(NOUT,980) N* READ(NIN,950) LINE GO TO 10 ENDIFC*C ------ DECODE ANSWERC* CALL BLANKS ( LINE )* CALL RIGHT ( LINE )& READ (LINE,960,ERR=30) ANSWER GO TO 40 CT +C ------ ERROR, PROBABLY NON-DIGITS ENTERED C 30 CALL MBELL  WRITE(NOUT,970) N READ(NIN,950) LINEe GO TO 10 C +C ------ CHECK FOR OR VALID ANSWER5C0 40 IF (ANSWER .EQ. 0) THEN# IF (I .EQ. NR) GO TO 10B ELSEI= IF ((ANSWER .GT. 0) .AND. (ANSWER .LE. N)) RETURNE CALL MBELL  WRITE(NOUT,970) N READ(NIN,950) LINE GO TO 10 ENDIF100 CONTINUES ! RETURN900 FORMAT(' ',A)P910 FORMAT(' ') :920 FORMAT(/' Please enter response (1-',I,') : ',$) 930 FORMAT+ $(/' Please enter response (1-',I,G2 $ ') or to see choices again : ',$) 940 FORMAT+ $(/' Please enter response (1-',I,*9 $ ') or to continue viewing choices : ',$)950 FORMAT(A) 960 FORMAT(74X,I5)>970 FORMAT(' Please respond with a number from 1 to',I5,////. $' Enter ''?'' at the prompt for help.'//% $ "' Enter to continue.') 980 FORMAT(//,A $' Please make a selection from the list of choices given.'/ D $' Your response should be an integer number from 1 to',I5,'.'/E $' The number associated with each choice is shown immediately'/T* $' before that choice in the menu.'//E $' If the number of choices is too great for all of them to be'/*H $' displayed on a single screen, there will be a pause at the end'/G $' of each screen. In this case, you will be pro mpted to either'/XE $' enter a choice or hit to continue viewing choices.'/ C $' On the last screen of the display, entering will'/*1 $' redisplay all choices from the start.'///7 $' Please enter to go back to the menu.')L990 FORMAT(I2) END C2 C---END MENUC wwAmes Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :C* CLOSE THE MAILBOXC*C* INPUT ARGUMENTS :? $S륚; SUBROUTINE MENU2 ( CHOICE, N, TITLE, PROMPT, ANSWER )BC*3C* *******************************A3C* *******************************P3C* ** ** 3C* ** MENU2 ***3C* ** ***3C* ********************************3C* ******************************* C*C* AUTHOR :VC* ART RAGO%STATC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :FC* THIS SUBPROGRAM PRESENTS A LIST OF OPTIONS TO THE USER ANDGC* REQUESTS A CHOICE BE MADE. ALL ERROR CHECKING IS DONE, AND AC* PAGINATION FOR REQUESTS WITH MANY CHOICES IS HANDLED.EC* (BASICALLY THE SAME AS MENU, BUT HAS USER-INPUT OF BOTTOM C* PROMPT)*C*C* INPUT ARGUMENTS :,C* CHOICE& - THE TEXT OF THE CHOICES4C* N - THE NUMBER OF ENTRIES IN CHOICEDC* TITLE - THE TEXT TO BE PRODUCED AT THE TOP OF EACH PAGE:C* PROMPT - THE PROMPT AT THE BOTTOM OF EACH PAGEC*C* OUTPUT ARGUMENTS :8&C* ANSWER - THE USER'S ANSWERC*C* SUBPROGRAM REFERENCES :;C* LENGTH, CLEAR, FIRST, BLANKS, RIGHT, MBELLAC*C* ERROR PROCESSING : BC* CHECK FOR ERRORS DURING CONVERSION OF INPUT TO INTEGER)C* CHECK RESPON'SE AGAINST LIMITS*C*%C* TRANSPORTABILITY LIMITATIONS :L:C* THE '$' FORMAT DESCRIPTOR IS NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :SFC* THE TEXT IN CHOICE SHOULD BE LESS THAN ABOUT 75 CHARACTERSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77PC*C* CHANGE HISTORY :R(C* 26-NOV-85 INITIAL VERSION5C* 21-AUG-87 ADDED VARIABLE BOTTOM PROMPT*7C* 29-JUN-90 FIXED FOR OTHER MERLIB CHANGES*C*HC*********(**************************************************************C*- CHARACTER *(*) CHOICE(N), PROMPT, TITLE( CHARACTER *79 LINE CHARACTER *2 A CHARACTER *1 CC  INTEGER ANSWERC, IF (N .LT. 1) RETURN! CALL MLIB_GET ('NREAD',NIN)O$ CALL MLIB_GET ('NWRITE', NOUT)C-C --- HOW MANY CHOICES WILL FIT ON 1 SCREEN ? CU L = 0U DO 5 I=1,N& L = MAX0(L,LENGTH(CHOICE(I)))5 CONTINUE* IF (L .LT. 21) THEN  IF (N) .LT. 19) THEN NS = 18 ! ELSE IF (N .LT. 37) THEN NS = 36* ELSEI NS = 54  ENDIF ELSE IF (L .LT. 34) THEN IF (N .LT. 19) THEN NS = 18 ELSE  NS = 36* ENDIF ELSE NS = 18 ENDIFECa C --- NUMBER OF SCREENS REQUIREDCC NR = (N + NS - 1) / NSCC --- DISPLAY CHOICESeCr 10 IS = 1 DO 100 I = 1, NR CALL CLEAR  W*RITE(NOUT,900) TITLE WRITE(NOUT,910)CS/C --- PUT NEXT SCREEN FULL, WITH CHOICE NUMBERSEC IE = MIN0(IS+17,N)  DO 50 II=IS,IETCOC --------- ONE COLUMN WIDEACO IF (NS .EQ. 18) THEN WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS) IS = IS + 1CLC --------- TWO COLUMNS WIDEC % ELSE IF (NS .EQ. 36) THEN* WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS)' + IF ((IS+18) .LE. N) THENR$ WRITE(A,990) IS+189 LINE(40:) = A // '. ' // CHOICE(IS+18)  ENDIF IS = IS + 1COC --------- THREE COLUMNS WIDEC* ELSE WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS)' IF ((IS+18) .LE. N) THENU$ WRITE(A,990) IS+189 LINE(27:) = A // '. ' // CHOICE(IS+18)  ENDIF' IF ((ISG+36) .LE. N) THENL$ WRITE(A,990) IS+369 LINE(53:) = A // '. ' // CHOICE(IS+36)N ENDIF IS = IS + 1 ENDIF WRITE(NOUT,900)LINE50 CONTINUEC0C ------ UPDATE STARTING POINTER FOR NEXT SCREENC IS = IS + NS - 18C$C ------ PROMPT FOR ANSWER OR RETURNC IF (I .EQ. NR) THEN IF (NR .NE. 1) THEN WRITE(NOUT,930) ELSE% W -2륚: SUBROUTINE OPEN_MAILBOX (NAME, ISPERM, IPROT, ICHAN)C*3C* *******************************3C* *******************************3C* ** **3C* ** OPEN_MAILBOX **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. .Ragosta'C* RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :;C* CREATE A MAILBOX FOR INTERPROCESS COMMUNICATIONC*C* INPUT ARGUMENTS :5C* NAME - THE LOGICAL NAME FOR THE MAILBOXCC* ISPERM - PERMANENT OR TEMP? (PERM REQUIRES PRMMBX PRIV)%C* IPROT - PROTECTION TYPE:+C* = 0 FOR NO PROTECT/ION-C* = 1 FOR NO WORLD ACCESS6C* = 2 FOR NO WORLD OR GROUP ACCESS?C* = 3 FOR NO WORLD, GROUP, OR SYSTEM ACCESSC*C* OUTPUT ARGUMENTS :0C* ICHAN - NEEDED FOR LATER READ/WRITEC*C* SUBPROGRAM REFERENCES :C* SYS$CREMBXC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE=C* THE MAILBOX IS INITIALIZED FOR 1000 BYTE MESSAGES*C* Up to 8 messages are buffered.C*0C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONDC* 3-mar-1993 - Message size increased; protection fixedC*HC***********************************************************************C* CHARACTER *(*) NAME LOGICAL ISPERM INTEGER SYS$CREMBX INTEGER *2 PROMASKC C --- IS IT A PERMANENT MAILBOX?C IF (ISPERM) THEN IPERM = 1 ELSE IPERM =1 0 ENDIFCDC --- '0' ALLOWS ACCESS, '1' DENIES IT (REF: SYSTEM SERVICES SYS-94)C IF (IPROT .EQ. 1) THEN PROMASK = 'F000'X! ELSE IF (IPROT .EQ. 2) THEN PROMASK = 'FF00'X! ELSE IF (IPROT .EQ. 3) THEN PROMASK = 'FF0F'X ELSE PROMASK = 0 ENDIFCF ISTAT = SYS$CREMBX ( %VAL(IPERM), ICHAN, %VAL(1000), %VAL(8000),@ $ %VAL(PROMASK),, NAME(1:LENGTH(NAME)))% IF (.NOT. ISTAT) ICHAN = -IS2TATC RETURN ENDCC---END OPEN_MAILBOXC- SUBROUTINE READ_MAILBOX (ICHAN, BUFFER)C*3C* *******************************3C* *******************************3C* ** **3C* ** READ_MAILBOX **3C* ** **3C* *******************************3C* *******************************C*C* 3 AUTHOR :C* Arthur E. Ragosta'C* RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :<C* READ A MESSAGE FROM A PREVIOUSLY OPENED MAILBOX.C*C* INPUT ARGUMENTS :4C* ICHAN - CHANNEL ASSIGNED BY OPEN_MAILBOXC*C* OUTPUT ARGUMENTS :4C* BUFFER - MESSAGE TEXT = BLANK FOR ERROR,DC* 4 "END-OF-FILE" FOR MAILBOX CLOSEDC*C* SUBPROGRAM REFERENCES :C* SYS$QIOWC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE-C* BUFFER MUST BE <= 1000 BYTES LONGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) BUFFER INTEGER*2 IOSB(4) 5INTEGER SYS$QIOWC INCLUDE '($IODEF)' INCLUDE '($SSDEF)'C LB = LEN(BUFFER); ISTAT = SYS$QIOW ( , %VAL(ICHAN), %VAL(IO$_READVBLK),= $ IOSB,,, %REF(BUFFER), %VAL(LB),,,, ) IF (.NOT. ISTAT) THEN BUFFER = ' ' RETURN ENDIFC IF (.NOT. IOSB(1)) THEN- IF (IOSB(1) .EQ. SS$_ENDOFFILE) THEN" BUFFER = 'END-OF-FILE' ELSE BUFFER = ' ' ENDIF ENDIF6C RETURN ENDCC---END READ_MAILBOXC4 LOGICAL FUNCTION CHECK_MAILBOX (ICHAN, BUFFER)C*3C* *******************************3C* *******************************3C* ** **3C* ** CHECK_MAILBOX **3C* ** **3C* *******************************3C* *******************************C*C* 7 AUTHOR :C* Arthur E. Ragosta'C* RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* DESCRIPTION :FC* CHECK TO SEE IF THERE IS A MESSAGE IN THE MAILBOX; READ ITC* IF THERE IS.C*C* INPUT ARGUMENTS :;C* ICHAN - CHANNEL NUMBER ASSIGNED BY OPEN_MAILBOXC*C* OUTPUT ARGUMENTS :-C* BUFFER - TEXT OF MESSAGE (IF A8NY)6C* CHECK_MAILBOX - TRUE IF A MESSAGE WAS READC*C* SUBPROGRAM REFERENCES :C* SYS$QIOWC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE-C* BUFFER MUST BE <= 1000 BYTES LONGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) BUFFER IN9TEGER*2 IOSB(4) INTEGER SYS$QIOWC INCLUDE '($IODEF)' INCLUDE '($SSDEF)'C CHECK_MAILBOX = .FALSE. LB = LEN(BUFFER)D ISTAT = SYS$QIOW ( , %VAL(ICHAN), %VAL(IO$_READVBLK+IO$M_NOW),= $ IOSB,,, %REF(BUFFER), %VAL(LB),,,, ) IF (.NOT. ISTAT) RETURNC IF (.NOT. IOSB(1)) THEN< IF (IOSB(1) .NE. SS$_ENDOFFILE) CALL EXIT (IOSB(1)) BUFFER = ' ' ELSE CHECK_MAILBOX = .TRUE. ENDIF:C RETURN ENDCC---END CHECK_MAILBOXC. SUBROUTINE WRITE_MAILBOX (ICHAN, BUFFER)C*3C* *******************************3C* *******************************3C* ** **3C* ** WRITE_MAILBOX **3C* ** **3C* *******************************3C* *******************************C*C* AUT;HOR :C* Arthur E. Ragosta'C* RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :(C* WRITE A MESSAGE TO A MAILBOXC*C* INPUT ARGUMENTS :?C* ICHAN - THE CHANNEL NUMBER ASSIGNED BY OPEN_MAILBOX%C* BUFFER - THE MESSAGE TEXTC*C* SUBPROGRAM REFERENCES :C* SYS$QIOWC*%C* ASSUMPTIONS AND RESTR<ICTIONS :C* NOT TRANSPORTABLE-C* BUFFER MUST BE <= 1000 BYTES LONGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) BUFFERC INCLUDE '($IODEF)' INTEGER*2 IOSB(4) INTEGER SYS$QIOC L = LEN(BUFFER)C; ISTAT = SYS$QIO ( , %VAL(ICHAN), %VAL(IO$_=WRITEVBLK),; $ IOSB,,, %REF(BUFFER), %VAL(L),,,,)? IF ((.NOT. ISTAT) .AND. (ISTAT .NE. 0)) CALL EXIT (ISTAT)E IF ((.NOT. IOSB(1)) .AND. (IOSB(1) .NE. 0)) CALL EXIT (IOSB(1))C RETURN ENDCC---END WRITE_MAILBOXC& SUBROUTINE CLOSE_MAILBOX (ICHAN)C*3C* *******************************3C* *******************************3C* ** **3C* ** > CLOSE_MAILBOX **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta'C* RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :C* CLOSE THE MAILBOXC*C* INPUT ARGUMENTS :??C* ICHAN - THE CHANNEL NUMBER ASSIGNED BY OPEN_MAILBOXC*C* SUBPROGRAM REFERENCES :C* SYS$DELMBXC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* INTEGER SYS$DELMBXC& ISTAT = SYS$DELMBX (%VAL(ICHAN))( IF (@.NOT. ISTAT) CALL EXIT (ISTAT)C RETURN ENDCC---END CLOSE_MAILBOXC- SUBROUTINE INPUT_MAILBOX (ICHAN, INPUT)C*3C* *******************************3C* *******************************3C* ** **3C* ** INPUT_MAILBOX **3C* ** **3C* *******************************3C* ****************A***************C*C* AUTHOR :C* Arthur E. Ragosta'C* RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :CC* THIS ROUTINE SETS UP AN AST TO CALL THE PASSED ROUTINE,@C* "INPUT" WHENEVER A PROCESS ATTEMPTS TO READ FROM THEC* SPECIFIED MAILBOX.C*C* INPUT ARGUMENTS :4C* ICHAN - CHANNEL ASSIGNED BBY OPEN_MAILBOX2C* INPUT - EXTERNAL ROUTINE TO BE CALLED.@C* "INPUT" WILL RECEIVE "ICHAN" AS A PARAMETERC*C* SUBPROGRAM REFERENCES :C* SYS$QIOW, EXITC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 30-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CINCLUDE '($IODEF)' INTEGER*2 IOSB(4) INTEGER SYS$QIOW EXTERNAL INPUTCF ISTAT = SYS$QIOW ( ,%VAL(ICHAN), %VAL(IO$_SETMODE+IO$M_WRTATTN),3 $ IOSB,,, INPUT, ICHAN,,,,)' IF (.NOT. ISTAT) CALL EXIT(ISTAT)+ IF (.NOT. IOSB(1)) CALL EXIT(IOSB(1)) RETURN ENDCC---END INPUT_MAILBOXC/ SUBROUTINE OUTPUT_MAILBOX (ICHAN, OUTPUT)C*3C* *******************************3C* ****************D***************3C* ** **3C* ** OUTPUT_MAILBOX **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta'C* RAGOSTA@MERLIN.ARC.NASA.GOVC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 60E4-5558C*C* DESCRIPTION :CC* THIS ROUTINE SETS UP AN AST TO CALL THE PASSED ROUTINE,@C* "OUTPUT" WHENEVER A PROCESS COMPLETES A WRITE TO THEC* SPECIFIED MAILBOX.C*C* INPUT ARGUMENTS :?C* ICHAN - THE CHANNEL NUMBER ASSIGNED BY OPEN_MAILBOX0C* OUTPUT - THE EXTERNAL ROUTINE CALLED=C* "OUTPUT" RECEIVES "ICHAN" AS A PARAMETERC*C* SUBPROGRAM REFERENCES :C* SYS$QIOW, EXITC*%C* ASSUMPTIONS AND RFESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 30-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($IODEF)' INTEGER*2 IOSB(4) INTEGER SYS$QIOW EXTERNAL OUTPUTCG ISTAT = SYS$QIOW ( ,%VAL(ICHAN), %VAL(IO$_SETMODE+IO$M_READATTN),4 $ IOSB,,, OUTPUT, ICHAN,,,,)' IF (.NOT. ISTAT) CALL EXIT(ISTAT)+ IF (.NOT. IOSB(1)) CALL EXIT(IOSB(1)) RETURN ENDCC---END OUTPUT_MAILBOXCwwHRITE(NOUT,920) PROMPT ENDIF ELSE WRITE(NOUT,940) ENDIFCC --- GET RESPONSEC READ(NIN,950) LINECC --- CHECK FOR HELP REQUESTEDC# CALL FIRST ( LINE, CC, J ) IF (CC .EQ. '?') THEN CALL CLEAR WRITE(NOUT,980) N READ(NIN,950) LINE GO TO 10 ENDIFCC ------ DECODE ANSWERC CALL BLANKS ( LINE ) CALL RIGHT ( LINE )& REAID (LINE,960,ERR=30) ANSWER GO TO 40C+C ------ ERROR, PROBABLY NON-DIGITS ENTEREDC30 CALL MBELL  WRITE(NOUT,970) N READ(NIN,950) LINE GO TO 10C+C ------ CHECK FOR OR VALID ANSWERC 40 IF (ANSWER .EQ. 0) THEN# IF (I .EQ. NR) GO TO 10 ELSE= IF ((ANSWER .GT. 0) .AND. (ANSWER .LE. N)) RETURN CALL MBELL  WRITE(NOUT,970) N READ(NIN,950) LINE J GO TO 10 ENDIF100 CONTINUE RETURN900 FORMAT(' ',A)910 FORMAT(' ')920 FORMAT(/' ',A,$) 930 FORMATG $(/' Please enter response or to see choices again : ',$) 940 FORMAT: $(/' Please enter response or to continue ', $ 'viewing choices : ',$)950 FORMAT(A)960 FORMAT(74X,I5)>970 FORMAT(' Please respond with a number from 1 to',I5,////. $' Enter ''?'' at the prompt for help.'//% $' Enter to cont Kinue.')980 FORMAT(//,A $' Please make a selection from the list of choices given.'/D $' Your response should be an integer number from 1 to',I5,'.'/E $' The number associated with each choice is shown immediately'/* $' before that choice in the menu.'//E $' If the number of choices is too great for all of them to be'/H $' displayed on a single screen, there will be a pause at the end'/G $' of each screen. In this case, you will be prompted to either'/E $' enter a choice or hit to continue viewing choices.'/C $' On the last screen of the display, entering will'/1 $' redisplay all choices from the start.'///7 $' Please enter to go back to the menu.')990 FORMAT(I2) ENDC C---END MENUCwwCĮ! SUBROUTINE READQ ( STRING )C*3C* *******************************G3C* ******************************* 3C* ** **C3C* ** READQ **3C* ** **A3C* *******************************3C* ******************************* C*C* SUBPROGRAM :OC* READ QUIETC*C* AUTHOR NGI륚. SUBROUTINE MERGE ( A, NA, B, NB, C, NC )C*/C* *******************************/C* *******************************/C* ** **/C* ** MERGE **/C* ** **/C* *******************************/C* *******************************C*C* SUBPROGRAM :C* MERGEC*C* AUTHOR :C* ArthOur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :FC* PERFORM A MERGE OPERATION ON TWO (SORTED) CHARACTER ARRAYSC*C* INPUT ARGUMENTS :C* A - FIRST ARRAY(C* NA - NUMBER OF ELEMENTS IN AC* B - SECOND ARRAY(C* NB - NUMBER OF ELEMENTS IN BC*C* OUTPUT ARGUMENTS :C* C - MERGED ARRAYEC* NC - NUMBER OF P ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSEGC* DUPLICATES ARE DROPPED)C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSION2C* 29-JUN-1990 - EFFICIENCY IMPROVEMENTEC* 16-AUG-1990 - BUG FIX IN DO LOOPS - INITIAL PARAMETERS 2C* CHANGED FROM 1 TO IA/BC*HC***************************************************************Q********C*' CHARACTER *(*) A(NA), B(NB), C(1)C NC = 0 IA = 1 IB = 1CB100 IF (IA .GT. NA) THEN ! IF A ARRAY IS EMPTY, COPY B TO C DO 10 I = IB,NB NC = NC + 1 C(NC) = B(I)10 CONTINUE RETURN ENDIFB IF (IB .GT. NB) THEN ! IF B ARRAY IS EMPTY, COPY A TO C DO 20 I = IA,NA NC = NC + 1 C(NC) = A(I)20 CONTINUE RETURN ENDIFCD IF (A(IA) .GT. B(IB)) THEN ! COPY SMALLER ELEMENT TO C NC = NC + 1 C(NC) = B(IB) IB = IB + 1% ELSE IF (A(IA) .LT. B(IB)) THEN NC = NC + 1 C(NC) = A(IA) IA = IA + 1G ELSE ! EQUAL.... DELETE ONE OF THEM IA = IA + 1 ENDIF GO TO 100 ENDC C---END MERGECwwSW륚/ SUBROUTINE MERGEI ( A, NA, B, NB, C, NC )C*.C* *******************************.C* *******************************.C* ** **.C* ** MERGEI **.C* ** **.C* *******************************.C* *******************************C*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA AmeTs Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :DC* PERFORM A MERGE OPERATION ON TWO (SORTED) INTEGER ARRAYSC*C* INPUT ARGUMENTS :C* A - FIRST ARRAY(C* NA - NUMBER OF ELEMENTS IN AC* B - SECOND ARRAY(C* NB - NUMBER OF ELEMENTS IN BC*C* OUTPUT ARGUMENTS :C* C - MERGED ARRAYEC* NC - NUMBER OF ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSEGC* U DUPLICATES ARE DROPPED)C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSION3C* 29-JUN-1990 - EFFICIENCY IMPROVEMENTSEC* 16-AUG-1990 - BUG FIX IN DO LOOPS - INITIAL PARAMETERS 2C* CHANGED FROM 1 TO IA/BC*HC***********************************************************************C* INTEGER A(NA), B(NB), C(1)C VNC = 0 IA = 1 IB = 1CB100 IF (IA .GT. NA) THEN ! IF A ARRAY IS EMPTY, COPY B TO C DO 10 I = IB,NB NC = NC + 1 C(NC) = B(I)10 CONTINUE RETURN ENDIFB IF (IB .GT. NB) THEN ! IF B ARRAY IS EMPTY, COPY A TO C DO 20 I = IA,NA NC = NC + 1 C(NC) = A(I)20 CONTINUE RETURN ENDIFCD IF (A(IA) .GT. B(IB)) THEN ! COPY SMALLER ELEMENT TO C NC = NC + 1 C(NC) = B(IB) IB = IB + 1% ELSE IF (A(IA) .LT. B(IB)) THEN NC = NC + 1 C(NC) = A(IA) IA = IA + 1G ELSE ! EQUAL.... DELETE ONE OF THEM IA = IA + 1 ENDIF GO TO 100 ENDCC---END MERGEICwwX=륚/ SUBROUTINE MERGER ( A, NA, B, NB, C, NC )C*-C* *******************************-C* *******************************-C* ** **-C* ** MERGER **-C* ** **-C* *******************************-C* *******************************C*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA AmeYs Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :AC* PERFORM A MERGE OPERATION ON TWO (SORTED) REAL ARRAYSC*C* INPUT ARGUMENTS :C* A - FIRST ARRAY(C* NA - NUMBER OF ELEMENTS IN AC* B - SECOND ARRAY(C* NB - NUMBER OF ELEMENTS IN BC*C* OUTPUT ARGUMENTS :C* C - MERGED ARRAYEC* NC - NUMBER OF ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSEGC* Z DUPLICATES ARE DROPPED)C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSION3C* 29-JUN-1990 - EFFICIENCY IMPROVEMENTSEC* 16-AUG-1990 - BUG FIX IN DO LOOPS - INITIAL PARAMETERS 2C* CHANGED FROM 1 TO IA/BC*HC***********************************************************************C*" DIMENSION A(NA), B(NB), C(1)C [NC = 0 IA = 1 IB = 1C<100 IF (IA .GT. NA) THEN ! IF A IS EMPTY, COPY B TO C DO 10 I = IB,NB NC = NC + 1 C(NC) = B(I)10 CONTINUE RETURN ENDIF< IF (IB .GT. NB) THEN ! IF B IS EMPTY, COPY A TO C DO 20 I = IA,NA NC = NC + 1 C(NC) = A(I)20 CONTINUE RETURN ENDIFCD IF (A(IA) .GT. B(IB)) THEN ! COPY SMALLER ELEMENT TO C  NC = NC + 1 C(NC) = B(IB) IB = IB + 1% ELSE IF (A(IA) .LT. B(IB)) THEN NC = NC + 1 C(NC) = A(IA) IA = IA + 1G ELSE ! EQUAL.... DELETE ONE OF THEM IA = IA + 1 ENDIF GO TO 100 ENDCC---END MERGERCww] |p륚 SUBROUTINE START_MESSC*+C* *******************************+C* *******************************+C* ** **+C* ** START_MESS **+C* ** **+C* *******************************+C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD,^ CA 94035C* (415) 604-5558C*C* PURPOSE :BC* RESTORE THE BROADCAST OF MESSAGES STOPPED BY STOP_MESS7C* DISPLAY ANY MESSAGES THAT HAVE BEEN TRAPPEDC*C* COMMON BLOCKS :C* MLIB$MESSAGEC*C* SUBPROGRAM REFERENCES :>C* SMG$SET_BROADCAST_TRAPPING, SMG$DELETE_PASTEBOARD,$C* LIB$STOP, LIB$PUT_OUTPUTC*%C* TRANSPORTABILITY LIMITATIONS : C* USES SYSTEM ROUTINESC*C* LANGUAGE AND COMPILER :C* _ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSION#C* 12-MAY-88 CLEANED UPC*HC***********************************************************************C* PARAMETER (MAX_MES=10)D COMMON / MLIB$MESSAGE / MESSES(MAX_MES), LENGS(MAX_MES), NMESS CHARACTER *2000 MESSESC C --- RESTORE BROADCAST MESSAGESC0 ISTAT = SMG$SET_BROADCAST_TRAPPING (ID,0,)) ISTAT = SMG$DELETE_PASTEBOARD(ID,0)CC --- DISPLAY TRAPPED MESS`AGESFC --- IF MESSAGES WERE SUPRESSED, BEEP AT THE USER TO WARN HIM TO LOOKC IF (NMESS .GT. 0) THEN LENGS(1) = LENGS(1) + 1/ MESSES(1)(LENGS(1):LENGS(1)) = CHAR(7) ENDIF DO 10 I = 1,NMESS6 ISTAT = LIB$PUT_OUTPUT(MESSES(I)(1:LENGS(I)))10 CONTINUE RETURN ENDCC---END START_MESSC SUBROUTINE STOP_MESSC*,C* *******************************,C* *******************************,C* ** a **,C* ** STOP_MESS **,C* ** **,C* *******************************,C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :2C* BEGIN INTERCEPTON OF TERMINAL MESSAGESC*C* INTERNAL WORK AREAS :)C* MEbSSES - MESSAGES INTERCEPTEDC*C* COMMON BLOCKS :C* MLIB$MESSAGEC*C* SUBPROGRAM REFERENCES :>C* SMG$CREATE_PASTEBOARD, SMG$SET_BROADCAST_TRAPPING,+C* SMG$DELETE_PASTEBOARD, LIB$STOPC*%C* TRANSPORTABILITY LIMITATIONS : C* USES SYSTEM ROUTINESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSIONC*HC*******************************************************c****************C* PARAMETER (MAX_MES=10)D COMMON / MLIB$MESSAGE / MESSES(MAX_MES), LENGS(MAX_MES), NMESS CHARACTER *2000 MESSES@ INTEGER SMG$CREATE_PASTEBOARD, SMG$SET_BROADCAST_TRAPPING# INTEGER SMG$DELETE_PASTEBOARD EXTERNAL MLIB_TRAPCC --- TRAP BROADCAST MESSAGESC- ISTAT = SMG$CREATE_PASTEBOARD (ID,,,,1): ISTAT = SMG$SET_BROADCAST_TRAPPING (ID,MLIB_TRAP,ID)C C --- NUMBER OF MESSAGES TRAPPEDC NMESS = 0 RETURN d ENDCC---END STOP_MESSC! SUBROUTINE MLIB_TRAP ( ID )C*,C* *******************************,C* *******************************,C* ** **,C* ** MLIB_TRAP **,C* ** **,C* *******************************,C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C*e MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE ::C* SUBROUTINE SET UP FOR CALL BY STOP_MESS WHEN A/C* BROADCAST MESSAGE HAS BEEN RECEIVEDC*C* INPUT ARGUMENTS :BC* ID - SPECIFIES THE TERMINAL TO BE CHECKED FOR MESSAGESC*C* COMMON BLOCKS :C* MLIB$MESSAGEC*C* SUBPROGRAM REFERENCES :%C* SMG$GET_BROADCAST MESSAGEC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C*f ASSUMPTIONS AND RESTRICTIONS :<C* NOT A USER ENTRY POINT - USED ONLY BY STOP_MESS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 5-JAN-87 INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (MAX_MES=10)D COMMON / MLIB$MESSAGE / MESSES(MAX_MES), LENGS(MAX_MES), NMESS CHARACTER *2000 MESSES CHARACTER *2000 LONG' INTEGER SMG$GET_BROADCAST_MESSAGEC3 ISTAT = SMG$GET_BROADCAST_MESSAGE(ID,LONG,LW)0 IF (ISTAT .AND. (NMESS .LT. MAX_MES)) THEN NMESS = NMESS + 1 LW = MIN0(2000,LW) LW = MAX0(1,LW)# MESSES(NMESS) = LONG(1:LW) LENGS(NMESS) = LW ENDIF RETURN ENDCC---END MLIB_TRAPCwwh륚* SUBROUTINE MLIB_Error (Isever, Text)C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_Error **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* i RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* or.C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV C* C* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :'C* Produce an error message. C*C* INPUT ARGUMENTS :AC* ISEVER = severity; 0-Inform, 1-Warn, 2-Error, 3-Fatal,C* TEXT = the text of the messageC*C* SUBPROGRAM REFEjRENCES :C* MLIB_GETC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 3-JUL-1990 - INITIAL VERSIONC*HC***********************************************************************C* character *(*) textc% call mlib_get ('NERROR',nerror) if (isever .eq. 0) thenE write(nerror,900) 'MERLIB Information', Text(1:length(Text))" else if (isever .eq. 1) thenA write(nerror,900) 'MERLIB Warkning', Text(1:length(Text))" else if (isever .eq. 2) thenH write(nerror,900) char(7)//'MERLIB Error', Text(1:length(Text)) else9 write(nerror,900) char(7)//'MERLIB Fatal Error',/ $ Text(1:length(Text)) endif RETURN900 format(' ',A,' --- ',A) ENDCC---END MLIB_ErrorC* SUBROUTINE MLIB_Get ( name, ivalue )C*3C* *******************************3C* **********************l*********3C* ** **3C* ** MLIB_Get **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* or.C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV C* C* MS 219-3%C* m NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :8c* Get the value for a MERLIB internal variableC*C* INPUT ARGUMENTS :,c* NAME - the name of the variableC*C* OUTPUT ARGUMENTS :c* IVALUE - the valueC*C* COMMON BLOCKS :c* MLIB$INTERNALC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :+C* 3-JUL-1990 - nINITIAL VERSIONC*HC***********************************************************************C* character *(*) name character *2 short4 common / mlib$internal / nread, nwrite, nerror) data nread/5/, nwrite/6/, nerror/6/c short = name(1:2) call caps(short) if (short .eq. 'NR') then ivalue = nread$ else if (short .eq. 'NW') then ivalue = nwrite else ivalue = nerror endif RETURN ENDoCC---END MLIB_GetC( SUBROUTINE MLIB_Set (name, ivalue)C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_Set **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta p2C* RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* or.C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV C* C* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :=c* Modifies the value for a MERLIB internal variableC*C* INPUT ARGUMENTS :-C* NAME - the name of the variable"C* IVALUE - the new valueC*C* COMMON BLOCKS :qc* mlib$internalC*%C* ASSUMPTIONS AND RESTRICTIONS :'c* Nonstandard data statement.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 3-JUL-1990 - INITIAL VERSIONC*HC***********************************************************************C* character *(*) name character *2 short4 common / mlib$internal / nread, nwrite, nerror) data nread/5/, nwrite/6/, nerror/6/c short = name(1:2) call caps(short) if (short .eq. 'NR') then nread = ivalue$ else if (short .eq. 'NW') then nwrite = ivalue else nerror = ivalue endif RETURN ENDCC---END MLIB_SetCwwscX륚 .title mlib_recall;; Author: Arthur E. Ragosta;L; Return the recall buffer ( the buffer used by the ^B line edit descriptor,; for storage of the last 20 DCL commands).;(; CALL MLIB_RECALL ( BUFFER, IPTR );G; Where BUFFER is an array of BYTES and IPTR is the location in BUFFERI; of the most recent command length. BUFFER is a circular queue of 1025;; bytes. The format is LENGTH, NUL, COMMAND, NUL, LENGTH.;; Link thusly: ?; LI tNK X.OBJ,MERLIB/LIB,SYS$SYSTEM:DCLDEF.STB/SEL,SYS.STB/SEL;; $SSDEF+ .entry mlib_recall,^m9 movl 4(ap),r0 ;loc of descriptor to r0: movl 4(r0),r1 ;location of buffer to r1; movl 8(ap),r0 ;location of lenbuff to r04 movab g^ctl$ag_clidata,r2 ; address of ppdA movl ppd$l_prc(r2),r3 ; address of CLI private storage@ movl prc_l_recallptr(r3),r4 ; current command pointer@ movab prc_g_commands(r3),r2 ; address of recall buffer4 subl3 r2,r4,(r0) ; current command offset: movc3 #1025,(r2),(r1) ; recall buffer to BUFFER ret .end wwvHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :*C* RETRIEVE THE PROCESS MODE TYPEC*C* OUTPUT ARGUMENTS :AC* MTYPE - "INTERACTIVE", "BATCH", "DETACHED", "NETWORK"C*C* SUBPROGRAM REFERENCES :C* SYS$GETJPIWC*%C* TRANSPORTABILITY LIMITATIONS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :wC* ANSI FORTRAN 77C*C* CHANGE HISTORY :-C* 07-JUN-1985 INITIAL VERSION.C* 10-MAR-1989 CHANGED FOR MODEC*HC***********************************************************************C* INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' CHARACTER *(*) MTYPE INTEGER *2 ITEM(14)# INTEGER *4 ITMLST(7), IOSB(2)% EQUIVALENCE (ITEM(1),ITMLST(1))CC --- FILL ITMLSTC ITEM(1) = 4 ITEM(2) = JPI$_MODEx ITMLST(2) = %LOC( MT ) ITMLST(3) = 0 ITEM(7) = 4 ITEM(8) = JPI$_JOBTYPE ITMLST(5) = %LOC( MJ ) ITMLST(6) = 0 ITMLST(7) = 04 ISTAT = SYS$GETJPIW ( ,,, ITMLST, IOSB,, )C) IF ( IOSB(1) .NE. SS$_NORMAL ) THEN MTYPE = 'ERROR' ELSE IF (MJ .EQ. 0) THEN MTYPE = 'DETACHED'! ELSE IF (MT .EQ. 1) THEN MTYPE = 'NETWORK'! ELSE IF (MT .EQ. 2) THEN MTYPE = 'BATCH'! ELSE IF (MT .EQ. 3) THEN IF (MJ .EQ. 1) THEN MTYPE = 'REMOTE' ELSE$ MTYPE = 'INTERACTIVE' ENDIF ELSE MTYPE = 'OTHER' ENDIF ENDIF RETURN ENDC C---END MODEww zt- SUBROUTINE NAME_TO_PID ( IPNAME, EPID )C*3C* *******************************3C* *******************************3C* ** **3C* ** NAME_TO_PID **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :5C* CONVERT A PROCESS {NAME TO AN EXTENDED PIDC*C* AUTHOR :C* Arthur E. Ragosta .C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :GC* FIND THE EXTERNAL PID FROM THE SYSTEM, GIVEN A PROCESS NAME?C* NOTE: THE PROCESS NAME IS CAPITALIZED AND TRUNCATEDC*C* INPUT ARGUMENTS :$C* PNAME - THE PROCESS NAMEC*C* OUTPU|T ARGUMENTS :#C* EPID - THE EXTENDED PIDC*C* SUBPROGRAM REFERENCES :C* SYS$GETJPIWC*%C* TRANSPORTABILITY LIMITATIONS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 4 DEC 1989C*HC***********************************************************************C*  INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' CHARACTER *(*) IPNAME}# CHARACTER *15 PROCNAME, PNAME INTEGER EPID, SYS$GETJPIW INTEGER *2 ITEM(14)# INTEGER *4 ITMLST(7), IOSB(2)% EQUIVALENCE (ITEM(1),ITMLST(1))CC --- WILDCARD SEARCHC IPID = -1 PNAME = IPNAME LP = LEFT ( PNAME ) CALL CAPS ( PNAME )CC --- FILL ITMLSTC ITEM(1) = 15 ITEM(2) = JPI$_PRCNAM" ITMLST(2) = %LOC( PROCNAME ) ITMLST(3) = %LOC( LPROC ) ITEM(7) = 4 ITEM(8) = JPI$_PID ITMLST(5) = %LOC( EPID ) ITMLST(6) = %LOC( LE ) ITMLST(7) = 0810 ISTAT = SYS$GETJPIW ( ,IPID,, ITMLST, IOSB,, )4 IF (PNAME(1:LP) .EQ. PROCNAME(1:LPROC)) RETURN/ IF ( ISTAT .NE. SS$_NOMOREPROC ) GO TO 10C EPID = 0 RETURN ENDCC---END NAME_TO_PIDCww"" FUNCTION NDEX (STRING, TARG)C*3C* *******************************3C* *******************************3C* ** **3C* ** NDEX **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* END INDEXC*C* AUTHOR :C* L JURGELEITC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*C* PURPOSE :=C* FIND THE FIRST OCCURRENCE OF THE SPECIFIED TARGET1C* CHARACTERS FROM THE END OF THE STRINGC*C* INPUT ARGUMENTS :/C* STRING - CHARACTER STRING TO SEARCH-C* TARG - CHARACTERS TO SEARCH FORC*C* OUTPUT ARGUMENTS :9C* NDEX - POSITION IN STRING OF TARGET CHARACTERC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 15-DEC-1987 - INITIAL VERSIONC*HC***********************************************************************C*! CHARACTER *(*) STRING, TARGC ISLEN = LEN (STRING) ITLEN = LEN (TARG) IF (ITLEN .LE. ISLEN) THEN ITLEN = ITLEN - 1 IST = ISLEN - ITLEN DO 10 I = IST, 1, -11 IF (STRING(I:I+ITLEN) .EQ. TARG) THEN NDEX = I RETURN ENDIF10 CONTINUE ENDIF NDEX = 0 RETURN ENDC C---END NDEXCwwe SUBROUTINE NUMERICC*3C* *******************************3C* *******************************3C* ** **3C* ** NUMERIC **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5578C*C* DESCRIPTION :6C* SET AN ANSI TERMINAL TO USE NUMERIC KEYPADC*C* SUBPROGRAM REFERENCES :C* LIB$PUT_OUTPUTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC******************************************************* ****************C*- CALL LIB$PUT_OUTPUT ( CHAR(27) // '>' ) RETURN ENDCC---END NUMERICCww SUBROUTINE OCTDEC ( O, I )C*3C* *******************************3C* *******************************3C* ** **3C* ** OCTDEC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* OCTAL TO DECIMALC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :>C* TO CONVERT AN OCTAL STRING INTO THE DECIMAL NUMBER+C* EQUIVALENT TO THE OCTAL STRING.C*C* INPUT ARGUMENTS : C* O - THE OCTAL STRINGC*C* OUTPUT ARGUMENTS :"C* I - THE INTEGER NUMBERC*%C* TRANSPORTABILITY LIMITATIONS :8C* USES THE NON-STANDARD FORMAT DESCRIPTOR, 'O'C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *16 OC CALL RIGHT (O) READ(O,900)I RETURN900 FORMAT(O16) ENDCC---END OCTDECCwwN% SUBROUTINE OPER ( MESSAG, WHO )C*3C* *******************************3C* *******************************3C* ** **3C* ** OPER **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* OPERATOR MESSAGEC*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER%C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :7C* TO SEND A MESSAGE TO AN OPERATOR'S CONSOLE.C*C* INPUT ARGUMENTS :,C* MESSAG - THE MESSAGE TO BE SENTJC* WHO - WHICH OPERATOR TO SEND IT TO (EG, 'CENTRAL','TAPES')C*C* INTERNAL WORK AREAS :AC* MSGBUF - THE BUFFER FOR THE MESSAGE AND COMMAND CODESFC*  OPER,IOPER - THE OPERATOR TARGET CODES IN ASCII AND BINARYC*C* SUBPROGRAM REFERENCES :C* SYS$SNDOPRC*%C* TRANSPORTABILITY LIMITATIONS :$C* HIGHLY NON-TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :2C* NO CHECK IS DONE ON 'WHO' FOR ACCURACYC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 25-JUL-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) MESSAG, WHO CHARACTER *255 MSGBUF# CHARACTER *2 OPERS(11), DUMMY" INTEGER *2 IOPER(11), IDUMMY EQUIVALENCE (DUMMY,IDUMMY)C8C --- OPERATOR TARGET CODES FROM SYSLIB:STARLET($OPCDEF)CH DATA OPERS/'CE','PR','TA','DI','DE','CA','NT','CL','SE','RE','NE'/G DATA IOPER/ 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 64/C&C --- TO WHOM DO WE SEND THE MESSAGE ?C DO 10 I = 1,11- IF (WHO(1:2) .EQ. OPERS(I)) GO TO 2010 CONTINUE I = 1C620 MSGBUF(1:1) = CHAR(3) ! REQUEST ALWAYS IDUMMY = IOPER(I) MSGBUF(2:2) = CHAR(0)< MSGBUF(3:4) = DUMMY ! OPERATOR TARGET CODE MSGBUF(5:8) = ' '4 MSGBUF(9:) = MESSAG ! USER MESSAGEC! ISTAT = SYS$SNDOPR(MSGBUF,) RETURN ENDC C---END OPERCww рD- SUBROUTINE OPERW ( MESSAG, WHO, REPLY )C*3C* *******************************3C* *******************************3C* ** **3C* ** OPERW **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :+C* OPERATOR MESSAGE/WAIT FOR REPLYC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER%C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* TO SEND A MESSAGE TO AN OPERATOR'S CONSOLE AND WAIT FOR AC* REPLY.C*C* INPUT ARGUMENTS :7C* MESSAG - THE TEXT OF THE MESSAGE TO BE SENTOC* WHO - THE OPERATOR TO RECEIVE THE MESSAGE (EG,'CENTRAL','TAPES')C*C* OUTPUT ARGUMENTS :HC* REPLY - THE TEXT STRING ENTERED BY THE OPERATOR, OR AN ERROR3C* MESSAGE(FIRST WORD IS 'ERROR')C*C* INTERNAL WORK AREAS :AC* MSGBUF - THE BUFFER FOR THE MESSAGE AND COMMAND CODESFC* OPER,IOPER - THE OPERATOR TARGET CODES IN ASCII AND BINARYC*C* FILE REFERENCES :!C* 0 - READ FROM MAILBOXC*C* SUBPROGRAM REFERENCES :.C* SYS$SNDOPR, SYS$CREMBX, SYS$DASSGNC*C* ERROR PROCESSING :EC* THE STATUS OF THE PREVIOUS SYSTEM SERVICE CALL IS CHECKEDC* BEFORE CONTINUING.C*%C* TRANSPORTABILITY LIMITATIONS :$C* HIGHLY NON-TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS ::C* NO CHECK IS PERFORMED TO SEE IF 'WHO' IS VALIDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 25-JUL-85 INITIAL VERSIONC*HC***********************************************************************C*' CHARACTER *(*) MESSAG, WHO, REPLY CHARACTER *255 MSGBUF# CHARACTER *2 OPERS(11), DUMMY" INTEGER *2 IOPER(11), IDUMMY EQUIVALENCE (DUMMY,IDUMMY)C8C --- OPERATOR TARGET CODES FROM SYSLIB:STARLET($OPCDEF)CH DATA OPERS/'CE','PR','TA','DI','DE','CA','NT','CL','SE','RE','NE'/G DATA IOPER/ 1, 2, 4, 8, 16, 32, 64, 128, 256, 512, 64/C&C --- TO WHOM DO WE SEND THE MESSAGE ?C DO 10 I = 1,11- IF (WHO(1:2) .EQ. OPERS(I)) GO TO 2010 CONTINUE I = 1C620 MSGBUF(1:1) = CHAR(3) ! REQUEST ALWAYS IDUMMY = IOPER(I) MSGBUF(2:2) = CHAR(0)< MSGBUF(3:4) = DUMMY ! OPERATOR TARGET CODE MSGBUF(5:8) = ' '6 MSGBUF(9:) = MESSAG ! USER'S MESSAGECC --- OPEN MAILBOX FOR REPLYC2 ISTAT = SYS$CREMBX ( ,ICHAN,,,,, 'OPERMBX' ) IF ( ISTAT .NE. 0 ) THEN( REPLY = 'ERROR OPENING MAILBOX' RETURN ENDIFCC --- SEND THE MESSAGEC, ISTAT = SYS$SNDOPR(MSGBUF,%VAL(ICHAN)) IF ( ISTAT .NE. 0 ) THEN( REPLY = 'ERROR OPENING MAILBOX' RETURN ENDIF- OPEN (UNIT=0,NAME='OPERMBX',TYPE='OLD')( READ(0,900,END=100,ERR=100) MSGBUF GO TO 200,100 REPLY = 'ERROR GETTING OPERATOR REPLY'200 CLOSE(UNIT=0)% ISTAT = SYS$DASSGN(%VAL(ICHAN)) REPLY = MSGBUF(9:132) RETURN900 FORMAT(A) ENDC C---END OPERWCww˻ SUBROUTINE ORDINAL (NUM)C*3C* *******************************3C* *******************************3C* ** **3C* ** ORDINAL **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :?C* RETURN THE ORDINAL REPRESENTATION OF A NUMBER; E.G.C* 1 = 1stC* 2 = 2ndC* 3 = 3rdC* .C*C* INPUT ARGUMENTS : C* NUM - THE RAW NUMBERC*C* OUTPUT ARGUMENTS : C* NUM - ORDINAL NUMBERC*C* SUBPROGRAM REFERENCES :C* LEFTC*%C* ASSUMPTIONS AND RESTRICTIONS :7C* IT RETURNS THE ORDINAL POSTFIX IN LOWERCASE/C* NO ERROR CHECKING IS DONE ON NUMBERC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 1-MAY-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) NUM CHARACTER *2 TWOC LL = LEFT (NUM) LN = LEN(NUM) IF ((LL+2) .GT. LN) RETURNC# IF (NUM(LL:LL) .EQ. '1') THEN TWO = 'st'( ELSE IF (NUM(LL:LL) .EQ. '2') THEN TWO = 'nd'( ELSE IF (NUM(LL:LL) .EQ. '3') THEN TWO = 'rd' ELSE TWO = 'th' ENDIFC"C --- TEENS ARE THE ONLY EXCEPTIONC IF (LL .GT. 1) THEN0 IF (NUM(LL-1:LL-1) .EQ. '1') TWO = 'th' ENDIFC NUM(LL+1:LL+2) = TWO RETURN ENDCC---END ORDINALCwwK}'" SUBROUTINE SETIMEC*3C* ******************************* 3C* *******************************3C* ** ** 3C* ** SETIME **3C* ** **S3C* *******************************3C* *******************************TC*C* SUBPROGRAM :C* SET TIMEC*C* AUTHOR :SC* Vb= SUBROUTINE PackOut (nout, in, out, iout, cstring, cend)C*3C* *******************************3C* *******************************3C* ** **3C* ** PackOut **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta .C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :HC* Pack text into an output buffer and dump it when it is full.9C* Note, CALL FLUSHOUT to force writing of line.1C* FORTRAN carriage control is not used.C*C* INPUT ARGUMENTS :,C* NOUT - UNIT NUMBER FOR OUTPUT7C* IN - TE XT TO BE ADDED TO OUTPUT BUFFER.C* OUT - OUTPUT BUFFER (PREVIOUS)EC* IOUT - LOCATION OF LAST CHARACTER IN OUT (INITIALLY 0))C* CSTRING - CONTINUATION STRINGHC* CEND - TRUE IF CSTRING IS APPENDED TO THE END OF THE LINEGC* TO BE CONTINUED, FALSE IF IT GOES ON THE START (C* OF THE NEXT LINEC*C* OUTPUT ARGUMENTS :)C* OUT - UPDATED OUTPUT BUFFER*C* IOUT - UPDATED POINTER IN OUTC*C* SUBPROGRAM REFERENCES :C* FlushoutC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 16-MAR-1990 - INITIAL VERSIONC*HC***********************************************************************C*% character *(*) in, out, cstring logical cendc)c --- maximum characters in output bufferc max = len(out)( if (cend) max = max - len(cstring) lin = len(in)c8c --- if there isn't enough room in the buffer, flush itc# if ((iout+lin) .gt. max) thencDc ----- it is possible that the input string is too long to buffer, c break it into partsc if (lin .gt. max) thenH call FlushOut (nout, out, iout) ! First, flush buffer istart = 1 iend = max@10 out = in(istart:iend) ! Print parts- iout = min0(max, (iend-istart+1))# if (iend .lt. lin) then.  call FlushOut (nout, out, iout) istart = iend + 1& iend = istart + max - 1 go to 10 endifc1c ----- not too big, flush buffer then pack inputc elsecHc ------- does the continuation string go on the end of the string to bec continued...c if (cend) then% out(iout+1:) = cstring) iout = iout + len(cstring). call FlushOut (nout, out, iout)  iout = lin out = inc+c ------- or at the start of the next line?c else= call FlushOut (nout, out, iout) " out = cstring // in( iout = lin + len(cstring) endif endifcc --- buffer input onlyc else out(iout+1:) = in iout = iout + lin endif RETURN ENDCC---END PackOutC+ SUBROUTINE FlushOut (nout, out, iout) character *(*) outc2 if (iout .gt. 0) write(nout,900) out(1:iout) iout = 0 return900 format(a) endcc---end flushoutcwwU.7 INTEGER FUNCTION PARSE (SPEC, DEFAULT, PART, OUT)C*3C* *******************************3C* *******************************3C* ** **3C* ** PARSE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PARSEC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :7C* PARSE A FILE SPECIFICATION (OR PART OF ONE)1C* EMULATES THE LEXICAL FUNCTION F$PARSEC*C* INPUT ARGUMENTS :/C* SPEC - INPUT (PARTIAL) FILE SPECCC* DEFAULT - DEFAULT SPEC FOR MISSING PARTS (IF BLANK, USE+C* CURRENT NODE, ETC.)&C* PART - THE PART WANTED:AC* 'NODE', 'DEVICE', 'DIRECTORY', 'NAME',3C* 'TYPE', 'VERSION', 'FULL'C*C* OUTPUT ARGUMENTS :(C* OUT - THE PART REQUESTEDC*C* SUBPROGRAM REFERENCES :2C* TRANSL8, SYS$PARSE, EXIT, LIB$MOVC5C*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE.HC* ASSUMES CURRENT DIRECTORY AND FILE TYPE '.DAT' IF NONE GIVENC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 20-JUN-1988C*C* CHANGE HISTORY :+C* 20-JUN-1988 - INITIAL VERSIONHC* 29-JUN-1990 - BUG FIXED WHILE REUSING "OUT" AS WORK BUFFERGC* 8-FEB-1991 - CHANGED TO INTEGER FUNCTION TO RETURN ISTATC*HC***********************************************************************C* INCLUDE '($FABDEF)' INCLUDE '($NAMDEF)' RECORD /FABDEF/ FAB  RECORD /NAMDEF/ NAM CHARACTER *127 WORK- CHARACTER *(*) SPEC, DEFAULT, PART, OUT INTEGER SYS$PARSE INTEGER *2 IIC parse = 0: 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_BLNC) 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_BLNC" 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_DEVB 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 (PA RT(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. '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 RETURN1000 parse= istat out = ' ' return ENDC C---END PARSECww< INTEGER FUNCTION PAY_DAYC*3C* *******************************3C* *******************************3C* ** **3C* ** PAY_DAY **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* RAGOSTA@MERLIN.ARC.NASA.GOV (Internet) C* C* MS 219-1%C* NASA Ames Research Center*C* Moffett Field, Ca. 94035-1000C* (415) 604-5558C*C* DESCRIPTION :AC* Return the day of the pay period (i.e., 1 through 14)C*C* SUBPROGRAM REFERENCES :'C* TRANSL8, RIGHT, DAY_OF_YEARC*%C* ASSUMPTIONS AND RESTRICTIONS :EC* The logical name PAY_FIRST_DAY must be set with the firstDC* day of the pay year (1 through 13). It should be set at8C* boot time/first day of pay year (by Kronos).C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 26-JAN-1993 - INITIAL VERSIONC*HC***********************************************************************C* EXTERNAL DAY_OF_YEAR INTEGER DAY_OF_YEAR CHARACTER *2 PFDC( CALL TRANSL8 ('PAY_FIRST_DAY',PFD) CALL RIGHT (PFD); READ(PFD,'(I2)') JDAY ! First day of pay year1 I = DAY_OF_YEAR () ! Current day IDAY = I - JDAY + 1< PAY_DAY = MOD (IDAY, 14) ! 14 days per pay period RETURN ENDCC---END PAY_DAYCwwQC SUBROUTINE PCALFA C*3C* *******************************3C* *******************************3C* ** **3C* ** PCALFA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PCALFAC*C* AUTHOR :C*  Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :FC* RETURN A PC (USING THE KERMIT VT100 EMULATOR) TO TEXT MODEC*%C* ASSUMPTIONS AND RESTRICTIONS :-C* UNIQUE TO VERSION 2.3 OF MSKERMIT3C* USES NON-STANDARD '$' FORMAT DESCRIPTORC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 16-MAY -1988 - INITIAL VERSIONC*HC***********************************************************************C*# call mlib_get('NWRITE',nunit) WRITE(NUNIT,900) CHAR(27) RETURN900 FORMAT(' ',A1,'[?38l',$) ENDCC---END PCALFACwwD I .title peek;; Author: Arthur E. Ragosta;G; Look at the byte at the specified location. Location by reference.;; i = peek (location); ; Example:; i = peek (%loc(x)); .entry peek,^m<>: movl @4(ap),r1 ;address of location to r11 movb (r1),r0 ;move that sucker ret .endww=N .title peekl;; Author: Arthur E. Ragosta;L; Look at the longword at the specified location. Parameter by reference.;; i = peekl (location); ; Example:; i = peekl (%loc(x)+3); .entry peekl,^m<>: movl @4(ap),r1 ;address of location to r11 movl (r1),r0 ;move that sucker ret .endww _ .title pokel;; Author: Arthur E. Ragosta;N; Put a longword into the specified location. Both parameters by reference.;#; call pokel (location, value); ; Example:; i = %loc(x); call pokel (i, 1024); .entry pokel,^m<>: movl @4(ap),r1 ;address of location to r1: movl 8(ap),r0 ;address of longword to r01 movl (r0),(r1) ;move that sucker ret .endww. INTEGER FUNCTION Print_File ( fname, q )C*3C* *******************************3C* *******************************3C* ** **3C* ** Print_File **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* or.C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV C* C* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION : C* Prints a single fileC*C* INPUT ARGUMENTS :GC* FNAME - (character*(*),input) the name of the file to printFC* Q - (character*(*),input) the name of the system queueC*C* SUBPROGRAM REFERENCES : C* LENGTH, SYS$SNDJCBWC*%C* ASSUMPTIONS AND RESTRICTIONS :C* Not Transportable.C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :+C* 29-JUN-1990 - INITIAL VERSIONC*HC***********************************************************************C* include '($sjcdef)' character *(*) fname, q character *20 qnamec" integer iosb(2), sys$sndjbcw structure / item_list / integer *2 leng integer *2 item integer loc integer outleng end structure# record / item_list / list (4)c if (q .ne. ' ') then qname = q else qname = 'SYS$PRINT' endifc% list(1).leng = length(fname)/ list(1).item = SJC$_FILE_SPECIFICATION# list(1).loc = %loc(fname)c% list(2).leng = length(qname)" list(2).item = SJC$_QUEUE#  list(2).loc = %loc(qname)c list(3).leng = 0# list(3).item = SJC$_NOTIFY list(3).loc = 0c list(4).leng = 0 list(4).item = 0cG print_file = SYS$SNDJBCW (, %val(SJC$_ENTER_FILE),, list, iosb,,)* if (print_file) print_file = iosb(1) RETURN ENDCC---END Print_FileCwwa" SUBROUTINE PROMPT ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** PROMPT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PROMPTC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :<C* PRODUCE A PROMPT TO THE TERMINAL WITHOUT A .C*C* METHODOLOGY :EC* NON-TRANSPORTABLE DEC '$' FIELD DESCRIPTOR IN THE FORMAT.C*C* INPUT ARGUMENTS :,C* STRING - THE TEXT OF THE PROMPT.C*C* FILE REFERENCES : C* NUNIT - OUTPUT UNIT.C*%C* TRANSPORTABILITY LIMITATIONS :=C* USES DEC-SPECIFIC '$' FIELD DESCRIPTOR IN FORMAT.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC% call mlib_get ('NWRITE', nunit) WRITE ( NUNIT, 900 )STRING900 FORMAT (' ', A, $ ) RETURN ENDCC---END PROMPTCwwf8! SUBROUTINE PUTC ( C, NOUT )C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PUT CHARACTERC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :6C* PUT A SINGLE CHARACTER TO THE OUTPUT FILE.<C* CALL PUTC WITH A CARRIAGE RETURN TO DUMP BUFFER.C*C* INPUT ARGUMENTS :)C* C - THE CHARACTER TO OUTPUT0C* NOUT- THE OUTPUT LOGICAL UNIT NUMBERC*C* SUBPROGRAM REFERENCES :C* MLIB_ERRORC*%C* TRANSPORTABILITY LIMITATIONS :DC* THE SAVE STATEMENT (WHICH IS COMMENTED) MAY BE NEEDED ONC* SOME SYSTEMSC*%C* ASSUMPTIONS AND RESTRICTIONS :BC* THE OUTPUT LINE LENGTH IS RESTRICTED TO 132 CHARACTERSJC* NOTE: IT IS PROBABLY DESIRABLE TO USE AN OPEN STATEMENT BEFOREJC* THE FIRST CALL TO PUTC WITH THE OPTION "CARRIAGECONTROL=%C* 'LIST'" ON THE VAX.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 10-SEP-85 INITIAL VERSIONC*HC***********************************************************************C*# PARAMETER (LMAX=132,NSTART=0) CHARACTER *(LMAX) LINE CHARACTER CC SAVE NPTR, LINE DATA NPTR/NSTART/CC --- END OF LINE, WRITE BUFFERC IF (C .EQ. CHAR(13)) THEN IF (NPTR .EQ. 0) THEN$ WRITE(NOUT,910,ERR=1000) ELSE1 WRITE(NOUT,900,ERR=1000) LINE(1:NPTR) NPTR = 0 ENDIFCC --- ELSE BUFFER CHARACTERC ELSE! IF (NPTR .EQ. LMAX) THEN1 WRITE(NOUT,900,ERR=1000) LINE(1:NPTR) NPTR = 0 ENDIF NPTR = NPTR + 1 LINE(NPTR:NPTR) = C ENDIF RETURN;1000 CALL MLIB_ERROR(2, 'PUTC', 'Unknown error on write.') RETURN900 FORMAT(A)910 FORMAT( ) ENDC C---END PUTCCww,] SUBROUTINE PUTCHAR ( STR )C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTCHAR **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :C*C* INPUT ARGUMENTS :C*C* OUTPUT ARGUMENTS :C*C* COMMON BLOCKS :C*C* SUBPROGRAM REFERENCES :C*%C* ASSUMPTIONS AND RESTRICTIONS :C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 7-MAR-1989 - INITIAL VERSIONC* HC***********************************************************************C* CHARACTER *(*) STRC$ CALL MLIB_GET('NWRITE',NWRITE) WRITE(NWRITE,900) STR RETURN900 FORMAT(' ',A,$) ENDCC---END PUTCHARCww . SUBROUTINE PUTSTM ( NUNIT, LABEL, STMT )C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTSTM **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* PUT STATEMENT  C*C* AUTHOR :4C* LAURA JURGELEIT C* MS 219-34C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 604-5578 C*C* PURPOSE :5C* WRITE A FORTRAN STATEMENT TO UNIT 'NUNIT'C*C* FILE REFERENCES :C* NUNITC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 3-SEP-86 INITIAL VERSION8C* 1-JUN-88 GENERALIZED AND PUT INTO MERLIB7C* 3-AUG-90 DELETED UNUSED VARIABLE "CARD"C*HC***********************************************************************C* PARAMETER (LC=72,LL=LC-6) CHARACTER *(*) STMT CHARACTER *6 TLABEL CHARACTER *5 LABELCA IST = 1 ! POINTER TO NEXT LOCATION TO PRINT. L = LENGTH(STMT) ! LENGTH OF STMT@ LS = L ! " " " YET TO BE PRINTED TLABEL = LABEL10 IF (LS .GT. LL) THEN5 WRITE (NUNIT,900) TLABEL, STMT(IST:IST+LL-1) TLABEL = ' $' LS = LS-LL IST = IST + LL GO TO 10 ENDIF7 IF (LS .GT. 0) WRITE(NUNIT,900)TLABEL,STMT(IST:L) RETURN900 FORMAT(A6,A) ENDCC---END PUTSTMC wwq# SUBROUTINE PUTSTRING (STRING)C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTSTRING **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PUTSTRINGC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :?C* PUT A STRING TO A TERMINAL, WRAPPING AT END OF LINEC*C* INPUT ARGUMENTS :&C* STRING - THE OUTPUT STRINGC*C* SUBPROGRAM REFERENCES :1C* LENGTH, GET_TERM_SIZE, LIB$PUT_OUTPUTC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 22-DEC-1987 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC LS = LENGTH ( STRING ) IF (LS .EQ. 0) RETURNC! CALL GET_TERM_SIZE (IW, IL) I = 1CEC --- IF THE REMAINING CHARACTERS ALL FIT ON ONE LINE, DO IT AND EXITC 10 IF ((I+IW-1) .GT. LS) THEN- CALL LIB$PUT_OUTPUT ( STRING(I:LS) )CAC --- OTHERWISE, FIND A GOOD BREAK POINT (SPACE NEAR END OF LINE)C ELSE J = I + IW - 1'20 IF (STRING(J:J) .NE. ' ') THEN J = J - 1) IF (J .GT. (I + 40)) GO TO 20 J = I + IW - 1 ENDIF, CALL LIB$PUT_OUTPUT ( STRING(I:J) ) I = J + 1 GO TO 10 ENDIF RETURN ENDCC---END PUTSTRINGCwwK# SUBROUTINE UNIQUE ( NAME )C*3C* *******************************T3C* *******************************G3C* ** **3C* ** UNIQUE **S3C* ** **"3C* ******************************* 3C* *******************************C*C* AUTHOR :CC* Arthur E. Ragosta C* MS 2W@% SUBROUTINE QSORT ( X, N, WORK )C*3C* *******************************3C* *******************************3C* ** **3C* ** QSORT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* QUICK SORTC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :(C* QUICK SORT A CHARACTER ARRAY<C* REF: "SOFTWARE TOOLS" BY KERNIGHAN AND PLAUGERC*C* INPUT ARGUMENTS :C* X - ARRAY TO SORT(C* N - NUMBER OF ELEMENTS IN NC* WORK - WORK STRINGC*C* INTERNAL WORK AREAS :;C* LEFT, RIGHT - TEMPORARY STORAGE FOR POINTERS TO,C* SIMULATE RECURSIONC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) X(N), WORK CHARACTER *80 TEMP! INTEGER LEFT(40), RIGHT(40)C LEFT(1) = 1 RIGHT(1) = N ISP = 1CC --- DO WHILE ISP > 0C10 IF (ISP .GT. 0) THEN, IF (LEFT(ISP) .GE. RIGHT(ISP)) THEN ISP = ISP - 1 ELSE I = LEFT(ISP) J = RIGHT(ISP) WORK = X(J) MID = (I+J) / 2" IF ((J-I) .GT. 5) THENE IF (((X(MID) .LT. WORK) .AND. (X(MID) .GT. X(I))) .OR.F $ ((X(MID) .GT. WORK) .AND. (X(MID) .LT. X(I)))) THENCC --- SWAP X(MID) WITH X(J)C TEMP = X(MID) X(MID) = X(J) X(J) = TEMPH  ELSE IF (((X(I) .LT. X(MID)) .AND. (X(I) .GT. WORK)) .OR.C $ ((X(I) .GT. X(MID)) .AND. (X(I) .LT. WORK))) THENCC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP ENDIF ENDIF WORK = X(J)20 IF (I .LT. J) THEN'30 IF (X(I) .LT. WORK) THEN I = I + 1 GO TO 30 ENDIF  J = J - 1:40 IF ((I .LT. J) .AND. (WORK .LT. X(J))) THEN J = J - 1 GO TO 40 ENDIF! IF (I .LT. J) THENCC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP ENDIF GO TO 20 ENDIF J = RIGHT(ISP)CC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP9 IF ((I-LEFT(ISP)) .GE. (RIGHT(ISP) - 1)) THENCC --- PUT SHORTER PART FIRSTC& LEFT(ISP+1) = LEFT(ISP)! RIGHT(ISP+1) = I-1 LEFT(ISP) = I+1 ELSE LEFT(ISP+1) = I+1( RIGHT(ISP+1) = RIGHT(ISP)! RIGHT(ISP) = I - 1 ENDIFCC --- PUSH STACKC ISP = ISP + 1 ENDIF GO TO 10 ENDIFCC --- END DO WHILEC RETURN ENDC C---END QSORTCwwl̩ SUBROUTINE QSORTI ( X, N )C*3C* *******************************3C* *******************************3C* ** **3C* ** QSORTI **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM : C* QUICK SORT (INTEGER)C*C*  AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :'C* QUICK SORT AN INTEGER ARRAY<C* REF: "SOFTWARE TOOLS" BY KERNIGHAN AND PLAUGERC*C* INPUT ARGUMENTS :C* X - ARRAY TO SORT(C* N - NUMBER OF ELEMENTS IN NC*C* INTERNAL WORK AREAS :;C* LEFT, RIGHT - TEMPORARY STORAGE FOR POINTERS TO,C*  SIMULATE RECURSIONC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* INTEGER X(N), TEMP, WORK! INTEGER LEFT(40), RIGHT(40)C LEFT(1) = 1 RIGHT(1) = N ISP = 1CC --- DO WHILE ISP > 0C10 IF (ISP .GT. 0) THEN, IF (LEFT(ISP) .GE. RIGHT(ISP)) THEN ISP = ISP - 1 ELSE I = LEFT(ISP) J = RIGHT(ISP) WORK = X(J) MID = (I+J) / 2" IF ((J-I) .GT. 5) THENE IF (((X(MID) .LT. WORK) .AND. (X(MID) .GT. X(I))) .OR.F $ ((X(MID) .GT. WORK) .AND. (X(MID) .LT. X(I)))) THENCC --- SWAP X(MID) WITH X(J)C TEMP = X(MID) X(MID) = X(J) X(J) = TEMPH ELSE IF (((X(I) .LT. X(MID)) .AND. (X(I) .GT. WORK)) .OR.C $ ((X(I) .GT. X(MID)) .AND. (X(I) .LT. WORK))) THENCC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP ENDIF ENDIF WORK = X(J)20 IF (I .LT. J) THEN'30 IF (X(I) .LT. WORK) THEN I = I + 1 GO TO 30 ENDIF J = J - 1:40 IF ((I .LT. J) .AND. (WORK .LT. X(J))) THEN J = J - 1 GO TO 40 ENDIF! IF (I .LT. J) THENCC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP ENDIF GO TO 20 ENDIF J = RIGHT(ISP)CC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP9 IF ((I-LEFT(ISP)) .GE. (RIGHT(ISP) - 1)) THENCC --- PUT SHORTER PART FIRSTC& LEFT(ISP+1) = LEFT(ISP)! RIGHT(ISP+1) = I-1 LEFT(ISP) = I+1 ELSE LEFT(ISP+1) = I+1( RIGHT(ISP+1) = RIGHT(ISP)! RIGHT(ISP) = I - 1 ENDIFCC --- PUSH STACKC ISP = ISP + 1 ENDIF GO TO 10 ENDIFCC --- END DO WHILEC RETURN ENDCC---END QSORTRCww0 SUBROUTINE QSORTR ( X, N )C*3C* *******************************3C* *******************************3C* ** **3C* ** QSORTR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* QUICK SORT (REAL)C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :#C* QUICK SORT A REAL ARRAY<C* REF: "SOFTWARE TOOLS" BY KERNIGHAN AND PLAUGERC*C* INPUT ARGUMENTS :C* X - ARRAY TO SORT(C* N - NUMBER OF ELEMENTS IN NC*C* INTERNAL WORK AREAS :;C* LEFT, RIGHT - TEMPORARY STORAGE FOR POINTERS TO,C* SIMULATE RECURSIONC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION X(N)! INTEGER LEFT(40), RIGHT(40)C LEFT(1) = 1 RIGHT(1) = N ISP = 1CC --- DO WHILE ISP > 0C10 IF (ISP .GT. 0) THEN, IF (LEFT(ISP) .GE. RIGHT(ISP)) THEN ISP = ISP - 1 ELSE I = LEFT(ISP) J = RIGHT(ISP) WORK = X(J) MID = (I+J) / 2" IF ((J-I) .GT. 5) THENE IF (((X(MID) .LT. WORK) .AND. (X(MID) .GT. X(I))) .OR.F $ ((X(MID) .GT. WORK) .AND. (X(MID) .LT. X(I)))) THENCC --- SWAP X(MID) WITH X(J)C TEMP = X(MID) X(MID) = X(J) X(J) = TEMPH ELSE IF (((X(I) .LT. X(MID)) .AND. (X(I) .GT. WORK)) .OR.C $ ((X(I) .GT. X(MID)) .AND. (X(I) .LT. WORK))) THENCC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP ENDIF ENDIF WORK = X(J)20 IF (I .LT. J) THEN'30 IF (X(I) .LT. WORK) THEN I = I + 1 GO TO 30 ENDIF J = J - 1:40 IF ((I .LT. J) .AND. (WORK .LT. X(J))) THEN J = J - 1 GO TO 40 ENDIF! IF (I .LT. J) THENCC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP ENDIF GO TO 20 ENDIF J = RIGHT(ISP)CC --- SWAP X(I) WITH X(J)C TEMP = X(I) X(I) = X(J) X(J) = TEMP9 IF ((I-LEFT(ISP)) .GE. (RIGHT(ISP) - 1)) THENCC --- PUT SHORTER PART FIRSTC& LEFT(ISP+1) = LEFT(ISP)! RIGHT(ISP+1) = I-1 LEFT(ISP) = I+1 ELSE LEFT(ISP+1) = I+1( RIGHT(ISP+1) = RIGHT(ISP)! RIGHT(ISP) = I - 1 ENDIFCC --- PUSH STACKC ISP = ISP + 1 ENDIF GO TO 10 ENDIFCC --- END DO WHILEC RETURN ENDCC---END QSORTRCww%hC5 SUBROUTINE QUOTA (DISK, CUIC, USED, PERM, IRET)C*3C* *******************************3C* *******************************3C* ** **3C* ** QUOTA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* QUOTAC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :DC* TO RETURN A USER'S PERMANENT DISKQUOTA AND AMOUNT OF THE!C* QUOTA PRESENTLY USED.C*C* INPUT ARGUMENTS :EC* DISK - THE "PHYSICAL" DEVICE TO CHECK (BLANK FOR CURRENT)EC* CUIC - THE UIC TO CHECK IN "[NUM,NUM]" (CHARACTER) FORMAT,C* (BLANK TO CHECK CALLER)C*C* OUTPUT ARGUMENTS :C* USED - BLOCKS USED+C* PERM - PERMANENT QUOTA (BLOCKS)1C* IRET - 0 FOR SUCCESS, ISTAT OTHERWISEC*C* SUBPROGRAM REFERENCES ::C8 SYS$ASSGN, LIB$GETJPI, SYS$QIOW, SYS$DASSGNC*%C* ASSUMPTIONS AND RESTRICTIONS :2C* DON'T EVEN THINK ABOUT TRANSPORTING IT:C* USES "FORSYSDEF.TLB[$FIBDEF, $IODEF, $JPIDEF]"C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 2-JUN-1988 - INITIAL VERSIONC*HC***********************************************************************C* IMPLICIT INTEGER (A-Z) INCLUDE '($IODEF)' INCLUDE '($FIBDEF)' INCLUDE '($JPIDEF)' CHARACTER *(*) CUIC, DISK CHARACTER *16 TEMP8 DIMENSION IOSB(2), P1(2), P2(2), P4(10), XQUOTA(8) INTEGER *2 DISK_CHAN RECORD /FIBDEF1/ FIBCC --- ASSIGN DISK CHANNELC IF (DISK .EQ. ' ') RETURN, ISTAT = SYS$ASSIGN (DISK, DISK_CHAN,,)! IF (.NOT. ISTAT) GO TO 1000CC --- GET NUMERIC UICC IF (CUIC .NE. ' ') THEN LC = LENGTH(CUIC) IC = INDEX(CUIC,',') IF (IC .EQ. 0) THEN ISTAT = 1 GO TO 1000 ENDIF I = 1& IF (CUIC(1:1) .EQ. '[') I = 2 TEMP = CUIC(I:IC-1) CALL RIGHT(TEMP)! CALL OCTDEC (TEMP, IUIC) I = LC * IF (CUIC(I:I) .EQ. ']') I = I - 1 TEMP = CUIC(IC+1:I) CALL RIGHT(TEMP) CALL OCTDEC(TEMP, JUIC) UIC = 65536*IUIC + JUIC ELSE. ISTAT = LIB$GETJPI (JPI$_UIC,,,UIC,,)$ IF (.NOT. ISTAT) GO TO 1000 ENDIF XQUOTA(2) = UICC%C --- SEE I/O REFERENCE MANUAL, VOL 1C IFUNC = IO$_ACPCONTROL+ FIB.FIB$W_CNTRLFUNC = FIB$C_EXA_QUOTA/ P1(1) = 64 ! FIB DESCRIPTOR P1(2) = %LOC(FIB)< P2(1) = 32 ! QUOTA DATA BLOCK DESCRIPTOR P2(2) = %LOC(XQUOTA)8 P3 = 0 ! LENGTH OF P4 (RETURNED)G P4(1) = 32 ! QUOTA DATA BLOCK DESCRIPTOR (RETURNED) P4(2) = %LOC(XQUOTA)CB ISTAT = SYS$QIOW ( , %VAL(DISK_CHAN), %VAL(IFUNC), IOSB, , , $ P1, P2, P3, P4,,)! IF (.NOT. ISTAT) GO TO 1000C USED = XQUOTA(3) PERM = XQUOTA(4), ISTAT = SYS$DASSGN ( %VAL(DISK_CHAN) )! IF (.NOT. ISTAT) GO TO 1000 IRET = 0 RETURNC C --- ERRORC1000 IRET = ISTAT USED = 0 PERM = 0 RETURN ENDC C---END QUOTACww/C SUBROUTINE READINT (INT)C*3C* *******************************3C* *******************************3C* ** **3C* ** READINT **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :FC* READ AN INTEGER FROM SYS$INPUT. SQUAWK ON BAD CHARACTERS.3C* ACCEPT . END ON , ^Y, OR ^Z.C*#C* VALID EDITING KEYS ARE:9C* LEFT ARROW, RIGHT ARROW, ^U, ^H, , ^EC*C* OUTPUT ARGUMENTS :C* INT - THE VALUEC*C* SUBPROGRAM REFERENCES :-C* MLIB_GET, READKEY, ISDIGIT, RIGHTC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE.0C* USES CURSOR STORE AND RESET COMMANDSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *3 C3 CHARACTER *1 C CHARACTER *20 S LOGICAL ISDIGIT, INSERT EQUIVALENCE (C,C3)C$ CALL MLIB_GET('NWRITE',NWRITE)CC --- SAVE CURSOR POSITIONC% WRITE(NWRITE,910) CHAR(27)//'7' INSERT = .FALSE.0 IS = 1 ! NEXT LOCATION IN STRING2 IC = 1 ! CURSOR LOCATION IN STRING S = ' 'CC --- KEYSTROKE LOOPC10 CALL READKEY ( C3 )# IF (C3 .EQ. 'ERR') GO TO 10003 IF (C3 .EQ. 'LEF') THEN ! LEFT ARROW IF (IC .GT. 1) THEN IC = IC - 1  GO TO 400 ENDIF4 ELSE IF (C3 .EQ. 'RIG') THEN ! RIGHT ARROW IF (IC .LT. IS) THEN IC = IC + 1 GO TO 400 ENDIF? ELSE IF (C3 .EQ. '^U') THEN ! DEL TO START OF STRING IF (IC .GT. 1) THEN S = S(IC:) IS = IS - IC + 1 IC = 1 GO TO 400 ENDIF> ELSE IF (C3 .EQ. '^H') THEN ! GO TO START OF STRING IF (IC .GT. 1) THEN IC = 1 GO TO 400 ENDIF< ELSE IF (C3 .EQ. '^E') THEN ! GO TO END OF STRING IF (IC .LT. IS) THEN IC = IS GO TO 400 ENDIFF ELSE IF (C3 .EQ. '^A') THEN ! TOGGLE INSERT/OVERSTRIKE MODE INSERT = .NOT. INSERTB ELSE IF (C3 .EQ. 'DEL') THEN ! DELETE PREVIOUS CHARACTER IF (IC .EQ. 2) THEN S = S(2:) IC = IC - 1 GO TO 400! ELSE IF (IC .GT. 2) THEN# S = S(1:IC-2) // S(IC:) IS = IS - 1 IC = IC - 1 GO TO 400 ENDIF/ ELSE IF ((C3 .EQ. '^Z') .OR. ! RETURN" $ (C3 .EQ. '^C') .OR." $ (C3 .EQ. '^Y') .OR.# $ (C3 .EQ. '^M')) THEN GO TO 200F ELSE IF (C .EQ. '-') THEN ! NEGATION IN FIRST COLUMN ONLY! IF (IC .NE. 1) GO TO 100 IF (INSERT .AND.A $ ((S(1:1) .EQ. '-') .OR. (S(1:1) .EQ. '+'))) GO TO 100 GO TO 300H ELSE IF (C .EQ. '+') THEN ! SUPERFLOUS PLUS IN FIRST COLUMN! IF (IS .NE. 1) GO TO 100 GO TO 300B ELSE IF (ISDIGIT(C)) THEN ! A DIGIT BELIEVE IT OR NOT GO TO 300E ELSE ! ALL OTHER CHARACTERS ILLEGAL GO TO 100 ENDIF GO TO 10C C --- SQUAWKC100 WRITE(NWRITE,910) CHAR(7) GO TO 10CC --- INTERPRET STRING AND EXITC200 CALL RIGHT(S) READ(S,900) INT RETURNC+C --- ADD CHAR TO STRING AND UPDATE DISPLAYC300 IF (INSERT) THEN IF (IC .GT. 1) THEN( S = S(1:IC-1) // C // S(IC:) ELSE S = C // S(IC:) ENDIF ELSE S(IC:IC) = C ENDIF IS = IS + 1 IC = IC + 1C(C --- DISPLAY STRING AND POSITION CURSORC'400 WRITE(NWRITE,910) CHAR(27) // '8' WRITE(NWRITE,910) S(1:IS)CC --- CORRECT CURSOR LOCATIONC K = IS - IC + 1" WRITE(NWRITE,920) CHAR(27),K GO TO 10CC --- ERROR EXITC 1000 INT = 0 RETURN900 FORMAT(10X,I10)910 FORMAT('+',A,$)!920 FORMAT('+',A1,'[',I1,'D',$) ENDCC---END READINTCww's SUBROUTINE READKEY (S)C*3C* *******************************3C* *******************************3C* ** **3C* ** READKEY **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :6C* READ A KEYSTROKE FROM A VT100/200 KEYBOARDC*C* OUTPUT ARGUMENTS :1C* S - CHARACTER*3 STRING DESCRIBING KEYC*?C* IF KEYSTROKE WAS TYPING KEY, THAT VALUE IS RETURNED;C* IF IT WAS A CONTROL KEY, ^C IS RETURNED (ANY C)$C* IF KEYPAD NUMERIC, K0-K9CC*  OTHER, THREE CHAR ABBREVIATION (E.G., "INS" FOR INSERT)C*C* SUBPROGRAM REFERENCES :C* GETCHARC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 28-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *3 S, STR(6) BYTE C LOGICAL ERR9 DATA STR /'FIN', 'INS', 'REM', 'SEL', 'PRE', 'NEX'/C S = ' ' CALL GETCHAR ( C, ERR ) IF (ERR) GO TO 1000C#C --- CHECK TO SEE IF ITS PRINTABLEC. IF ((C .GE. 32) .AND. (C .LE. 126)) THEN S = CHAR(C)C$C --- NOT PRINTABLE, CHECK FOR "CSI"C2 ELSE IF ((C .EQ. 27) .OR. (C .EQ. 155)) THEN CALL GETCHAR ( C, ERR ) IF (ERR) GO TO 1000CFC --- THE "CSI" FOR 7 BIT TERMINALS IS "[". THE FOLLOWING SKIPS EC --- THE "[". NOTE THAT THIS COULD BE A PROBLEM IF 8 BIT CODES ARE C --- USED AND THEN PASS A "[".C IF (C .EQ. 91) THEN# CALL GETCHAR ( C, ERR ) IF (ERR) GO TO 1000 ENDIFCCC --- THE "SS3" SEQUENCE IS "O". THE FOLLOWING SKIPS THE "O".;C --- NOTE THAT THIS COULD BE A PROBLEM IF "CSI"O IS SENT.C0 IF (C .EQ. 79) THEN ! "O" - PF1-4# CALL GETCHAR ( C, ERR ) IF (ERR) GO TO 1000 ENDIFCFC ---- WE HAVE EITHER "CSI" OR "SS3" AT THIS POINT. THE COMMANDS ARE ;C ---- ALL UNIQUE SO WE DON'T BOTHER TO CHECK WHICH IT IS.CC --- CHECK FOR "PF" KEYSC IF (C .EQ. 80) THEN S = 'PF1'! ELSE IF (C .EQ. 81) THEN S = 'PF2'! ELSE IF (C .EQ. 82) THEN S = 'PF3'! ELSE IF (C .EQ. 83) THEN S = 'PF4'CC --- CHECK FOR KEYPAD DIGITSC9 ELSE IF (((C .GE. 108) .AND. (C .LE. 121)) .AND.% $ (C .NE. 111)) THEN S(1:1) = 'K'5 IF ((C .GE. 112) .AND. (C .LE. 121)) THEN% S(2:2) = CHAR(C-64)% ELSE IF (C .EQ. 108) THEN S(2:2) = ','% ELSE IF (C .EQ. 109) THEN S(2:2) = '-' ELSE S(2:2) = '.' ENDIFC!C --- CHECK FOR LK201 LABELED PADC5 ELSE IF ((C .GE. 49) .AND. (C .LE. 54)) THEN IOLD = C - 48# CALL GETCHAR ( C, ERR ) IF (ERR) GO TO 1000C>C ------ IF THE TERMINATOR("~") WAS RECEIVED ITS A LABELED KEYC IF (C .EQ. 126) THEN S = STR(IOLD)C+C ------ OTHERWISE, PROBABLY A FUNCTION KEYC ELSE JOLD = C& CALL GETCHAR ( C, ERR )4 IF (ERR .OR. (C .NE. 126)) GO TO 1000C$ IF (IOLD .EQ. 1) THEN( IF (JOLD .EQ. 55) THEN S = 'F6'- ELSE IF (JOLD .EQ. 56) THEN S = 'F7'- ELSE IF (JOLD .EQ. 57) THEN S = 'F8' ELSE S = 'ERR' ENDIF) ELSE IF (IOLD .EQ. 2) THEN( IF (JOLD .EQ. 48) THEN S = 'F9'- ELSE IF (JOLD .EQ. 49) THEN S = 'F10'- ELSE IF (JOLD .EQ. 51) THEN S = 'F11'-  ELSE IF (JOLD .EQ. 52) THEN S = 'F12'- ELSE IF (JOLD .EQ. 53) THEN S = 'F13'- ELSE IF (JOLD .EQ. 54) THEN S = 'F14'- ELSE IF (JOLD .EQ. 56) THEN S = 'HEL'- ELSE IF (JOLD .EQ. 57) THEN S = 'DO' ELSE S = 'ERR' ENDIF) ELSE IF (IOLD .EQ. 3) THEN( IF (JOLD .EQ. 49) THEN S = 'F17'- ELSE IF (JOLD .EQ. 50) THEN S = 'F18'- ELSE IF (JOLD .EQ. 51) THEN S = 'F19'- ELSE IF (JOLD .EQ. 52) THEN S = 'F20' ELSE S = 'ERR' ENDIF ELSE S = 'ERR' ENDIF ENDIFCC ----- CHECK FOR ARROW KEYSC! ELSE IF (C .EQ. 65) THEN S = 'UP '! ELSE IF (C .EQ. 66) THEN S = 'DOW'! ELSE IF (C .EQ. 67) THEN S = 'RIG'! ELSE IF (C .EQ. 68) THEN S = 'LEF'C'C ----- UNKNOWN "CSI" OR "SS3" SEQUENCEC ELSE S = 'ERR' ENDIFC!C --- CHECK FOR CONTROL CHARACTERC1 ELSE IF ((C. GE. 0) .AND. (C .LE. 31)) THEN S = '^' // CHAR(C+64)CC --- SPECIAL CASEC ELSE IF (C .EQ. 127) THEN S = 'DEL'C5C --- THIS SECTION GETS HIT ONLY FOR 8 BIT CHARACTERSC ELSE GO TO 1000 ENDIF RETURN1000 S = 'ERR' RETURN ENDCC---END READKEYCww:C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :=C* READ A CHARACTER STRING FROM THE TERMINAL WITHOUTDC* ECHOING THE STRING AS IT IS TYPED (E.G., FOR PASSWORDS).C*C* OUTPUT ARGUMENTS : C* STRING - THE STRING!C*C* SUBPROGRAM REFERENCES :-C* SYS$ASSIGN, SYS$QIOW, MLIB_ERRORC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE.;C* WILL BOMB IF UNABLE TO ASSIGN TERMINAL CHANNEL.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 12-MAY-1988 - INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($IODEF)' CHARACTER *(*) STRING" INTEGER SYS$ASSIGN, SYS$QIOW INTEGER *2 CHAN DATA CHAN/0/C IF (CHAN .LE. 0) THEN+  ISTAT = SYS$ASSIGN('TT:', CHAN,, ) IF (.NOT. ISTAT)F $ CALL MLIB_ERROR(3,'READQ','Unable to access terminal.') ENDIF<10 ISTAT = SYS$QIOW (, %VAL(CHAN), %VAL(IO$_READVBLK .OR.7 $ IO$M_NOECHO),,,, %REF(STRING),/ $ %VAL(LEN(STRING)),,,,) I = INDEX(STRING,CHAR(13))$ IF (I .GT. 0) STRING(I:) = ' ' RETURN ENDC C---END READQCww, INTEGER FUNCTION READT ( ITIME, BUFF )C*3C* *******************************3C* *******************************3C* ** **3C* ** READT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* READ WITH TIMEOUT C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :AC* TO READ A CHARACTER STRING FROM THE TERMINAL WITHIN AAC* SPECIFIED TIME PERIOD. READ IS ENDED BY TIMEOUT OR AC* CARRIAGE RETURN.C*C* INPUT ARGUMENTS :/C* ITIME - TIMEOUT PERIOD (IN SECONDS)C*C* OUTPUT ARGUMENTS :5C* BUFF - THE BUFFER H OLDING THE TYPED DATA6C* READT - = 0 FOR NORMAL RETURN ( OR ^Z)2C* = 1 FOR TIMEOUT PERIOD REACHED$C* =-1 FOR AN ERRORC*C* SUBPROGRAM REFERENCES : C* SYS$QIOW, SYS$ASSIGNC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 27-FEB-85 INITIAL VERSION4C* 12-MAY-88 OUTPUT CHANGED TO CHARACTER7 C* 2-JUL-90 FIXED FORMAT, CHANGED ARG LISTC*HC***********************************************************************C* INCLUDE '($IODEF)' INCLUDE '($SSDEF)' CHARACTER *(*) BUFF INTEGER*2 IOSB(4)$ INTEGER SYS$ASSIGN, SYS$DASSGNC; IF (SYS$ASSIGN ('TT:', ICHAN,,) .NE. SS$_NORMAL) THEN READT = -1 RETURN ENDIFC NUM = LEN(BUFF)0 IFUNC = (IO$_READVBLK .OR. IO$M_TRMNOECHO) IF (ITIME .GE. 0)  THEN IT = ITIME( IFUNC = (IFUNC .OR. IO$M_TIMED) ELSE IT = 0 ENDIFF ISTAT = SYS$QIOW (,%VAL(ICHAN), %VAL(IFUNC), IOSB,,, %REF(BUFF),, $ %VAL(NUM), %VAL(IT),,,)C2 IF (IOSB(2) .LT. NUM) BUFF(IOSB(2)+1:) = ' '' IF (IOSB(1) .EQ. SS$_NORMAL) THEN READT = 0- ELSE IF (IOSB(1) .EQ. SS$_TIMEOUT) THEN READT = 1 ELSE READT = -1 ENDIF CALL SYS$DASSGN (ICHAN)  RETURN ENDC C---END READTCww;( SUBROUTINE RECALL ( COMMAND, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** RECALL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* RECALLC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C*C* PURPOSE :CC* TO RETURN THE "NUM"th MOST RECENTLY ENTERED DCL COMMANDC*C* ARGUMENTS:6C* COMMAND - THE TEXT OF THE COMMAND (OUTPUT)NC* NUM - THE COMMAND NUMBER (1 = MOST RECENT, 20 = LAST ) (INPUT)C*C* SUBPROGRAM REFERENCES :C* MLIB_RECALLC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 5-MAY-1987C*C* CHANGE HISTORY :C*HC***********************************************************************C* CHARACTER *(*) COMMAND CHARACTER *1025 BUFFC/ IF ((NUM .LT. 1) .OR. (NUM .GT. 20)) THEN NN = 1 ELSE NN = NUM ENDIFC:C --- IBUFF POINTS TO THE LENGTH OF THE CURRENT COMMAND...8C --- COMMANDS ARE STORED IN REVERSE ORDER IN A CIRCULARC --- BUFFER OF 1025 BYTESC$ CALL MLIB_RECALL (BUFF, IBUFF) COMMAND = ' '6 IC = MIN0(ICHAR(BUFF(IBUFF:IBUFF)),LEN(COMMAND))C *C --- SCAN BACKWARDS FOR REQUESTED COMMANDC5 IF (NN .GT. 1) THEN+ ISKIP = ICHAR(BUFF(IBUFF:IBUFF))+3 IBUFF = IBUFF - ISKIP/ IF (IBUFF .LE. 0) IBUFF = 1025 + IBUFF9 IC = MIN0(ICHAR(BUFF(IBUFF:IBUFF)),LEN(COMMAND)) NN = NN - 1 GO TO 5 ENDIFC#C --- COPY COMMAND TO OUTPUT STRINGC ICOM = IC+1 DO 10 I = 1, IC ICOM = ICOM - 1 IBUFF = IBUFF - 1' IF (IBUFF .EQ. 0) IBUFF = 1025/ COMMAND(ICOM:ICOM) = BUFF(IBUFF:IBUFF)10 CONTINUE RETURN ENDCC---END RECALLCww * integer function rename ( old, new ) character *(*) old, newc3 rename = lib$rename_file (old, new,,,,,,,,,,) return endcc---end renamecwwB, SUBROUTINE REPLAC ( STRING, OLD, NEW )C*3C* *******************************3C* *******************************3C* ** **3C* ** REPLAC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* REPLACE CHARACTERC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :FC* TO REPLACE ALL OCCURRENCES OF A CHARACTER IN A STRING WITHC* ANOTHER CHARACTER.C*C* INPUT ARGUMENTS :)C* STRING - THE STRING TO MODIFY-C* OLD - THE CHARACTER TO REPLACE;C* NEW - THE CHARACTER WITH WHICH TO REPLACE ITC*C* OUTPUT ARGUMENTS :(C* STRING - THE MODIFIED STRINGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 1-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING CHARACTER *1 OLD, NEWC DO 10 I = 1, LEN(STRING)4 IF (STRING(I:I) .EQ. OLD) STRING(I:I) = NEW10 CONTINUE RETURN ENDCC---END REPLACCww? SUBROUTINE REVLF C*3C* *******************************3C* *******************************3C* ** **3C* ** REVLF **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* REVERSE LINE FEEDC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :8C* SEND A REVERSE LINEFEED TO AN ANSI TERMINAL.C*C* FILE REFERENCES :C* NWRITEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *1 ESC DATA ESC/27/C& call mlib_get ('NWRITE', nwrite) WRITE ( NWRITE, 900 )ESC RETURN900 FORMAT ( '+',A1,'[A',$) ENDC C---END REVLFCwwZ .title right;; Author: Arthur E. Ragosta;@; Right justify a string and return location of first nonblank;; CHARACTER *10 STRING; STRING = 'A string'; CALL RIGHT ( STRING );$; Results in STRING = ' A string';+ .entry right,^m9 movl 4(ap),r0 ;loc of descriptor to r01 subl3 #1,4(r0),r7 ;location to r7. movzwl (r0),r0 ;length to r0+ movl r0,r1 ;copy of length for later use'loop: cmpb (r7)[r0],#32 ;space ? bneq out+ sobgtr r0,loop ;if still characters left ret ;all blank out: incl r7- subl3 r0,r1,r6 ;r6 now has number of blanks2 movc3 r0,(r7),(r7)[r6] ;move non-blank characters$ movc5 #0,(sp),#32,r6,(r7) ;pad only ret .end;; Portable FORTRAN version;"; SUBROUTINE RIGHT ( STRING );C*4;C* *******************************4;C* *******************************4;C* ** **4;C* ** RIGHT **4;C* ** **4;C* *******************************4;C* *******************************;C*;C* SUBPROGRAM :;C* RIGHT JUSTIFY;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 :D;C* REPLACES A STRING WITH THE SAME STRING RIGHT JUSTIFIED.;C*;C* INPUT ARGUMENTS :7;C* STRING - THE STRING TO BE RIGHT JUSTIFIED.;C*;C* OUTPUT ARGUMENTS :;;C* STRING - THE RIGHT JUSTIFIED STRING (INPLACE).;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*I;C***********************************************************************;C*; CHARACTER *(*) STRING;C; L = LEN(STRING);C$;C --- FIND LAST NON-BLANK CHARACTER;C; DO 10 I=L,1,-1,; IF (STRING(I:I) .NE. ' ') GO TO 20;10 CONTINUE;C ;C --- ALL CHARACTERS WERE BLANK;C ; RETURN;20 IF (I .NE. L) THEN'; STRING(L-I+1:L) = STRING(1:I); STRING(1:L-I) = ' ' ; ENDIF ; RETURN ; END;C;C---END RIGHT;Cww W5: SUBROUTINE SCALE (XMIN, XMAX, N, XMINP, XMAXP, DIST)C*3C* *******************************3C* *******************************3C* ** **3C* ** SCALE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SCALE!C*C* AUTHOR :C* C.R. LEWART,C* BELL TELEPHONE LABORATORIES, INCC* HOLMDEL, NJ 07733C* (coded by: AER)C*C* REFERENCE:%C* COMMUNICATIONS OF THE ACMC* VOLUME 16, 1973C*C* PURPOSE :DC* GIVEN XMIN,XMAX AND N SCALE1 FINDS A NEW RANGE XMINP ANDAC* XMAXP DIVISIBLE INTO APPROXIMATELY N LINEAR INTERVALSC* OF SIZE DISTC*C* INPUT ARGUMENTS :C* XMIN - DATA MINIMUMC* " XMAX - DATA MAXIMUM-C* N - TARGET NUMBER OF INTERVALSC*C* OUTPUT ARGUMENTS :C* XMINP - NEW MINIMUMC* XMAXP - NEW MAXIMUM&C* DIST - VALUE PER INTERVALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 6-NOV-1987 - INITIAL VERSIONC*HC***********************************************************************C*7C VINT IS AN ARRAY OF ACCEPTABLE VALUES FOR DIST (TIMESC AN I#NTEGER POWER OF 10)7C SQR IS AN ARRAW OF GEOMETRIC MEANS OF ADJACENT VALUES2C OF VINT, IT IS USED AS BREAK POINTS TO DETERMINE$C WHICH VINT VALUE TO ASSIGN TO DIST DIMENSION VINT(4), SQR(3)> DATA VINT(1), VINT(2), VINT(3), VINT(4)/1., 2., 5., 10./? DATA SQR(1), SQR(2), SQR(3)/1.414214, 3.162278, 7.071068/C1C CHECK WHETHER PROPER INPUT VALUES WERE SUPPLIEDC- IF (XMIN.LT.XMAX .AND. N.GT.0) GO TO 10 DIST = 0.0 RETURNC%C DEL ACCOUNTS FOR COMPUTER $ROUND-OFF8C DEL SHOULD BE GREATER THAN THE ROUND-OFF EXPECTED FROM8C A DIVISION AND FLOAT OPERATION, IT SHOULD BE LESS THAN6C THE MINIMUM INCREMENT OF THE PLOTTING DEVICE USED BY7C THE MAIN PROGRAM (IN.) DIVIDED BY THE PLOT SIZE (IN.)C TIMES NUMBER OF INTERVALS NC 10 DEL = .00002 FN = NC"C FIND APPROXIMATE INTERVAL SIZE AC A = (XMAX-XMIN)/FN AL = ALOG10(A) NAL = AL IF (A.LT.1.) NAL = NAL - 1C4C A IS SCALED INTO VARIABLE NAMED B BETWEEN 1 AN%D 10C B = A/10.**NALC.C THE CLOSEST PERMISSIBLE VALUE FOR B IS FOUNDC DO 20 I=1,3! IF (B.LT.SQR(I)) GO TO 30 20 CONTINUE I = 4CC THE INTERVAL SIZE IS COMPUTEDC 30 DIST = VINT(I)*10.**NAL FM1 = XMIN/DIST M1 = FM1 IF (FM1.LT.0.) M1 = M1 - 12 IF (ABS(FLOAT(M1)+1.-FM1).LT.DEL) M1 = M1 +1C.C THE NEW MINIMUM AND MAXIMUM LIMITS ARE FOUNDC XMINP = DIST*FLOAT(M1) FM2 = XMAX/DIST M2 = FM2 + 1.# IF (FM2.LT.(-1.)) M2 = M2 - 13 IF (ABS(FM2+1.-FLOAT(M2)).LT.DEL) M2 = M2 - 1 XMAXP = DIST*FLOAT(M2)C5C ADJUST LIMITS TO ACCOUNT FOR ROUND-OFF IF NECESSARYC% IF (XMINP.GT.XMIN) XMINP = XMIN% IF (XMAXP.LT.XMAX) XMAXP = XMAX RETURN ENDC C---END SCALECww'; ! SUBROUTINE SCOLOR ( COLOR )C*3C* *******************************3C* *******************************3C* ** **3C* ** SCOLOR **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* L JURGELEITC* MS 219-3( C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*9C* --- BASED ALMOST ENTIRELY ON SUBROUTINE "BCOLOR"C* BY ART RAGOSTAC*C* DESCRIPTION :>C* SET THE SURFACE COLOR ON A TEKTRONIX 41XX TERMINAL0C* NOTE: TERMINAL MUST BE IN "RGB" MODEC*C* INPUT ARGUMENTS :IC* COLOR - THE COLOR TO SET (SEE ARRAY "COLRS" BELOW FOR VALUES)C*C* SUBPROGRAM REFERENCES :"C* CAPS, SEARCH, ML)IB_GETC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 14-AUG-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) COLOR PARAMETER (NCOLOR=28) CHARACTER *8 COLRS(NCOLOR) CHARACTER *6 CSTRG(NCOLOR) CHARACTER *1 ESC LOGICAL MAT,AM DATA ESC / 27 /F DATA COLRS / 'BCYAN ', 'BEIGE ', 'BLACK ', 'BLUE ',F $* 'BMAGENTA ', 'CBLUE ', 'CGREEN ', 'CHARCOAL', 'CREAM ',F $ 'CYAN ', 'GCYAN ', 'GRAY ', 'GREEN ', 'GYELLOW ',F $ 'KHAKI ', 'MAGENTA ', 'MBLUE ', 'MRED ', 'ORANGE ',F $ 'PURPLE ', 'RED ', 'RMAGENTA', 'RYELLOW ', 'TAN ',9 $ 'WHITE ', 'YELLOW ', 'YGREEN ', 'YRED '/D DATA CSTRG / '0C9F4 ', 'E4D6B8', '000 ', '00F4 ',D $ 'C90F4 ', '0C9F4 ', '0F4C9 ', 'A=A=7 ', 'F4E7C?',D $ '0F4F4 ', '0F4 +C9 ', 'C1C1C1', '0F40 ', 'C9F40 ',D $ 'C9B=7 ', 'F40F4 ', 'C90F4 ', 'F40C9 ', 'F4C20 ',D $ 'F40F4 ', 'F400 ', 'F40C9 ', 'F4C20 ', 'B8B00 ',7 $ 'F4F4F4', 'F4F40 ', 'C9F40 ', 'F4C20 '/C CALL CAPS ( COLOR ): CALL SEARCH ( COLRS, NCOLOR, COLOR, INDEX, MAT, AM )( IF (AM .OR. (.NOT. MAT)) INDEX = 1$ CALL MLIB_GET('NWRITE',NWRITE)6 WRITE(NWRITE,900) ESC // 'TG141' // CSTRG(INDEX)900 FORMAT(' ',A) RETURN ENDCC---END SCOLORCwwYuH7 SUBROUTINE VT340GRAFC*3C* *******************************3C* ******************************* 3C* ** **3C* ** VT340GRAF **E3C* ** **O3C* *******************************j3C* ******************************* C*C* SUBPROGRAM :AC* VT340GRAFC*C* AUTHOR : C* .,t& SUBROUTINE SCROLL ( ITOP, IBOT )C*3C* *******************************3C* *******************************3C* ** **3C* ** SCROLL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SET SCROLL REGIONC*C* / AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :EC* ON A VT100 TERMINAL, DEFINE A PORTION OF THE SCREEN TO BEFC* USED FOR A SCROLL REGION AND PLACE THE CURSOR IN THE FIRSTFC* LINE OF THAT REGION. NOTE: USE SRESET BEFORE EXITING YOUR8C* PROGRAM TO RESTORE THE NORMAL SCROLL REGION.GC* NOTE: GOTOXY CAN STILL GET T0HE CURSOR OUTSIDE OF THE SCROLLC* REGION.C*C* INPUT ARGUMENTS :=C* ITOP - THE FIRST ROW TO BE IN THE SCROLL REGION<C* IBOT - THE LAST ROW TO BE IN THE SCROLL REGIONC*C* FILE REFERENCES :C* NWRITEC*%C* TRANSPORTABILITY LIMITATIONS :)C* NON-STANDARD FORMAT STATEMENTC*%C* ASSUMPTIONS AND RESTRICTIONS :0C* ONLY WORKS ON VT100S AND COMPATIBLESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 717C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSION$C* 2-JUL-90 REFORMATTEDC*HC***********************************************************************C*5 IF ((ITOP .LT. 1) .OR. (ITOP .GT. 23)) ITOP = 16 IF ((IBOT .LT. 2) .OR. (IBOT .GT. 24)) IBOT = 24 IT = 1 IF (ITOP .GT. 9) IT=2 IB = 1 IF (IBOT .GT. 9) IB=2% CALL MLIB_GET ('NWRITE',NWRITE)+ WRITE (NWRITE,900) CHAR(27),ITOP,IBOT RETURN.900 FORMAT(' ',A1,'[',I,';',I,'r',$) ENDCC---END SCROLLCww 30MC*,C* Note MLIB_COMPAR is in the SEARCH moduleC*> SUBROUTINE FRMSTD ( VALIN, STRIN, VALOUT, STROUT, IERR )C*3C* ********************************3C* ******************************* 3C* ** ** 3C* ** FRMSTD ** 3C* ** ***3C* ********************************3C* ********************4***********SC*C* SUBPROGRAM : C* FROM STANDARD UNITS C*C* AUTHOR : C* ART RAGOSTATC* MS 219-1 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :HC* TO CONVERT A VALUE FROM STANDARD UNITS TO NON-STANDARD UNITSC*C* INPUT ARGUMENTS :$C* VALIN - THE INPUT VALUE)C* STRIN - THE UNITS OF 'VALIN'A4C* STROUT - THE REQUESTED UNITS OF 'VALOUT'5C*C* OUTPUT ARGUMENTS :S/C* VALOUT - THE VALUE AFTER CONVERTINGO$C* IERR -= 0 FOR NO ERROR,C* = 1-4 FOR ERROR IN TOSTDHC* = 5 FOR INVALID UNITS REQUESTED (IE, OUTPUT UNITS DO4C* NOT FOLLOW FROM INPUT UNITS)C*C* INTERNAL WORK AREAS :=C* STEMP - USED TO CALCULATE THE RESULTANT STD UNITSRC*C* SUBPROGRAM REFERENCES :C* TOSTD, MLIB_CMPARRC*C* LANGUAGE AND COMPILER :C* 6 ANSI FORTRAN 77NC*C* CHANGE HISTORY :R(C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C*" CHARACTER *(*) STRIN, STROUT CHARACTER *255 STEMPC*=C --- USE TOSTD TO CALCULATE THE CONVERSION FACTOR FOR STROUT*C* VTEMP = 1.0O6 CALL TOSTD ( VTEMP, STROUT, VTEMP, STEMP, IERR ) IF ( IERR .NE. 0 ) RETURNAC.3C --- VTEMP HAS THE FACTOR FOR THE NON-STD UNITS...2C --- DIVIDE AND MAKE SURE 7THE UNITS ARE THE SAMEC , CALL MLIB_CMPAR ( STRIN, STEMP, IERR )- IF (IERR .EQ. 0) VALOUT = VALIN / VTEMP RETURN END(C1C---END FRMSTDC= SUBROUTINE TOSTD ( VALIN, STRIN, VALOUT, STROUT, IERR )C*3C* ******************************* 3C* *******************************W3C* ** ** 3C* ** TOSTD **E3C* ** *8*S3C* ******************************* 3C* *******************************RC*C* SUBPROGRAM : C* TO STANDARD UNITS)C*C* AUTHOR : C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :FC* CONVERTS A VALUE WITH NON-STANDARD UNITS TO THE EQUIVALENTEC* VALUE WITH STANDARD UNITS AND RETURNS THE STANDARD UNITS 9. C*C* METHODOLOGY :HC* PARSES THE INPUT UNITS, REPLACES EACH ONE WITH AN EQUIVALENTJC* STANDARD UNIT AND A SCALE FACTOR, MULTIPLIES THE SCALE FACTORS4C* TOGETHER AND EVALUATES THE UNITS STRING.C*C* INPUT ARGUMENTS :FC* VALIN - THE VALUE OF THE VARIABLE WITH THE ORIGINAL UNITSGC* STRIN - THE STRING CONTAINING THE UNITS OF THE INPUT VALUEC*C* OUTPUT ARGUMENTS :*AC* VALOUT - THE VALUE AFTER CONVERSION TO STANDARD UNIT :ST=C* STROUT - THE STRING CONTAINING THE STANDARD UNITSS!C* IERR - 0 = NO ERROR DC* 1 = ILLEGAL CHARACTERS IN UNITS OR BAD EXPONENT5C* 2 = UNKNOWN UNIT IN INPUT STRINGG7C* 3 = AMBIGUOUS UNIT IN INPUT STRINGEHC* 4 = TOO COMPLICATED TO EVALUATE OR UNMATCHED PARENSDC* 5 = INVALID UNITS REQUESTED (I.E., OUTPUT UNITS8C* DO NOT FOLLOW FROM INPUT UNITS)C*C* INTERNAL WORK AREAS :FC* WORK - TEMPORARY STRING FOR REPLACEMENT OF NON-STD SYMBOLSGC* TOP, BOTTOM - ARRAYS TO HOLD THE UNITS EXTRACTED FROM STRINLC*C* SUBPROGRAM REFERENCES :EC* LENGTH, MLIB_PARSE, MLIB_STD, MLIB_POLISH, MLIB_EVAL, C* MLIB_BUILD, CAPS C*C* ERROR PROCESSING :N*C* ERRORS PASSED FROM SUBROUTINESC*%C* ASSUMPTIONS AND RESTRICTIONS :JC* THE INPUT UNITS STRING AND THE RESULTING OUTPUT STRING MUST BE)C* <1> SUBROUTINE SEARCH1 ( STRING, NSTRNG, TARGET, K, MATCHD )C*3C* *******************************3C* *******************************3C* ** **3C* ** SEARCH1 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :)C* BI=NARY SEARCH FOR EXACT MATCHC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :HC* TO SEARCH AN ARRAY OF CHARACTER STRINGS FOR A TARGET STRING.C*C* INPUT ARGUMENTS :>C* STRING - THE ARRAY OF CHARACTER STRINGS TO SEARCH&C* (MUST BE SORTED)6C* NSTRNG - THE NUMBER OF ELEMENTS IN STRING,C* TARG>ET - THE STRING TO LOOK FORC*C* OUTPUT ARGUMENTS :;C* K - THE INDEX OF TARGET STRING (IF FOUND)?C* MATCHD - TRUE IF TARGET WAS FOUND, FALSE OTHERWISEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :8C* 03-AUG-90 DELETED UNUSED VARIABLE "MATCH"(C* 16-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* LOGICAL MATCHD& CHARACTER *(*) STRING(1), TARGETCC --- BINARY SEARCHC J = NSTRNG I = 15 K = (I+J)/2( IF (TARGET .LE. STRING(K)) J = K-1( IF (TARGET .GE. STRING(K)) I = K+1 IF (I .LE. J) GOTO 5 IF ((I-1) .GT. J) THENC C --- MATCH FOUND, K HOLDS INDEXC MATCHD = .TRUE. ELSE MATCHD = .FALSE. ENDIF RETURN ENDCC---END SEARCH1Cww@C$ SUBROUTINE SEND ( USER, TEXT )C*3C* *******************************3C* *******************************3C* ** **3C* ** SEND **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SEND MESSAGEC*C* AUTAHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* SEND A MESSAGE TO A USER, A TERMINAL, OR ALL USERS ON THEC* SYSTEM.C*C* INPUT ARGUMENTS :LC* USER - THE NAME OF THE USER OR TERMINAL. IF THE LAST CHARACTERMC* IN THIS FIELD IS A COLON(:), IT IS ASSUMED THAT THE USERKC* IS A TERMINAL NAME(EG, TT BA0:). IF THE USER FIELD IS ALC* BLANK OR ASTERISK(*), THE MESSAGE IS SENT TO ALL USERS.IC* ANY OTHER CONDITION IMPLIES TRANSMISSION TO A SINGLEC* USERID.IC* TEXT - THE TEXT OF THE MESSAGE TO BE SENT. NOTE: NO BELL ISJC* SENT BY DEFAULT, BUT BELLS(^G) MAY BE INCLUDED IN THE"C* MESSAGE TEXT.C*C* SUBPROGRAM REFERENCES :C* SYS$BRKTHRUC*%C* TRANSPORTABILITY LIMITATIONS C:C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :FC* THE CALLING PROGRAM OR USERID MUST HAVE 'OPER' AND 'WORLD'C* PRIVILEGE.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 16-APR-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) USER, TEXT INTEGER TYPE, TIMEO INTEGER *2 II(4) ! condition_code, nuDmterm, numtimeout, numnobroadC LU = LENGTH ( USER )" LT = MAX0(1,LENGTH ( TEXT )) TIME = 154 IF (( LU .EQ. 0 ) .OR. ( USER .EQ. '*' )) THEN( TYPE = '00000003'X ! all users LU = 1+ ELSE IF ( USER(LU:LU) .EQ. ':' ) THEN* TYPE = '00000001'X ! device name ELSE( TYPE = '00000002'X ! user name ENDIF4 ISTAT = SYS$BRKTHRU ( ,TEXT(1:LT), USER(1:LU),= $ %VAL(TYPE), II,,,, %VAL(TIME),,) RETURN ENDC C---END SENDCww F.5 SUBROUTINE SENDW ( USER, TEXT, NUMOK, NUMFAIL )C*3C* *******************************3C* *******************************3C* ** **3C* ** SENDW **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :!C* SEND MESSAGGE AND WAITC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* SEND A MESSAGE TO A USER, A TERMINAL, OR ALL USERS ON THE+C* SYSTEM AND WAIT FOR COMPLETION.C*C* INPUT ARGUMENTS :LC* USER - THE NAME OF THE USER OR TERMINAL. IF THE LAST CHARACTERMC* IN THIS FIELD IS A COLON(:), IT IS ASSUMED THAT THE U HSERKC* IS A TERMINAL NAME(EG, TTA0:). IF THE USER FIELD IS ALC* BLANK OR ASTERISK(*), THE MESSAGE IS SENT TO ALL USERS.IC* ANY OTHER CONDITION IMPLIES TRANSMISSION TO A SINGLEC* USERID.IC* TEXT - THE TEXT OF THE MESSAGE TO BE SENT. NOTE: NO BELL ISJC* SENT BY DEFAULT, BUT BELLS(^G) MAY BE INCLUDED IN THE"C* MESSAGE TEXT.C*C* OUTPUT ARGUMENTS :OC* NUMOK I - THE NUMBER OF TERMINALS TO WHICH THE TRANSMISSION WAS OK.GC* NUMFAIL - THE NUMBER OF TERMINALS TO WHICH TRANSMISSION WASLC* REQUESTED, BUT FAILED DUE TO EITHER A TIMEOUT(15 SEC)7C* OR 'NOBROADCAST' (SEE SET TERM).C*C* SUBPROGRAM REFERENCES :C* SYS$BRKTHRUWC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :FC* THE CALLING PROGRAM OR USERID MUST HAVJE 'OPER' AND 'WORLD'C* PRIVILEGE.C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 16-APR-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) USER, TEXT INTEGER TYPE, TIMEO INTEGER *2 II(4) ! condition_code, numterm, numtimeout, numnobroadC LU = LENGTH ( USER )# LT = MAX0 (1,LENGTH ( TEXT )) TIME = 154 IF (( LU .EQ. 0 ) .OR. ( USER .EQ. '*' )) THEN( TYPE = '00000003'X ! all users LU = 1+ ELSE IF ( USER(LU:LU) .EQ. ':' ) THEN* TYPE = '00000001'X ! device name ELSE( TYPE = '00000002'X ! user name ENDIFC7 ISTAT = SYS$BRKTHRUW ( ,TEXT(1:LT), USER(1:LU),= $ %VAL(TYPE), II,,,, %VAL(TIME),,) NUMOK = II(2) NUMFAIL = II(3) + II(4) RETURN ENDC C---END SENDWCwwL ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :,C* START THE CPU TIME CLOCK RUNNINGC*C* SUBPROGRAM REFERENCES :C* LIB$INIT_TIMERC*%C* TRANSPORTABILITY LIMITATIONS :C* USES SYSTEM ROUTINEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 22-DEC-86 INITIAL VERSIONC*HC************* **********************************************************C* CALL LIB$INIT_TIMER() RETURN ENDCC---END SETIMECwwNĮ&$ SUBROUTINE SLEEP ( REAL_TIME )C*3C* *******************************3C* *******************************3C* ** **3C* ** SLEEP **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 219O-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :=C* PUT THIS PROGRAM TO SLEEP FOR 'REAL_TIME' SECONDSC*C* INPUT ARGUMENTS :@C* REAL_TIME - THE AMOUNT OF TIME, IN SECONDS, TO SLEEPC*C* SUBPROGRAM REFERENCES :-C* SYS$BINTIM, SYS$SCHDWK, SYS$HIBERC*%C* TRANSPORTABILITY LIMITATIONS : C* USES SYSTEM ROUTINESC*%C* ASSUMPTIONS AND RESTRICTIONS :C* 'RPEAL_TIME' <= 7200C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 23-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *16 BTIME' CHARACTER *2 HOUR, MIN, SEC, FRAC DIMENSION ITIME(2)C$ IF (REAL_TIME .LE. 0.0) RETURN$ RTIME = MIN (7200.0,REAL_TIME) IH = RTIME / 3600.0 RTIME = RTIME - 3600.0*IH IM = RTIME / 60.0 RTIME = RTIME - 60.0*IM IS = RTIME RTIME = RTIME - IS IF = 100.0*RTIME% WRITE(BTIME,900) IH, IM, IS, IF) ISTAT = SYS$BINTIM ( BTIME, ITIME ) CALL SYS$SCHDWK (,,ITIME,) CALL SYS$HIBER RETURN5900 FORMAT('0000 ',I2.2,':',I2.2,':',I2.2,'.',I2.2) ENDC C---END SLEEPCwwRy*$ SUBROUTINE SORT ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 219S-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :1C* REPLACE AN ARRAY WITH A SORTED ARRAY.C*C* METHODOLOGY :C* SHELLSORTC*C* INPUT ARGUMENTS :'C* ARRAY - ARRAY TO BE SORTED0C* NUM - NUMBER OF ELEMENTS IN ARRAYC*%C* ASSUMPTIONS AND RESTRICTIONS :BC* THE TYPE OF THE ARRAY 'ARRAY' AND THE VARIABLE 'TEMPA'FC* MUST BE SET FOR EACH TYPE OF STORT. THE SAMPLE BELOW IS FOR/C* CHARACTER*255 (OR BELOW) VARIABLES.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 03/12/84 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION ARRAY(1) CHARACTER *(*) ARRAY CHARACTER *255 TEMPA LOGICAL DONEC IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 230 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 ENDIF40 CONTINUE IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20 RETURN ENDC C---END SORTCwwVn-% SUBROUTINE SORTI ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 2W19-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :1C* REPLACE AN ARRAY WITH A SORTED ARRAY.C*C* METHODOLOGY :C* SHELLSORTC*C* INPUT ARGUMENTS :'C* ARRAY - ARRAY TO BE SORTED0C* NUM - NUMBER OF ELEMENTS IN ARRAYC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 03/12/84 INITIAL VERSIONC*HC*********X**************************************************************C* INTEGER ARRAY(1), TEMPA LOGICAL DONEC IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 230 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 ENDIF40 CONTINUE IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20 RETURN ENDC C---END SORTICwwZsZ2% SUBROUTINE SORTR ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 2[19-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :1C* REPLACE AN ARRAY WITH A SORTED ARRAY.C*C* METHODOLOGY :C* SHELLSORTC*C* INPUT ARGUMENTS :'C* ARRAY - ARRAY TO BE SORTED0C* NUM - NUMBER OF ELEMENTS IN ARRAYC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 03/12/84 INITIAL VERSIONC*HC*********\**************************************************************C* DIMENSION ARRAY(1) LOGICAL DONEC IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 230 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 ENDIF40 CONTINUE IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20 RETURN ENDC C---END SORTRCww^ty7 SUBROUTINE SRESETC*3C* *******************************3C* *******************************3C* ** **3C* ** SRESET **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STATUS LINE RESETC*C* AUTHOR :_C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE ::C* TO RESET THE VT-100 SCREEN AFTER USING STATUS.C*C* METHODOLOGY :*C* USES VT-100 CONTROL SEQUENCES.C*C* FILE REFERENCES :C* NWRITEC*%C* TRANSPORTABILITY LIMITATIONS :9C* WORKS ONLY ON VT-100 OR COMPATIBLE TERMINALS.7C* USES THE NON-STANDARD FORMAT DESCR`IPTOR, $.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSION'C* 2-JUL-90 ADDED MLIB_GETC*HC***********************************************************************C* CHARACTER *1 ESC DATA ESC/27/C(C --- RESET SCROLL REGION TO FULL SCREENC% CALL MLIB_GET ('NWRITE',NWRITE) WRITE ( NWRITE, 900 ) ESCCC --- CLEAR SCREENC CALL CLEAR RETURN900  FORMAT('+',A1,'[1;24r',$) ENDCC---END SRESETCwwbZ_;# SUBROUTINE STAT ( IX, IY, T )C*3C* *******************************3C* *******************************3C* ** **3C* ** STAT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STATUS LINEC*C* AUTcHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :EC* DISPLAY A SINGLE LINE OF STATUS INFORMATION AT THE TOP OFC* A VT-100 SCREEN.C*C* METHODOLOGY :)C* USE VT-100 CONTROL SEQUENCES.C*C* INPUT ARGUMENTS :/C* IX - THE X LOCATION OF THE CURSOR/C* IY - THE Y LOCATION OF THE CURSOR#C* T - THEd MESSAGE TEXTC*C* SUBPROGRAM REFERENCES :BC* CENTER, LIB$PUT_SCREEN, LIB$SET_CURSOR, LIB$SET_SCROLLC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :&C* VT-100 COMPATIBLE TERMINALC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) T CHARACTER *79 TXC TX = T CALL CENTER ( TX )C,C --- PUT MESSAGE ON LINE 1 IN REVERSE VIDEOC, ISTAT = LIB$PUT_SCREEN ( TX, 1, 1, 2 )C2C --- RETORE CURSOR LOCATION AND SET SCROLL REGIONC' ISTAT = LIB$SET_CURSOR ( IY, IX )& ISTAT = LIB$SET_SCROLL ( 2, 24 ) RETURN ENDC C---END STATCwwfY?> SUBROUTINE STATUS ( T )C*3C* *******************************3C* *******************************3C* ** **3C* ** STATUS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STATUS LINEC*C* AUTHOR : gC* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :CC* TO PRODUCE A STATUS LINE IN REVERSE VIDEO ON THE TOP OFFC* A VT-100 OR COMPATIBLE SCREEN. SET SCROLL REGION TO LINESFC* 2 THROUGH 24 TO PREVENT THE STATUS LINE FROM BEING WRITTENC* OVER.GC* NOTE : THE STATUS LINE WILL BE UNREACHABLE EXCEPT FOR THE USE OFC* SUBROUTINEh GOTOXY.C*C* METHODOLOGY :0C* USE VT-100 SCREEN CONTROL SEQUENCES.C*C* INPUT ARGUMENTS :2C* T - THE TEXT STRING TO BE OUTPUT.C*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :C* GETXY, GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :9C* WORKS ONLY ON A VT100 OR COMPATIBLE TERMINAL.2C* NON-STANDARD $ FORMAT DESCRIPTOR USED.C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*iC* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSION'C* 2-JUL-90 ADDED MLIB_GETC*HC***********************************************************************C* CHARACTER *(*) T CHARACTER *1 ESC INTEGER C DATA ESC/27/C'C --- FIRST GET PRESENT CURSOR LOCATIONC% CALL MLIB_GET ('NWRITE',NWRITE)# CALL GETXY ( NWRITE, IX, IY ) IF (IY .LT. 2) IY = 2CC --- HOME CURSORC WRITE ( NWRITE, 900 ) ESC" CALL GOTOXY ( NWRITE, 1, 1 )CC --- WRITE IN REVERSE VIDEOC, WRITE ( NWRITE, 940 ) ESC, ESC, T, ESCCC --- RESTORE CURSOR LOCATIONC$ CALL GOTOXY ( NWRITE, IX, IY ) WRITE ( NWRITE, 910 ) ESC RETURN900 FORMAT('+',A1,'[1;24r',$)910 FORMAT('+',A1,'[2;24r',$)/940 FORMAT('+',A1,'[K',A1,'[7m',A,A1,'[0m',$) ENDCC---END STATUSCwwkaB# SUBROUTINE Strip_Exc (string)C*3C* *******************************3C* *******************************3C* ** **3C* ** Strip_Exc **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* l RAGOSTA@MERLIN.ARC.NASA.GOV (Internet) C* C* MS 219-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :GC* Strip off exclamation point comments. I.e., an exclamation9C* point at the end of a string (not in quotes).C*C* INPUT ARGUMENTS :#C* String - to be strippedC*C* OUTPUT ARGUMENTS :c* String - strippedC*C* SUBPROGRAM REFEREmNCES :C* Index, IcountC*%C* ASSUMPTIONS AND RESTRICTIONS :(C* Uses IF to test for even/oddC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 22-JUL-1991 - INITIAL VERSIONC*HC***********************************************************************C* character *(*) stringc* if (index(string,'!') .eq. 0) returnc is = 1 ls = len(string)c6c --- look for next exclamation, skinpping test stringsc&10 IF (string(is:is) .eq. '!') THEN string(is:) = ' ' return+ ELSE if (string(is:is) .eq. '"') then20 is = is + 1 if (is .gt. ls) return- if (string(is:is) .ne. '"') go to 20, else if (string(is:is) .eq. '''') then30 is = is + 1 if (is .gt. ls) return. if (string(is:is) .ne. '''') go to 30 ENDIF if (is .lt. ls) then is = is + 1 go to 10 endif return ENDCC---END Strip_ExcCwwEXC I RAGOSTA STRPSTM}YX RAGOSTA SUBMIT 5h RAGOSTA SUBMITPl RAGOSTA TIMER ,F RAGOSTA TRANSL8J RAGOSTA TRIM=% RAGOSTA UNIQUE$3 RAGOSTA UNITSyօ  RAGOSTA UNITS״  RAGOSTA UNTAB#P  RAGOSTA MAC_VERIFY"3~  RAGOSTA VT_CURSOR  RAGOSTA WEKDAY#H  RAGOSTA WILD_MATCH#WqMmI3 SUBROUTINE STRPSTM (STM, LENST, SSTM, LENSST)C*3C* *******************************3C* *******************************3C* ** **3C* ** STRPSTM **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* L JURGELEITC*r MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5578C*C* DESCRIPTION :=C* REMOVE CHARACTER STRINGS FROM A FORTRAN STATEMENTC*C* INPUT ARGUMENTS :@C* STM - FORTRAN STATEMENT FROM WHICH TO REMOVE STRINGS!C* LENST - LENGTH OF STMC*C* OUTPUT ARGUMENTS :9C* SSTM - FORTRAN STATEMENT WITH STRINGS REMOVED1C* LENSST - LENGTH OF STRIPPED STATEMENTC*C* LANGUAGE sAND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 14-JUN-1990 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STM, SSTMC SSTM = ' ' I = 0 IPTR = 110 I = I + 1" IF (STM(I:I) .NE. '''') THEN# SSTM(IPTR:IPTR) = STM(I:I) IPTR = IPTR + 1' ELSE IF (STM(I:I) .EQ. '''') THENC"C --- CHARACTER STRING BEGINS HEREC20 I = I + 1% IF (STM(I:I) .EQ. '''') THENCC --- CHECK FOR EMBEDDED QUOTEC, IF (STM(I+1:I+1) .EQ. '''') THEN I = I + 1) IF (I .LT. LENST) GO TO 20 ENDIFC#C --- THIS IS THE END OF THE STRINGC GO TO 10 ENDIF# IF (I .LT. LENST) GO TO 20 ENDIF IF (I .LT. LENST) GO TO 10 LENSST = IPTR - 1 RETURN ENDCC---END STRPSTMCwwu0X( SUBROUTINE SUBMIT ( FNAME, QUEUE )C*3C* *******************************3C* *******************************3C* ** **3C* ** SUBMIT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SUBMIT BATCH JOBC*C*v AUTHOR :C* ARTHUR E. RAGOSTAC* MS 219-3%C* NASA AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :/C* TO SUBMIT A JOB FOR BATCH EXECUTIONC*C* INPUT ARGUMENTS ::C* FNAME - FILESPEC FOR THE '.COM' FILE TO SUBMIT/C* QUEUE - THE NAME OF THE BATCH QUEUEC*C* SUBPROGRAM REFERENCES :"C* LIB$SIGNAL, SYS$SNDJBCC*%C* ASSUMPTIONS AND RESTRICTIONS :(C*w ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :*C* 2-JUL-90 FORMAT CLEANED UPC*HC***********************************************************************C*! CHARACTER *(*) FNAME, QUEUE! INTEGER SYS$SNDJBCW, STATUS INCLUDE '($SJCDEF)' STRUCTURE /ITMLST/ UNION MAP( INTEGER *2 BUFLEN, ITMCOD( INTEGER *4 BUFADR, RETADR x END MAP MAP" INTEGER *4 END_LIST END MAP END UNION END STRUCTUREC STRUCTURE /IOSBLK/ INTEGER *4 STS, ZEROED END STRUCTUREC$ RECORD /ITMLST/ SUBMIT_LIST(6) RECORD /IOSBLK/ IOSBC. CHARACTER *10 QUEUES /'SYS$BATCH '/ INTEGER ENTRY_NUMBERC( IF (QUEUE .NE. ' ') QUEUES = QUEUE- SUBMIT_LIST( 1).BUFLEN = LENGTH(QUEUES)) SUBMIT_LIST( 1).ITMCOD = SJC$_QU yEUE+ SUBMIT_LIST( 1).BUFADR = %LOC(QUEUES) SUBMIT_LIST( 1).RETADR = 0, SUBMIT_LIST( 2).BUFLEN = LENGTH(FNAME)6 SUBMIT_LIST( 2).ITMCOD = SJC$_FILE_SPECIFICATION* SUBMIT_LIST( 2).BUFADR = %LOC(FNAME) SUBMIT_LIST( 2).RETADR = 0 SUBMIT_LIST( 3).BUFLEN = 08 SUBMIT_LIST( 3).ITMCOD = SJC$_NO_LOG_SPECIFICATION SUBMIT_LIST( 3).BUFADR = 0 SUBMIT_LIST( 3).RETADR = 0 SUBMIT_LIST( 4).BUFLEN = 47 SUBMIT_LIST( 4).ITMCOD = SJC$_ENTRY_NUMBER_OUTPUT1 SUBMIT_LIST( 4).BUFADR = %LOC(ENTRY_NUMBER) SUBMIT_LIST( 4).RETADR = 0" SUBMIT_LIST( 5).END_LIST = 0CG STATUS = SYS$SNDJBCW (,%VAL(SJC$_ENTER_FILE),,SUBMIT_LIST,IOSB,,)# IF (STATUS) STATUS = IOSB.STS6 IF (.NOT. STATUS ) CALL LIB$SIGNAL(%VAL(STATUS)) RETURN ENDCC---END SUBMITCww {XJ4h5 SUBROUTINE SUBMITP ( FNAME, QUEUE, LOG, NP, P )C*3C* *******************************3C* *******************************3C* ** **3C* ** SUBMITP **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :"C* SUBMIT WIT|H PARAMETERSC*C* AUTHOR :C* ARTHUR E. RAGOSTAC* MS 219-3%C* NASA AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :/C* TO SUBMIT A JOB FOR BATCH EXECUTIONC*C* INPUT ARGUMENTS ::C* FNAME - FILESPEC FOR THE '.COM' FILE TO SUBMIT/C* QUEUE - THE NAME OF THE BATCH QUEUE1C* LOG - TRUE IF A LOG FILE IS DESIRED(C* NP - NUMBER OF PARAMETERSC* } P - PARAMETERSC*C* SUBPROGRAM REFERENCES :,C* LENGTH, PARSE, SYS$SNDJBCW, EXITC*%C* ASSUMPTIONS AND RESTRICTIONS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 7-APR-89 INTITIAL VERSIONC*HC***********************************************************************C*' CHARACTER *(*) FNAME, QUEUE, P(1) CHARACTER *127 LNAME! INTEGER SYS$SNDJ~BCW, STATUS INCLUDE '($SJCDEF)' STRUCTURE /ITMLST/ UNION MAP( INTEGER *2 BUFLEN, ITMCOD( INTEGER *4 BUFADR, RETADR END MAP MAP" INTEGER *4 END_LIST END MAP END UNION END STRUCTUREC STRUCTURE /IOSBLK/ INTEGER *4 STS, ZEROED END STRUCTUREC% RECORD /ITMLST/ SUBMIT_LIST(12) RECORD /IOSBLK/ IOSBC. CHARACTER *10 QUEUES /'SYS$BATCH '/ INTEGER ENTRY_NUMBERCC --- EXECUTION QUEUEC( IF (QUEUE .NE. ' ') QUEUES = QUEUE- SUBMIT_LIST( 1).BUFLEN = LENGTH(QUEUES)) SUBMIT_LIST( 1).ITMCOD = SJC$_QUEUE+ SUBMIT_LIST( 1).BUFADR = %LOC(QUEUES) SUBMIT_LIST( 1).RETADR = 0CC --- .COM FILE NAMEC, SUBMIT_LIST( 2).BUFLEN = LENGTH(FNAME)6 SUBMIT_LIST( 2).ITMCOD = SJC$_FILE_SPECIFICATION* SUBMIT_LIST( 2).BUFADR = %LOC(FNAME) SUBMIT_LIST( 2).RETADR = 0CC --- .LOG FILE (IF ANY)C IF (LOG) THEN2 CALL PARSE ('.LOG', FNAME, 'FULL', LNAME)/ SUBMIT_LIST( 3).BUFLEN = LENGTH(LNAME)8 SUBMIT_LIST( 3).ITMCOD = SJC$_LOG_SPECIFICATION- SUBMIT_LIST( 3).BUFADR = %LOC(LNAME)# SUBMIT_LIST( 3).RETADR = 0 ELSE# SUBMIT_LIST( 3).BUFLEN = 0; SUBMIT_LIST( 3).ITMCOD = SJC$_NO_LOG_SPECIFICATION# SUBMIT_LIST( 3).BUFADR = 0# SUBMIT_LIST( 3).RETADR = 0 ENDIFCC --- PARAMETERSC IP = 4 DO 10 I = 1, NP. SUBMIT_LIST(IP).BUFLEN = LENGTH(P(I)), SUBMIT_LIST(IP).BUFADR = %LOC(P(I))# SUBMIT_LIST(IP).RETADR = 0 IP = IP + 110 CONTINUE. SUBMIT_LIST(4).ITMCOD = SJC$_PARAMETER_1. SUBMIT_LIST(5).ITMCOD = SJC$_PARAMETER_2. SUBMIT_LIST(6).ITMCOD = SJC$_PARAMETER_3. SUBMIT_LIST(7).ITMCOD = SJC$_PARAMETER_4. SUBMIT_LIST(8).ITMCOD = SJC$_PARAMETER_5. SUBMIT_LIST(9).ITMCOD = SJC$_PARAMETER_6/ SUBMIT_LIST(10).ITMCOD = SJC$_PARAMETER_7/ SUBMIT_LIST(11).ITMCOD = SJC$_PARAMETER_8CC --- ALL DONEC" SUBMIT_LIST(IP).END_LIST = 0CG STATUS = SYS$SNDJBCW (,%VAL(SJC$_ENTER_FILE),,SUBMIT_LIST,IOSB,,)& IF (STATUS) CALL EXIT (IOSB.STS) RETURN ENDCC---END SUBMITPCww 0l- SUBROUTINE TIMER_SET (SECONDS, AST, ID)C**C*HC* Queues a timer request which will expire in the specified numberHC* of seconds. When the timer expires, a subroutine provided by theHC* user is called at AST level. The name of the subroutine is givenHC* as the AST argument (remember to declare it EXTERNAL in the call-HC* ing routine). The subroutine is called with one argument, theHC* value of ID. NOTE THAT THIS ARGUMENT IS PASSED BY VALUE TO YOURC* SUBROUTINE.C*HC* The ID value allows your subroutine to tell which timer expired,HC* when more than one is used. It also allows a program to cancel aHC* timer before it expires, to prevent the subroutine from beingHC* called (see routine TIMER_CANCEL). The ID can be any 32-bit inte- C* ger.C*5C* Alan L. Zirkle Naval Surface Warfare Center$C* Code K53K53+C* 11 May 1987 Dahlgren, VirginiaC* EXTERNAL AST5 INTEGER STATUS, SYS$SETIMR, SYS$CANTIM, SECONDS REAL*8 VMSTIMEC4 CALL LIB$EMUL (-SECONDS, 10000000, 0, VMSTIME)C3 STATUS = SYS$SETIMR (,VMSTIME, AST, %VAL(ID))2 IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))C RETURN ENDCC---END TIMER_SETC" SUBROUTINE TIMER_CANCEL (ID)C**C*IC* Cancels a timer request which has not expired yet. See the de-IC* scription for routine TIMER_SET for information on queueing timerC* requests.C*IC* Using an ID for an already-expired or non-existant request is not6C* considered an error; it is effectively a no-op.C*6C* Alan L. Zirkle Naval Surface Warfare Center%C* Code K53K53,C* 11 May 1987 Dahlgren, VirginiaC* INTEGER STATUS, SYS$CANTIMC% STATUS = SYS$CANTIM (%VAL(ID),)2 IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))C RETURN ENDCC---END TIMER_CANCELCwwSE* SUBROUTINE TRANSL8 ( LOGIC, PHYSIC )C*3C* *******************************3C* *******************************3C* ** **3C* ** TRANSL8 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* TRANSLATE LOGICALC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :9C* TRANSLATE A LOGICAL NAME INTO A PHYSICAL NAMEC*C* INPUT ARGUMENTS : C* LOGIC - LOGICAL NAMEC*C* OUTPUT ARGUMENTS :0C* PHYSIC - PHYSICAL NAME (TRANSLATION)C*C* SUBPROGRAM REFERENCES :&C* CAPS, LENGTH, SYS$TRNLNMC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE;C* RETURNS ONLY THE MOST USER SPECIFIC TRANSLATIONC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 20-JUN-1988 - INITIAL VERSIONC*HC***********************************************************************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$TRNLNMC LOGC = LOGIC CALL CAPS (LOGC) ITEM(1) = LEN(PHYSIC) ITEM(2) = LNM$_STRING ITMLST(2) = %LOC(PHYSIC) ITMLST(3) = %LOC(LP) ITMLST(4) = 0C=C --- SEARCH USER-SPECIFIC (E.G., PROCESS, JOB) TABLES AT THE.C --- HIGHEST PRIORITY, THEN GROUP AND SYSTEMC10 LL = LENGTH ( LOGC )+ IF (LOGC(LL:LL) .EQ. ':') LL = LL - 1A ISTAT = SYS$TRNLNM ( , 'LNM$PROCESS', LO GC(1:LL),, ITMLST )' IF (ISTAT .EQ. SS$_NOLOGNAM) THEN@ ISTAT = SYS$TRNLNM ( , 'LNM$JOB', LOGC(1:LL),, ITMLST )* IF (ISTAT .EQ. SS$_NOLOGNAM) THENE ISTAT = SYS$TRNLNM ( , 'LNM$GROUP', LOGC(1:LL),, ITMLST )- IF (ISTAT .EQ. SS$_NOLOGNAM) THEN@ ISTAT = SYS$TRNLNM ( , 'LNM$SYSTEM', LOGC(1:LL),,# $ ITMLST )0 IF (ISTAT .EQ. SS$_NOLOGNAM) THEN PHYSIC = LOGC RETURN ENDIF ENDIF ENDIF ENDIF PHYSIC (LP+1:) = ' 'CC --- DO MULTIPLE TRANSLATIONSC% IF (ISTAT .EQ. SS$_NORMAL) THEN LOGC = PHYSIC GO TO 10 ENDIF RETURN ENDCC---END TRANSL8Cww )int trim (char s[]){ int n; for (n=strlen(s)-1; n>=0; n--) if (s[n] != ' ') break; s[n+1] = '\0'; return n;}ww19-1%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* PURPOSE :?C* RETURN A UNIQUE STRING BASED UPON THE CURRENT TIME.@C* TYPICAL USE IS FOR A UNIQUE FILENAME FOR A TEMPORARYC* FILE.C*C* OUTPUT ARGUMENTS :7C* NAME - (CHARACTER*(14)) THE GENERATED NAMEC*C* SUBPROGRAM REFERENCES :C* LIB$DATE_TIMEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :+C* 28-JUN-1988 - INITIAL VERSION4C* 02-NOV-1992 - BUG FIXED FOR DAYS 01-09C*HC***********************************************************************C* CHARACTER *(*) NAME CHARACTER *23 DC CALL LIB$DATE_TIME ( D )' IF (D(1:1) .EQ. ' ') D(1:1) = '0'E NAME = D(5:6)//D(1:2)//D(10:11)//D(13:14)//D(16:17)//D(19:20)// $ D(22:23) RETURN ENDCC---END UNIQUECwwԴ ! SUBROUTINE UNTAB ( STRING )SC*3C* ********************************3C* ********************************3C* ** ** 3C* ** UNTAB ** 3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM :*C* REMOVE TABS C*C* AUTHOR :SC* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :@C* REPLACE A STRING WITH THE SAME STRING WHERE TABS ARE?C* REPLACED BY AN APPROPRIATE NUMBER OF BLANKS TO HAVEGC* SIMILAR SPACING.C*C* INPUT ARGUMENTS :=C* STRING - STRING FROM WHICH TABS ARE TO BE REMOVEDTC*C* OUTPUT ARGUMENTS : DC* STRING - SAME STRING WITH BLANKS REPLACING TABS(INPLACE)C*C* INTERNAL WORK AREAS :=C* ITAB - AN ARRAY CONTAINING THE TAB STOP SETTINGS. 7C* LINE - TEMPORARY STORAGE FOR TABBED STRING. C*C* SUBPROGRAM REFERENCES :C* LENGTHC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77AC*C* CHANGE HISTORY :T(C* 15-OCT-84 INITIAL VERSION2C* 29-JUL-85 ITPTR FIXED (INITIALIZED)>C* 08-AUG-90 MINOR BUG FIXED (VARIABLE MISSPELLED)C*HC***********************************************************************C* CHARACTER *(*) STRING* CHARACTER *255 LINE  DIMENSION ITAB(32)E DATA ITAB / 9, 17, 25, 33, 41, 49, 57, 65, 73, 81, 89, 98, 106,NC $ 114, 122, 130, 138, 146, 154, 162, 170, 178, 186, 195, 203,(- $ 211, 219, 227, 235, 243, 251, 65000 /(CR LINE = STRING STRING = ' ' L = LENGTH(LINE). LL = LEN(STRING) K = 1 ITPTR = 1 DO 20 I = 1,LT, IF ( LINE(I:I) .EQ. CHAR(9) ) THENC C ------ FIND NEXT TAB STOPNC A5 IF ((K .GE. ITAB(ITPTR)) .AND. (ITPTR .LT. 32)) THENT! ITPTR = ITPTR + 1* GO TO 5* ENDIFCGC ------ SKIP BLANKS TO TAB STOP ( ALREADY BEEN INITIALIZED TO BLANKS ) C*=10 IF ((K .LT. ITAB(ITPTR)) .AND. (K .LT. LL)) THEN  K = K + 1  GO TO 10 ENDIF ELSEC C ------ COPY NON-TAB CHARACTE RSC*$ STRING(K:K) = LINE(I:I) K = K + 1 ENDIF*! IF ( K .GT. LL ) RETURN*20 CONTINUE RETURN END C C---END UNTAB*C ww AMES RESEARCH CENTER(C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :FC* CONVERTS A VALUE WITH NON-STANDARD UNITS TO THE EQUIVALENTEC* VALUE WITH STANDARD UNITS AND RETURNS THE STANDARD UNITS.C*C* METHODOLOGY :HC* PARSES THE I?  .title verify;E; Author: Arthur E. Ragosta; ?; Verify that all characters in string 1 are also in string 2A;ED; LOG = VERIFY( 'A STRING ','ABC ' ) ! Note, LOG is false;I# .entry verify,^mHF movl 4(ap),r1 ;location of descriptor1 to r15 movzwl (r1),r0 ;length to r0 7 subl3 #1,4(r1),r1 ;location to r1TF movl 8(ap),r2 ;location of  descriptor2 to r25 movzwl (r2),r3 ;length to r3=7 movl r3,r4 ;copy for later 7 subl3 #1,4(r2),r2 ;location to r2 ?LOOP: cmpb (r1)[r0],(r2)[r3] ;compare each character=; beql next ;this character OK? K sobgtr r3,loop ;NO - try next character in string2 ; J clrl r0 ;this character not found, failure retM;A>NEXT: movl r4,r3 ;reset string2 pointerH sobgtr r0,loop ;if more characters, do it again2 movl #1,r0 ;success ! retI .end;V; Portable FORTRAN version ;P-; LOGICAL FUNCTION VERIFY ( STR1, STR2 ) ;C*S4;C* *******************************4;C* *******************************4;C* ** **4;C* ** VERIFY  **4;C* ** **4;C* *******************************4;C* *******************************;C*I;C* SUBPROGRAM :;C* VERIFY*;C**;C* AUTHOR :;C* ART RAGOSTA;C* MS 219-3E!;C* AMES RESEARCH CENTER );C* MOFFETT FIELD, CALIF. 94035 ;C* (415) 604-55584;C*O;C* PURPOSE :BH;C* TO VERIFY THAT EACH CHARACTER IN STR1 ALSO APPEARS IN STR2. ;C* EFFICIENCY NOTES :F;C* 1. THE RAREST LETTER(S) SHOULD APPEAR FIRST IN 'STR2'.I;C* 2. THE LENGTHS OF 'STR1' AND 'STR2' SHOULD BE AS SMALL AS L;C* POSSIBLE, SINCE ALL CHARACTERS OUT TO 'LEN(STR1/2)' WILL?;C* BE CHECKED EVEN IF THEY ARE NOT MEANINGFUL.N;C* ;C* INPUT ARGUMENTS :=%;C* STR1 - STRING TO CHECK. B;C* STR2 - STRING CONTAINING CHARACTERS WHICH ARE VALID.;C*:;C* OUTPUT ARGUMENTS :I;C* VERIFY - (FUNCTION VALUE) TRUE IF EVERY CHARACTER IN STR1 IS5;C* ALSO IN STR2, FALSE OTHERWISE.;C*-;C* LANGUAGE AND COMPILER :;C* ANSI FORTRAN 77;C*K;C* VERSION AND DATE :&;C* VERSION I.0 17-JAN-85;C* ;C* CHANGE HISTORY :);C* 17-JAN-85 INITIAL VERSIONW;C*TI;C***********************************************************************N;C*N; CHARACTER *(*) STR1,STR2E;C; L1 = LEN(STR1)R;  L2 = LEN(STR2) ; VERIFY = .FALSE. ; DO 20 I = 1, L1; DO 10 J = 1, L2 2; IF (STR1(I:I) .EQ. STR2(J:J))GO TO 20;10 CONTINUEO; RETURN;20 CONTINUE; VERIFY = .TRUE. ; RETURN ; END;C;C---END VERIFY;Cww-- PASS 5, EVALUATE CONVERSION FACTORSCC CALL MLIB_EVAL ( TOKE, NTOKE, FACTS, TOP, NTOP, BOTTOM, NBOT, $ FACTOR )C$ VALOUT = VALIN * SNGL (FACTOR)C&C --- PASS 6, BUILD  % subroutine cursor_right ( num )Oc*4c* Move ANSI terminal's cursor right "num" columnsc* character *3 scU if (num .le. 0) return write(s,910) num call left(s)$ call mlib_get('NWRITE',nwrite)@ write(nwrite,900) char(27) // '[' // s(1:length(s)) // 'C' return900 format('+',A,$)910 format(I3) end cU$ subroutine cursor_left ( num )c*3c* Move ANSI terminal's cursor left "num" columns*c* character *3 sc if (num .le. 0) return write(s,910) num call left(s)$ call mlib_get('NWRITE',nwrite)@ write(nwrite,900) char(27) // '[' // s(1:length(s)) // 'D' return900 format('+',A,$)R910 format(I3) endCc  subroutine save_cursorc*2c* Tell terminal to save current cursor locationc*$ call mlib_get('NWRITE',nwrite) write(nwrite,900) char(27) return900 format('+',A1,'7',$) endIcA subroutine r estore_cursorPc*Bc* Tell terminal to put cursor back to previously saved locationc*$ call mlib_get('NWRITE',nwrite) write(nwrite,900) char(27) return900 format('+',a1,'8',$) endIwwAL WORK AREAS :6C* TSTR - USED TO SIMPLIFY '**N' CALCULATIONSC*C* SUBPROGRAM REFERENCES :C* LEFT, LENGTHC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 13-SEP-85C*C* Cz_ % SUBROUTINE WEKDAY ( TIME, DAY )NC*3C* ********************************3C* *******************************3C* ** ** 3C* ** WEKDAY **3C* ** **3C* ******************************* 3C* *******************************TC*C* AUTHOR : C* ART RAGOSTA(C* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD. CALIF 94035C* (415) 604-5558C*C* PURPOSE :CC* TO CALCULATE THE DAY OF THE WEEK('SUNDAY', 'MONDAY'...)TC*C* METHODOLOGY :)C* USE BUILT-IN SYSTEM SERVICES.C*C* INPUT ARGUMENTS :HC* TIME - THE DATE IN QUESTION (EG,'21-JAN-1985 12:00:00.00').C*C* OUTPUT ARGUMENTS :T7C* DAY - THE DAY OF THE WEEK (EG, 'MONDAY' ). C*C* SUBPROGRAM REFERENCES :C*  SYS$BINTIM, LIB$DAYSC*C* ERROR PROCESSING : 2C* DAY = 'ERROR' IF AN ERROR HAS OCCURREDC*%C* TRANSPORTABILITY LIMITATIONS :OC* EVERYTHINGC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :1(C* 25-JAN-85 INITIAL VERSION)C* 16-JAN-86 CAPITALIZE INPUTOC*HC***********************************************************************C* CHARACTER*23 TIMEI CHARACTER*9 DAYS(0:6), DAYH  DATA DAYS / 'WEDNESDAY', 'THURSDAY ', 'FRIDAY ', 'SATURDAY ',: $ 'SUNDAY ', 'MONDAY ', 'TUESDAY '/" INTEGER ITIME(2), SYS$BINTIMC  CALL CAPS(TIME)I DAY = 'ERROR'3! I = SYS$BINTIM (TIME,ITIME)E IF (.NOT. I) RETURN= I = LIB$DAY (NDAYS,ITIME)N IF (.NOT. I) RETURNTC'6C --- NDAYS IS THE NUMBER OF DAYS SINCE SYSTEM TIME 0.CT I = MOD(NDAYS,7) DAY = DAYS(I)N RETURN ENDDCnC---END WEKDAYC wwURN ENDIF STR(IS-1:IS-1) = ' ' ELSE STR(IS-1:IS-1) = '/'CEC --- REPLACE MULTIPLE ENTRIES WITH '**'N, ADD BOTTOM UNITS TO STRINGC I = 145 IF (I .LE. NBOT) THEN STR(IS:) = BOTTOM(I)' IS = IS + LENGTH(BOTTOM(I)) STR(IS:IS) = '*' IS = IS + 1 IC = 1 J = I + 1!50 IF (J .LE. NBOT) THEN1 IF (BOTTOM(I) .EQ. BOTTOM(J)) THEN L  RAGOSTA WILD_MATCH  RAGOSTA YESNO3I  RAGOSTA TOUCHp RAGOSTA SEARCHw RAGOSTA UNITStzC7 HOLST GPALFA,* H7 HOLST VT340GRAF VT340ALFAȳyJ4 GALVAS ISORT S6 RAGOSTA IS_PASS"c%:@ GALVAS GETUSRPRV"J@@ GALVAS GETUSRPRV\h] GALVAS GETOKE Wρ GALVAS IS_PASSZ'͜ GALVAS LEAPeA ' SUBROUTINE YESNO ( ISYES, ERROR ) C*3C* ******************************* 3C* *******************************03C* ** **s3C* ** YESNO ** 3C* ** **c3C* ******************************* 3C* *******************************iC*C* AUTHOR :cC* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :BC* GET THE ANSWER TO A YES/NO TYPE QUESTION FROM TERMINALC*C* METHODOLOGY :KC* SEARCH FOR THE FIRST NON-BLANK CHARACTER. COMPARE TO 'Y' OR 'N'rC*C* INPUT ARGUMENTS :KC* ISYES - (UPDATE) THE DEFAULT VALUE TO BE RETURNED IN THE EVENTm1C* OF AN ERROR OR NULL ANSWER.eC*C* OUTPUT ARGUMENTS : MC* ISYES - (UPDATE) A LOGICAL VALUE WHICH IS TRUE IF THE ANSWER WAS:6C* YES, FALSE IF THE ANSWER WAS NO.IC* ERROR - LOGICAL FLAG SHOWING THAT THERE WAS AN INAPPROPRIATE*HC* ANSWER (EG, 'MAYBE')... THE DEFAULT VALUE OF ISYES"C* IS RETURNED.C*C* INTERNAL WORK AREAS :@C* STRING - THE BUFFER INTO WHICH THE RESPONSE IS READ.@C* C - THE FIRST NON-BLANK CHARACTER IN THE STRINGC*C* FILE REFERENCES :'C* NUNIT - READ THE INPUT LINEaC*C* ERROR PROCESSING :tHC* THE END= AND ERR= PARAMETERS ARE USED ON THE READ STATEMENT.5C* THE FIRST CHARACTER SHOULD BE "Y" OR "N". C*%C* TRANSPORTABILITY LIMITATIONS : JC* SOME COMPILERS MAY NOT PERMIT THE ENTRY OF LOWER CASE LETTERS;<C* THUS THE CAPITALIZATION LINE MAY BE MEANINGLESS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77-C*C* CHANGE HISTORY :s(C* 31-AUG-84  INITIAL VERSIONC*HC***********************************************************************C* LOGICAL ISYES, ERROR CHARACTER *1 C CHARACTER *80 STRINGC  ERROR = .FALSE. # CALL MLIB_GET ('NREAD',NUNIT)a. READ (NUNIT,900,END=1000,ERR=1000)STRINGCr.C --- SEARCH FOR THE FIRST NON-BLANK CHARACTERCt CALL FIRST (STRING, C, I) CsC ------ CAPITALIZE IT.oCr. IF ((C .EQ. 'Y') .OR. (C .EQ. 'y')) THEN ISYES = .TRUE.r3 ELSE IF ((C .EQ. 'N') .OR. (C .EQ. 'n')) THEN* ISYES = .FALSE. ELSE IF (C .NE. ' ') THEN)C /C ------ FIRST CHARACTER WAS NEITHER 'Y' OR 'N'C  ERROR = .TRUE. ENDIF RETURNC-7C --- LEAVE ISYES AS DEFAULT RESPONSE, BUT RETURN ERRORwC,1000 ERROR = .TRUE. RETURN900 FORMAT(A)* END*C C---END YESNO C ww************************** 3C* ** ** 3C* ** match_word ** 3=C SUBROUTINE TOUCH ( FNAME )C*3C* ********************************3C* ********************************3C* ** ***3C* ** TOUCH ** 3C* ** ***3C* ******************************* 3C* ******************************* C*C* AUTHOR :dC* Arthur E. Ragosta o0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Centerd%C* Moffett Field, Ca. 94035C* (415) 604-5558C*C* DESCRIPTION :FC* SETS THE REVISION DATE FOR THE SPECIFIED FILE TO RIGHT NOWC*C* INPUT ARGUMENTS :!C* FNAME - THE FILE NAMEMC*C* SUBPROGRAM REFERENCES :-C* LIB$FILE_SCAN, LIB$FILE_SCAN_END C*%C* ASSUMPTIONS AND RESTRICTIONS :e&C* SERIOUSLY NONTRANSPORTABLEC*C*  LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :-+C* 1-MAY-1990 - INITIAL VERSION*?C* 28-JUN-1990 - CHANGED COMMON TO FILE_DATES COMMONrC*HC***********************************************************************C* INCLUDE '($FABDEF)'. RECORD /FABDEF/ FABa INCLUDE '($NAMDEF)'  RECORD /NAMDEF/ NAM , INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2)-Cf CHARACTER *(*) FNAME CHARACTER *80 DEFAULT_NAMEE CHARACTER *255 Es, Rs ! Expanded string, Resultant string( EXTERNAL MLIB_TOUCH_OK uC DEFAULT_NAME = '.'D FAB.FAB$B_BLN = FAB$C_BLN ! Identify Fab as a valid FAB FAB.FAB$B_BID = FAB$C_BID ( FAB.FAB$L_DNA = %LOC(DEFAULT_NAME)' FAB.FAB$B_DNS = LEN(DEFAULT_NAME) ! FAB.FAB$L_FNA = %LOC(FNAME)i FAB.FAB$B_FNS = LEN(FNAME)L FAB.FAB$L_NAM = %LOC(NAM) ! Tell the Fab where to find the NAM C C CALL LIB$MOVC5 (0,, 0, NAM$C_BLN, NAM) ! Initialize NAM to 0wC D NAM.NAM$B_BLN = NAM$C_BLN ! Identify Nam as a valid NAM NAM.NAM$B_BID = NAM$C_BID O NAM.NAM$L_ESA = %LOC(Es) ! Tell it where to find the Expanded and : NAM.NAM$L_RSA = %LOC(Rs) ! Resultant strings6 NAM.NAM$B_ESS = 255 ! Their lengths NAM.NAM$B_RSS = 255 C- ICON = 08 ISTAT = LIB$FIa 0 logical FUNCTION wild_match ( wild, file )C*3C* *******************************P3C* *******************************S3C* ** ** 3C* ** wild_match **R3C* ** **T3C* ******************************* 3C* *******************************NC*C* AUTHOR : C* Arthur E. Ragosta 0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center %C* Moffett Field, Ca. 94035AC* (415) 604-5558C*C* DESCRIPTION :Dc* attempts to verify if a file specification is adequately@c* matched by a (potentially) wildcarded specification.5c* No attempt is made to see if file exists.*C*C* INPUT ARGUMENTS :8c* wild - the file specification with wildcardsHc* file - the file specification to verify (i.e., no wildcards)C*C* OUTPUT ARGUMENTS :*+c* wild_match - true if they match C*C* SUBPROGRAM REFERENCES :.c* parse, transl8, match_word, lengthC*%C* ASSUMPTIONS AND RESTRICTIONS :C6c* Only one asterisk may appear in each part.3c* Asterisk and percents may not be mixed. +c* Multiple percents ARE permittedL>c* No device wildcards are permitted, by logicals are7c* Only ... wildcard is permitted in directoryEC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :E+C* 30-MAR-1989 - INITIAL VERSIONAC*HC***********************************************************************C* character *(*) wild, fileS& character *80 wpart, fpart, temp logical match_wordc @c --- device must be identical or be a logical for hardware onlyc  wild_match = .false.- call parse (wild, ' ', 'DEVICE', temp )"  call transl8 ( temp, wpart )- call parse (file, ' ', 'DEVICE', temp ) " call transl8 ( temp, fpart )" if (fpart .ne. wpart) returnc <c --- check for portion of directory which is not wildcardedc 1 call parse (wild, ' ', 'DIRECTORY', wpart ) 1 call parse (file, ' ', 'DIRECTORY', fpart )= i = index(wpart,'...')% if (i .eq. 0) i = length(wpart) , if (fpart(1:i) .ne. wpart(1:i)) returncN+c --- let MATCH_WORD do the hard stuff hereTc, call parse (wild, ' ', 'NAME', wpart ), call parse (file, ' ', 'NAME', fpart )/ if (.not. match_word(wpart,fpart)) return'cMc --- and herecI, call parse (wild, ' ', 'TYPE', wpart ), call parse (file, ' ', 'TYPE', fpart )/ if (.not. match_word(wpart,fpart)) return,c0c --- version...c --- ";*" matches everything0c --- so does ";" although this is iffy at best$c --- otherwise, must match exactlyc / call parse (wild, ' ', 'VERSION', wpart ) 8 if ((wpart .ne. ';') .and. (wpart .ne. ';*')) then2 call parse (file, ' ', 'VERSION', fpart )% if (wpart .ne. fpart) return endif+ wild_match = .true. return END C C---END wild_matchC'1 logical FUNCTION match_word (wild, notwild) C*3C* *******************************T3C* ******************************* 3C* ** **I3C* ** match_word ** 3C* ** ** 3C* ******************************* 3C* ******************************* C*C* AUTHOR :'C* Arthur E. Ragosta+0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research CenterE%C* Moffett Field, Ca. 94035EC* (415) 604-5558C*C* DESCRIPTION :Ec* Verifies that the wildcarded word (containing asterisk or 2c*  percents) matches the nonwildcard wordC*C* INPUT ARGUMENTS :?c* wild - word with (possibly) "*" or "%" wildcards('c* notwild - word of text only C*C* OUTPUT ARGUMENTS :+c* match_word - true if they match C*C* SUBPROGRAM REFERENCES :c* lengthC*%C* ASSUMPTIONS AND RESTRICTIONS :Lc* One asterisk only.-c* No asterisk and percent together.(!c* Multiple percents OK.NC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY : +C* 30-MAR-1989 - INITIAL VERSION C*HC***********************************************************************C*" character *(*) wild, notwildcH match_word = .false.c12c --- Note: if * appears, no others are allowed...#c --- multiple % are allowed. c lw = length(wild) lnw = length(notwild)  i = index(wild,'*')E if (i .ne. 0) thenc 1c ----- * found, compare part before and after it cA3c ----- if the * is all there is, it always matches c  if (lw .ne. 1) then if (i .gt. 1) then: if (wild(1:i-1) .ne. notwild(1:i-1)) return endif  if (i .lt. lw) then % ins = lnw - lw + i + 1B= if (wild(i+1:lw) .ne. notwild(ins:lnw)) return  endif  endif else if (lw .ne. lnw) return iws = 1"10 i = index(wild(iws:),'%') if (i .ne. 0) then1 iwp = iws + i - 1B? if (wild(iws:iwp-1) .ne. notwild(iws:iwp-1)) return  iws = iwp + 1 % if (iws .lt. lw) go to 10 else+5 if (wild(iws:) .ne. notwild(iws:)) returnT endif endif  match_word = .true. RETURN END C C---END match_wordC ww TSTACK(ISP) = T1 BSTACK(ISP) = B1CFC ----- OTHERWISE THE TOKEN IS A UNIT, PUT IT ON THE TOP SIDE OF STACKC LE_SCAN (FAB, MLIB_TOUCH_OK, , ICON)+ ISTAT = LIB$FILE_SCAN_END (FAB, ICON) RETURN END C C---END TOUCHDC$ SUBROUTINE MLIB_TOUCH_OK (FAB)CH/c *** this routine called by FILE_SCAN in TOUCH cS INCLUDE '($ATRDEF)'A INCLUDE '($FABDEF)'H INCLUDE '($FIBDEF)'( INCLUDE '($IODEF)' INCLUDE '($NAMDEF)'C  STRUCTURE /Dsc/N INTEGER*4 Length INTEGER*4 Addr= END STRUCTURE C  RECORD /Dsc/ Descr  RECORD /Atrdef/ Atr(2) RECORD /Fabdef/ Fab  RECORD /Fibdef/ Fib RECORD /NAMDEF/ NAM2, INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2)BCI INTEGER*2 IOSB(4)D INTEGER SYS$ASSIGN, SYS$QIOW, RDATE(2), SYS$BINTIM, SYS$ASCTIM integer sys$dassgn CHARACTER *23 TIMECLI Descr.Length = Nam.NAM$B_DEV ! Build a Strdescr for the device nameL" Descr.Addr = Nam.NAM$L_DEVCS. ISTAT = SYS$ASCTIM ( ,TIME,, ) ! NOW( ISTAT = SYS$BINTIM ( TIME, RDATE ) IOSB(1) = 0 * ISTAT = SYS$ASSIGN (DESCR ,ICHAN,,) ( IF (.NOT. ISTAT) CALL EXIT (ISTAT)C' ATR(1).ATR$W_SIZE = ATR$S_REVDATE ' ATR(1).ATR$W_TYPE = ATR$C_REVDATE % ATR(1).ATR$L_ADDR = %LOC(RDATE)  ATR(2).ATR$W_SIZE = 0* ATR(2).ATR$W_TYPE = 0*C*B Fib.FIB$W_FID_NUM = Nam.NAM$W_FID_NUM ! Setup File ID values+ Fib.FIB$W_FID_SEQ = Nam.NAM$W_FID_SEQA+ Fib.FIB$W_FID_RVN = Nam.NAM$W_FID_RVNSJ Fib.FIB$W_DID_NUM = Nam.NAM$W_DID_NUM ! Same for Directory ID values+ Fib.FIB$W_DID_SEQ = Nam.NAM$W_DID_SEQ + Fib.FIB$W_DID_RVN = Nam.NAM$W_DID_RVN*C Descr.Length=FIB$C_ACCDATA Descr.Addr = %LOC(Fib)CSC --- OK, BLAST ITC ? ISTAT = SYS$QIOW( ,%VAL(ICHAN), %VAL(IO$_MODIFY), IOSB,,, + $ DESCR,,,, ATR,) ( IF (.NOT. ISTAT) CALL EXIT (ISTAT)% ISTAT = SYS$DASSGN(%VAL(ICHAN))K RETURN ENDFCDC---END MLIB_TOUCH_OKECRww AN ERROR IS UNCOVEREDC*C* ERROR PROCESSING :*C* CHECKS FOR INVALID CHARACTERS.0C* DISALLOWS EXPONENTS GREATER THAN 99.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***************************************************************** *<D SUBROUTINE SEARCH ( STRING, NSTRNG, TARGET, K, MATCHD, AMBIG )C*3C* *******************************T3C* *******************************E3C* ** **O3C* ** SEARCH **)3C* ** **O3C* ******************************* 3C* ******************************* C*C* SUBPROGRAM : C*  BINARY SEARCH'C*C* AUTHOR :.C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 940359C* (415) 604-5558C*C* PURPOSE :HC* TO SEARCH AN ARRAY OF CHARACTER STRINGS FOR A TARGET STRING,?C* IF NO EXACT MATCH IS FOUND CHECK FOR NON-AMBIGUOUS c* ABBREVIATIONC*C* INPUT ARGUMENTS :NC* STRING - THE ARRAY OF CHARACTER STRINGD TO SEARCH(MUST BE SORTED)6C* NS TRNG - THE NUMBER OF ELEMENTS IN STRING,C* TARGET - THE STRING TO LOOK FORC*C* OUTPUT ARGUMENTS :.>C* K - THE INDEX OF TARGET IN STRING (IF FOUND)?C* MATCHD - TRUE IF TARGET WAS FOUND, FALSE OTHERWISEIHC* AMBIG - TRUE IF NO EXACT MATCH WAS FOUND AND MORE THAN ONEKC* ENTRY IN STRING COULD BE ABBREVIATED TO TARGET. IN ;C* THIS CASE, MATCHD IS STILL SET TRUE.C*C* LANGUAGE AND COMPILER :C*  ANSI FORTRAN 77-C*C* CHANGE HISTORY :U(C* 16-JAN-85 INITIAL VERSIONEC* 05-FEB-86 BUG FIXED FOR TARGET LARGER THAN MAX ELEMENT CC* 09-MAY-88 REMOVED REPLACEMENT FOR ABBREVIATED TARGET*C*HC***********************************************************************C*" LOGICAL MATCH, MATCHD, AMBIG& CHARACTER *(*) STRING(1), TARGETC* MATCHD = .FALSE. AMBIG = .FALSE.C C --- BINARY SEARCH*C* J = NSTRNG I = 15 K = (I+J)/2H( IF (TARGET .LE. STRING(K)) J = K-1( IF (TARGET .GE. STRING(K)) I = K+1 IF (I .LE. J) GOTO 5 IF ((I-1) .GT. J) THENC C --- MATCH FOUND, K HOLDS INDEXC5 MATCHD = .TRUE. RETURN " ELSE IF (I .GT. NSTRNG) THEN RETURN ENDIFOCIHC --- SINCE NO MATCH WAS FOUND, I SHOULD POINT TO THE NEXT LARGEST ENTRYC --- IN THE STRINGS ARRAYPCT L = LENGTH(TARGET) K = I 5 CALL MLIB_COMPAR (TARGET, L, STRING(I), MATCHD)O IF ( MATCHD ) THEN IF (I .LT. NSTRNG) THEN< CALL MLIB_COMPAR (TARGET, L, STRING(I+1), MATCH)' IF ( MATCH ) AMBIG = .TRUE.S ENDIF ENDIF RETURN END CEC---END SEARCHC ; SUBROUTINE MLIB_COMPAR (TARGET, LTARG, STRING, MATCH)NC*3C* *******************************P3C* ******************************* 3C* ** **3C*  ** MLIB_COMPAR **G3C* ** **G3C* ********************************3C* ******************************* C*C* AUTHOR : C* Arthur E. Ragosta 'C* RAGOSTA@MERLIN.ARC.NASA.GOV*C* MS 219-1%C* NASA Ames Research Center*%C* Moffett Field, Ca. 94035CC* (415) 604-5558C*C* DESCRIPTION :@C* VERIFY THAT A STRING MATCHES A TARGET STRING UP TO A*C* SPECIFIED NUMBER OF CHARACTERSC*C* INPUT ARGUMENTS :'C* TARGET - THE TARGET STRING-CC* LTARG - THE NUMBER OF CHARACTERS IN "TARGET" TO CHECKT2C* STRING - THE STRING WE'RE LOOKING FORC*C* OUTPUT ARGUMENTS : 6C* MATCH - TRUE IF MATCHED, FALSE OTHERWISEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77NC*C* CHANGE HISTORY :+C* 8-MAR-1989 - INITIAL VERSION0C*HC***********************************************************************C*# CHARACTER *(*) TARGET, STRINGFCS MATCH = .FALSE.C >C --- IF THE TARGET IS LONGER THAN THE SEARCH STRING, NO MATCHCS LS = LEN(STRING) IF (LTARG .GT. LS) RETURN C C --- COMPARE SUBSTRINGSC > IF (TARGET(1:LTARG) .EQ. STRING(1:LTARG)) MATCH = .TRUE. RETURN END C C---END MLIB_COMPAR C wwO 20 ENDIF ISP = ISP - 1C@C ----- '*' OR '/' ... UNSTACK ANY SHORTER THAN 255 CHARACTERS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77KC*C* CHANGE HISTORY : (C* 7-FEB-85 INITIAL VERSIONFC* 13-SEP-85 EFFICIENCY IMPROVED, BETTER UNITS CONVERSIONSC*HC***********************************************************************C* PARAMETER (WLEN=255)" CHARACTER *(*) STRIN, STROUT CHARACTER *(WLEN) WORK1 CHARACTER *6 TOP(40), BOTTOM(40), TOKE(100) ) DOUBLE PRECISION FACTOR, FACTS(100)C LOGICAL ERRORKC WORK = STRIN CALL CAPS ( WORK ) ERROR = .FALSE. IERR = 0 L = LENGTH ( WORK )C 8C --- PASS 1, REPLACE '-' WITH '*' AND '**' WITH '^'CE J = 0P I = 1 "5 IF (WORK(I:I) .EQ. '-') THEN J = J + 1 WORK(J:J) = '*'* ELSE IF (WORK(I:I+1) .EQ. '**') THEN J = J + 1 I = I + 1 WORK(J:J) = '^'C0C --- ALL OTHER CHARACTERS EXCEPT ' ' GET COPIEDC ' ELSE IF (WORK(I:I) .NE. ' ') THENP J = J + 1 WORK(J:J) = WORK(I:I) ENDIF  I = I + 1C IF ( I .LE. L )GO TO 5 WORK(J+1:) = ' 'C C --- PASS 2, PARSE INTO TOKENS CO5 CALL MLIB_PARSE ( WORK, J, TOKE, NTOKE, ERROR )S IF ( ERROR ) THENN IERR = 1  RETURNI ENDIF CN6C --- PASS 3, REPLACE NON-STANDARD UNITS WITH STANDARDCD0 CALL MLIB_STD ( FACTS, TOKE, NTOKE, NERR ) IF ( NERR .NE. 0 ) THEN   IF ( NERR .EQ. 1 ) THEN3 IERR = 2$ ELSE IF ( NERR .EQ. 2 ) THEN IERR = 3 ENDIFI RETURN ENDIFEC)'C --- PASS 4, CONVERT TO REVERSE POLISH*C*4 CALL MLIB_POLISH ( TOKE, NTOKE, FACTS, ERROR ) IF ( ERROR ) THEN  IERR = 4  RETURN* ENDIF C )C --- PASS 5, EVALUATE CONVERSION FACTORS C C CALL MLIB_EVAL ( TOKE, NTOKE, FACTS, TOP, NTOP, BOTTOM, NBOT,* $ FACTOR ) C $ VALOUT = VALIN * SNGL (FACTOR)C*&C --- PASS 6, BUILD OUTPUT UNIT STRINGCT9 CALL MLIB_BUILD ( STROUT, TOP, NTOP, BOTTOM, NBOT ) RETURN END C C---END TOSTDCCE< SUBROUTINE MLIB_BUILD ( STR, TOP, NTOP, BOTTOM, NBOT )C*3C* *******************************E3C* ******************************* 3C* ** ** 3C* ** BUILD **O3C* **  **U3C* ******************************* 3C* *******************************UC*C* SUBPROGRAM : C* BUILD OUTPUT LINE C*C* AUTHOR : C* ART RAGOSTACC* MS 219-3 C* AMES RESEARCH CENTER%C* MOFFETT FIELD, CA 94035UC* (415) 694-5578C*C* PURPOSE :EC* BUILD THE STRING OF OUTPUT UNITS, CANCELLING UNITS ON TOPC* AND BOTTOM.SC*C* INPUT ARGUMENTS :1C* TOP - UNITS WHICH ARE IN NUMERATORH"C* NTOP - NUMBER IN TOP)C* BOTTOM - UNITS IN DENOMINATOR*%C* NBOT - NUMBER IN BOTTOM C*C* OUTPUT ARGUMENTS : 3C* STR - THE TOTAL STRING OF OUTPUT UNITS7C*C* INTERNAL WORK AREAS :6C* TSTR - USED TO SIMPLIFY '**N' CALCULATIONSC*C* SUBPROGRAM REFERENCES :C* LEFT, LENGTHC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77TC*C* VERSION AND DATE :,%C* VERSION I.0 13-SEP-85 C*C* CHANGE HISTORY :O(C* 13-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *500 TSTR  CHARACTER *(*) STR, CHARACTER *6 TOP(40), BOTTOM(40), WORKC  STR = ' 'C IS = 1C0C --- DELETE DUPLICATE ENTRIES ON TOP AND BOTTOMCG I = 1 10 IF (NTOP .GT. 0) THEN  DO 20 J = 1, NBOT+ IF (TOP(I) .EQ. BOTTOM(J)) THENM' BOTTOM(J) = BOTTOM(NBOT)I! TOP(I) = TOP(NTOP)  NTOP = NTOP - 1 NBOT = NBOT - 1$ IF (I .LE. NTOP) THEN GO TO 10 ELSEP GO TO 30 ENDIF ENDIFA20 CONTINUE I = I + 1" IF (I .LE. NTOP) GO TO 10 ENDIF CRBC --- REPLACE MULTIPLE ENTRIES WITH '**'N, ADD TOP UNITS TO STRINGC 30 I = 1)35 IF (I .LE. NTOP) THEN  STR(IS:) = TOP(I)! IS = IS + LENGTH(TOP(I))  STR(IS:IS) = '*'  IS = IS + 1 IC = 1  J = I + 140 IF (J .LE. NTOP) THEN( IF (TOP(I) .EQ. TOP(J)) THEN IC = IC + 1! TOP(J) = TOP(NTOP)  NTOP = NTOP - 1 GO TO 40  ENDIFI J = J + 1  GO TO 40 ENDIFC);C ----- IF THERE WERE MORE THAN ONE, REPLACE FIRST WITH **N CM IF (IC .GT. 1) THEN WRITE(WORK,900) IC CALL LEFT ( WORK )5 TSTR = '*' // WORK(1:LENGTH(WORK)) // '*'  STR(IS:) = TSTRP" IS = IS + LENGTH(TSTR) ENDIF I = I + 1 GO TO 35 ENDIFP IF ( NTOP .EQ. 0 ) THEN  STR = '1*'  IS = 3F ENDIFC >C --- REPLACE LAST '*' WITH '/' UNLESS THERE IS NO DENOMINATORC IF (NBOT .LE. 0) THENE IF (NTOP .EQ. 0) THEN# STR = 'Non Dimensional'T RETURN ENDIF STR(IS-1:IS-1) = ' ' ELSE STR(IS-1:IS-1) = '/'OCEEC --- REPLACE MULTIPLE ENTRIES WITH '**'N, ADD BOTTOM UNITS TO STRINGC  I = 145 IF (I .LE. NBOT) THEN STR(IS:) = BOTTOM(I)' IS = IS + LENGTH(BOTTOM(I))L STR(IS:IS) = '*' IS = IS + 1  IC = 1 J = I + 1 !50 IF (J .LE. NBOT) THENN1 IF (BOTTOM(I) .EQ. BOTTOM(J)) THENF IC = IC + 1 * BOTTOM(J) = BOTTOM(NBOT)! NBOT = NBOT - 1N GO TO 50 ENDIF J = J + 1 GO TO 50' ENDIF'C ;C ----- IF THERE WERE MORE THAN ONE, REPLACE FIRST WITH **N C' IF (IC .GT. 1) THENR! WRITE(WORK,900) IC'! CALL LEFT ( WORK )L8 TSTR = '*' // WORK(1:LENGTH(WORK)) // '*'  STR(IS:) = TSTR% IS = IS + LENGTH(TSTR)' ENDIF  I = I + 1' GO TO 45 ENDIF STR(IS-1:IS-1) = ' ' ENDIFC RETURN900 FORMAT(I6) END C,C---END MLIB_BUILDCN, SUBROUTINE MLIB_CMPAR ( S1, S2, IERR )C*3C* ******************************* 3C* *******************************F3C* ** **N3C* **  CMPAR **E3C* ** **L3C* ******************************* 3C* ******************************* C*C* SUBPROGRAM :DC* COMPARE UNITSDC*C* AUTHOR :1C* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*C* PURPOSE :EC* COMPARE THE CALCULATED UNITS WITH THE REQUESTED UNITS, IF8GC* THEY ARE THE SAME, SUCCESS, OTHERWISE THE REQUESTED NON-STD >C* UNITS WERE NOT COMPATIBLE WITH THE STANDARD UNITS.C*C* INPUT ARGUMENTS : C* S1 - ONE UNIT STRINGC* S2 - THE OTHERC*C* OUTPUT ARGUMENTS :0&C* IERR = 1 IF ERROR IN PARSE6C* IERR = 5 IF INPUT UNITS ARE NOT COMPATIBLE&C* WITH OUTPUT UNITSC*C* SUBPROGRAM REFERENCES :#C* CAPS, MLIB_PARSE, QSORT'C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* VERSION AND DATE : %C* VERSION I.0 24-SEP-85 C*C* CHANGE HISTORY : (C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) S1, S2 ) CHARACTER *6 TOP(50), BOT(50), WORK LOGICAL ERRORFC  ERROR = .FALSE.  IERR = 0, CALL CAPS ( S1 ) L = LENGTH ( S1 )1C 8C --- PASS 1, REPLACE '-' WITH '*' AND '**' WITH '^'CD J = 0E I = 1$ 5 IF (S1(I:I) .EQ. '-') THEN J = J + 1 S1(J:J) = '*'C0C --- ALL OTHER CHARACTERS EXCEPT ' ' GET COPIEDCM% ELSE IF (S1(I:I) .NE. ' ') THENA J = J + 1 S1(J:J) = S1(I:I) ENDIF  I = I + 1  IF ( I .LE. L )GO TO 5 S1(J+1:) = ' 'C C --- PASS 2, PARSE INTO TOKENS C'1 CALL MLIB_PARSE ( S1, J, TOP, NTOP, ERROR )  IF ( ERROR ) THEN$ IERR = 1  RETURN , ENDIFLC  K = LENGTH(S2)1 CALL MLIB_PARSE ( S2, K, BOT, NBOT, ERROR ) BOT(NBOT+1) = ' '  IF ( ERROR ) THEN' IERR = 1  RETURN ENDIFACI?C --- NOW ASCERTAIN THAT TOP AND BOT ARE FUNCTIONALLY IDENTICAL?C --- ( THOUGH NOT INFALLABLE, THIS TEST IS DONE BY SORTING THE9C --- ARRAYS AND REQUIRING THE RESULT TO BE IDENTICAL.)C IF ( NTOP .NE. NBOT ) THEN IERR = 5 ELSE' CALL QSORT ( TOP, NTOP, WORK )'zC7 SUBROUTINE GPALFA C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** GPALFA ** 3C* ** ** 3C* ******************************* 3C* ******************************* C*C* SUBPROGRAM :*(C* GP-29 TERMINAL TO ALPHA MODEC*C*  AUTHOR :RC* ART RAGOSTAOC* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035 C* (415) 604-5558C*C* PURPOSE :4C* TO RETURN A GP-29 TERMINAL TO TEXT MODE.C*C* FILE REFERENCES :C* NWRITEC*%C* ASSUMPTIONS AND RESTRICTIONS : <C* WORKS ONLY ON NORTHWEST DIGITAL GP-29 TERMINALS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY : *C* 19-AUG-1985 INITIAL VERSIONC*HC***********************************************************************C*% CALL MLIB_GET ('NWRITE',NWRITE)T WRITE(NWRITE,900) CHAR(2) RETURN900 FORMAT(' ',A1,$) ENDTCC---END GPALFAC wwAREAS :=C* STEMP - USED TO CALCULATE THE RESULTANT STD UNITSC*C* SUBPROGRAM REFERENCES :C* TOSTD, MLIB_CMPARC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C*  Arthur E. RagostaIC* MS 219-3%C* NASA Ames Research Center*%C* Moffett Field, Ca. 94035HC* (415) 604-5558C*C* PURPOSE :4C* KICK A VT340 TERMINAL INTO GRAPHICS MODEC*C* INPUT ARGUMENTS :=C* NWRITE - LOGICAL UNIT NUMBER ASSIGNED TO TERMINALEC*%C* ASSUMPTIONS AND RESTRICTIONS :2C* THE "$" EDIT DESCRIPTOR IS NONSTANDARDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77AC*C* CHANGE HISTORY : +C* 9-AUG-1988 - INITIAL VERSION C*HC***********************************************************************C*$ CALL MLIB_GET('NWRITE',NWRITE) WRITE(NWRITE,900) CHAR(27)900 FORMAT(' ',A1,'[?38h') RETURN END*C*C---END VT340GRAFC*ww ** **3C* ** TOSTD **3C* ** **3C* ******************************ݲ}H7 SUBROUTINE VT340ALFAC*3C* *******************************D3C* *******************************O3C* ** ** 3C* ** VT340ALFA ** 3C* ** ** 3C* *******************************Q3C* *******************************EC*C* SUBPROGRAM :(C* VT340 TERMINAL TO ALPHA MODEC*C*  AUTHOR : C* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER)C* MOFFETT FIELD, CALIF 94035 C* (415) 604-5558C*C* PURPOSE :4C* TO RETURN A VT340 TERMINAL TO TEXT MODE.C*C* FILE REFERENCES :C* NWRITEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77*C*C* CHANGE HISTORY :*C* 28-APR-1997 INITIAL VERSIONC*HC******************************************************************* ****C*$ CALL MLIB_GET('NWRITE',NWRITE) WRITE(NWRITE,900) CHAR(27) RETURN900 FORMAT(' ',A1,'[?38l') END C C---END VT340ALFANCPwwRING7C* 3 = AMBIGUOUS UNIT IN INPUT STRINGHC* 4 = TOO COMPLICATED TO EVALUATE OR UNMATCHED PARENSDC* 5 = INVALID UNITS REQUESTED (I.E., OUTPUT UNITS8C* DO NOT FOLLOW FROM INPUT UNITS)C*C* INTERNAL WORK AREAS :FC* WORK - TEMPORARY STRING viJ4+ SUBROUTINE ISORT ( ARRAY, NUM, INDX )RC*3C* *******************************S3C* *******************************S3C* ** ** 3C* ** ISORT ***3C* ** **A3C* ******************************* 3C* *******************************C*C* AUTHOR :TC* ART RAGOSTAC*  MS 219-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :0C* PRODUCE A SORTED INDEX POINTER ARRAY:C* THE INPUT ARRAY IS SORTED AS WELL AS THE ARRAY8C* 'INDX'. THEREFORE, INDX CAN BE USED TO PRINT)C* ANY NUMBER OF RELATED ARRAYS. C*C*C* METHODOLOGY :C* SHELLSORTOC*C* INPUT ARGUMENTS :0C* NUM - NUMBER OF ELEMENTS IN ARRAY'C* ARRAY - ARRAY TO BE SORTEDAC*C* OUTPUT ARGUMENTS := C* INDX - INDEX ARRAYC*C* INTERNAL WORK AREAS :%C* TEMPA - USED DURING SWAPS'C*%C* ASSUMPTIONS AND RESTRICTIONS :BC* THE TYPE OF THE ARRAY 'ARRAY' AND THE VARIABLE 'TEMPA'CC* MUST BE SET FOR EACH TYPE OF SORT. FOR THIS PARTICULARJFC* 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 VERSIONC*HC***********************************************************************C* DIMENSION INDX(1)  CHARACTER *(*) ARRAY(1)I CHARACTER *255 TEMPA INTEGER TEMPIF LOGICAL DONEC  DO 10 I = 1, NUM INDX(I) = I10 CONTINUEE IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 2,30 DONE = .TRUE. NJ = NUM-JUMP0 DO 40 J = 1, NJN I = J + JUMP ( IF (ARRAY(J) .GT. ARRAY(I))THEN DONE = .FALSE. TEMPA = ARRAY(J) ARRAY(J) = ARRAY(I)S ARRAY(I) = TEMPA TEMPI = INDX(J)( INDX(J) = INDX(I)  INDX(I) = TEMPI  ENDIF40 CONTINUE  IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20 RETURN ENDNCE C---END ISORTTC - SUBROUTINE ISORTI ( IARRAY, NUM, INDX )C*3C* *******************************S3C*  *******************************L3C* ** **3C* ** ISORTI **M3C* ** ** 3C* ******************************* 3C* ******************************* C*C* AUTHOR : C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :0C* PRODUCE A SORTED INDEX POINTER ARRAY:C* THE INPUT ARRAY IS SORTED AS WELL AS THE ARRAY8C* 'INDX'. THEREFORE, INDX CAN BE USED TO PRINT)C* ANY NUMBER OF RELATED ARRAYS.MC*C*C* METHODOLOGY :C* SHELLSORT4C*C* INPUT ARGUMENTS :0C* NUM - NUMBER OF ELEMENTS IN ARRAY'C* IARRAY - ARRAY TO BE SORTED C*C* OUTPUT ARGUMENTS : C* INDX - INDEX ARRAYC*C* INTERNAL WORK AREAS :%C* ITEMP - USED DURING SWAPSEC*%C* ASSUMPTIONS AND RESTRICTIONS :OCC* THE TYPE OF THE ARRAY 'IARRAY' AND THE VARIABLE 'ITEMP'RCC* MUST BE SET FOR EACH TYPE OF SORT. FOR THIS PARTICULAR1C* IMPLEMENTATION, THE ARRAY IS INTEGER.EC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77SC*C* CHANGE HISTORY :(C* 03/12/84 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION INDX(1)C DIMENSION IARRAY(1)  INTEGER TEMPIL LOGICAL DONEC* DO 10 I = 1, NUM INDX(I) = I10 CONTINUE* IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 2 30 DONE = .TRUE.) NJ = NUM-JUMP  DO 40 J = 1, NJ I = J + JUMPE* IF (IARRAY(J) .GT. IARRAY(I))THEN DONE = .FALSE. ITEMP = IARRAY(J)! IARRAY(J) = IARRAY(I)J IARRAY(I) = ITEMP( TEMPI = INDX(J)  INDX(J) = INDX(I)  INDX(I) = TEMPI  ENDIF40 CONTINUE  IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20 RETURN END C C---END ISORTIC . SUBROUTINE ISORTI8 ( IARRAY, NUM, INDX )C*3C* *******************************T3C* *******************************S3C* ** **3C* ** ISORTI8 **O3C* **  **R3C* *******************************3C* *******************************C*C* AUTHOR :)C* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :0C* PRODUCE A SORTED INDEX POINTER ARRAY:C* THE INPUT ARRAY IS SORTED AS WELL AS THE ARRAY8C* 'INDX'. THEREFORE, INDX CAN BE USED TO PRINT)C*  ANY NUMBER OF RELATED ARRAYS.KC*C* METHODOLOGY :C* SHELLSORT)C*C* INPUT ARGUMENTS :0C* NUM - NUMBER OF ELEMENTS IN ARRAY(C* IARRAY - ARRAY TO BE SORTEDC*C* OUTPUT ARGUMENTS :F C* INDX - INDEX ARRAYC*C* INTERNAL WORK AREAS :%C* ITEMP - USED DURING SWAPSTC*%C* ASSUMPTIONS AND RESTRICTIONS : CC* THE TYPE OF THE ARRAY 'IARRAY' AND THE VARIABLE 'ITEMP' CC* MUST BE SET FOR EACH TYPE OF SORT. FOR THIS PARTICULAR 4C* IMPLEMENTATION, THE ARRAY IS INTEGER *8.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77DC*C* CHANGE HISTORY :(C* 03/12/84 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION INDX(1)' INTEGER *8 IARRAY(1) INTEGER TEMPI INTEGER *8 ITEMP LOGICAL DONECN DO 10 I = 1, NUM INDX(I) = I10 CONTINUE  IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 2)30 DONE = .TRUE.B NJ = NUM-JUMP  DO 40 J = 1, NJ  I = J + JUMP * IF (IARRAY(J) .GT. IARRAY(I))THEN DONE = .FALSE. ITEMP = IARRAY(J) ! IARRAY(J) = IARRAY(I)  IARRAY(I) = ITEMP TEMPI = INDX(J)) INDX(J) = INDX(I)( INDX(I) = TEMPI  ENDIF40 CONTINUE' IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20( RETURN ENDC C---END ISORTI8 Cww GO TO 45 ENDIF STR(IS-1:IS-1) = ' ' ENDIF RETURN900 FORMAT(I6) ENDCC---END MLIB_BUILDC, SUBROUTINE MLIB_CMPAR ( S1, S2, IERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** CMPAR **3C* ** T TOKEN*C*C* AUTHOR :*C* ART RAGOSTA*C* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :@C* EXTRACT THE NEXT TOKEN FROM A CHARACTER STRING USING'C* THE FOLLOWING CONVENTIONS :ACC* 1. MORE THAN ONE CONSECUTIVE SPACE IS TREATED AS A "C* SINGLE SPACE.CC* 2. TWO CONSECUTIVE DELIMITERS RETURN A NULL TOKEN. 6C* 3. WORDS MUST BEGIN WITH A CHARACTER.4C* 4. NUMBERS MUST BEGIN WITH A DIGIT.?C* 5. ALL OTHER CHARACTERS ARE RETURNED VERBATIM.S:C* 6. VALID DELIMITERS ARE , ; AND C*C* INPUT ARGUMENTS :)C* LINE - THE LINE TO BE PARSED.C6C* LL - THE LAST CHARACTER TO SCAN IN LINE.?C* IPTR - THE LOCATION FROM WHICH PARSING IS TO BEGIN.TC*C* OUTPUT ARGUMENTS :O@C* IPTR - THE LAST CHARACTER IN LINE THAT WAS SCANNE D..C* TOKEN - THE CHARACTER *(*) RESULT.)C* TYPE - THE TYPE OF THE TOKENA/C* S - FOR SPECIAL CHARACTER**C* A - FOR ALPHANUMERIC%C* I - FOR INTEGER,"C* R - FOR REAL?C* N - FOR NULL (TWO CONSECUTIVE DELIMITERS)E)C* E - FOR END OF LINE :C* ERROR - AN ERROR OCCURRED IN PARSING THE LINE.C*%C* TRANSPORTABILITY LIMITATIONS :-/C* NON-STANDARD D ATA STATEMENT FOR EOL C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :'(C* 3-OCT-84 INITIAL VERSION?C* 4-NOV-85 FIXED TO ALLOW NUMBERS STARTING WITH .L3C* 25-MAR-86 COLON REMOVED AS DELIMITER <C* 20-MAY-87 ERROR IN END OF LINE HANDLING FIXED9C* 25-JUN-87 FIXED TO ALLOW LOWERCASE LETTERST+C* IN 'A' TYPE TOKENS'FC* 10-MAY-88 TOKEN CHANGED TO CHARACTER *(*), CHECK LENGTHDC* 07-May-1998 Fixed bug when returning TOKEN found not to&C* be a numberC*HC***********************************************************************C* CHARACTER *(*) LINE, TOKEN CHARACTER *1 EOL,CH,TYPE INTEGER TSIZER LOGICAL ERRORS DATA EOL/13/C1! IF ( IPTR .LT. 1 ) IPTR = 16 IF ( IPTR .GT. LL ) THEN TYPE = 'E'6 RETURN8 ENDIF C C --- SKIP LEADING BLANKS C 10 CH = LINE(IPTR:IPTR) IF ( CH .EQ. ' ' ) THEN  IPTR = IPTR + 1! IF ( IPTR .GT. LL ) THEN  TYPE = 'E' RETURN ENDIF GO TO 104 ENDIF7C24C --- IF CHARACTER IS DELIMITER, RETURN A NULL VALUEC9 TOKEN = ' '5 TSIZE = 1A0 IF ((CH .EQ. ',') .OR. (CH .EQ. ';')) THEN TYPE = 'N'C4)C --- FIRST CHARACTER WAS NOT A DELIMITER,C 7 ELSE IF (((CH .GE. 'A') .AND. (CH .LE. 'Z')) .OR.L6 $ ((CH .GE. 'a') .AND. (CH .LE. 'z'))) THENCPC ----- ALPHABETIC TOKENC  TYPE = 'A'LC3?C ------- WHILE (CH IN ALPHA+DIGITS) PACK CHARACTERS INTO TOKEN,CE,30 IF (TSIZE .GT. LEN(TOKEN)) GO TO 60 TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 12! IF ( IPTR .GT. LL ) THEN( CH = EOL ELSE CH = LINE(IPTR:IPTR) ENDIF5 IF (((CH .GE. 'A') .AND. (CH .LE. 'Z')) .OR.Q5 $ ((CH .GE. 'a') .AND. (CH .LE. 'z')) .OR.2: $ ((CH .GE. '0') .AND. (CH .LE. '9'))) GO TO 30C &C ----- END WHILE (CH IN ALPHA+DIGITS)C E ELSE IF (((CH .GE. '0') .AND. (CH .LE. '9')) .OR. (CH .EQ. '+')9 $ .OR. (CH .EQ. '-') .OR. (CH .EQ. '.')) THEN*C ,C ----- NUMERICAL TYPE... DEFAULT TO INTEGERCN TYPE = 'I'CA=C --- CHECK FOR LEADING SIGN AS THESE MAY NOT DENOTE A NUMBERCCG3 IF ((CH .EQ. '-') .OR. (CH .EQ. '+')) THENN/ IF (TSIZE .GT.  @@0 SUBROUTINE GETUSRPRV ( USERNAME, N, PRIV )C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** GETUSRPRV **C3C* ** **F3C* ******************************* 3C* ******************************* C*C* SUBPROGRAM :*C* GET USER PRIVILEGES C*C* AUTHOR : C* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* TO CHECK THE AUTHORIZED PRIVILEGES ALLOWED BY THE SYSUAF GCC* FILE FOR USER "USERNAME" AND RETURN THEM IN ASCII FORM.AC*C* INPUT ARGUMENTS :BC* USERNAME - NAME OF USER FOR WHICH TO RETURN PRIVILEGESC*C* OUTPUT ARGUMENTS :5FC* N - THE NUMBER OF PRIVILEGES FOUND (-STATUS, IF ERROR)DC* PRIV - THE ARRAY CONTAINING THE NAMES OF THE PRIVILEGESC*C* INTERNAL WORK AREAS :;C* MASK1, MASK2 - THE MASK BITS FOR THE PRIVILEGES*IC* ALL1, ALL2 - THE ASCII NAMES CORRESPONDING TO MASK1 AND MASK2CC*C* SUBPROGRAM REFERENCES :"C* UAI$_PRIV, SYS$GETUAIC*%C* TRANSPORTABILITY LIMITATIONS :R(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77TC*C* CHANGE HISTORY :REC* 30-MAR-1998 ADDED USER FOR WHICH TO GET PRIVILEGES - LEG (C* 12-APR-85 INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($UAIDEF)' & CHARACTER *(*) PRIV(1), USERNAME% CHARACTER *10 ALL1(32), ALL2(7)* INTEGER *2 ITEM(2)B INTEGER *4 MASK1(32), MASK2(7), ITMLST(4), QUAD(2), ICONTEXT INTEGER SYS$GETUAI% EQUIVALENCE (ITEM(1),ITMLST(1))R DATA ICONT EXT /-1/C +C --- PRIVILEGE NAMES IN THE FIRST QUADWORD*C*? DATA ALL1 / 'ACNT ', 'ALLSPOOL ', 'BUGCHK ', ? $ 'BYPASS ', 'CMEXEC ', 'CMKRNL ', 'DETACH ',K? $ 'DIAGNOSE ', 'EXQUOTA ', 'GROUP ', 'GRPNAM ',S? $ 'LOG_IO ', 'MOUNT ', 'NETMBX ', 'OPER ',? $ 'PFNMAP ', 'PHY_IO ', 'PRMCEB ', 'PRMGBL ', ? $ 'PRMMBX ', 'PSWAPM ', 'SETPRI ', 'SETPRV ',? $ 'SHARE ', 'SHMEM ', 'SYSGBL  ', 'SYSLCK ', ? $ 'SYSNAM ', 'SYSPRV ', 'TMPMBX ', 'VOLPRO ',  $ 'WORLD '/C -C --- PRIVILEGE NAMES IN THE SECOND QUAD WORD C ? DATA ALL2 / 'DOWNGRADE ', 'GRPPRV ', 'PRMJNL ', ? $ 'READALL ', 'SECURITY ', 'TMPJNL ', 'UPGRADE '/ C 'C --- MASK BITS FOR THE FIRST QUAD WORDPC; DATA MASK1 / 512, 16, 8388608, 6 $ 536870912, 2, 1, 32,5 $ 64, 524288, 256 , 8, : $ 128, 131072, 1048576, 262144,< $ 67108864, 4194304, 1024, 16777216,9 $ 2048, 4096, 8192, 16384, > $ -2147483648, 134217728, 33554432, 1073741824,; $ 4, 268435456, 32768, 2097152,) $ 65536 /C (C --- MASK BITS FOR THE SECOND QUAD WORDC6 DATA MASK2 / 2, 4, 32,6 $ 8, 64, 16, 1 /CT N = 0 C C --- FILL ITMLST0C  ITEM(1) = 8K ITEM(2) = UAI$_PRIVA! ITMLST(2) = %LOC( QUAD(1) )' ITMLST(3) = 0  ITMLST(4) = 0'B ISTAT = SYS$GETUAI (,ICONTEXT, USERNAME(1:LENGTH(USERNAME)),& $ ITMLST,,,) IF (.NOT. ISTAT) THEN) N = -ISTAT  RETURN ENDIF CS%C --- PROCESS FIRST WORD OF QUAD WORDC  DO 10 I = 1,322 IF ((QUAD(1) .AND. MASK1(I)) .NE. 0) THEN N = N + 1  PRIV(N) = ALL1(I)  ENDIF10 CONTINUETCT&C --- PROCESS SECOND WORD OF QUAD WORDCM DO 20 I = 1,7(2 IF ((QUAD(2) .AND. MASK2(I)) .NE. 0) THEN N = N + 1( PRIV(N) = ALL2(I)  ENDIF20 CONTINUET RETURN ENDC C---END GETUSRPRV CTww DO 15 II = 1, NUM* B(IB:IB+LB-1) = B1(1:LB) IB = IB + LB B(IB:IB) = '*'  LEN(TOKEN)) GO TO 60 # TOKEN(TSIZE:TSIZE) = CHN TSIZE = TSIZE + 1  IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOL ELSE# CH = LINE(IPTR:IPTR)  ENDIFS# IF ((CH .NE. '.') .AND.T7 $ ((CH .LT. '0') .OR. (CH .GT. '9'))) THEN  TYPE = 'S'. RETURN  ENDIF ENDIF CA-C --- NUMBER FOR SURE (INTEGER OR WHOLE PART) C1435 IF ((CH .GE. '0') .AND. (CH .LE. '9')) THEN/ IF (TSIZE .GT. LEN(TOKEN)) GO TO 60(# TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOLT ELSE# CH = LINE(IPTR:IPTR)1 ENDIF  GO TO 35 ENDIFCLC --- CHECK FOR FRACTIONAL PARTC --- DECIMAL POINT?C0 IF (CH .EQ. '.') THEN/ IF (TSIZE .GT. L EN(TOKEN)) GO TO 60 # TOKEN(TSIZE:TSIZE) = CH  TSIZE = TSIZE + 1  IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOL  ELSE# CH = LINE(IPTR:IPTR)  ENDIF  TYPE = 'R' 6 IF ((CH .LT. '0') .OR. (CH .GT. '9')) THEN% IF (TSIZE .LE. 2) THEN TYPE = 'S' RETURN ENDIF ENDIFOCIC ----- FRACTIONAL P ART C 737 IF ((CH .GE. '0') .AND. (CH .LE. '9')) THEN 2 IF (TSIZE .GT. LEN(TOKEN)) GO TO 60& TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1B' IF ( IPTR .GT. LL ) THENH CH = EOL ELSE & CH = LINE(IPTR:IPTR) ENDIF GO TO 37  ENDIF' ENDIFCIC ------ CHECK FOR EXPONENT C.3 IF ((CH .EQ. 'E ') .OR. (CH .EQ. 'D')) THEN/ IF (TSIZE .GT. LEN(TOKEN)) GO TO 60I# TOKEN(TSIZE:TSIZE) = CH  TSIZE = TSIZE + 1  IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOL  ELSE# CH = LINE(IPTR:IPTR)T ENDIF 7 IF ((CH .NE. '+') .AND. (CH .NE. '-') .AND.S7 $ ((CH .LT. '0') .OR. (CH .GT. '9'))) THEN  IPTR = IPTR - 1cIIc --- we also need to remove the l ast character from TOKEN - leg 5/7/1998 c TSIZE = TSIZE - 1' TOKEN(TSIZE:TSIZE) = ' '  RETURNI ENDIF  TYPE = 'R'CA1C ------- IF WE GET THIS FAR, WE HAVE AN EXPONENT C 6 IF ((CH .EQ. '+') .OR. (CH .EQ. '-')) THEN2 IF (TSIZE .GT. LEN(TOKEN)) GO TO 60& TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1N' IF ( IPTR .GT. LL ) THENF  CH = EOL ELSE)& CH = LINE(IPTR:IPTR) ENDIF ENDIF740 IF ((CH .GE. '0') .AND. (CH .LE. '9')) THEN 2 IF (TSIZE .GT. LEN(TOKEN)) GO TO 60& TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1.' IF ( IPTR .GT. LL ) THEN  CH = EOL ELSEO& CH = LINE(IPTR:IPTR) ENDIF GO TO 40K ENDIFE ENDIFC 5C ------ OTHERWISE, RETURN THE SPECIAL CHARACTER ONLY C ELSE TYPE = 'S'* TOKEN(1:1) = CH IPTR = IPTR + 1 IF (IPTR .GT. LL) THEN  CH = EOL ELSE CH = LINE(IPTR:IPTR) ENDIF ENDIF*C*CC --- SKIP SPACES AND DELIMITER (IF ANY) -- GET READY FOR NEXT CALL*C*60 IF ( CH .EQ. ' ' ) THEN IPTR = IPTR + 1! IF ( IPTR .LE . LL ) THENA CH = LINE(IPTR:IPTR) GO TO 60 ENDIF ENDIFI; IF ((CH .EQ. ',') .OR. (CH .EQ. ';')) IPTR = IPTR + 1R RETURN END C C---END GETOKECYwwOKENS..C* NOTE: THE ONLY VALID SYMBOLS ARE -LC* UNITS, EXPONENTS, '*', '^', '/', '(', AND ')'C*C* INPUT ARGUMENTS :+C* WORK - THE STRING TO BE PARSEDC*C* OUTPUT ARGUMENTS :'C* TOKE - THE ARRAY OF TOKENS.C*  NTOKE - THE NUMBER OF TOKENS FOUND5C* ERR - SET TRUE IF AN ERROR IS UNCOVEREDC*C* ERROR PROCESSING :*C* CHECKS FOR INVALID CHARACTERS.0C* DISALLOWS EXPONENTS GREATER THAN 99.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) WORK CHARACTER *6 TOKE(1) LOGICAL ERRC I = 1 NTOKE = 0C&C --- ALL UNITS BEGIN WITH A CHARACTERC?100 IF ((WORK(I:I) .GE. 'A') .AND. (WORK(I:I) .LE. 'Z')) THEN NTOKE = NTOKE + 1 INT = 1 TOKE(NTOKE) = ' '110 IF (INT .LE. 6) THEN, TOKE(NTOKE)(INT:INT) = WORK(I:I) INT = INT + 1 ENDIF I = I + 1" IF (I .GT. LW) GO TO 1000G IF ((WORK(I:I) .GE. 'A') .AND. (WORK(I:I) .LE. 'Z')) GO TO 110CC --- NUMBERS USED AS EXPONENTSCD ELSE IF ((WORK(I:I) .GE. '0') .AND. (WORK(I:I) .LE. '9')) THEN NTOKE = NTOKE + 1 INT = 1 TOKE(NTOKE) = ' ')210 TOKE(NTOKE)(INT:INT) = WORK(I:I) IF (INT .GT. 2) THEN ERR = .TRUE. RETURN ENDIF INT = INT + 1 I = I + 1" IF (I .GT. LW) GO TO 1000G IF ((WORK(I:I) .GE. '0') .AND. (WORK(I:I) .LE. '9')) GO TO 210C#C --- OPERATORS ARE ( ) * / ^CB ELSE IF ((WORK(I:I) .EQ. '(') .OR. (WORK(I:I) .EQ. ')') .OR.B $ (WORK(I:I) .EQ. '*') .OR. (WORK(I:I) .EQ. '/') .OR.) $ (WORK(I:I) .EQ. '^')) THEN NTOKE = NTOKE + 1 TOKE(NTOKE) = WORK(I:I) I = I + 1C#C --- NO OTHER CHARACTERS ARE VALIDC ELSE ERR = .TRUE. RETURN ENDIF IF (I .LE. LW) GO TO 100 1000 RETURN ENDCC---END MLIB_PARSEC8 SUBROUTINE MLIB_POLISH ( TOKE, NTOKE, FACTS, ERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** POLISH **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :&C* POLISH NOTATION CONVERSIONC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :=C* TO REPLACE THE UNITS ARRAY (WHICH IS IN ALGEBRAIC@C* NOTATION) WITH THE EQUIVALENT REVERSE POLISH STRING.C*C* METHODOLOGY :;C* USE THE STACK COMPILATION TECHNIQUE, REFERENCE:EC* KATZAN, "ADVANCED PROGRAMMING", VAN NOSTRAND REINHOLD CO,C* NEW YORK, 1970.C*C* INPUT ARGUMENTS :8C* TOKE - THE LIST OF TOKENS IN ALGEBRAIC FORM4C* NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'C*C* OUTPUT ARGUMENTS :7C* TOKE - THE NEW LIST IN REVERSE POLISH FORM4C* NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'7C* ERR - SET TRUE FOR UNMATCHED PARENTHESES.C*C* INTERNAL WORK AREAS :5C* ISTACK, STACK - TEMPORARY OPERATOR STACKSC*C* ERROR PROCESSING :<C* CHECK EACH RIGHT PAREN FOR A MATCHING LEFT PARENC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*% CHARACTER *6 TOKE(1), STACK(20)+ DOUBLE PRECISION FACTS(1), FSTACK(20) DIMENSION ISTACK(20) LOGICAL ERRC  ISP = 1 IPOLE = 0 ISTACK ( ISP ) = -1 STACK ( ISP ) = ' ' FSTACK ( ISP ) = 0.D0CC --- ALL TOKENSC DO 100 I = 1, NTOKECC ----- '(' STACK IT ONLYC# IF (TOKE(I) .EQ. '(') THEN ISP = ISP + 1! STACK(ISP) = TOKE(I) ISTACK(ISP) = 0" FSTACK(ISP) = FACTS(I)C/C ----- ')' UNSTACK UNTIL MATCHING '(' IS FOUNDC( ELSE IF (TOKE(I) .EQ. ')') THEN 20 IF (ISP .LE. 1) THEN ERR = .TRUE. RETURN ENDIF( IF (ISTACK(ISP) .NE. 0) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1% IF (IPOLE .LE. 0) THEN ERR = .TRUE. RETURN ENDIF GO TO 20 ENDIF ISP = ISP - 1C@C ----- '*' OR '/' ... UNSTACK ANY '^', '*', OR '/' ON THE STACKC) ELSE IF ((TOKE(I) .EQ. '*') .OR.* $ (TOKE(I) .EQ. '/')) THEN(30 IF (ISTACK(ISP) .GE. 8) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1 GO TO 30 ENDIF ISP = ISP + 1! STACK(ISP) = TOKE(I)" FSTACK(ISP) = FACTS(I) ISTACK(ISP) = 8C,C ----- '^' ... UNSTACK ANY '^' ON THE STACKC( ELSE IF (TOKE(I) .EQ. '^') THEN(40 IF (ISTACK(ISP) .GE. 9) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1 GO TO 40 ENDIF ISP = ISP + 1! STACK(ISP) = TOKE(I)" FSTACK(ISP) = FACTS(I) ISTACK(ISP) = 9C8C ----- UNITS AND EXPONENTS GET MOVED DIRECTLY TO OUTPUTC ELSE IPOLE = IPOLE + 1" TOKE(IPOLE) = TOKE(I)# FACTS(IPOLE) = FACTS(I) ENDIF100 CONTINUE NTOKE = IPOLEC?C --- THERE MAY STILL BE OPERATORS ON THE STACK... UNSTACK THEMC300 IF (ISP .GT. 1) THEN NTOKE = NTOKE + 1& IF (STACK(ISP) .EQ. '(') THEN ERR = .TRUE. RETURN ENDIF! TOKE(NTOKE) = STACK(ISP)" FACTS(NTOKE)= FSTACK(ISP) ISP = ISP - 1 GO TO 300 ENDIF RETURN ENDCC---END MLIB_POLISHC6 SUBROUTINE MLIB_STD ( FACTS, TOKE, NTOKE, NERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** STD **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STANDARDIZEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :?C* TO REPLACE NON-STANDARD UNITS WITH THEIR EQUIVALENT6C* STANDARD UNITS AND RESULTING SCALE FACTOR.C*C* INPUT ARGUMENTS :=C* TOKE - ARRAY OF (POTENTIALLY) NON-STANDARD UNITS-C*  NTOKE - NUMBER OF ENTRIES IN TOKEC*C* OUTPUT ARGUMENTS :6C* TOKE - THE ARRAY WITH ONLY STANDARD UNITS-C* NTOKE - NUMBER OF ENTRIES IN TOKEBC* FACTS - ARRAY WITH SCALE FACTORS FOR EACH UNIT IN TOKE2C* NERR - = 1 IF UNIT COULD NOT BE FOUND,C* = 2 IF UNIT IS AMBIGUOUSC*C* INTERNAL WORK AREAS :EC* TEMP - USED TO STORE TOKENS UNTIL ALL UNITS ARE REPLACEDC*C* COMMON BLOCKS :C* MLIB$UNITSC*C*  SUBPROGRAM REFERENCES :C* SEARCHC*C* ERROR PROCESSING :)C* IF A UNIT ISN'T FOUND, ABORT.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (NUM=50,NLIS=29)9 CHARACTER *6 TOKE(1), TEMP(100) ,KNOWN, ALIAS, LIS!T CHARACTER *1 FIRST LOGICAL AMBIG,MATCH& DOUBLE PRECISION FACTS(1), KFACTH COMMON /MLIB$UNITS/ KFACT(NUM), KNOWN(NUM), ALIAS(NUM), LIST(NLIS)C ITOKE = 1 IFAC = 1 NERR = 0 DO 100 I = 1, NTOKEC>C --- IF THE TOKEN REPRESENTS A UNIT, BINARY SEARCH UNITS LISTC FIRST = TOKE(I)(1:1): IF ((FIRST .GE. 'A') .AND. (FIRST .LE. 'Z')) THENC$C --- BINARY SEARCH KNOWN UNITS LISTC= CALL SEARCH (KNOWN, NUM, TO"KE(I), K, MATCH, AMBIG)! IF (.NOT.(MATCH)) THEN NERR = 1 RETURN ELSE IF (AMBIG) THEN NERR = 2 RETURN ENDIFC:C --- FOUND... PUT IN SCALE FACTOR (1 IF ALREADY STANDARD)6C --- IF NOT STANDARD, PACK REPLACEMENT UNITS IN TEMPC, IF (ALIAS(K)(1:1) .EQ. '-') THEN+ READ(ALIAS(K)(2:6),900) IPTR ISTORE = IFAC"20 FACTS(IFAC) = 1.0D0 IFA#C = IFAC + 1' TEMP(ITOKE) = LIST(IPTR) ITOKE = ITOKE + 1 IPTR = IPTR + 10 IF (LIST(IPTR) .NE. ')') GO TO 20" FACTS(IFAC) = 1.0D0 IFAC = IFAC + 1' TEMP(ITOKE) = LIST(IPTR) ITOKE = ITOKE + 1 IPTR = IPTR + 1) FACTS(ISTORE+1) = KFACT(K) ELSE% FACTS(IFAC) = KFACT(K) IFAC = IFAC + 1% TEMP(IT$OKE) = ALIAS(K) ITOKE = ITOKE + 1 ENDIFC3C --- IF THE TOKEN IS A NUMBER (EXPONENT) PASS A 1.AC --- (THIS IS NEEDED SINCE 'EVAL' PASSES EXPONENTS TO THE STACKC> ELSE IF((FIRST .GE. '0') .AND. (FIRST .LE. '9')) THEN! TEMP(ITOKE) = TOKE(I) ITOKE = ITOKE + 1 FACTS(IFAC) = 1.0D0 IFAC = IFAC + 1C C --- OTHERWISE, ITS AN OPERATORC ELSE! TEMP(ITOKE) = TOKE(I) IT%OKE = ITOKE + 1 FACTS(IFAC) = 1.0D0 IFAC = IFAC + 1 ENDIF100 CONTINUEC)C --- COPY FROM TEMP STORAGE BACK TO TOKEC NTOKE = ITOKE - 1 DO 200 I = 1, NTOKE TOKE(I) = TEMP(I)200 CONTINUE RETURN900 FORMAT(I5) ENDCC---END MLIB_STDC BLOCK DATA MLIB$DATA PARAMETER (NUM=50,NLIS=29)% CHARACTER *6 KNOWN, ALIAS, LIST DOUBLE PRECISION KFACTH COMMON /MLIB$UNITS/ KFACT(&NUM), KNOWN(NUM), ALIAS(NUM), LIST(NLIS)C2C --- KNOWN UNITS (BOTH STANDARD AND NON-STANDARD)C;C --- NOTE: THE FOLLOWING ARRAY MUST BE IN ALPHABETIC ORDERCD DATA KNOWN / 'ATMOS ', 'BAR ', 'BTU ', 'CM ',D $ 'DEGREE', 'DYNE ', 'ERG ', 'FATHOM', 'FEET ',D $ 'FPS ', 'FT ', 'GALLON', 'GM ', 'GRAMS ',D $ 'HOURS ', 'HP ', 'HR ', 'INCHES', 'JOULES',D $ 'KG ', 'KILOGR', 'KILOME', 'KM ', ' 'KNOTS ',D $ 'L ', 'LB ', 'LITERS', 'M ', 'METERS',D $ 'MI ', 'MILES ', 'MINUTE', 'MPH ', 'N ',D $ 'NAUTMI', 'NEWTON', 'PASCAL', 'PINTS ', 'POUNDS',D $ 'PSI ', 'QUARTS', 'RADIAN', 'REV ', 'S ',D $ 'SECOND', 'SLUGS ', 'TONS ', 'WATTS ', 'YARDS ', $ 'YD '/C:C --- THE CONVERSION FACTOR TO GET FROM 'KNOWN' TO 'ALIAS'CCC --- IMPORTANT!!! THE CONVERSION FACTORS FOR 'GAL' AND 'L(ITER' AREFC --- THE CUBE ROOT OF THE ACTUAL CONVERSION FACTOR SINCE 'EVAL' WILL%C --- CUBE THEM WHEN IT SEES 'FT^3'.CF DATA KFACT / 2.11536D3, 2.0896347D3, 7.783D2, 3.28084D-2,A $1.0D0, 2.2481D-6, 7.376D-8, 6.0D0, 1.0D0,H $1.0D0, 1.0D0, 5.11317368D-1,6.8465014D-5,6.8465014D-5,H $3.6D3, 5.5D2, 3.6D3, 8.3333333D-2,7.3746313D-1,H $6.8465014D-2,6.8465014D-2,3.28084D3, 3.28084D3, 1.68780648D0,E $3.2808719D)-1,1.0D0, 3.2808719D-1, 3.28084D0, 3.28084D0,E $5.28D3, 5.28D3, 6.0D1, 1.4666667D0, 2.2481D-1,A $6.0761157D3, 2.2481D-1, 2.0885531D-2,2.55658684D-1,1.0D0,A $1.44D2, 3.22109757D-1,5.7295779D1, 3.6D2, 1.0D0,A $1.0D0, 1.0D0, 2.0D3, 7.376D-1, 3.0D0, $3.0D0/C9C --- THE EQUIVALENT STANDARD UNIT OR POINTER INTO 'LIST'CD DATA ALIAS / '- 18', '- 18', '- 25', 'FT ',D $ 'DEG ', 'L*B ', '- 25', 'FT ', 'FT ',D $ '- 8', 'FT ', '- 13', 'SLUG ', 'SLUG ',D $ 'SEC ', '- 1', 'SEC ', 'FT ', '- 25',D $ 'SLUG ', 'SLUG ', 'FT ', 'FT ', '- 8',D $ '- 13', 'LB ', '- 13', 'FT ', 'FT ',D $ 'FT ', 'FT ', 'SEC ', '- 8', 'LB ',D $ 'FT ', 'LB ', '- 18', '- 13', 'LB ',D $ '- 18', '- 13', 'DEG + ', 'DEG ', 'SEC ',D $ 'SEC ', 'SLUG ', 'LB ', '- 1', 'FT ', $ 'FT '/CFC --- THIS LIST IS USED WHEN A NON-STANDARD UNIT MUST BE REPLACED BY A6C --- LIST OF STANDARD UNITS (EG, 'HP' = 'FT-LB/SEC')CA DATA LIST / '( ', 'FT ', '* ', 'LB ',A $ '/ ', 'SEC ', ') ', '( ', 'FT ',A $ '/ ', 'SEC ', ') ', '( ', 'FT ',A $ '^ ', '3 ', ') ', '( ', 'LB ',A $ '/ ', 'FT ', '^ ', '2 ', ') ',A $ '( ', 'FT ', '* ', 'LB ', ') '/ ENDCC --- END BLOCK DATA MLIB$DATACww- CALL QSORT ( BOT, NBOT, WORK ) DO 10 I = 1,NTOP. IF ( TOP(I) .NE. BOT(I) ) GO TO 2010 CONTINUE ENDIF RETURN20 IERR = 5 RETURN ENDCC---END MLIB_CMPARCG SUBROUTINE MLIB_EVAL (TOKE, NTOKE, FACTS, TOP, NT, BOT, NB, FAC )C*3C* *******************************3C* *******************************3C* ** **3C* ** . EVAL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* EVALUATEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :AC* TO EVALUATE THE REVERSE POLISH STRING, RESULTING IN A4C* / FINAL SCALE FACTOR AND THE PROPER UNITS.C*C* INPUT ARGUMENTS :8C* TOKE - THE LIST OF TOKENS IN REVERSE POLISH2C* NTOKE - THE NUMBER OF TOKENS IN 'TOKE'>C* FACTS - THE SCALE FACTORS FOR EACH ENTRY IN 'TOKE'C*C* OUTPUT ARGUMENTS :@C* TOP - THE LIST OF UNITS WHICH ARE IN THE NUMERATOR2C* NT - THE NUMBER OF ENTRIES IN 'TOP'BC* BOT - THE LIST OF UNITS WHICH ARE IN THE DENOMINATOR2C* NB - THE NUMBER OF ENTR0IES IN 'BOT'*C* FAC - THE TOTAL SCALE FACTORC*C* INTERNAL WORK AREAS :2C* TFAC, BFAC - STACKS FOR SCALE FACTORS4C* TSTACK, BSTACK - STACKS FOR UNIT STRINGSC*C* SUBPROGRAM REFERENCES :C* LENGTH, RIGHTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC*****************************1******************************************C*9 CHARACTER *600 BSTACK(50), TSTACK(50), T, T1, B, B1. CHARACTER *6 TOKE(1), TOP(1), BOT(1), TT0 DOUBLE PRECISION FACTS(1), FAC, FSTACK(50)C FAC = 1.0D0 NT = 0 NB = 0 IF ( NTOKE .LE. 0 ) RETURN ISP = 0C(C --- FIRST PASS, CALCULATE SCALE FACTORC DO 100 I = 1, NTOKEC4C ----- FOR EXPONENTIATION, GET EXPONENT FROM TOKENSC$ IF ( TOKE(I) .EQ. '^') THEN TT =2 TOKE(I-1) CALL RIGHT ( TT )* READ ( TT, 900, ERR=1000 ) NUM* FSTACK(ISP) = FSTACK(ISP)**NUMCC ----- MULTIPLYC( ELSE IF (TOKE(I) .EQ. '*') THEN ISP = ISP - 15 FSTACK(ISP) = FSTACK(ISP) * FSTACK(ISP+1)CC ----- DIVIDEC( ELSE IF (TOKE(I) .EQ. '/') THEN ISP = ISP - 15 FSTACK(ISP) = FSTACK(ISP) / FSTACK(ISP+1)C%C ----- OTHERWISE THE TOKEN IS A UNITC ELSEC1C --3------ IF THE TOKEN IS NUMERIC, DO NOTHING---/C -------- IF IT IS ALPHA, ADD FACTOR TO STACKC, IF ((TOKE(I)(1:1) .LT. '0') .OR.- $ (TOKE(I)(1:1) .GT. '9')) THEN" ISP = ISP + 1% FSTACK(ISP) = FACTS(I) ENDIF ENDIF100 CONTINUE FAC = FSTACK(ISP)CFC --- PASS 2, DETERMINE WHICH SYMBOLS ARE IN NUMERATOR AND DENOMINATORC NT = 0 NB = 0 ISP = 0 DO 200 I = 1, NTOK4ECAC ----- FOR EXPONENTIATION, ADD THE STRING TO ITSELF 'NUM' TIMES.C$ IF ( TOKE(I) .EQ. '^') THEN TT = TSTACK(ISP) ISP = ISP - 1 CALL RIGHT ( TT )* READ ( TT, 900, ERR=1000 ) NUM T1 = TSTACK(ISP) B1 = BSTACK(ISP) ISP = ISP - 1 T = ' ' B = ' ' IT = 1 IB = 1 LT = LENGTH(T1) LB = LENGTH(B1) 5 IF (LT .GT. 0) THEN DO 10 II = 1, NUM* T(IT:IT+LT-1) = T1(1:LT) IT = IT + LT T(IT:IT) = '*' IT = IT + 110 CONTINUE ENDIF IF (LB .GT. 0) THEN DO 15 II = 1, NUM* B(IB:IB+LB-1) = B1(1:LB) IB = IB + LB B(IB:IB) = '*' IB = IB + 115 CONTINUE ENDIF6 IT = IT - 1 IB = IB - 1 T(IT:IT) = ' ' B(IB:IB) = ' ' ISP = ISP + 1 TSTACK(ISP) = T BSTACK(ISP) = BCDC ----- FOR A MULTIPLY, ADD STRINGS FROM THE SAME SIDE OF THE STACK.C( ELSE IF (TOKE(I) .EQ. '*') THEN T = TSTACK(ISP) B = BSTACK(ISP) ISP = ISP - 1 T1 = TSTACK(ISP) B1 = BSTACK(ISP) ISP 7= ISP - 1 LT = LENGTH ( T ) LB = LENGTH ( B ) LT1 = LENGTH ( T1 ) LB1 = LENGTH ( B1 )CAC -------- CHECK TO SEE THAT THERE WAS AN ENTRY IN BOTH LOCATIONSC4 IF ((LT .GT. 0) .AND. (LT1 .GT. 0)) THEN LT = LT + 1 T(LT:LT) = '*' ENDIF4 IF ((LB .GT. 0) .AND. (LB1 .GT. 0)) THEN LB = LB + 1 B(LB:LB) = '*' ENDIF LT = 8LT + 1 LB = LB + 1 IF (LT1 .GT. 0) THEN) T(LT:LT+LT1-1) = T1(1:LT1) ENDIF IF (LB1 .GT. 0) THEN) B(LB:LB+LB1-1) = B1(1:LB1) ENDIF ISP = ISP + 1 TSTACK(ISP) = T BSTACK(ISP) = BCCC ----- FOR A DIVIDE, ADD STRINGS FROM OPPOSITE SIDES OF THE STACK.C( ELSE IF (TOKE(I) .EQ. '/') THEN T = TSTACK(ISP) B = BSTACK(ISP) 9 ISP = ISP - 1 T1 = TSTACK(ISP) B1 = BSTACK(ISP) ISP = ISP - 1 LT = LENGTH ( T ) LB = LENGTH ( B ) LT1 = LENGTH ( T1 ) LB1 = LENGTH ( B1 )4 IF ((LT1 .GT. 0) .AND. (LB .GT. 0)) THEN LT1 = LT1 + 1 T1(LT1:LT1) = '*' ENDIF4 IF ((LB1 .GT. 0) .AND. (LT .GT. 0)) THEN LB1 = LB1 + 1 B1(LB1:LB1) = '*' : ENDIF LT1 = LT1 + 1 LB1 = LB1 + 1 IF (LB .GT. 0 ) THEN) T1(LT1:LT1+LB-1) = B(1:LB) ENDIF IF (LT .GT. 0 ) THEN) B1(LB1:LB1+LT-1) = T(1:LT) ENDIF ISP = ISP + 1 TSTACK(ISP) = T1 BSTACK(ISP) = B1CFC ----- OTHERWISE THE TOKEN IS A UNIT, PUT IT ON THE TOP SIDE OF STACKC ELSE ISP = ISP + 1! TSTACK;(ISP) = TOKE(I) BSTACK(ISP) = ' ' ENDIF200 CONTINUEC4C --- NOW PARSE THE TOP STRINGS INTO ARRAYS OF UNITSC T = TSTACK(ISP) B = BSTACK(ISP) LT = LENGTH ( T ) LB = LENGTH ( B ) NT = 0 NB = 0 I = 1205 NT = NT + 1 INT = 1 TOP(NT) = ' '210 TOP(NT)(INT:INT) = T(I:I) INT = INT + 1 I = I + 1 IF (I .GT. LT) GO TO 250$ IF (T(I:I) .NE. '*') GO TO 210 < I = I + 1 IF (I .LE. LT) GO TO 205C 250 I = 1 IF (LB .EQ. 0) GO TO 1000300 NB = NB + 1 INT = 1 BOT(NB) = ' '310 BOT(NB)(INT:INT) = B(I:I) INT = INT + 1 I = I + 1 IF (I .GT. LB) GO TO 1000$ IF (B(I:I) .NE. '*') GO TO 310 I = I + 1 IF (I .LE. LB) GO TO 300 1000 RETURN900 FORMAT ( I6 ) ENDCC---END MLIB_EVALC: SUBROUTINE MLIB_PARSE ( WORK, LW, TOKE, NTOKE, ERR )C*3C* = *******************************3C* *******************************3C* ** **3C* ** PARSE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PARSERC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEA>RCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :5C* PARSE THE STRING INTO AN ARRAY OF TOKENS..C* NOTE: THE ONLY VALID SYMBOLS ARE -LC* UNITS, EXPONENTS, '*', '^', '/', '(', AND ')'C*C* INPUT ARGUMENTS :+C* WORK - THE STRING TO BE PARSEDC*C* OUTPUT ARGUMENTS :'C* TOKE - THE ARRAY OF TOKENS.C* NTOKE - THE NUMBER OF TOKENS FOUND5C* ERR - SE?T TRUE IF AN ERROR IS UNCOVEREDC*C* ERROR PROCESSING :*C* CHECKS FOR INVALID CHARACTERS.0C* DISALLOWS EXPONENTS GREATER THAN 99.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) WORK CHARACTER *6 TOKE(1)@ LOGICAL ERRC I = 1 NTOKE = 0C&C --- ALL UNITS BEGIN WITH A CHARACTERC?100 IF ((WORK(I:I) .GE. 'A') .AND. (WORK(I:I) .LE. 'Z')) THEN NTOKE = NTOKE + 1 INT = 1 TOKE(NTOKE) = ' '110 IF (INT .LE. 6) THEN, TOKE(NTOKE)(INT:INT) = WORK(I:I) INT = INT + 1 ENDIF I = I + 1" IF (I .GT. LW) GO TO 1000G IF ((WORK(I:I) .GE. 'A') .AND. (WORK(I:I) .LE. 'Z')) GO TO 110CAC --- NUMBERS USED AS EXPONENTSCD ELSE IF ((WORK(I:I) .GE. '0') .AND. (WORK(I:I) .LE. '9')) THEN NTOKE = NTOKE + 1 INT = 1 TOKE(NTOKE) = ' ')210 TOKE(NTOKE)(INT:INT) = WORK(I:I) IF (INT .GT. 2) THEN ERR = .TRUE. RETURN ENDIF INT = INT + 1 I = I + 1" IF (I .GT. LW) GO TO 1000G IF ((WORK(I:I) .GE. '0') .AND. (WORK(I:I) .LE. '9')) GO TO 210C#C --- OPERATORS ARE B ( ) * / ^CB ELSE IF ((WORK(I:I) .EQ. '(') .OR. (WORK(I:I) .EQ. ')') .OR.B $ (WORK(I:I) .EQ. '*') .OR. (WORK(I:I) .EQ. '/') .OR.) $ (WORK(I:I) .EQ. '^')) THEN NTOKE = NTOKE + 1 TOKE(NTOKE) = WORK(I:I) I = I + 1C#C --- NO OTHER CHARACTERS ARE VALIDC ELSE ERR = .TRUE. RETURN ENDIF IF (I .LE. LW) GO TO 100 1000 RETURN ENDCC---END MLIB_PARSEC8 SUBROUTINE MLIB_CPOLISH ( TOKE, NTOKE, FACTS, ERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** POLISH **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :&C* POLISH NOTATION CONVERSIONC*C* AUTHOR :DC* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :=C* TO REPLACE THE UNITS ARRAY (WHICH IS IN ALGEBRAIC@C* NOTATION) WITH THE EQUIVALENT REVERSE POLISH STRING.C*C* METHODOLOGY :;C* USE THE STACK COMPILATION TECHNIQUE, REFERENCE:EC* KATZAN, "ADVANCED PROGRAMMING", VAN NOSTRAND REINHOLD CO,C* NEW YORK, 1970.C*C* IENPUT ARGUMENTS :8C* TOKE - THE LIST OF TOKENS IN ALGEBRAIC FORM4C* NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'C*C* OUTPUT ARGUMENTS :7C* TOKE - THE NEW LIST IN REVERSE POLISH FORM4C* NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'7C* ERR - SET TRUE FOR UNMATCHED PARENTHESES.C*C* INTERNAL WORK AREAS :5C* ISTACK, STACK - TEMPORARY OPERATOR STACKSC*C* ERROR PROCESSING :<C* CHECK EACH RIGHT PAREN FOR A MATCHING LEFFT PARENC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*% CHARACTER *6 TOKE(1), STACK(20)+ DOUBLE PRECISION FACTS(1), FSTACK(20) DIMENSION ISTACK(20) LOGICAL ERRC ISP = 1 IPOLE = 0 ISTACK ( ISP ) = -1 G STACK ( ISP ) = ' ' FSTACK ( ISP ) = 0.D0CC --- ALL TOKENSC DO 100 I = 1, NTOKECC ----- '(' STACK IT ONLYC# IF (TOKE(I) .EQ. '(') THEN ISP = ISP + 1! STACK(ISP) = TOKE(I) ISTACK(ISP) = 0" FSTACK(ISP) = FACTS(I)C/C ----- ')' UNSTACK UNTIL MATCHING '(' IS FOUNDC( ELSE IF (TOKE(I) .EQ. ')') THEN 20 IF (ISP .LE. 1) THEN ERR = .TRUE. RETURN H ENDIF( IF (ISTACK(ISP) .NE. 0) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1% IF (IPOLE .LE. 0) THEN ERR = .TRUE. RETURN ENDIF GO TO 20 ENDIF ISP = ISP - 1C@C ----- '*' OR '/' ... UNSTACK ANY '^', '*', OR '/' ON THE STACKC) ELSE IF ((TOKE(I) .EQI. '*') .OR.* $ (TOKE(I) .EQ. '/')) THEN(30 IF (ISTACK(ISP) .GE. 8) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1 GO TO 30 ENDIF ISP = ISP + 1! STACK(ISP) = TOKE(I)" FSTACK(ISP) = FACTS(I) ISTACK(ISP) = 8C,C ----- '^' ... UNSTACK ANY '^' ON THE STACKC( ELSE IF (TOKE(I) J.EQ. '^') THEN(40 IF (ISTACK(ISP) .GE. 9) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1 GO TO 40 ENDIF ISP = ISP + 1! STACK(ISP) = TOKE(I)" FSTACK(ISP) = FACTS(I) ISTACK(ISP) = 9C8C ----- UNITS AND EXPONENTS GET MOVED DIRECTLY TO OUTPUTC ELSE IPOLE = IPOLE + 1" K TOKE(IPOLE) = TOKE(I)# FACTS(IPOLE) = FACTS(I) ENDIF100 CONTINUE NTOKE = IPOLEC?C --- THERE MAY STILL BE OPERATORS ON THE STACK... UNSTACK THEMC300 IF (ISP .GT. 1) THEN NTOKE = NTOKE + 1& IF (STACK(ISP) .EQ. '(') THEN ERR = .TRUE. RETURN ENDIF! TOKE(NTOKE) = STACK(ISP)" FACTS(NTOKE)= FSTACK(ISP) ISP = ISP - 1 GO TO 300 ENDIF RETURN LENDCC---END MLIB_POLISHC6 SUBROUTINE MLIB_STD ( FACTS, TOKE, NTOKE, NERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** STD **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* M STANDARDIZEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :?C* TO REPLACE NON-STANDARD UNITS WITH THEIR EQUIVALENT6C* STANDARD UNITS AND RESULTING SCALE FACTOR.C*C* INPUT ARGUMENTS :=C* TOKE - ARRAY OF (POTENTIALLY) NON-STANDARD UNITS-C* NTOKE - NUMBER OF ENTRIES IN TOKEC*C* OUTPUT ARGUMENTNS :6C* TOKE - THE ARRAY WITH ONLY STANDARD UNITS-C* NTOKE - NUMBER OF ENTRIES IN TOKEBC* FACTS - ARRAY WITH SCALE FACTORS FOR EACH UNIT IN TOKE2C* NERR - = 1 IF UNIT COULD NOT BE FOUND,C* = 2 IF UNIT IS AMBIGUOUSC*C* INTERNAL WORK AREAS :EC* TEMP - USED TO STORE TOKENS UNTIL ALL UNITS ARE REPLACEDC*C* COMMON BLOCKS :C* MLIB$UNITSC*C* SUBPROGRAM REFERENCES :C* SEARCHC*C* ERRORO PROCESSING :)C* IF A UNIT ISN'T FOUND, ABORT.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (NUM=50,NLIS=29)9 CHARACTER *6 TOKE(1), TEMP(100) ,KNOWN, ALIAS, LIST CHARACTER *1 FIRST LOGICAL AMBIG,MATCH& PDOUBLE PRECISION FACTS(1), KFACTH COMMON /MLIB$UNITS/ KFACT(NUM), KNOWN(NUM), ALIAS(NUM), LIST(NLIS)C ITOKE = 1 IFAC = 1 NERR = 0 DO 100 I = 1, NTOKEC>C --- IF THE TOKEN REPRESENTS A UNIT, BINARY SEARCH UNITS LISTC FIRST = TOKE(I)(1:1): IF ((FIRST .GE. 'A') .AND. (FIRST .LE. 'Z')) THENC$C --- BINARY SEARCH KNOWN UNITS LISTC= CALL SEARCH (KNOWN, NUM, TOKE(I), K, MATCH, AMBIG)! IF (.NOT.(MATCH)) THEN Q NERR = 1 RETURN ELSE IF (AMBIG) THEN NERR = 2 RETURN ENDIFC:C --- FOUND... PUT IN SCALE FACTOR (1 IF ALREADY STANDARD)6C --- IF NOT STANDARD, PACK REPLACEMENT UNITS IN TEMPC, IF (ALIAS(K)(1:1) .EQ. '-') THEN+ READ(ALIAS(K)(2:6),900) IPTR ISTORE = IFAC"20 FACTS(IFAC) = 1.0D0 IFAC = IFAC + 1' TEMP(ITOKE) = LIST(IPTR) R ITOKE = ITOKE + 1 IPTR = IPTR + 10 IF (LIST(IPTR) .NE. ')') GO TO 20" FACTS(IFAC) = 1.0D0 IFAC = IFAC + 1' TEMP(ITOKE) = LIST(IPTR) ITOKE = ITOKE + 1 IPTR = IPTR + 1) FACTS(ISTORE+1) = KFACT(K) ELSE% FACTS(IFAC) = KFACT(K) IFAC = IFAC + 1% TEMP(ITOKE) = ALIAS(K) ITOKE = ITOKE + 1 SENDIFC3C --- IF THE TOKEN IS A NUMBER (EXPONENT) PASS A 1.AC --- (THIS IS NEEDED SINCE 'EVAL' PASSES EXPONENTS TO THE STACKC> ELSE IF((FIRST .GE. '0') .AND. (FIRST .LE. '9')) THEN! TEMP(ITOKE) = TOKE(I) ITOKE = ITOKE + 1 FACTS(IFAC) = 1.0D0 IFAC = IFAC + 1C C --- OTHERWISE, ITS AN OPERATORC ELSE! TEMP(ITOKE) = TOKE(I) ITOKE = ITOKE + 1 FACTS(IFAC) = 1.0D0 TIFAC = IFAC + 1 ENDIF100 CONTINUEC)C --- COPY FROM TEMP STORAGE BACK TO TOKEC NTOKE = ITOKE - 1 DO 200 I = 1, NTOKE TOKE(I) = TEMP(I)200 CONTINUE RETURN900 FORMAT(I5) ENDCC---END MLIB_STDC BLOCK DATA MLIB$DATA PARAMETER (NUM=50,NLIS=29)% CHARACTER *6 KNOWN, ALIAS, LIST DOUBLE PRECISION KFACTH COMMON /MLIB$UNITS/ KFACT(NUM), KNOWN(NUM), ALIAS(NUM), LIST(NLIS)C2C --- KNOWN UNITS U(BOTH STANDARD AND NON-STANDARD)C;C --- NOTE: THE FOLLOWING ARRAY MUST BE IN ALPHABETIC ORDERCD DATA KNOWN / 'ATMOS ', 'BAR ', 'BTU ', 'CM ',D $ 'DEGREE', 'DYNE ', 'ERG ', 'FATHOM', 'FEET ',D $ 'FPS ', 'FT ', 'GALLON', 'GM ', 'GRAMS ',D $ 'HOURS ', 'HP ', 'HR ', 'INCHES', 'JOULES',D $ 'KG ', 'KILOGR', 'KILOME', 'KM ', 'KNOTS ',D $ 'L ', 'LB ', 'LITERS', 'M V ', 'METERS',D $ 'MI ', 'MILES ', 'MINUTE', 'MPH ', 'N ',D $ 'NAUTMI', 'NEWTON', 'PASCAL', 'PINTS ', 'POUNDS',D $ 'PSI ', 'QUARTS', 'RADIAN', 'REV ', 'S ',D $ 'SECOND', 'SLUGS ', 'TONS ', 'WATTS ', 'YARDS ', $ 'YD '/C:C --- THE CONVERSION FACTOR TO GET FROM 'KNOWN' TO 'ALIAS'CCC --- IMPORTANT!!! THE CONVERSION FACTORS FOR 'GAL' AND 'LITER' AREFC --- THE CUBE ROOT OF THE ACTUAL CONVERSION FACTOR W SINCE 'EVAL' WILL%C --- CUBE THEM WHEN IT SEES 'FT^3'.CF DATA KFACT / 2.11536D3, 2.0896347D3, 7.783D2, 3.28084D-2,A $1.0D0, 2.2481D-6, 7.376D-8, 6.0D0, 1.0D0,H $1.0D0, 1.0D0, 5.11317368D-1,6.8465014D-5,6.8465014D-5,H $3.6D3, 5.5D2, 3.6D3, 8.3333333D-2,7.3746313D-1,H $6.8465014D-2,6.8465014D-2,3.28084D3, 3.28084D3, 1.68780648D0,E $3.2808719D-1,1.0D0, 3.2808719D-1, 3.28084D0, 3.28084D0,E $5. X28D3, 5.28D3, 6.0D1, 1.4666667D0, 2.2481D-1,A $6.0761157D3, 2.2481D-1, 2.0885531D-2,2.55658684D-1,1.0D0,A $1.44D2, 3.22109757D-1,5.7295779D1, 3.6D2, 1.0D0,A $1.0D0, 1.0D0, 2.0D3, 7.376D-1, 3.0D0, $3.0D0/C9C --- THE EQUIVALENT STANDARD UNIT OR POINTER INTO 'LIST'CD DATA ALIAS / '- 18', '- 18', '- 25', 'FT ',D $ 'DEG ', 'LB ', '- 25', 'FT ', 'FT ',D $ '- 8',Y 'FT ', '- 13', 'SLUG ', 'SLUG ',D $ 'SEC ', '- 1', 'SEC ', 'FT ', '- 25',D $ 'SLUG ', 'SLUG ', 'FT ', 'FT ', '- 8',D $ '- 13', 'LB ', '- 13', 'FT ', 'FT ',D $ 'FT ', 'FT ', 'SEC ', '- 8', 'LB ',D $ 'FT ', 'LB ', '- 18', '- 13', 'LB ',D $ '- 18', '- 13', 'DEG ', 'DEG ', 'SEC ',D $ 'SEC ', 'SLUG ', Z 'LB ', '- 1', 'FT ', $ 'FT '/CFC --- THIS LIST IS USED WHEN A NON-STANDARD UNIT MUST BE REPLACED BY A6C --- LIST OF STANDARD UNITS (EG, 'HP' = 'FT-LB/SEC')CA DATA LIST / '( ', 'FT ', '* ', 'LB ',A $ '/ ', 'SEC ', ') ', '( ', 'FT ',A $ '/ ', 'SEC ', ') ', '( ', 'FT ',A $ '^ ', '3 ', ') ', '( ', 'LB ',A $ '/ ', 'FT ', '^ ',  '2 ', ') ',A $ '( ', 'FT ', '* ', 'LB ', ') '/ ENDCC --- END BLOCK DATA MLIB$DATACww