% VAX-11 Librarian V04-00@uegm   G(WACOLOR^ADAMANYc APPLICATIONfASCIInBCOLORBLANKSCAPITALCAPS~CATEGtCENTERx CLEANSE_DATECLEARCOMPRESSCONTROLCOPYCTIMECTLYCURSORDASCII< DAY_OF_YEARDECHEXDECOCTDEFAULTIDELAYDELETEDIR DISK_SPACEEDITEXISTSLOWER4 MLIB_RECALLGNARGS7RECALLFRENAMERIGHT<VERIFY VT_CURSOR] FID_TO_NAME FILE_BDATES FILE_DATESFIRST FOPENFPACKOUTVG4ALFAG4GRAFGAUSS%GETC*GETCHARGETCPRVAGETFDEV:GETFDIR=GETFILEIGETFILEXTGETFNAMEGETFOR`GETFTYPEGETFVERSpGETIMEtGETLINGETOKEGETPRV"GETSTM1 GETSTRING8GETTERM GETTERMSIZEGETUSERGETXY GET_DEFAULTGET_PASSCICOUNT"LEFT(LENGTHJEXISTSGETSTMLENGTHPUTCSORTRYESNOMATCHFLENXLOWERhM2IMAILMAILBOX3MATCH5MBELL4MENUTMENU2MERGEMERGEIMERGERMESSAGEH MLIB_MISC4 MLIB_RECALLmMODErNAE- NAME_TO_PIDGNARGS2NDEX6NUMERIC9OCTDEC<OPERAOPERWIORDINALMPACKOUT(PARSE8PAY_DAYUPCALFAPEEKPEEKLPOKEPOKELX PRINT_FILE]PROMPTPUTCTOUCH<VERIFY VT_CURSOR1 GETSTRING8GETTERM GETTERMSIZEXGETUSERGETXY GET_DEFAULTGET_PASSGOTOXYGPALFA\ GRAF_XORYGRAF_XYGRAF_ZGRALFA HASH_PASSHAS_PRIVHELPHEXHEXDEC ICOUNTIDIGITM IMAGE_NAMEINTRPLISALPHAISDIGIT9ISLETTERISORT@ISORTIEISORTI8gIS_DIRKEYHITKURV1KURV2LAST_DAYLEAP{LEFTCLENGTHddPUTCHARPUTSTMk PUTSTRINGoQSORTwQSORTIQSORTRQUOTAREADINTREADKEYREADQREADT7RECALLFRENAMEREPLACREVLF.RIGHTSCALESCOLORSCROLLSEARCHnSEARCH1SENDSENDWSETIMESLEEPSORTSORTISORTRSRESETSTATHSTATUSSTRPSTMSUBMIT SUBMITPTIMERTOUCH<VERIFY VT_CURSORSRESETSTATSTATUS STRIP_EXCSTRPSTMSUBMIT SUBMITPTIMERTOUCHTRANSL8TRIMUNIQUE UNITSzUNTABVERIFY VT_CURSORuWEKDAY< WILD_MATCHYESNO AlK3~cc .title icountcc; cc; Author: Arthur E. Ragostacc;M?cc; Count the number of occurences of a character in a stringicc;AAcc; IC = ICOUNT (',','This is a long, skinny, blue string.')Icc; ! IC is 2.cc;;"cc .entry icount,^mccIcc movl 4(ap),r1 ;location of character descriptor to r1w9cc movb @4(r1),r1 ;character is now in r1#Fcc movl 8(ap),r2 ;location of string descriptor to r2/cc movzwl (r2),r3 ;length to r3s0cc subl3 #1,4(r2),r2 ;address to r2-cc clrl r0 ;zero countn=ccLOOP: cmpb (r2)[r3],r1 ;the character in question? 1cc bneq next ;no... try nextc2cc incl r0 ;Yes... count it1ccNEXT: sobgtr r3,loop ;next characterU cc ret cc .end c c function icount (chr, str) character *1 chr character *(*) strc* ` /~c .title capsc;c; Author: Arthur E. Ragostac;,c; Make all lowercase characters capitals.c;%c; STRING = 'This Is A String.' c; CALL CAPS ( STRING )c;,c; Results in STRING = 'THIS IS A STRING.'c;c .entry caps,^m<>c Ac movl 4(ap),r1 ;loc of descriptor to r1 6c movzwl (r1),r0 ;length to r08c subl3 #1,4(r1),r1 ;location to r1cmcloop: cmpb (r1)[r0],#96q8c bleq next ;Less than "a"?c cmpb (r1)[r0],#122;c bgtr next ;Greater than "z"? ;c subb2 #32,(r1)[r0] ;Its LC... CAP it! Acnext: sobgtr r0,loop ;check for end of string c c ret c .endAc;c; Portable FORTRAN versionc; SUBROUTINE CAPS ( STRING )C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** CAPS ** 3C* ** ** 3C* ******************************* 3C* *******************************PC*C* SUBPROGRAM :PC* CAPITALIZEC*C* AUTHOR : C* ART RAGOSTA C* MS 219-3%C* NASA AMES RESEARCH CENTER $C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* TO REPLACE A STRING WITH THE SAME STRING BUT ONLY CAPITALCC* LETTERS.C*C* INPUT ARGUMENTS :1C* STRING - THE STRING TO BE CAPITALIZEDZC*C* OUTPUT ARGUMENTS :N+C* STRING - THE CAPITALIZED STRINGTC*%C* ASSUMPTIONS AND RESTRICTIONS :TIC* THE COLLATING SEQUENCE MUST HAVE 'Z' > 'A' AND ALL CHARACTERSRIC* IN THE UPPER CASE ALPHABET AND LOWER CASE ALPHABET CONTIGUOUSTC*C* LANGUAGE AND COMPILER :C*  ANSI FORTRAN 77 C*C* VERSION AND DATE :O%C* VERSION I.0 1-OCT-84 C*C* CHANGE HISTORY :H(C* 1-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING CA" IC = ICHAR('A') - ICHAR('a') DO 10 I = 1, LEN(STRING)A IF ((STRING(I:I) .GE. 'a') .AND. (STRING(I:I) .LE. 'z'))N9 $ STRING(I:I) = CHAR( IC + ICHAR(STRING(I:I)) )(10 CONTINUEI RETU)䍓 SUBROUTINE DEFAULT (DIR_STRING)*SD* 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 K53G)* 9 Nov 1983 Dahlgren, Virginia 22448 *O IMPLICIT INTEGER (A-Z)A CHARACTER*(*) DIR_STRING CO3 STATUS = SYS$TRNLOG('SYS$DISK',LEN1,DIR_STRING,,,)- IF (.NOT.RN ENDEC C---END CAPSC wwD;C ;C---END CAPS ;Cwwa;9; Capitalize first character of a string (fast version);; STRING = 'abc.'; CALL CAPITAL ( STRING );; Results in STRING = 'Abc.'; .entry capital,^m<>9 movl 4(ap),r0 ;loc of descriptor to r00 movl 4(r0),r1 ;location to r1 cmpb (r1),#97 ; 'a' blss out ; nope... get out cmpb (r1),#122 ; 'z'$ bgtr out ; nope... get outGOSTA LENX5q6~ RAGOSTA LOWER|]8~ RAGOSTA RIGHT -d9~ RAGOSTA VERIFY#4:9~ RAGOSTA WILD_MATCH-ј RAGOSTA GETOKEј RAGOSTA LEFTј RAGOSTA PARSE %XԘ RAGOSTA GETOKE5Z RAGOSTA MENU SM. RAGOSTA PAY_DAY${\. RAGOSTA DAY_OF_YEAR.R2T RAGOSTA PARSEgdf RAGOSTA PARSE,f RAGOSTA ISORTII#q6~cc .title lowerocc;? cc; Author: Arthur E. Ragostacc; -cc; Make all capital characters lower case.gcc; &cc; STRING = 'This Is A String.'cc; CALL LOWER ( STRING ) cc;-cc; Results in STRING = 'this is a string.' cc;hcc .entry lower,^m<>cc;cc movl 4(ap),r1 ;loc of descriptor to r1 0cc movzwl (r1),r0 ;length to r07cc subl3 #1,4(r1),r1 ;location(-1) to r1 ccccloop: cmpb (r1)[r0],#.~cc .title blanksacc; cc; Author: Arthur E. Ragostacc;eCcc; Remove all embedded blanks from a string (left justifies) and,cc; returns the resulting string's length.cc;Occ; INTEGER BLANKS&cc; STRING = 'This is a string.'cc; I = BLANKS ( STRING )occ;d*cc; Results in STRING = 'Thisisastring.'cc; and I = 14cc; cc; Also used as: cc; CALL BLANKS ( STRING )cc;+cc .entry blanks,^mt ccBcc movl 4(ap),r2 ;loc of descriptor to r27cc movzwl (r2),r3 ;length to r3oFcc movl r3,r4 ;copy to r4 for later length9cc movl 4(r2),r1 ;location to r1c:cc clrl r2 ;input pointer=0;cc clrl r6 ;output pointer=0NccDccloop: cmpb (r1)[r2],#32 ;space in original string?cc beql next?cc movb (r1) 2],(r1)[r6] ;move non-blank bytes0Bcc incl r6 ;output increased by one?ccnext: incl r2 ;next input characterIBcc sobgtr r3,loop ;check for end of stringcc;cc subl2 r6,r4 ;remaining lengthc:cc movc5 #0,(sp),#32,r4,(r1)[r6] ;pad with blanksDcc movl r6,r0 ;length of squeezed string cc retlcc .end cc; %cc; Portable FORTRAN version followsTcc; ( INTEGER FUNCTION BLANKS ( STRING )C*3C* *******************************E3C* *******************************-3C* ** **13C* ** BLANKS ** 3C* ** **3C* *******************************3C* *******************************EC*C* SUBPROGRAM :C4C* REMOVE BLANKS }&d9~cc .title verifycc;r cc; Author: Arthur E. Ragostacc;tAcc; Verify that all characters in string 1 are also in string 2 cc;TFcc; LOG = VERIFY( 'A STRING ','ABC ' ) ! Note, LOG is falsecc;e%cc .entry verify,^m ccHcc movl 4(ap),r1 ;location of descriptor1 to r17cc movzwl (r1),r0 ;length to r0 9cc subl3 #1,4(r1),r1 ;location to r1hHcc movl 8(ap),r2  ;location of descriptor2 to r27cc movzwl (r2),r3 ;length to r3 9cc movl r3,r4 ;copy for laterc9cc subl3 #1,4(r2),r2 ;location to r23ccAccLOOP: cmpb (r1)[r0],(r2)[r3] ;compare each character)=cc beql next ;this character OK?Mcc sobgtr r3,loop ;NO - try next character in string2*cc;*Lcc clrl r0 ;this character not found, failure cc ret cc; @ccNEXT: movl r4,r3 ;reset string2 pointerJcc sobgtr r0,loop ;if more characters, do it again4cc movl #1,r0 ;success ! cc ret*cc .endcc;*cc; Portable FORTRAN version:cc; , LOGICAL FUNCTION VERIFY ( STR1, STR2 )C*3C* ******************************* 3C* *******************************E3C* **  **C3C* ** VERIFY ** 3C* ** ** 3C* *******************************R3C* *******************************CC*C* SUBPROGRAM :IC* VERIFYC*C* AUTHOR :CC* ART RAGOSTAEC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF. 94035C* (415) 604-5558C*C* PURPOSE :GC* TO VERIFY THAT E !ACH CHARACTER IN STR1 ALSO APPEARS IN STR2.*C* EFFICIENCY NOTES :EC* 1. THE RAREST LETTER(S) SHOULD APPEAR FIRST IN 'STR2'.RHC* 2. THE LENGTHS OF 'STR1' AND 'STR2' SHOULD BE AS SMALL ASKC* POSSIBLE, SINCE ALL CHARACTERS OUT TO 'LEN(STR1/2)' WILL->C* BE CHECKED EVEN IF THEY ARE NOT MEANINGFUL.C*C* INPUT ARGUMENTS :$C* STR1 - STRING TO CHECK.AC* STR2 - STRING CONTAINING CHARACTERS WHICH ARE VALID.-C*QC* OUTPUT ARGUMENTS :HC* VERIFY - (FUNCTION VALUE) TRUE IF EVERY CHARACTER IN STR1 IS4C* ALSO IN STR2, FALSE OTHERWISE.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 17-JAN-85C*C* CHANGE HISTORY :(C* 17-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STR1,STR2C L1 = LEN(STR1) #bZﲓ; SUBROUTINE GETSTM ( NREAD, STMT, LENST, CLABEL, EOF )eC*3C* *******************************i3C* ******************************* 3C* ** **i3C* ** GETSTM **a3C* ** **,3C* ******************************* 3C* ******************************* C*C* SUBPROGRAM :rC* GET $STATEMENTsC*C* AUTHOR :(C* ART RAGOSTAtC* 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 77 C*C* CHANGE HISTORY : (C* 10/13/83 INITIAL VERSION)C* 01/24/84 CONVERTED TO VAX*EC* 09/15/86 MODIFIED TO NOT REMOVE BLANKS FROM CHARACTERC"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 *(*) STMTO CHARACTER *(LC) CARD CHARACTER *5 CLABEL LOGICAL NOT_INIT, EOFC SAVE NOT_INIT, CARDI DATA NOT_INIT/.TRUE./CCAC --- FIRST TIME THROUGH WE WON'T HAVE A LOOK-AHEAD CARD, GET ONESCN IF ( NOT_INIT ) THEN EOF = .FALSE.. C'ALL MLIB_GETCRD ( NREAD, CARD, EOF ) NOT_INIT = .FALSE. ENDIF C15 STMT = ' ' IPTR = 1 CLABEL = CARD(1:5)C BC --- COPY ONLY NON-BLANK CHARACTERS, EXCEPT FOR CHARACTER STRINGSC*10 I = 7C13 IF ((CARD(I:I) .NE. '''') .AND. (CARD(I:I) .NE. ' ') .AND.(+ $ (CARD(I:I) .NE. CHAR(9))) THEN F IF (CARD(I:I) .EQ. '!') THEN ! EXCLAMATION POINT COMMENT$ IF (IPTR .GT. 1) THEN GO TO 20  ELSET5 CALL MLIB_GETCRD (NREAD, CARD, EOF)E GO TO 5 ENDIF ENDIFL# 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 )Zf7 INTEGER FUNCTION PARSE (SPEC, DEFAULT, PART, OUT)RC*3C* ******************************* 3C* *******************************L3C* ** **L3C* ** PARSE **3C* ** ** 3C* *******************************3C* ******************************* C*C* SUBPROGRAM : C* PARSE *C*C* AUTHOR : C* Arthur E. Ragosta,C* MS 219-1%C* NASA Ames Research Center,*C* Moffett Field, Ca. 94035-1000C* (415) 604-5558C*C* PURPOSE :7C* PARSE A FILE SPECIFICATION (OR PART OF ONE)*1C* EMULATES THE LEXICAL FUNCTION F$PARSE*C*C* INPUT ARGUMENTS :/C* SPEC - INPUT (PARTIAL) FILE SPEC*CC* DEFAULT - DEFAULT SPEC FOR MISSING PARTS (IF BLANK, USE*+C* CURRENT NODE+, ETC.)*&C* PART - THE PART WANTED:AC* 'NODE', 'DEVICE', 'DIRECTORY', 'NAME',*DC* 'TYPE', 'VERSION', 'FULL', 'LONGNAME'C*C* OUTPUT ARGUMENTS : (C* OUT - THE PART REQUESTEDC*C* SUBPROGRAM REFERENCES :2C* TRANSL8, SYS$PARSE, EXIT, LIB$MOVC5C*%C* ASSUMPTIONS AND RESTRICTIONS :RC* NOT TRANSPORTABLE.HC* ASSUMES CURRENT DIRECTORY AND FILE TYPE '.DAT' IF NONE GIVENC*C*, LANGUAGE AND COMPILER :C* ANSI FORTRAN 77NC*C* VERSION AND DATE :O'C* VERSION I.0 - 20-JUN-1988 C*C* CHANGE HISTORY :N+C* 20-JUN-1988 - INITIAL VERSIONNHC* 29-JUN-1990 - BUG FIXED WHILE REUSING "OUT" AS WORK BUFFERGC* 8-FEB-1991 - CHANGED TO INTEGER FUNCTION TO RETURN ISTAT*?C* 15-AUG-1995 - Internal work area increased to 255 C*HC***********************************************************************C*- INCLUDE '($FABDEF)' INCLUDE '($NAMDEF)' RECORD /FABDEF/ FABD RECORD /NAMDEF/ NAMN CHARACTER *255 WORKE- CHARACTER *(*) SPEC, DEFAULT, PART, OUTT INTEGER SYS$PARSE  INTEGER *2 II C  parse = 0, CALL CAPS(PART).: IF (PART(1:2) .EQ. 'NO') THEN ! NODE I = INDEX(SPEC,'::'), IF (I .NE. 0) THEN. OUT = SPEC(1:I+1)D ELSE# I = INDEX(DEFAULT,'::')  IF (I .NE. 0) THEN# OUT = DEFAULT(1:I+1)L ELSE+ CALL TRANSL8('SYS$NODE',OUT)E ENDIF ENDIF ELSE& NAM.NAM$L_ESA = %LOC ( WORK )% NAM.NAM$B_ESS = LEN ( WORK )B% NAM.NAM$B_NOP = NAM$V_SYNCHK " NAM.NAM$B_BID = NAM$C_BID" NAM.NAM$B_BLN = NAM$C_BLNCL) FAB.FAB$L_DNA = %LOC ( DEFAULT )S+ FAB.FAB$B_DNS = LENGTH ( DEFAULT )%& FAB.FAB$L_FNA = %LOC ( SPEC )( FAB.F/a]8~cc .title rightcc; cc; Author: Arthur E. Ragostacc;aBcc; Right justify a string and return location of first nonblankcc;tcc; CHARACTER *10 STRINGcc; STRING = 'A string'ncc; CALL RIGHT ( STRING )cc; &cc; Results in STRING = ' A string'cc;p-cc .entry right,^m cc;cc movl 4(ap),r0 ;loc of descriptor to r0 3cc subl3 #1,4(r0),r7 ;location to r7]0cc movzwl (r0),r0 ;0length to r0-cc movl r0,r1 ;copy of length for later usecc)ccloop: cmpb (r7)[r0],#32 ;space ?ecc bneq out-cc sobgtr r0,loop ;if still characters left cc ret ;all blankccccout: incl r7/cc subl3 r0,r1,r6 ;r6 now has number of blanksC4cc movc3 r0,(r7),(r7)[r6] ;move non-blank characters&cc movc5 #0,(sp),#32,r6,(r7) ;pad onlycc retcc .endcc; cc; Portable FORTRAN version cc;C! SUBROUTINE RIGHT ( STRING )RC*3C* **************1***************** 3C* ********************************3C* ** ***3C* ** RIGHT **L3C* ** **R3C* *******************************E3C* *******************************C*C* SUBPROGRAM :5C* RIGHT JUSTIFYC*C* AUTHOR :LC* ART RAGOSTAEC* MS 219-1 C* AMES RESEARCH CENTER$C* 2 MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :CC* REPLACES A STRING WITH THE SAME STRING RIGHT JUSTIFIED.HC*C* INPUT ARGUMENTS :6C* 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 :A%C* VERSION I.0 15-OCT-84C*C* CHANGE HISTORY :M(C* 3 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING C  L = LEN(STRING)ECO#C --- FIND LAST NON-BLANK CHARACTER*C* DO 10 I=L,1,-1+ IF (STRING(I:I) .NE. ' ') GO TO 20*10 CONTINUEDC C --- ALL CHARACTERS WERE BLANK C( RETURN20 IF (I .NE. L) THEN& STRING(L-I+1:L) = STRING(1:I) STRING(1:L-I) = ' ' ENDIFT RETURN ENDOCN C---END RIGHTRCww END;C;C---END LOWER;Cww5`y: .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 6NK 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 ww8@9j( SUBROUTINE RECALL ( COMMAND, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** RECALL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* RECALLC*C* AUTHO9R :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 77:C*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 B;YTESC$ 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=P,9~0 logical FUNCTION wild_match ( wild, file )C*3C* *******************************13C* *******************************T3C* ** ** 3C* ** wild_match **p3C* ** ** 3C* *******************************3C* *******************************rC*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. 94035 C* (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.iC*C* INPUT ARGUMENTS :8c* wild - the file specification with wildcardsHc* file - the file ?specification to verify (i.e., no wildcards)C*C* OUTPUT ARGUMENTS :l+c* wild_match - true if they matchtC*C* SUBPROGRAM REFERENCES :.c* parse, transl8, match_word, lengthC*%C* ASSUMPTIONS AND RESTRICTIONS : 6c* Only one asterisk may appear in each part.3c* Asterisk and percents may not be mixed. +c* Multiple percents ARE permitted*>c* No device wildcards are permitted, by logicals are7c* Only ... wildcard is p@ermitted in directory C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :*+C* 30-MAR-1989 - INITIAL VERSION*C*HC***********************************************************************C* character *(*) wild, file & character *80 wpart, fpart, temp logical match_wordcM@c --- device must be identical or be a logical for hardware onlyc  wild_match = .false.- call parse (wild, ' ', 'DEVICE', temp )E" callA transl8 ( temp, wpart )- call parse (file, ' ', 'DEVICE', temp )R" 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 )N i = index(wpart,'...')% if (i .eq. 0) i = length(wpart)N, if (fpart(1:i) .ne. wpart(1:i)) returncI+c --- let MATCH_WORD do the hard stuff here cP, call parseB (wild, ' ', 'NAME', wpart ), call parse (file, ' ', 'NAME', fpart )/ if (.not. match_word(wpart,fpart)) returnIcc --- and herecG, call parse (wild, ' ', 'TYPE', wpart ), call parse (file, ' ', 'TYPE', fpart )/ if (.not. match_word(wpart,fpart)) returnHcEc --- 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 .Rne. ';') .and. (wpart .ne. ';*')) then2 call parse (file, ' ', 'VERSION', fpart )% if (wpart .ne. fpart) returnT endif  wild_match = .true. return END COC---END wild_matchC 1 logical FUNCTION match_word (wild, notwild)RC*3C* *******************************3C* *******************************3C* ** **3C* ** match_word **3C* D&&5~cc .title lengthcc; cc; Author: Arthur E. Ragostacc;oHcc; Return the true length of a string; i.e., the location of the lastHcc; non-blank character. Since FORTRAN's strings are non-dynamic, theFcc; function skips ONLY spaces (not NULs, control characters, etc.).cc;t9cc; LS = LENGTH( 'A STRING ' ) ! Note, LS is 8rcc; cc .entry length,^m<> cc?cc movl 4(ap),r1 ;location of descriptor to r1 /cc movzwl (r1),r0 ;length to r0 1cc subl3 #1,4(r1),r1 ;location to r1l*ccLOOP: cmpb (r1)[r0],#32 ;space ?cc; cc bneq donecc;t0cc; beql next ;replace previous line with these-cc; cmpb (r1)[r0],#09 ;to skip tabs too cc; bneq donecc;NEXT:cc;l?cc sobgtr r0,loop ;check for zero length string ccDONE: retcc .endcc;cc; Portable FORTRAN versioncc; FUNCTION LENGTH ( STRING )4c* *********\+ subroutine rename ( old, new, istat ) character *(*) old, newc2 istat = lib$rename_file (old, new,,,,,,,,,,) return endcc---end renamecww `s* integer function rename ( old, new ) character *(*) old, newc3 rename = lib$rename_file (old, new,,,,,,,,,,) return endcc---end renamecwwHH&( .TITLE NARGS Return number of arguments .IDENT /1.0/;; Functional description:C; This routine returns the number of arguments given to its caller.A; This routine is called by a procedure having optional arguments6; and needing to know how many arguments it is passed.;; Calling sequence:$; CALL NARGS ( Number_of_arguments );; Formal parameters:C; Number_of_arguments This argument returns the number of arguments"; given to the caller of NARGS. ;; Implicit inputs:(; The saved AP of the calling procedure.; SAVEAP = 8 .ENTRY NARGS,^M<> MOVZBL @SAVEAP(FP),@4(AP) RET .ENDww J`g .TITLE DELAYH;----------------------------------------------------------------------;H; SUBROUTINE: DELAY ;H;----------------------------------------------------------------------;H; LANGUAGE: VAX-11 MACRO ASSEMBLY LANGUAGE ;H; SYSTEM: VAX-11/780 ;H; MOSTEK CORPORATION ;H; K 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; L 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; M ;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 NUMBENR 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 OTANDARD. ;H;----------------------------------------------------------------------;H; REFERENCES: VAX-11/780 SYSTEM SERVICES REFERENCE ;H;----------------------------------------------------------------------; .PAGE5 .SBTTL DATA: SYSTEM DELTA-TIME QUADWORDSH;----------------------------------------------------------------------;H; ;H; DATA AREA P ;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 ; QAST 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 RFOR 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 S 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;-------------------------------------------T---------------------------;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;------------------------------- U---------------------------------------;= .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 G4ALFA C*3C* *******************************R3C* *******************************S3C* ** ** 3C* ** G4ALFA **3C* ** **S3C* *******************************R3C* *******************************RC*C* SUBPROGRAM :C* G4ALFAC*C* AUTHOR : C* X [0A) SUBROUTINE ACOLOR (CIN, COUT, IERR)C*3C* *******************************3C* *******************************3C* ** **3C* ** ACOLORS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* ARTA COLORSC*C* Y 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* = 0Z ==> 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_`A' 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* a 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, OUTFILECb" 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 ADAMCwwd_A SUBROUTINE APPLICATION C*3C* *******************************3C* *******************************3C* ** **3C* ** APPLICATION **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta .C* RAGOeSTA%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 APPLICATIONCwwgcB! SUBROUTINE ASCII ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** ASCII **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* ASCIIC*C* AUTHOR :hC* 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 ( iIN 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*****************************************j******************************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 --- kDO 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 l 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. '9m'))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 ASCIICwwo@1C! SUBROUTINE BCOLOR ( COLOR )C*3C* *******************************3C* *******************************3C* ** **3C* ** BCOLOR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* BCOLORC*C* AUTHOR :pC* 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* q 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 rCOLOR) 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 ', ' sYGREEN ', '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 BCOLORCwwu15F" SUBROUTINE CENTER ( STRING )C*3C* ********************************3C* ********************************3C* ** ** 3C* ** CENTER ** 3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM :SC* CENTERC*C* AUTHOR :FvC* ART RAGOSTATC* 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 STRING C*C* OUTPUT ARGUMENTS :I,C* STRING - OUTPUT STRING (INPLACE)C*C* INTERNAL WORK AREAS :/C* LINE - TEMPORARY STORAGE FOR STRINGTC*wC* SUBPROGRAM REFERENCES :C* LEFTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :S(C* 15-OCT-84 INITIAL VERSIONAC* 26-JUN-90 REMOVED LENGTH LIMITATION, USED NEW LEFT C*HC***********************************************************************C* CHARACTER *(*) STRINGNC3C --- 'LL' IS THE LENGTH OF THE TEXT TO BE CENTERED @C --- 'N' IS THE NUMBER OF BLANKS TO BE INSERTED BEFORE THE TEXTC8 LL = LEFT ( STRING )% N = ( LEN(STRING) - LL ) / 2* IF ( N .EQ. 0 ) RETURNC*$C --- COPY TEXT INTO PROPER LOCATIONC  STRING(N+1:) = STRING CNC --- CLEAR LEADING SPACESCN STRING(1:N) = ' '( RETURN ENDTC C---END CENTERCTww 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 yo>) SUBROUTINE CLEANSE_DATE ( IN, OUT )IC*3C* CLEANUP A TIME/DATE STRING AND MAKE IT STANDARD'C*C* VALID FORMATS:C* MM/DD/YYC* MM/DD/YYYYC* DD[-]MMM[-]YY C* DD[-]MMM[-]YYYY 1C* DD-MMM-YYYY[:]HH:MM:SS.CC (OUTPUT FORMAT) C* MMM DD[,] YYC* MMM DD[,] YYYY C* "TODAY" C* "TOMORROW"C* "YESTERDAY"HC* C* NOTES:FC* ALL STRINGS OF FORM "HH:MM:SS.CC" MAY BE SHORTENED ON THE RIGHT.MC* STRINGS CONTAINING HOURS, BUT NO DATE zMEAN TODAY AT THE SPECIFIED HOUR.()C* OUT MUST BE AT LEAST CHARACTER *23. C* C* CHANGE HISTORY: AC* 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)  CHARACTER *3 MON CHARACTER *2 DAY CHARACTER *4 YEAR.4 INTEGER IDATE(2), JDATE(2), SYS$BINTIM, BLANKS LOGICAL MATCH, MAT, AMBIG B{ DATA MONTHS / 'JANUARY', 'FEBRUARY', 'MARCH', 'APRIL',F $ 'MAY', 'JUNE', 'JULY', 'AUGUST', 'SEPTEMBER',+ $ 'OCTOBER', 'NOVEMBER', 'DECEMBER'/ C  TEMP = IN-0 IF (BLANKS ( TEMP ) .EQ. 0) TEMP = 'TODAY' CALL CAPS ( TEMP )CF C --- TODAYSCN$ IF ( MATCH(TEMP,'TODAY')) THEN# CALL LIB$DATE_TIME ( OUT ).C'C --- YESTERDAY OR TOMORROW CR- ELSE IF ((MATCH(TEMP,'YESTERDAY')) .OR. - $ (MATCH(TEMP,'TOMORROW') |)) THENP$ 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') THENIB ISTAT = LIB$SUB_TIMES (IDATE, JDATE, IDATE) ! YESTER ELSETA ISTAT = LIB$ADD_TIMES (JDATE, IDATE, IDATE) ! TOMOR  ENDIF2 ISTAT = LIB$FORMAT_DATE_TIME (OUT, IDATE)H OUT(13:) = '00:00:00.01' ! START OF DAY}C C --- DATE/TIME SPECIFIEDEC( ELSECE/C ----- EACH PART DEFAULTS TO CURRENT DATE/TIME C ' CALL LIB$DATE_TIME ( ONE_DAY ) DAY = ONE_DAY(1:2)Q MON = ONE_DAY(4:6)Q YEAR = ONE_DAY(8:11) HOUR = ONE_DAY(13:23)CT"C ----- "MM/DD/YY" OR "MM/DD/YYYY"C.) IF (INDEX(TEMP,'/') .NE. 0) THEN IS = INDEX(TEMP,'/') IF (IS .LT. 3) THEN ' READ(TEMP,900,ERR=100) II ELSE' READ(TEMP,910,ERR=100) IT ENDIF I = MIN0(12,I) I = MAX0(1,I) MON = MONTHS(I)(1:3)( ISS = INDEX(TEMP(IS+1:),'/') IF (ISS .GT. 1) THEN# IF (ISS .LT. 3) THEN5 READ(TEMP(IS+1:IS+1),900,ERR=100) I( ELSE>5 READ(TEMP(IS+1:IS+2),910,ERR=100) I ENDIF( I = MIN0(LAST_DAY(MON),I) I = MAX0(1,I) WRITE(DAY,910  _E- 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 ARGUMENTS :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 INITIAL 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  = 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  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 IF (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'S 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') THEN 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 CATEGCww) I3 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%20 IF (I .LT. 50) THEN! I = I + 2000& WRITE(YEAR,920) I+ ELSE IF (I .LT. 100) THEN! I = I + 1900& WRITE(YEAR,920) I ENDIF ENDIF ENDIFCC ----- "MMM DD, YYYY"C. ELSE IF (INDEX(TEMP,',') .NE. 0) THEN MON = TEMP(1:3) DO 30 I = 1, 124 IF (MON .EQ. MONTHS(I)(1:3)) GO TO 4030 CONTINUE MON = ONE_DAY(4:6)40 DAY = TEMP(4:5)" 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) CALL RIGHT(YEAR)# READ(YEAR,920,ERR=60) I IF (I .LT. 0) THEN( READ(ONE_DAY(8:11),920) J I = I + J% ELSE IF (I .LT. 100) THEN I = I + 1900& ELSE IF (I .GT. 3000) THEN# YEAR = ONE_DAY(8:11) GO TO 100 ENDIF WRITE(YEAR,920) I GO TO 100 60 YEAR = ONE_DAY(8:11)C!C ----- "DD-MMM-YYYY HH:MM:SS.CC"EC ----- THIS IS ALREADY STANDARD, SO LET'S JUST LET SYSTEM SERVICES C ----- CLEANUP THE FORMAT!C. ELSE IF (INDEX(TEMP,'-') .NE. 0) THEN, ISTAT = SYS$BINTIM (TEMP, IDATE)5 ISTAT = LIB$FORMAT_DATE_TIME (OUT, IDATE) RETURN ENDIFD100 OUT = DAY // '-' // MON // '-' // YEAR // ' ' // HOUR ENDIF RETURN900 FORMAT(I1)910 FORMAT(I2)920 FORMAT(I4) ENDCC---END CLEANSE_DATECwwq> SUBROUTINE CLEARC*3C* *******************************3C* *******************************3C* ** **3C* ** CLEAR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* CLEAR SCREENC*C* AUTHOR :C*  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* LIB$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 CLEARCwwA 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 COMPRESSCww@`8M/ 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* 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 Surface 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' . OR.* $ 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))) ENDwwSN. 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 copied.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)' 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$ PUTC7 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 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 e 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) ! 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 ! 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. C6 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 COPYCww ߋN SUBROUTINE CTIME ( ATIME )C*3C* *******************************3C* *******************************3C* ** **3C* ** CTIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* CLOCK TIMEC*C* AUTHOR :C* 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* TIMEC*%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 CTIMECwwdK﨡) SUBROUTINE GETFVERS (IUNIT, FVERS )AC*3C* *******************************V3C* ******************************* 3C* ** **3C* ** GETFVERS **3C* ** ** 3C* *******************************D3C* *******************************RC*C* SUBPROGRAM :C* GET FILE VERSIONC*ލ& SUBROUTINE STOP_Y (USER_ROUTINE)C*3C* *******************************3C* *******************************3C* ** **3C* ** STOP_Y **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STOP_YC*C* AUTHOR :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 INTERCEPTED.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('02100000'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_YCww rߍ% 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 RESTRICTIONS :@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 CURSORCwwNѭፓ% subroutine cursor_right ( num )c*4c* Move ANSI terminal's cursor right "num" columnsc* 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)) // 'C' return900 format('+',A,$)910 format(I3) endc$ subroutine cursor_left ( num )c*3c* Move ANSI terminal's cursor left "num" columnsc* 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,$)910 format(I3) endc 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',$) endc subroutine r estore_cursorc*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',$) endww|V䍓" 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 DASCIICwwt䍓 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 DECHEXCwwe䍓 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 DECOCTCww 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`䍓( 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 DELETECww`,卓& 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 cY卓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ͪ1* Logical Function Leap_year ( iyear )C*3C* *******************************3C* *******************************3C* ** **3C* ** Leap_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 Centerl%C* Moffett Field, Ca. 940355C* (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 :C1C* Leap_year - .true. if its a leap yeardC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :s+C* 4-NOV-1992 - INITIAL VERSIONnC*HC***********************************************************************C*) itwo = iyear - (100*int(iyear/100))r+ leap_year = (int(itwo/4)*4 .eq. itwo) RETURN END C C---END Leap_year Ciww* Del - Delete character to left of cursor 4C* Remove - Delete character under cursor"C* Left Arrow - Move left$C* Right Arrow - Move rightJ.~cMC Portable FORTRAN versionIcI) logical function any (list, target)A! character *(*) list, target c  any = .true. do 10 i = 1,len(list)  do 5 j = 1,len(target)O2 if (target(j:j) .eq. list(i:i)) return5 continueD10 continue any = .false.E return endEww GOTOXY, READKEY, CURSOR_RIGHT, CURSOR_LEFT,(C* SAVE_CURSOR, RESTORE_CURSORC*%C* ASSUMPTIONS AND RESTRICTIONS :I'C*  C*C* AUTHOR :4C* ART RAGOSTA C* MS 219-34C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 604-5558 C*C* PURPOSE :HC* REPLACE A STRING WITH THE SAME STRING LESS LEADING AND HC* EMBEDDED BLANKS. C*C* INPUT ARGUMENTS :?C* STRING - STRING FROM WHICH BLANKS ARE TO BE REMOVEDeC*C* OUTPUT ARGUMENTS :)<C* STRING - STRING WITHOUT EMBEDDED BLANKS(INPLACE)C*C* RESTRICTIONS :CC* 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 VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGgCL L = LEN(STRING)i BLANKS = 0 DO 10 J = 1, L' IF (STRING(J:J) .NE. ' ') THENk BLANKS = BLANKS + 1S/ STRING(BLANKS:BLANKS) = STRING(J:J)) ENDIF10 CONTINUECn=C --- IF THE OUTPUT STRING IS LESS THAN FULL, PAD WITH BLANKS C 3 IF ( BLANKS .LT. L ) STRING(BLANKS+1:L) = ' 'a RETURN END C C---END BLANKSCqww) the[@#/~c .title CAPITAL c;c; Author: Arthur E. Ragostaic;:c; Capitalize first character of a string (fast version)c;c; STRING = 'abc.' c; CALL CAPITAL ( STRING )c;c; Results in STRING = 'Abc.'(c;c .entry capital,^m<>ocgAc movl 4(ap),r0 ;loc of descriptor to r0 8c movl 4(r0),r1 ;location to r1.c cmpb (r1),#97 ; 'a':c blss out ; nope... get out.c cmpb (r1),#122 ; 'z':c bgtr out ; nope... get out<c subb2 #32,(r1) ; zero that cap bit cout: retc .end subroutine capital ( str ) character *(*) strce= if ((str(1:1) .ge. 'a') .and. (str(1:1) .le. 'z')) thenlD str(1:1) = char (ichar(str(1:1)) + ichar('A') - ichar('a')) endif return endIwwen'. itemp = index(string(icol+1:),icount = 0 ls = length(str) do 10 i = 1,ls3 if (str(i:i) .eq. chr) icount = icount + 1*10 continue return end *ww* ******************************* 3C* ******************************* C*C* SUBPROGRAM :-C* CAPITALIZEC*C* AUTHOR :sC* ART RAGOSTA.C* MS 219-3%C* NASA AMES RESEARCH CENTER $C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* **********************3C* *******************************A3C* ** **N3C* ** LENGTH **E3C* ** **G3C* *******************************D3C* *******************************MC*C* SUBPROGRAM :LC* LENGTHC*C* AUTHOR :SC* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER$C*  MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :BC* 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.HC* 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 :e(C* 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC  LENGTH = LEN(STRING).10 IF (STRING(LENGTH:LENGTH) .EQ. ' ') THEN LENGTH = LENGTH-1% IF ( LENGTH .GT. 0 )GO TO 10( ENDIFt RETURN END CiC---END LENGTHCnwwfieldcc if (icol .lt. ls) thent icol = icol + 1 c 6c ------------ insert the character in the TEMP stringc1 if (insert) then4 string(icol:) = k(1) // string(icol:) call save_cursor)0 write(nwrite,900) string(icol:ls)" call restore_cursor# call cursor_right(1)c 5c ------------ overstrike the character in the string c  else' AB$B_FNS = LENGTH ( SPEC )% FAB.FAB$L_NAM = %LOC ( NAM )B" 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 @t鍓4 SUBROUTINE Fid_To_Name (Device, Fid, Filename)C*;C* Author: Jonathan Welch Creation Date: 27-Jul-1987 12:20 C* 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.OC* INCLUDE '($ATRDEF)' INCLUDE '($FIBDEF)'  INCLUDE '($IODEF)'C* CHARACTER*(*) DEVICE CHARACTER*(*) FILENAME CHARACTER *512 FILESPEC " INTEGER*2 FID(3), CHAN, FLEN INTEGER IOSB(2)E. INTEGER SYS$ASSIGN, SYS$DASSGN, SYS$QIOW! EQUIVALENCE (FLEN,FILESPEC)EC  STRUCTURE /DSC/T INTEGER*2 LENGTH  BYTE NULL1, NULL2 INTEGER*4 ADDRN END STRUCTURE.CL RECORD /ATRDEF/ ATR(2) RECORD /DSC/ DESCR RECORD /FIBDEF/ FIBTCE FIB.FIB$W_FID_NUM = FID(1) FIB.FIB$W_FID_SEQ = FID(2) FIB.FIB$W_FID_RVN = FID(3)CF FILENAME = ' ' FILESPEC = ' ' FLEN = 0C*( ISTAT = SYS$ASSIGN(DEVICE, CHAN,,) IF (.NOT. ISTAT) RETURNACC) ATR(1).ATR$W_SIZE = ATR$S_FILE_SPECN) ATR(1).ATR$W_TYPE = ATR$C_FILE_SPEC ( ATR(1).ATR$L_ADDR = %LOC(FILESPEC) ATR(2).ATR$W_SIZE = 0I ATR(2).ATR$W_TYPE = 0GCI" DESCR.LENGTH = FIB$C_ACCDATA DESCR.ADDR = %LOC(FIB)C*> ISTAT = SYS$QIOW (,%VAL(CHAN), %VAL(IO$_ACCESS), IOSB,,,' $ DESCR,,,, ATR,)S IF (.NOT. ISTAT) RETURN0CA# FILENAME = FILESPEC(3:FLEN+2) $ ISTAT = SYS$DASSGN(%VAL(CHAN))C RETURN ENDCC---END FID_TO_NAMECww@^L&捓' 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 3鍓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 E)$ 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.*A* 1* Alan L. Zirkle Naval Surface Weapons Center* Code K105)* 9 Nov 1983 Dahlgren, Virginia 22448 *9 IMPLICIT INTEGER (A-Z)CC CHARACTER*(*) DIR_STRING LOGICAL ARG_EXISTCR3 STATUS = SYS$TRNLOG('SYS$DI t鍓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_ERRORCww@Jꍓ SUBROUTINE TOUCH ( FNAME )C*3C* *******************************3C* *******************************3C* ** **3C* ** TOUCH **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* SETS THE REVISION DATE FOR THE SPECIFIED FILE TO RIGHT NOWC*C* INPUT ARGUMENTS :!C* FNAME - THE FILE NAMEC*C* SUBPROGRAM REFERENCES :-C* LIB$FILE_SCAN, LIB$FILE_SCAN_ENDC*%C* ASSUMPTIONS AND RESTRICTIONS :&C* SERIOUSLY NONTRANSPORTABLEC*C*  LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 1-MAY-1990 - INITIAL VERSION?C* 28-JUN-1990 - CHANGED COMMON TO FILE_DATES COMMONC*HC***********************************************************************C* INCLUDE '($FABDEF)' RECORD /FABDEF/ FAB INCLUDE '($NAMDEF)' RECORD /NAMDEF/ NAM, INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2)C CHARACTER *(*) FNAME CHARACTER *80 DEFAULT_NAMEE CHARACTER *255 Es, Rs ! Expanded string, Resultant string EXTERNAL MLIB_TOUCH_OK C 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 = 08 ISTAT = LIB$FILE_SCAN (FAB, MLIB_TOUCH_OK, , ICON)+ ISTAT = LIB$FILE_SCAN_END (FAB, ICON) RETURN ENDC C---END TOUCHC$ SUBROUTINE MLIB_TOUCH_OK (FAB)C/c *** this routine called by FILE_SCAN in TOUCHc INCLUDE '($ATRDEF)' INCLUDE '($FABDEF)' INCLUDE '($FIBDEF)' INCLUDE '($IODEF)' INCLUDE '($NAMDEF)'C STRUCTURE /Dsc/ INTEGER*4 Length INTEGER*4 Addr END STRUCTUREC RECORD /Dsc/ Descr RECORD /Atrdef/ Atr(2) RECORD /Fabdef/ Fab RECORD /Fibdef/ Fib RECORD /NAMDEF/ NAM, INTEGER TCDATE, TRDATE, TEDATE, TBDATEH COMMON / MLIB$DATES / ICHAN, NAM, TCDATE(2), TRDATE(2), TEDATE(2), $ TBDATE(2)C INTEGER*2 IOSB(4)D INTEGER SYS$ASSIGN, SYS$QIOW, RDATE(2), SYS$BINTIM, SYS$ASCTIM integer sys$dassgn CHARACTER *23 TIMECI Descr.Length = Nam.NAM$B_DEV ! Build a Strdescr for the device name" Descr.Addr = Nam.NAM$L_DEVC. 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 = 0CB 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_RVNC Descr.Length=FIB$C_ACCDATA Descr.Addr = %LOC(Fib)CC --- 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)) RETURN ENDCC---END MLIB_TOUCH_OKCwwms* 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 rC SUBROUTINE FOPEN ( NUNIT, FNAME, DEFNAME, PROMP, NEW, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** FOPEN **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C*   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 SPEC IFICATION/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 i5q> 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 flushoutcww 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 SI#NGULARC 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&@0S% 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 INITI)AL 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 GETCCww+@@& 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 (ISTAT0 .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 GETCHARCww2@_j# SUBROUTINE GETSTRING (STRING)MC*3C* ********************************3C* ********************************3C* ** ** 3C* ** GETSTRING ** 3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM :C* GETSTRINGNC*C* AUTHO3R :TC* Arthur E. Ragosta*C* MS 219-3%C* NASA Ames Research CenterS%C* Moffett Field, Ca. 94035IC* (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*%C* 4 ASSUMPTIONS AND RESTRICTIONS :T'C* NOT EVEN REMOTELY PORTABLE.*C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77OC*C* CHANGE HISTORY :R+C* 27-NOV-1987 - INITIAL VERSION :C* 10-MAY-1988 - MODIFIED TO USE LIB$PUT_OUTPUT5C* 29-JUN-1990 - FIXED HIGHLIGHT ON "EXIT"OC*HC***********************************************************************C* CHARACTER *(*) STRING  CHARACTER *1 C" INTEGER SYS$ASSIGN, SYS$QIOW5 BYTE BYTEO LOGICAL ERROR*E EXTERNAL SS$_NORMAL, IO$_TTYREADALL, IO$M_TIMED, IO$M_CTRLYAST,  $ IO$_SETMODE EQUIVALENCE (C,BYTE) INTEGER*2 IOSB(4) - INTEGER NO_TERMINATORS(2), TERM_MASK(8) 1 DATA NO_TERMINATORS /32,0/, TERM_MASK /8*0/RC! CALL GET_TERM_SIZE (LW, LS)  LS = LEN(STRING) LW8 = LW - 8A I = 0 J = 1 STRING = ' ') NO_TERMINATORS(2) = %LOC(TERM_MASK)RC,"C --- ASSIGN AN 6IO CHANNEL FOR TT:CE, ISTAT = SYS$ASSIGN ('TT', TERM_CHAN,,)- IF (ISTAT .NE. %LOC(SS$_NORMAL)) RETURN CLA READ_FUNC = %LOC(IO$_TTYREADALL) .OR. %LOC(IO$M_TIMED) .OR.F< $ %LOC(IO$M_CTRLYAST) .OR. %LOC(IO$_SETMODE)C &C --- INITIATE A SINGLE CHARACTER READC *10 ISTAT = SYS$QIOW (, %VAL(TERM_CHAN),? $ %VAL(READ_FUNC), IOSB,,, BYTE, %VAL(1),T4 $ %VAL(999), NO_TERMINATORS,,)G IF ((IOSB(1).NE.%LOC(SS$_NORMAL)) .O7R. (IOSB(2) .NE. 1)) BYTE = 0 D IF ((BYTE .EQ. 26) .OR. (BYTE .EQ. 25)) THEN ! ^Y or ^ZF CALL LIB$PUT_OUTPUT ( CHAR(27)//'[7m Exit '//CHAR(27)//'[0m') RETURNI ENDIF  IF (BYTE .EQ. 13) THEN2 CALL LIB$PUT_OUTPUT ( CHAR(13)//CHAR(10)) BYTE = 32 J = 0 ENDIFV J = J + 1  I = I + 1D STRING(I:I) = C0 IF (((C .EQ. ' ') .AND. (J .GT. LW8)) .OR. $ (J .GT. LW)) THEN2 CALL LIB$PUT_OUTPUT ( CHAR(13)//CHAR(10)) J = 1 ENDIF  IF (I .LT. LS) GO TO 10. RETURN END C C---END GETSTRING CAwwRD, 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. F@' SUBROUTINE GETTERM ( USER, TERM )IC*3C* *******************************C3C* *******************************L3C* ** ** 3C* ** GETTERM **3C* ** **'3C* *******************************3C* ******************************* C*C* SUBPROGRAM :1&C* GET TERMINAL NAME FOR US&ǎ# LOGICAL FUNCTION ISLETTER (C)EC*3C* *******************************R3C* *******************************N3C* ** ** 3C* ** isletter **F3C* ** ** 3C* *******************************N3C* *******************************GC*C* AUTHOR :C* Arthur E. Ragosta0C* ;@ Tf( SUBROUTINE GETFDIR ( IUNIT, FDIR )C*3C* ******************************* 3C* ******************************* 3C* ** **O3C* ** GETFDIR ***3C* ** **A3C* *******************************T3C* *******************************IC*C* SUBPROGRAM : C* GET FILE DIRECTORYC*<C* AUTHOR :EC* ART RAGOSTAEC* 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 FILE*C*C* OUTPUT ARGUMENTS :*=C* FDIR - THE FULL DIRECTORY NAME INCLUDING BRACKETS C*C* INTERNAL WORK AREAS :;C* EWORK - TEMPORARY VARIABLE TO HOLD THE FULL FILE C* SPECIFICATIONC*C* FILE REFERENCES :C* IUNITEC*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*********************>*bٟ, SUBROUTINE GETFILE ( INFILE, OUTFILE )C*3C* ********************************3C* ********************************3C* ** ***3C* ** GETFILE ***3C* ** ***3C* ********************************3C* ********************************C*C* SUBPROGRAM :*C* GETFILERC*C* ? AUTHOR :TC* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center %C* Moffett Field, Ca. 94035 C* (415) 604-5558C*C* PURPOSE :?C* RETRIEVE THE NEXT FILE NAME FROM A LIST (INCLUDING HC* WILDCARDS). C*C* INPUT ARGUMENTS :3C* INFILE - THE STRING CONTAINING THE LIST C*C* OUTPUT ARGUMENTS : -C* OUTFILE - NEXT NAME FROM THE LISTAHC* (IF "INFILE" CHANGES, WE START@ OVER AT FIRST FILE)C*C* SUBPROGRAM REFERENCES :!C* LENGTH, LIB$FIND_FILE C*%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 77 C*C* CHANGE HISTORY :V+C* 10-MAY-1988 - INITIAL VERSIONIC*HC***********************************************************************C*$ CHARACTER *(*) INFILE,F OUTFILE$ CHARACTER *127 WFILE, LIST(10) INCLUDE '($RMSDEF)'( DATA WFILE/'????????'/CRC --- NEW FILE NAME?C" IF (INFILE .NE. WFILE ) THEN" LENFILE = LENGTH (INFILE)# IF (LENFILE .EQ. 0) RETURNU WFILE = INFILEN 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* B@c( SUBROUTINE GETFDEV ( IUNIT, FDEV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFDEV **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FILE DEVICEC*C*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 TDHE 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**************************************************C* CHARACTER *(*) FDIR CHARACTER *127 WORKC FDIR = ' '/ INQUIRE (UNIT=IUNIT, NAME=WORK, ERR=1000)/ CALL PARSE (WORK, ' ', 'DIRECTORY', FDIR) 1000 RETURN ENDCC---END GETFDIRCwwG 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)! H 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 J %= SUBROUTINE GETFILEX ( INFILE, OUTFILE, DEFILE, EXFILE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFILEX **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :"C* GEKTFILE 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* INFILLE - 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 MCHARACTERS 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)'N 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.) $ O (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- P 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, IQF 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 IRF (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 = 1S 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 GETFILEXCwwU][* SUBROUTINE GETFNAME ( IUNIT, FNAME )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFNAME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FILE NAMEC*C*V 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*W 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 GETFNAMECwwY)Հ! SUBROUTINE GETUSER ( USER )LC*3C* ********************************3C* ********************************3C* ** ** 3C* ** GETUSER **F3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM : C* GET USER NAME C*C* AUTZHOR :*C* ART RAGOSTA C* 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 :O'C* USER - THE NAME OF THE USEROC*C* SUBPROGRAM REFERENCES :C* SYS$GETJPIWGC*%C* TRANSPORTABILITY LIMITATIONS :R(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :[C* ANSI FORTRAN 77TC*C* CHANGE HISTORY :A-C* 07-JUN-1985 INITIAL VERSION 2c* 3-May-1991 Pad USER with blanksC*HC***********************************************************************C* INCLUDE '($JPIDEF)' INCLUDE '($SSDEF)' CHARACTER *(*) USERT INTEGER *2 ITEM(2)# INTEGER *4 ITMLST(4), IOSB(2) % EQUIVALENCE (ITEM(1),ITMLST(1))TC.C --- FILL ITMLSTGCN ITEM(1) = 12 ITEM(2) = JPI$_USE RNAMEC ITMLST(2) = %LOC( USER ) ITMLST(3) = %loc(luser)E ITMLST(4) = 0 4 ISTAT = SYS$GETJPIW ( ,,, ITMLST, IOSB,, )C*4 if (luser .lt. len(user)) user(luser+1:) = ' '3 IF ( IOSB(1) .NE. SS$_NORMAL ) USER = 'ERROR'5 RETURN END C)C---END GETUSER1ww 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$_NOR ])| 7 subroutine graf_xory (xory, array, narray, nunit)IC*3C* *******************************(3C* *******************************R3C* ** ** 3C* ** GRAF_XORY **(3C* ** ** 3C* ******************************* 3C* *******************************AC*C* SUBPROGRAM : C* SUBROUTI^NE GRAF_XORYC*C* AUTHOR :OC* L JURGELEIT)C* 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.OC*C* INPUT ARGUMENTS :+C* XORY - THE CHARACTER "X" OR "Y"E%C* ARRAY - THE ARRAY OF DATAR6C* NARRAY - THE NUMBER OF ELEMENTS IN "ARRAY"7C* NUNIT - THE LOGI_CAL UNIT NUMBER TO WRITE TORC*C* SUBPROGRAM REFERENCES :C* FIRST C*$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 77 C*C* VERSION AND DATE : 'C* VERSION I.0 - 2-JUL-1991GC*C* CHANGE HISTORY : +C* 2-JUL-1991 - INITIAL VERSION0C*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 continas* SUBROUTINE GETFTYPE ( IUNIT, FTYPE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFTYPE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FILE TYPEC*C*b 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*cC* 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 GETFTYPECwweC* 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 - VARfIABLE 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 GETFVERSCwwhK[N( logical function is_dir (filename)C*3C* ********************************3C* ********************************3C* ** ** 3C* ** is_dir ** 3C* ** ** 3C* ********************************3C* ********************************C*C* AUTHOR : C* Arthur E. Ragosta .C* i RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV%C* soon to be changed to: 'C* RAGOSTA@MERLIN.ARC.NASA.GOV C* C* MS 219-3%C* NASA Ames Research Center:%C* Moffett Field, Ca. 94035NC* (415) 604-5558C*C* DESCRIPTION :.C* Is the specified file a directory?C*C* INPUT ARGUMENTS :5C* filename - the name of the file to checkFC*C* OUTPUT ARGUMENTS :6C* is_dir - .true. if the file is a djirectory,C* .false. if not or errorC*C* SUBPROGRAM REFERENCES : C* sys$open, sys$closeC*%C* ASSUMPTIONS AND RESTRICTIONS :*C* not transportable C*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY : +C* 28-FEB-1991 - INITIAL VERSIONMC*HC***********************************************************************C* character *(*) filename.c'. include '($fabdef)/nolist' k. include '($xabdef)/nolist' . include '($xabitmdef)/nolist'  record /xabitmdef/ xab record /fabdef/ fabJc1 structure /itmlst/ integer *2 buflenU integer *2 itemcodeW integer *4 bufadr* integer *4 retlen* end structure  record /itmlst/ items(3)c) integer sys$openc)c --- initialize FABc D fab.fab$b_bln = FAB$C_BLN ! Identify Fab as a valid FAB fab.fab$b_lbid = FAB$C_BID $ fab.fab$l_fna = %loc(filename)& fab.fab$b_fns = length(filename) fab.fab$b_fac = FAB$M_GET  fab.fab$l_xab = %loc(xab)'c4c --- initialize XAB (being lazy about named fields)c1&cc xab.xab$b_cod = XAB$C_ITM( xab.xabitmdef$$_fill_1 = XAB$C_ITM)cc xab.xab$b_bln = XAB$C_ITMLEN+ xab.xabitmdef$$_fill_2 = XAB$C_ITMLENL* xab.xab$b_mode = XAB$K_SENSEMODE& xab.xab$l_itemlist = %loc(items)cE#c --- initialize XABITMLST itemlistBcS. items(1).itemcode = XAB$_UCHAR_DIRECTORY items(1).buflen = 4B& items(1).bufadr = %loc(is_dir) items(1).retlen = 0F items(2).itemcode = 0 items(2).buflen = 0Tc c --- open returns the infoLcA is_dir = .false. istat = sys$open (fab)' if ( istat ) call sys$close (fab) return endDcFc---end is_dircFwwB$B_BLN = FAB$C_BLNC" ISTAT = SYS$PARSE ( FAB )* IF (.NOT. ISTAT) CAn`_1 SUBROUTINE GETFOR ( NQ, QUALS, NP, PARAMS )IC*3C* ******************************* 3C* *******************************I3C* ** **E3C* ** GETFOR **O3C* ** **M3C* ******************************* 3C* *******************************NC*C* SUBPROGRAM :MC* GET FOREIGN oC*C* AUTHOR :)C* ART RAGOSTAMC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035MC* (415) 604-5558C*C* PURPOSE :CC* TO RETURN ANY PARAMETERS AND/OR QUALIFIERS ENTERED ON AH!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 FOUND 7C* QUALS - THE LIST OF QUALIFIERS(LESS SLASH)K/C* NP - NUMBER OF PARAMETERS FOUNDE+C* PARAMS - THE LIST OF PARAMETERS3C*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 QUOq`( SUBROUTINE GETIME ( TOTAL, DELTA )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET TIMEC*C* AUTrHOR :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* s 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 GETIMECwwuE`F4 SUBROUTINE GETLIN ( NREAD, ERROR, LINE, LENG )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETLIN **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET LINEC*vC* 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 IwNPUT, 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* LANGUxAGE 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 yCONTINUE 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 - z130 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 GETLINCww|/Hјcc .title leftKcc;I cc; Author: Arthur E. Ragostacc;cc; Left justify a string*cc;*.cc; STRING = ' This is a string.'cc; CALL LEFT ( STRING )cc; or =cc; LS = LEFT (STRING) ! LS contains the lengthEcc; 5cc; Results in STRING = 'This is a string. ' cc;,cc .entry left,^mccBcc movl 4(ap),r0 ;loc of descriptor to r07cc movzwl (r0),r6 } ;length to r6O9cc movl 4(r0),r7 ;location to r7 cc>cc skpc #32,r6,(r7) ;skip leading spacesDcc bneq out ;continue if not all blankEcc clrl r0 ;all blank, return 0 lengthO cc ret*ccLcc ;r1 contains addr of nonblank charMcc ;r0 contains num of non-blank charsU7ccout: movc5 r0,(r1),#32,~r6,(r7) ;move and padHcc decl r7Rccloop1: cmpb (r7)[r6],#32 ;check backwards for blanks (set length)cc bneq out1cc sobgtr r6,loop1ccout1: movl r6,r0P cc ret cc .endcc;*cc; Portable FORTRAN version cc;D FUNCTION LEFT ( STRING )C*3C* *******************************O3C* ******************************* 3C* ** **I3C* ** LEFT **R3C* ** **H3C* *******************************C3C* ******************************* C*C* SUBPROGRAM : C* LEFT JUSTIFYC*C* AUTHOR :*C* ART RAGOSTAOC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :GC* REPLACES A STRING WITH THE SAME STRING LESS LEADING BLANKS.THC* NOTE: THIS ROUTINE IS REPLACED BY A MACRO ROUTINE IN MERLIB.C*C* INPUT ARGUMENTS :5C* STRING - THE STRING TO BE LEFT JUSTIFIED. C*C* OUTPUT ARGUMENTS :L9C* STRING - THE LEFT JUSTIFIED STRING (INPLACE).NC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77LC*C* VERSION AND DATE : %C* VERSION I.0 15-OCT-84EC*C* CHANGE HISTORY : (C* 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING*C*$ IF (STRING(1:1) .Eq. ' ') then L = LEN(STRING)CE$C --- FIND FIRST NON-BLANK CHARACTERC  DO 10 I=1,L. IF (STRING(I:I) .NE. ' ') GO TO 2010 CONTINUEC C --- ALL CHARACTERS WERE BLANKEC left = 0  RETURN C K20 STRING = STRING(I:L)H endifI LEFT = LENGTH(STRING)) RETURN ENDPC+ C---END LEFTC ww.GT. LL ) T  II = NAM.NAM$B_DIR" II = MIN0(II,LEN(OUT)) I = NAM.NAM$L_DIR= ELSE IF (PART(1:2) .EQ. 'NA') THEN ! NAME  II = NAM.NAM$B_NAME " II = MIN0(II,LEN(OUT)) I = NAM.NAM$L_NAME = ELSE IF (PART(1:1) .EQ. 'T') THEN ! TYPE  II = NAM.NAM$B_TYPE " II = MIN0(II,LEN(OUT)) I = NAM.NAM$L_TYPE @ ELSE IF (PART(1:1) .EQ. 'V') THEN ! VERSION II = NAM.NAM$B_VER" II = MIN0(II,LEN(OUT)) I = NAM.NAM$L_VERB ELSE IF (PART(1:1) .EQ. 'L') THEN ! LONG NAME- J = NAM.NAM$B_DEV + NAM.NAM$B_DIR - II = MIN0(LEN(OUT),(LEN(WORK)-J))I I = %LOC(WORK) + J + ELSE IF ((PART(1:1) .EQ. 'F') .OR. > $ (PART(1:1) .EQ. ' ')) THEN ! FULL ) II = MIN0(LEN(OUT),LEN(WORK))  I = %LOC(WORK)D ELSE) RETURN XԘ> SUBROUTINE GETOKE ( LINE, LL, IPTR, TOKEN, TYPE, ERROR )C*3C* *******************************)3C* *******************************E3C* ** **3C* ** GETOKE **A3C* ** **.3C* *******************************G3C* ******************************* C*C* SUBPROGRAM :C* GET TOKENRC*C* AUTHOR :(C* ART RAGOSTA C* MS 219-1%C* NASA AMES RESEARCH CENTERI)C* MOFFETT FIELD, CA 94035-1000 C* (415) 604-5558C*C* PURPOSE :@C* EXTRACT THE NEXT TOKEN FROM A CHARACTER STRING USING'C* THE FOLLOWING CONVENTIONS :CC* 1. MORE THAN ONE CONSECUTIVE SPACE IS TREATED AS A"C* SINGLE SPACE.CC* 2. TWO CONSECUTIVE DELIMITERS RETURN A NULL TOKEN.66C*  3. WORDS MUST BEGIN WITH A CHARACTER.4C* 4. NUMBERS MUST BEGIN WITH A DIGIT.?C* 5. ALL OTHER CHARACTERS ARE RETURNED VERBATIM. :C* 6. VALID DELIMITERS ARE , ; AND 8C* 7. Quoted strings are returned verbatimC*C* INPUT ARGUMENTS :)C* LINE - THE LINE TO BE PARSED.'6C* LL - THE LAST CHARACTER TO SCAN IN LINE.?C* IPTR - THE LOCATION FROM WHICH PARSING IS TO BEGIN.ZC*C* OUTPUT ARGUME NTS :R@C* IPTR - THE LAST CHARACTER IN LINE THAT WAS SCANNED..C* TOKEN - THE CHARACTER *(*) RESULT.)C* TYPE - THE TYPE OF THE TOKEN /C* S - FOR SPECIAL CHARACTER(*C* A - FOR ALPHANUMERIC%C* I - FOR INTEGER="C* R - FOR REAL?C* N - FOR NULL (TWO CONSECUTIVE DELIMITERS))C* E - FOR END OF LINEC:C* ERROR - AN ERROR OCCURRED IN PARSING THE LINE.C*%C* TRANSPORTABILITY LIMITATIONS :E/C* NON-STANDARD DATA STATEMENT FOR EOL C*C* LANGUAGE AND COMPILER :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 DELIMITERE<C* 20-MAY-87 ERROR IN END OF LINE HANDLING FIXED9C* 25-JUN-87 FIXED TO ALLOW LOWERCASE LETTERS6+C* IN 'A' TYPE TOKENS FC* 10-MAY-88 TOKEN CHANGED TO CHARACTER *(*), CHECK LENGTH-C* 9-MAR-95 Added quoted stringsC*HC***********************************************************************C* CHARACTER *(*) LINE, TOKEN$ CHARACTER *1 EOL,CH,TYPE,QCHAR INTEGER TSIZE. LOGICAL ERROR  DATA EOL/13/C-! IF ( IPTR .LT. 1 ) IPTR = 1  IF ( IPTR .GT. LL ) THEN TYPE = 'E'W RETURNE ENDIFNCC --- SKIP LEADING BLANKSEC'10 CH = LINE(IPTR:IPTR) IF ( CH .EQ. ' ' ) THEN  IPTR = IPTR + 1! IF ( IPTR .GT. LL ) THEN TYPE = 'E' RETURN ENDIF GO TO 10 ENDIF.C 4C --- IF CHARACTER IS DELIMITER, RETURN A NULL VALUECS TOKEN = ' '  TSIZE = 1I0 IF ((CH .EQ. ',') .OR. (CH .EQ. ';')) THEN TYPE = 'N'C')C --- FIRST CHARACTER WAS NOT A DELIMITER C 7 ELSE IF (((CH .GE. 'A') .AND. (CH .LE. 'Z')) .OR.I6 $ ((CH .GE. 'a') .AND. (CH .LE. 'z'))) THENC C ----- ALPHABETIC TOKENC  TYPE = 'A'TCL?C ------- WHILE (CH IN ALPHA+DIGITS) PACK CHARACTERS INTO TOKEN C (30 IF (TSIZE .GT. LEN(TOKEN)) THEN ERROR = .TRUE. GO TO 60 ENDIF TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1 ! IF ( IPTR .GT. LL ) THEN  CH = EOL ELSE CH = LINE(IPTR:IPTR) ENDIFO5 IF (((CH .GE. 'A') .AND. (CH .LE. 'Z')) .OR. 5 $ ((CH .GE. 'a') .AND. (CH .LE. 'z')) .OR.E: $ ((CH .GE. '0') .AND. (CH .LE. '9'))) GO TO 30C'&C ----- END WHILE (CH IN ALPHA+DIGITS)C 6 ELSE IF ((CH .EQ. '"') .OR. (CH .EQ. '''')) THENCTC ----- QUOTED STRING0C  TYPE = 'A'N IPTR = IPTR + 1 QCHAR = CH) CH = LINE(IPTR:IPTR)NC >C ----- PACK CHARACTERS INTO OUTPUT UNTIL QCHAR IS FOUND AGAINC(32 IF (TSIZE .GTϦ# SUBROUTINE GETPRV ( N, PRIV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETPRV **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET PRIVILEGESC*C* AUTHOR :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 - THE 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 '($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 ',? $ '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 --- MASK 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,  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@筎$ 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 GETCPRVCwwERC*C* AUTHOR :IC* ART RAGOSTATC* 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 LIMITATIONS : (C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*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)N% EQUIVALENCE (ITEM(1),ITMLST(1))TCG%C --- USE GETJPI TO GET TERMINAL NAMEACN ITEM(1) = 8R ITEM(2) = JPI$_TERMINALE 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 END C C---END GETTERM CSwwGRAM REFERENCES :C* UNTAB, MLIB_ERRORC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 10/13/83 INITIAL VERSION$U* SUBROUTINE GET_TERM_SIZE (WID, LENG)C*3C* ******************************* 3C* *******************************D3C* ** ***3C* ** GET_TERM_SIZE ***3C* ** **C3C* *******************************R3C* *******************************AC*C* SUBPROGRAM :)C* GET_TERM_SIZE C*C* AUTHOR :tC* Arthur E. Ragosta)C* MS 219-3%C* NASA Ames Research CenterM%C* Moffett Field, Ca. 94035RC* (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 ROWS C*C* SUBPROGRAM REFERENCES :C* LIB$GETDVIC*%C* ASSUMPTIONS AND RESTRICTIONS : C* NOT TRANSPORTABLEFC*C*  LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY : +C* 22-DEC-1987 - INITIAL VERSIONOC*HC***********************************************************************C* INCLUDE '($SSDEF)' INCLUDE '($DVIDEF)'A 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,,)E RETURN ENDAC1C---END GET_TERM_SIZE C wwRD(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_GETCRDCwwc@L:׎ SUBROUTINE START_MESSC*+C* *******************************+C* ******************************* +C* ** **T+C* ** START_MESS **T+C* ** **+C* *******************************+C* ******************************* C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER$C* MOFFETT FIELD,`/ SUBROUTINE MERGER ( A, NA, B, NB, C, NC )LC*-C* ********************************-C* ********************************-C* ** ***-C* ** MERGER ** -C* ** ** -C* ******************************* -C* *******************************C*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* PERFORM A MERGE OPERATION ON TWO (SORTED) REAL ARRAYS9C*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 :NC* C - MERGED ARRAYDEC* NC - NUMBER OF ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSEMGC*  DUPLICATES ARE DROPPED)GC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77*C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSIONG3C* 29-JUN-1990 - EFFICIENCY IMPROVEMENTSNEC* 16-AUG-1990 - BUG FIX IN DO LOOPS - INITIAL PARAMETERS M2C* 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 + 1S C(NC) = B(I)10 CONTINUE RETURN ENDIF1< IF (IB .GT. NB) THEN ! IF B IS EMPTY, COPY A TO C DO 20 I = IA,NA NC = NC + 1E C(NC) = A(I)20 CONTINUE RETURN( ENDIFHCD 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)) THENP NC = NC + 1 C(NC) = A(IA) IA = IA + 1G ELSE ! EQUAL.... DELETE ONE OF THEM( IA = IA + 1 ENDIFI GO TO 100 END C(C---END MERGERC(wwTHENF IF (CARD(I:I) .EQ. '!') THEN ! EXCLAMATION POINT COMMENT$ IF (IPTR .GT. 1) THEN GO TO 20 ELSE5`/ SUBROUTINE MERGEI ( A, NA, B, NB, C, NC ) C*.C* *******************************.C* *******************************.C* ** **.C* ** MERGEI **.C* ** **.C* *******************************.C* *******************************C*C* AUTHOR :OC* Arthur E. RagostaCC* MS 219-3%C* NASA Ames Research Center(%C* Moffett Field, Ca. 94035GC* (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 ARRAY EC* NC - NUMBER OF ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSEIGC*  DUPLICATES ARE DROPPED)CC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSIONI3C* 29-JUN-1990 - EFFICIENCY IMPROVEMENTSDEC* 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 NC = 0 IA = 1 IB = 1C B100 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* ENDIF*B 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* ENDIFSCSD 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)) THENN NC = NC + 1 C(NC) = A(IA) IA = IA + 1G ELSE ! EQUAL.... DELETE ONE OF THEMS IA = IA + 1 ENDIF* GO TO 100E END C C---END MERGEICAww OF FILE OCCURRED C* CARD - THE CARD READC*C* FILE REFERENCES :C* NREADC*C* SUBPROGRAM REFERENCES :C* UNTAnu`. SUBROUTINE MERGE ( A, NA, B, NB, C, NC )C*/C* ******************************* /C* *******************************2/C* ** **V/C* ** MERGE **8/C* ** **0/C* *******************************/C* ********************************C*C* SUBPROGRAM :*C* MERGEEC*C* AUTHOR :RC* Arthur E. RagostaEC* MS 219-3%C* NASA Ames Research Center'%C* Moffett Field, Ca. 94035OC* (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 :OC* C - MERGED ARRAYEC* NC - NUMBER OF  ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSECGC* DUPLICATES ARE DROPPED)EC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :.+C* 29-JUN-1988 - INITIAL VERSION.2C* 29-JUN-1990 - EFFICIENCY IMPROVEMENTEC* 16-AUG-1990 - BUG FIX IN DO LOOPS - INITIAL PARAMETERS 2C* CHANGED FROM 1 TO IA/BC*HC***********************************************************************C*' CHARACTER *(*) A(NA), B(NB), C(1)EC1 NC = 0 IA = 1 IB = 1CDB100 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= ENDIFNB IF (IB .GT. NB) THEN ! IF B ARRAY IS EMPTY, COPY A TO C DO 20 I = IA,NA NC = NC + 1A C(NC) = A(I)20 CONTINUE RETURN ENDIF'COD 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 MERGECwwue ist = ist - 2 cUc --- Write it out in GRAF form*c is = 1 ie = 76*15 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 wwOR :C* ART RAGOSTAC* 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 :'C* USER - THE NAME OF THE USERC*C* SUBPROGRAM REFERENCES :C* SYS$GETJPIWC*%C* TRANSPORTABILITY LIMITATIONS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER : !N 6 subroutine graf_xy (xarray, yarray, npts, nunit)C*3C* ********************************3C* ********************************3C* ** **D3C* ** GRAF_XY **E3C* ** **I3C* *******************************3C* *******************************NC*C* SUBPROGRAM :LC* SUBROUTINE GRAF_XYC*C* AUTHOR :C* L JURGELEITEC* 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 - TH`9, SUBROUTINE GETXY (IX, IY)C*3C* *******************************3C* *******************************3C* ** **3C* ** GETXY **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET X,Y LOCATIONC*C* AUTHOR :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 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 @󺶎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/ " SUBROUTINE GOTOXY ( IX, IY )C*3C* *******************************3C* *******************************3C* ** **3C* ** GOTOXY **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GO TO X,Y LOCATIONC*C*  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>Ď SUBROUTINE GPALFAC*3C* *******************************3C* *******************************3C* ** **3C* ** GPALFA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :(C* GP-29 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 :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 77C*C* CHANGE HISTORY :*C* 19-AUG-1985 INITIAL VERSIONC*HC***********************************************************************C*% CALL MLIB_GET ('NWRITE',NWRITE) WRITE(NWRITE,900) CHAR(2) RETURN900 FORMAT(' ',A1,$) ENDCC---END GPALFACww`Ď 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 HELPCww``ގ! SUBROUTINE PUTC ( C, NOUT )XC*3C* *******************************A3C* *******************************3C* ** ** 3C* ** PUTC **H3C* ** ** 3C* *******************************3C* *******************************AC*C* SUBPROGRAM :OC* PUT CHARACTERC*C* AUT@Ǝ% 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 HEXCww `Ǝ 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 HEXDECCww`Ǝ( 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 IDIGITCww{ǎ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 INTRPLCww Zǎ" LOGICAL FUNCTION ISALPHA (C)C*3C* *******************************3C* *******************************3C* ** **3C* ** ISALPHA **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 :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 ISDIGITCwwRAGOSTA%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`>Ȏ+ SUBROUTINE ISORT ( ARRAY, NUM, INDX )C*3C* *******************************3C* *******************************3C* ** **3C* ** ISORT **3C* ** **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.C*C*C* METHODOLOGY :C* SHELLSORTC*C* INPUT ARGUMENTS :0C* NUM - NUMBER OF ELEMENTS IN ARRAY'C* ARRAY - ARRAY TO BE SORTEDC*C* OUTPUT ARGUMENTS : C* INDX - INDEX ARRAYC*C* INTERNAL WORK AREAS :%C* TEMPA - USED DURING SWAPSC*%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 PARTICULARFC* IMPLEMENTATION, THE ARRAY IS CHARACTER WITH LENGTH <= 255.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 03/12/84 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION INDX(1) CHARACTER *(*) ARRAY(1) CHARACTER *255 TEMPA INTEGER TEMPI LOGICAL DONEC DO 10 I = 1, NUM INDX(I) = I10 CONTINUE 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 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 ISORTCww@T=Ɏ' 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 KEYHITCwwX̎> SUBROUTINE KURV1 ( N, X, Y, SLP1, SLPN, XP, YP, TEMP, S, $ SIGMA )C*3C* *******************************3C* *******************************3C* ** **3C* ** KURV1 **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* 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 SEQUENCE"C*  OF PAIRS IN THE PLANE.C*C* INPUT ARGUMENTS :.C* N - NUMBER OF POINTS TO BE FIT%C* X - ARRAY OF X VALUES%C* Y - ARRAY OF Y VALUESDC* 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 PO SITIVE,DC* THEY SHOULD BE INPUT IN SLP1 AND SLP2. A TYPICAL C* VALUE IS 1.)%C* TEMP - SCRATCH WORK AREAC*C* OUTPUT ARGUMENTS :2C* XP - CURVATURE PARAMETERS FOR KURV22C* YP - CURVATURE PARAMETERS FOR KURV2'C* S - ARC LENGTH OF CURVEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 18-DEC-86 INITIAL VERSIONC*HC******************************* ****************************************C*1 DIMENSION X(N), Y(N), YP(N), XP(N), TEMP(N)C DEGRAD = 0.01745329 NM1 = N - 1 NP1 = N + 1 DELX1 = X(2) - X(1) DELY1 = Y(2) - Y(1)* DELS1 = SQRT ( DELX1**2 + DELY1**2 ) DX1 = DELX1 / DELS1 DY1 = DELY1 / DELS1C IF ( SIGMA .LT. 0. ) THENC.C --- SECOND ORDER INTERPOLATION FOR ENDPOINTSC (IF NO SLOPES SPECIFIED)C IF ( N .EQ. 2 ) THENC-C --- TW O POINTS ONLY, RETURN A STRAIGHT LINEC XP(1) = 0. XP(2) = 0. YP(1) = 0. YP(2) = 0.; SLP1 = ATAN2 ((Y(2)-Y(1)),(X(2)-X(1))) / DEGRAD SLPN = SLP12 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 + DELS23 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  = -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 `1͎? 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 KURV2Cww}͎ 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_DAYCww  Ύ: SUBROUTINE OPEN_MAILBOX (NAME, ISPERM, IPROT, ICHAN)C*3C* *******************************3C* *******************************3C* ** **3C* ** OPEN_MAILBOX **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* 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*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 256 BYTE MESSAGESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) NAME LOGICAL ISPERM INTEGER SYS$CREMBXC IF (ISPERM) THEN IPERM = 1 ELSE IPERM = 0 ENDIFCD ISTAT = SYS$CREMBX ( %VAL(IPERM), ICHAN, %VAL(256), %VAL(512),> $ %VAL(IPROT),, NAME(1:LENGTH(NAME))) IF (.NOT. ISTAT) ICHAN = 0C RETURN ENDCC---END OPEN_MAILBOXC- SUBROUTINE READ_MAILBOX (ICHAN, BUFFER)C*3C* *******************************3C* *******************************3C*  ** **3C* ** READ_MAILBOX **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* DESCRIPTI ON :<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* "END-OF-FILE" FOR MAILBOX CLOSEDC*C* SUBPROGRAM REFERENCES :C* SYS$QIOWC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLE,C* BUFFER MUST BE <= 256 BYTES LONGC*C* LANGUAG!E AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) BUFFER INTEGER*2 IOSB(4) INTEGER 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 ENDIFC RETURN ENDCC---END READ_MAILBOXC4 LOGICAL FUNCTION CHECK_MAILBOX (ICHAN, BUFFER)C*3C* *******************************3C* *******************************3C* # ** **3C* ** CHECK_MAILBOX **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) 694-5578C*C* DES$CRIPTION :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 ANY)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 <= 256 %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) 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. ENDIFC RETURN ENDCC---END CHECK_MAILBOXC. SUBROUTINE WRITE_MAILBOX (ICHAN, BUFFER)C*3C* *******************************3C* *******************************3C* ' ** **3C* ** WRITE_MAILBOX **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* D(ESCRIPTION :(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 RESTRICTIONS :C* NOT TRANSPORTABLE,C* BUFFER MUST BE <= 256 BYTES LONGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 29-MAR-1989 - INITIAL VE)RSIONC*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 RE*TURN ENDCC---END WRITE_MAILBOXC& SUBROUTINE CLOSE_MAILBOX (ICHAN)C*3C* *******************************3C* *******************************3C* ** **3C* ** CLOSE_MAILBOX **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* 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* LANGU,AGE 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* *******************************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. 94.035C* (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 BY 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* INCLUDE '($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,,0,,)' 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* *******************************3C* ** **3C* ** OUTPUT_MAILBOX **3C* ** **3C* **********1*********************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 :CC* THIS ROUTINE SETS UP AN AST TO CALL THE PASSED ROUTINE,@C* "OUTPUT" WHENEVER A PROCESS COMPLETES A WRITE TO THEC* SPECIFIED MAILBOX.2C*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 RESTRICTIONS :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_MAILBOXCwwΎ- LOGICAL FUNCTION MATCH ( WORD, TARGET )C*6C* SEE IF A WORD IS AN ABBREVIATED MATCH FOR A TARGETC*! CHARACTER *(*) WORD, TARGETC MATCH = .FALSE. LW = LENGTH(WORD)& IF (LW .LE. LENGTH(TARGET)) THEN3 IF (WORD .EQ. TARGET(1:LW)) MATCH = .TRUE. ENDIF RETURN ENDC C---END MATCHCwwֶJ3 SUBROUTINE MENU ( CHOICE, N, PROMPT, ANSWER )PC*3C* ********************************3C* ********************************3C* ** ** 3C* ** MENU ** 3C* ** ** 3C* ********************************3C* ********************************C*C* AUTHOR : C* ART RAGOSTA C*6q ώ SUBROUTINE MBELL C*3C* *******************************3C* *******************************3C* ** **3C* ** MBELL **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* 7 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 :HC* THE '$' IN THE FORMAT STATEMENT IS NON-STD, COULD BE OMITTEDC*%C* ASSUMPTIONS AND RESTRICTIONS :EC* THE TERMINAL MUST RECOGNIZE AS THE PROPER CHARACTERC* TO RING THE BELL.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C*$ CALL MLIB_GET('NWRITE',NWRITE)+ WRITE ( NWRITE, 900 )CHAR(27),CHAR(7)900 FORMAT(2A1,$) RETURN ENDC C---END MBELLCww9oR. INTEGER FUNCTION PAY_DAYC*3C* ********************************3C* ********************************3C* ** ** 3C* ** PAY_DAY ** 3C* ** ** 3C* ********************************3C* ********************************C*C* AUTHOR :C* Arthur E. Ragosta 2C* RAGO:STA@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 firstTDC* 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 77WC*C* CHANGE HISTORY :S+C* 26-JAN-1993 - INITIAL VERSIONGC*HC***********************************************************************C* EXTERNAL DAY_OF_YEAR INTEGER DAY_OF_YEARO CHARACTER *2 PFDCU( CALL TRANSL8 ('PAY_FIRST_DAY',PFD) CALL RIGHT (PFD); READ(PFD,'(I2)') JDAY ! First day of pay yearT1 I = DAY_OF_YEAR () ! Current dayT IDAY = I - JDAY + 1*< PAY_DAY = MOD (IDAY, 14) ! 14 days per pay period RETURN ENDGCNC---END PAY_DAY C wwNSI FORTRAN 77C*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 CHARAC=\." INTEGER FUNCTION DAY_OF_YEARC*3C* *******************************13C* *******************************A3C* ** **C3C* ** DAY_OF_YEAR **O3C* ** ** 3C* *******************************I3C* *******************************SC*C* AUTHOR :C* Arthur E. Ragosta E2C* >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 year C*C* SUBPROGRAM REFERENCES :%C* DATE, SYS$BINTIM, LIB$DAY C*%C* ASSUMPTIONS AND RESTRICTIONS :I5C* IF THE CURRENT YEAR IS >= 50, ASSUME 1900C5C* ELSE, ASSUME 2000WC*C* L?ANGUAGE AND COMPILER :C* ANSI FORTRAN 77RC*C* CHANGE HISTORY :++C* 26-JAN-1993 - INITIAL VERSION-C*HC***********************************************************************C* CHARACTER *23 FIRSTN INTEGER IDATE(2)C)6C --- ALL WE REALLY NEED FROM CURRENT DATE IS THE YEARCI CALL DATE (FIRST)I 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'CD4C --- FIRST NOW LOOKS LIKE '01-JAN-1999 12:00:00.00'CU$ 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 ENDIC(C---END DAY_OF_YEARC ww WRITE(A,A!,f, SUBROUTINE ISORTI ( ARRAY, NUM, INDX )C*3C* ********************************3C* ********************************3C* ** ** 3C* ** ISORT ** 3C* ** ** 3C* ********************************3C* ********************************C*C* AUTHOR : C* ART RAGOSTA C* B 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.SC*C*C* METHODOLOGY :C* SHELLSORTC*C* INPUT ARGUMENTS :0C* NUM - NUMBER OF ELEMENTS IN ARRAY'C* ARRAY - ARRCAY TO BE SORTED C*C* OUTPUT ARGUMENTS :: C* INDX - INDEX ARRAYC*C* INTERNAL WORK AREAS :%C* TEMPA - USED DURING SWAPSRC*%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 PARTICULARFC* IMPLEMENTATION, THE ARRAY IS CHARACTER WITH LENGTH <= 255.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77EC*C* CHANGE HISTORY :ND(C* 03/12/84 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION INDX(1)* INTEGER ARRAY(1) INTEGER TEMPI, tempa LOGICAL DONEC  DO 10 I = 1, NUM INDX(I) = I10 CONTINUE  IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 2930 DONE = .TRUE.r 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)A ARRAY(I) = TEMPA TEMPI = INDX(J)) INDX(J) = INDX(I)  INDX(I) = TEMPIN ENDIF40 CONTINUE IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20 RETURN ENDC C---END ISORTICTww OUT = SPEC(1:I+1)e ELSEc# I = INDEX(DEFAULT,'::')d IF (I .NE. 0) THEN# OUT = DEF.f- SUBROUTINE ISORTI8 ( ARRAY, NUM, INDX )NC*3C* *******************************E3C* *******************************M3C* ** **N3C* ** ISORT ** 3C* ** **L3C* *******************************N3C* *******************************CC*C* AUTHOR :BC* ART RAGOSTA C* GuXx56~cc .title lenxcc; cc; Author: Arthur E. Ragostacc; Hcc; Return the true length of a string; i.e., the location of the lastcc; non-blank character. <cc; Unlike LENGTH, LENX skips control chracters and 8 bitscc;'8cc; LS = LENX ( 'A STRING ' ) ! Note, LS is 8cc;Tcc .entry lenx,^m<> cc?cc movl 4(ap),r1 ;location of descriptor to r1/cc movzwl (r1),r0 ;length to r01cc subl3 #1,4(r1),r1 H ;location to r1c4ccLOOP: cmpb (r1)[r0],#32 ;space or control?cc bleq next5cc cmpb (r1)[r0],#127 ;DEL or 8 bit char?ecc bgeq nextEcc ret ;valid character - that's all folks cc; ?ccNEXT: sobgtr r0,loop ;check for zero length stringu cc retcc .endc)c] function lenx (str)r character *(*) strc  lenx = len(str) 10 is = ichar(str(lenx:lenx))/ if ((is .le. 32) .or. (is .ge. 127)) then  lenx = lenx - 1" if (lenx .gt. 0) go to 10 endif return end wwr r3,loop ;check for end of string9 subl2 r6,r4 ;remaining lengthR8 movc5 #0,(sp),#32,r4,(r1)[r6] ;pad with blanksB movl r6,r0 ;length of squeezed string ret .end R;O#; Portable FORTRAN version followsO;D); INTEGER FUNCTION BLANKS ( STRING ) ;C* 4;C* J64%cc bleq next ;Less than "A"?*cc cmpb (r1)[r0],#90!cc bgtr next ;Greater than "Z"?C.cc addb2 #32,(r1)[r0] ;Its a CAP... lower it!9ccnext: sobgtr r0,loop ;check for end of stringCcccc retcc .endcc; cc; Portable FORTRAN version cc; ! SUBROUTINE LOWER ( STRING )CC*3C* *******************************3C* ******************************* 3C* ** ** 3C* **K LOWER ** 3C* ** ** 3C* ******************************* 3C* ******************************* C*C* SUBPROGRAM :C* LOWER CASEC*C* AUTHOR :EC* ART RAGOSTATC* MS 219-1 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 604-5558C*C* PURPOSE :EC* TO REPLACE A STRING WITH THE SAME STRING BUT WITH CAPITAL L-C* LETTERS REPLACED WITH LOWER CASE.TC*C* INPUT ARGUMENTS :-C* STRING - THE STRING TO BE CHNAGED C*C* OUTPUT ARGUMENTS :N*C* STRING - THE LOWER CASE STRINGC*%C* TRANSPORTABILITY LIMITATIONS : .C* USES THE ASCII VALUE OF 32 FOR IC.C*%C* ASSUMPTIONS AND RESTRICTIONS ::IC* THE COLLATING SEQUENCE MUST HAVE 'Z' > 'A' AND ALL CHARACTERSIC* IN THE UPPER CASE ALPHABET AND LOWER CASE ALPHABET CONTIGUOUS*C*C* LANPGUAGE AND COMPILER :C* ANSI FORTRAN 77AC*C* VERSION AND DATE :L%C* VERSION I.0 1-OCT-84 C*C* CHANGE HISTORY : (C* 1-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC DATA IC /32/CS DO 10 I = 1, LEN(STRING)A IF ((STRING(I:I) .GE. 'A') .AND. (STRING(I:I) .LE. 'Z'))9 $ STRING(I:I) = CHAR( IC + ICHAR(STRING(I:I)) )E10 CONTINq+ subroutine image_name ( image, full )I include '($JPIDEF)'1 character *(*) image dimension itmlst(4) integer *2 item(8) integer sys$getjpiw+ equivalence (item,itmlst)  logical fullc-)c --- current image is a getjpi item code c  item(1) = len(image) item(2) = jpi$_imagname  itmlst(2) = %loc(image)  itmlst(3) = %loc(li) itmlst(4) = 0 c + istat = sys$getjpiw ( ,,, itmlst,,, )2 if (.not. istat) then+ image = ' ' else image(li+1:) = ' 'TA if (.not. full) call parse ( image, ' ', 'NAME', image )5 endif return end c c---end image_namec wwIS = IS + 1 ENDIF  WRITE(NOUT,900)LINE 50 CONTINUEC-0C ------ 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)j. LEN(TOKEN)) THEN ERROR = .TRUE. GO TO 60 ENDIF IF (CH .NE. QCHAR) THEN# TOKEN(TSIZE:TSIZE) = CHA TSIZE = TSIZE + 1A IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOL  ELSE# CH = LINE(IPTR:IPTR) ENDIFE ELSER IPTR = IPTR + 1& IF (IPTR .GT. LL) GO TO 604 IF (LINE(IPTR:IPTR) .NE. QCHAR) GO TO 60# NUE RETURN ENDtCe C---END LOWER ChwwArthur E. Ragosta;N; Left justify a string ;G,; STRING = ' This is a string.'; CALL LEFT ( STRING ); or ;; LS = LEFT (STRING) ! LS contains the length ;13; Results in STRING = 'This is a string. ';* .entry left,^m@ movl 4(ap),r0 ;loc of descriptor to r05 movzwl (r0),r6 ;length to r6L7  L2 = LEN(STR2) VERIFY = .FALSE. DO 20 I = 1, L1  DO 10 J = 1, L21 IF (STR1(I:I) .EQ. STR2(J:J))GO TO 20 10 CONTINUE RETURN 20 CONTINUE  VERIFY = .TRUE.b RETURN END C C---END VERIFYC ww ;r1 contains addr of nonblank charK ;r0 contains num of non-blank chars 5out: movc5 r0,(r1),#32,r6,(r7) ;move and padm decl r7Ploop1:S ** **w3C* ******************************* 3C* ******************************* C*C* AUTHOR :C* Arthur E. Ragostat0C* RAGOSTA%MRL.DECNET@AMES.ARC.NASA.GOVC* MS 219-3%C* NASA Ames Research Center %C* Moffett Field, Ca. 94035*C* (415) 604-5558C*C* DESCRIPTION :Ec* Verifies that the wildcarded word (containing asterisk or 2c* percenbts) matches the nonwildcard wordC*C* INPUT ARGUMENTS :?c* wild - word with (possibly) "*" or "%" wildcardsC'c* notwild - word of text onlyFC*C* OUTPUT ARGUMENTS :R+c* match_word - true if they match C*C* SUBPROGRAM REFERENCES :c* lengthC*%C* ASSUMPTIONS AND RESTRICTIONS :1c* One asterisk only.-c* No asterisk and percent together. !c* Multiple percents OK.CC*C* LANGUAGE AND COMPILER :C* U}tպ; SUBROUTINE MENU2 ( CHOICE, N, TITLE, PROMPT, ANSWER ) C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** MENU2 ** 3C* ** ***3C* ********************************3C* *******************************EC*C* AUTHOR :OC* ART RAGOVSTAEC* 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, ANDAAC* PAGINATION FOR REQUESTS WITH MANY CHOICES IS HANDLED.CEC* (BASICALLY THE SAME AS MENU, BUT HAS USER-INPUT OF BOTTOM C* PROMPT) C*C* INPUT ARGUMENTS :,C* CHOICEW - 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 :-&C* ANSWER - THE USER'S ANSWERC*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 RESPONXSE AGAINST LIMITSFC*%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 77 C*C* CHANGE HISTORY : (C* 26-NOV-85 INITIAL VERSION5C* 21-AUG-87 ADDED VARIABLE BOTTOM PROMPTP7C* 29-JUN-90 FIXED FOR OTHER MERLIB CHANGESNC*HC*********Y**************************************************************C*- CHARACTER *(*) CHOICE(N), PROMPT, TITLEI CHARACTER *79 LINE CHARACTER *2 A CHARACTER *1 CC  INTEGER ANSWERC  IF (N .LT. 1) RETURN! CALL MLIB_GET ('NREAD',NIN)I$ CALL MLIB_GET ('NWRITE', NOUT)C -C --- HOW MANY CHOICES WILL FIT ON 1 SCREEN ?)C L = 0I DO 5 I=1,N& L = MAX0(L,LENGTH(CHOICE(I)))5 CONTINUES IF (L .LT. 21) THEN  IF (NZ .LT. 19) THEN NS = 18E! ELSE IF (N .LT. 37) THEND NS = 36. ELSE  NS = 54  ENDIF ELSE IF (L .LT. 34) THEN IF (N .LT. 19) THEN NS = 18 ELSE  NS = 36U ENDIF ELSE NS = 18 ENDIFC C --- NUMBER OF SCREENS REQUIREDC  NR = (N + NS - 1) / NSC*C --- DISPLAY CHOICESC* 10 IS = 1 DO 100 I = 1, NR CALL CLEAR  W[RITE(NOUT,900) TITLE WRITE(NOUT,910)C./C --- PUT NEXT SCREEN FULL, WITH CHOICE NUMBERSPCO IE = MIN0(IS+17,N)E DO 50 II=IS,IETC C --------- ONE COLUMN WIDEPCA IF (NS .EQ. 18) THEN WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS) IS = IS + 1CEC --------- TWO COLUMNS WIDECU% ELSE IF (NS .EQ. 36) THEN WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS)' \ IF ((IS+18) .LE. N) THEN $ WRITE(A,990) IS+189 LINE(40:) = A // '. ' // CHOICE(IS+18)* ENDIF IS = IS + 1CNC --------- THREE COLUMNS WIDEC1 ELSE WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS)' IF ((IS+18) .LE. N) THENN$ WRITE(A,990) IS+189 LINE(27:) = A // '. ' // CHOICE(IS+18)A ENDIF' IF ((IS]+36) .LE. N) THEN $ WRITE(A,990) IS+369 LINE(53:) = A // '. ' // CHOICE(IS+36) ENDIF IS = IS + 1 ENDIF  WRITE(NOUT,900)LINE 50 CONTINUEC 0C ------ UPDATE STARTING POINTER FOR NEXT SCREENC IS = IS + NS - 18C($C ------ PROMPT FOR ANSWER OR RETURNCE IF (I .EQ. NR) THEN IF (NR .NE. 1) THEN  WRITE(NOUT,930) ELSE% W^RITE(NOUT,920) PROMPT  ENDIF ELSE1 WRITE(NOUT,940)  ENDIFCLC --- GET RESPONSEC READ(NIN,950) LINE CIC --- 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 )& REA_D (LINE,960,ERR=30) ANSWER GO TO 40 CN+C ------ ERROR, PROBABLY NON-DIGITS ENTERED*C*30 CALL MBELL  WRITE(NOUT,970) N READ(NIN,950) LINE  GO TO 10 C +C ------ CHECK FOR OR VALID ANSWERRC 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 ` GO TO 10 ENDIF100 CONTINUEC RETURN900 FORMAT(' ',A)5910 FORMAT(' ')O920 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)E960 FORMAT(74X,I5)>970 FORMAT(' Please respond with a number from 1 to',I5,////. $' Enter ''?'' at the prompt for help.'//% $' Enter to cont ainue.') 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'/N* $' 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'/IE $' enter a choice or hit to continue viewing choices.'/ C $' On the last screen of the display, entering will'/N1 $' redisplay all choices from the start.'///I7 $' Please enter to go back to the menu.')(990 FORMAT(I2) END C C---END MENUCNwwCD 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 + 1g VAX FORTRAN 77C*C* CHANGE HISTORY : +C* 30-MAR-1989 - INITIAL VERSIONGC*HC***********************************************************************C*" character *(*) wild, notwildc match_word = .false.c 2c --- Note: if * appears, no others are allowed...#c --- multiple % are allowed.Ic  lw = length(wild) lnw = length(notwild)  i = index(wild,'*')O if (i .ne. 0) thenc*1c ----- * found, compare part before and ad 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* eANSI 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 MESSfAGESFC --- 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* ** g **,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* MEhSSES - 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*******************************************************i****************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 j 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*k 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*l 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_TRAPCwwn`V ؎ SUBROUTINE MODE ( MTYPE )C*3C* *******************************3C* *******************************3C* ** **3C* ** MODE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET PROCESS MODEC*C* AUToHOR :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 :pC* 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$_MODEq 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 svLڎ0 SUBROUTINE NAE ( NUM, MAX, IARRAY, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** NAE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* NIFTY ARRAY EDITtORC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :CC* TO ENABLE THE SCREEN-ORIENTED EDITING OF 1 TO 3 ARRAYS.C*C* METHODOLOGY :CC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION,C* ON A VT100-COMPATIBLE TERMINAL.C*C* INPUT ARGUMENTS :2C* NUM - NUMBER OF ELEMENTS IN ARRAYS.-C* uMAX - THE DIMENSION OF ARRAYS.*C* IARRAY - THE FIRST DATA ARRAY.C*C* OUTPUT ARGUMENTS :FC* ERROR - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.C*C* INTERNAL WORK AREAS :8C* STRING - TEMPORARY STORAGE FOR INPUT STRING.C*C* FILE REFERENCES :C* NREAD, NWRITEC*C* SUBPROGRAM REFERENCES :DC* CLEAR, MLIB_NSTAT, MLIB_WRITA, GOTOXY, CAPS, LEFT,FC* MBELL, STAT, SLEEP, MLIB_WRITL, REVLF, GETvOKE,C* RIGHT, SRESETC*C* ERROR PROCESSING :%C* CHECK FOR VALID COMMANDS.8C* CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.C*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :,C* VT100-COMPATIBLE TERMINALS ONLY.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC*********************************w**************************************C* CHARACTER *80 STRING CHARACTER *20 TOKE CHARACTER *1 ESC, TYPE LOGICAL ERROR, DOWN, ERR DIMENSION IARRAY(MAX) DATA ESC/27/C,C NUM - THE NUMBER OF ELEMENTS IN IARRAY+C MAX - THE MAXIMUM DIMENSION OF IARRAY!C IARRAY - THE DATA TO BE EDITED7C NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )C ERROR - INTERNAL ERROR FLAG3C DOWN - .TRUE. IF THE DEFAULT DIRECTION IS DOWN:C IPTR - THE ARxRAY ELEMENT WE ARE PRESENTLY POINTING TO>C IX - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)3C IY - Y LOCATION OF CURSOR (BETWEEN 2 AND 24) C NREAD - KEYBOARD UNIT NUMBERC NWRITE - SCREEN UNIT NUMBERC STRING - INPUT BUFFERHC ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREENC GO TO 50, ENTRY NAE1 ( NUM, MAX, IARRAY, ERROR )50 CALL CLEAR# CALL MLIB_GET ('NREAD',NREAD)% CALL MLIB_GET ('NWRITE',NWRITE) ERROR = .FAyLSE. IF ( NUM .GT. MAX ) THEN ERROR = .TRUE. RETURN ENDIF NARRAY = 1 DOWN = .TRUE. IX = 1 IY = 2C:C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYSC IPTR = 0 IF ( NUM .GE. 1 ) IPTR = 1 ISTART = IPTR+ CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )5 CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART ) CALL GOTOXY ( IX, IY )CC --- REPEAT UNTIL DONEC4100 READ ( NREAD, 900, EzND=1000, ERR=1000 ) STRING CALL CAPS ( STRING ) CALL LEFT ( STRING )$ IF (STRING(1:1) .EQ. 'A') THENCC ----- 'ADD' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELLB CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE IARRAY(NUM+1) = 0 NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )# IS{TART = MAX0(NUM-21,1)& IF (NUM .EQ. 0 )ISTART = 0; CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART ) IPTR = NUM' IY = MIN0 ( NUM+1, 23 )" IF (NUM .EQ. 0) IY = 2" CALL GOTOXY ( IX, IY ) ENDIF) ELSE IF (STRING(1:1) .EQ. 'B') THENCC ----- 'BEGIN' COMMANDC IPTR = 0! IF (NUM .GE. 1) IPTR = 1 ISTART = IPTR8 CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART ) | IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'D') THENCC ----- 'DELETE' COMMANDC IF (NUM .GT. 0) THEN NUM = NUM - 1% IF (IPTR .EQ. NUM+1) THEN IPTR = NUM" ISTART = ISTART - 1( IF ( ISTART .LE. 0 ) THEN ISTART = 1 IY = IY - 1 ENDIF ELSE$ DO 110 II = IPTR, NUM+ IARRAY(II)} = IARRAY(II+1)110 CONTINUE; IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1- IF ( ISTART .LE. 0 )ISTART = 1 ENDIF IF (NUM .EQ. 0) THEN ISTART = 0 IY = 2 ENDIF1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ); CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART ) ENDIF CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'E') THENCC ----- ~'END' COMMANDC ISTART = NUM - 21% IF (ISTART .LE. 0)ISTART = 1# IF (NUM .EQ. 0 )ISTART = 08 CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART ) IPTR = NUM IY = MIN0 ( NUM+1, 23 ) IF (NUM .EQ. 0) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'I') THENCC ----- 'INSERT' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELLB CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE# IF (IPTR .LE. NUM) THEN( DO 120 II = NUM, IPTR, -1+ IARRAY(II+1) = IARRAY(II)120 CONTINUE IARRAY(IPTR) = 0 ELSE IARRAY(NUM+1) = 0 ENDIF NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ); CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART )" CALL GOTOXY ( IX, IY ) ENDIFC) ELSE IF (STRING(1:1) .EQ. 'Q') THEN GO TO 1000C) ELSE IF (STRING(1:1) .EQ. 'R') THENCC ----- 'REPAINT' SCREENC8 CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART ) CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'S') THENC!C ----- 'SCROLL' DIRECTION TOGGLEC DOWN = .NOT. DOWN. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) CALL GOTOXY ( IX, IY )CG ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THENCC ----- 'HELP' COMMANDC CALL CLEAR WRITE ( NWRITE, 910 ) READ ( NREAD, 920 ) CALL CLEAR. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )8 CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART ) CALL GOTOXY ( IX, IY ) ELSECC ----- INPUT LINEC* IF ( LENGTH(STRING) .EQ. 0 ) THENCC -------- POSITION CURSOR ONLYC IF ( DOWN ) THEN( IF ( IPTR .LT. NUM ) THEN! IPTR = IPTR + 1 IY = IY + 1( IF ( IY .GT. 23 ) THENCC -------------- SCROLL UPC IY = 23( ISTART = ISTART + 1C CALL MLIB_WRITL ( NWRITE, IY+1, IPTR, IARRAY )* WRITE ( NWRITE, 940 ) CALL REVLF  ENDIF ELSE CALL REVLF   ENDIF ELSE& IF ( IPTR .GT. 1 ) THEN! IPTR = IPTR - 1 IY = IY - 1& IF (IY .LT. 2 ) THENCC -------------- DOWN SCROLLC IY = 2" ISTART = IPTR+ CALL GOTOXY ( IX, IY ). WRITE ( NWRITE, 930 ) ESCA CALL MLIB_WRITL ( NWRITE, IY, IPTR, IARRAY ) ENDIF ENDIF% CALL GOTOXY ( IX, IY ) ENDIF ELSECC ------ MODIFY LINEC IL = 1 IA = 0;200 CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )% IF ( TYPE .EQ. 'E' ) THEN; CALL MLIB_WRITL ( NWRITE, IY, IPTR, IARRAY ) GO TO 100 ENDIF1 IF (( TYPE .NE. 'I' ) .OR. ERR ) THEN CALL MBELL> CALL STAT ( IX, IY, ' Unintelligible input. ' ) CALL SL EEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ); CALL MLIB_WRITL ( NWRITE, IY, IPTR, IARRAY ) GO TO 100 ENDIF IA = IA + 1& IF ( IA .GT. NARRAY ) THEN CALL MBELLD CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ); CALL MLIB_WRITL ( NWRITE, IY, IPTR, IARRAY ) GO TO 100 ENDIFC!C ------- PUT NEW VALUE IN ARRAYC CALL RIGHT ( TOKE ). READ ( TOKE, 950 ) IARRAY ( IPTR ) GO TO 200 ENDIF ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET CALL CLEAR RETURN900 FORMAT ( A80 )H910 FORMAT (///,' A command is a line with a single letter on it :',/,D $ ' A)dd - add a blank line to the end of the arrays',/,< $ ' B)egin - go to t he beginning of the arrays',/,2 $ ' D)elete - delete the current line',/,6 $ ' E)nd - go to the end of the arrays',/,B $ ' I)nsert - insert a line before the indicated line',/,* $ ' Q)uit - exit the editor',/,- $ ' R)epaint - repaint the screen',/,< $ ' S)croll - change the direction of scrolling',/,* $ ' ? - produce this message',///,G $ ' Any other line is expected to be data. Enter ^Z (control/Z)',$ $ /,' to exit the editor.',//," $ ' Enter to continue.')920 FORMAT ( A )930 FORMAT ('+',A1,'M',$ )940 FORMAT ( / )950 FORMAT ( 10X,I10 ) ENDC C---END NAEC: SUBROUTINE NAE2 ( NUM, MAX, IARRAY, IARRAY2, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** NAE2 **3C* **  **3C* *******************************3C* *******************************C*C* SUBPROGRAM : C* NIFTY ARRAY EDITOR 2C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :>C* TO ENABLE THE SCREEN-ORIENTED EDITING OF 2 ARRAYS.C*C* METHODOLOGY :DC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.C*C* INPUT ARGUMENTS :2C* NUM - NUMBER OF ELEMENTS IN ARRAYS.-C* MAX - THE DIMENSION OF ARRAYS.*C* IARRAY - THE FIRST DATA ARRAY.+C* IARRAY2- THE SECOND DATA ARRAY.C*C* OUTPUT ARGUMENTS :FC* ERROR - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.C*C* INTERNAL WORK AREAS :8C* STRING - TEMPORARY STORAGE FOR INPUT STRING.C*C* FILE REFERENCES :C* NREAD, NWRITEC*C*  SUBPROGRAM REFERENCES ::C* CLEAR, MLIB_NSTAT, MLIB_WRITA2, GOTOXY, CAPS?C* LEFT, MBELL, STAT, SLEEP, MLIB_WRITL21C* REVLF, GETOKE, RIGHT, SRESETC*C* ERROR PROCESSING :%C* CHECK FOR VALID COMMANDS.8C* CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.C*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :-C* VT-100 COMPATIBLE TERMINALS ONLY.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *80 STRING CHARACTER *20 TOKE CHARACTER *1 ESC, TYPE LOGICAL ERROR, DOWN, ERR) DIMENSION IARRAY(MAX), IARRAY2(MAX) DATA ESC/27/C,C NUM - THE NUMBER OF ELEMENTS IN IARRAY+C MAX - THE MAXIMUM DIMENSION OF IARRAY!C IARRAY - THE DATA TO BE EDITED!C IARRAY2- THE DATA TO BE EDITED7C NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )C ERROR - INTERNAL ERROR FLAG3C DOWN - .TRUE. IF THE DEFAULT DIRECTION IS DOWN:C IPTR - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO>C IX - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)3C IY - Y LOCATION OF CURSOR (BETWEEN 2 AND 24) C NREAD - KEYBOARD UNIT NUMBERC NWRITE - SCREEN UNIT NUMBERC STRING - INPUT BUFFERHC ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREENC# CALL MLIB_GET ('NREAD',NREAD)% CALL MLIB_GET ('NWRITE',NWRITE) ERROR = .FALSE. NARRAY = 2 IF ( NUM .GT. MAX ) THEN ERROR = .TRUE. RETURN ENDIF DOWN = .TRUE. IX = 1 IY = 2C:C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYSC IPTR = 0 IF ( NUM .GE. 1 ) IPTR = 1 ISTART = IPTR+ CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )? CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART ) CALL GOTOXY ( IX, IY )CC --- REPEAT UNTIL DONEC4100 READ ( NREAD, 900, END=1000, ERR=1000 ) STRING CALL CAPS ( STRING ) CALL LEFT ( STRING )$ IF (STRING(1:1) .EQ. 'A') THENCC ----- 'ADD' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELLB CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE IARRAY(NUM+1) = 0 IARRAY2(NUM+1) = 0 NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ISTART = NUM - 21( IF (ISTART .LE. 0)ISTART = 1& IF (NUM .EQ. 0 )ISTART = 0E CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART ) IPTR = NUM# IY = MIN0 ( NUM+1, 23 )" IF (NUM .EQ. 0) IY = 2" CALL GOTOXY ( IX, IY ) ENDIF) ELSE IF (STRING(1:1) .EQ. 'B') THENCC ----- 'BEGIN' COMMANDC IPTR = 0! IF (NUM .GE. 1) IPTR = 1 ISTART = IPTRB CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART ) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'D') THENCC ----- 'DELETE' COMMANDC IF (NUM .GT. 0) THEN NUM = NUM - 1% IF (IPTR .EQ. NUM+1) THEN IPTR = NUM" ISTART = ISTART - 1( IF ( ISTART .LE. 0 ) THEN ISTART = 1 IY = IY - 1 ENDIF ELSE$ DO 110 II = IPTR, NUM+ IARRAY(II) = IARRAY(II+1)- IARRAY2(II) = IARRAY2(II+1)110 CONTINUE; IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1- IF ( ISTART .LE. 0 )ISTART = 1 ENDIF IF (NUM .EQ. 0) THEN ISTART = 0 IY = 2 ENDIF1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )E CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART ) ENDIF CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'E') THENCC ----- 'END' COMMANDC ISTART = NUM - 21% IF (ISTART .LE. 0)ISTART = 1# IF (NUM .EQ. 0 )ISTART = 0B CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART ) IPTR = NUM IY = MIN0 ( NUM+1, 23 ) IF (NUM .EQ. 0) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'I') THENCC ----- 'INSERT' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELLB CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE# IF (IPTR .LE. NUM) THEN( DO 120 II = NUM, IPTR, -1+ IARRAY(II+1) = IARRAY(II)- IARRAY2(II+1) = IARRAY2(II)120 CONTINUE IARRAY(IPTR) = 0 IARRAY2(IPTR) = 0 ELSE IARRAY(NUM+1) = 0! IARRAY2(NUM+1) = 0 ENDIF NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )E CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )" CALL GOTOXY ( IX, IY ) ENDIFC) ELSE IF (STRING(1:1) .EQ. 'Q') THEN GO TO 1000C) ELSE IF (STRING(1:1) .EQ. 'R') THENCC ----- 'REPAINT' SCREENCB CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART ) CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'S') THENC!C ----- 'SCROLL' DIRECTION TOGGLEC DOWN = .NOT. DOWN. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) CALL GOTOXY ( IX, IY )CG ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THENCC ----- 'HELP' COMMANDC CALL CLEAR WRITE ( NWRITE, 910 ) READ ( NREAD, 920 ) CALL CLEAR. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )B CALL MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART ) CALL GOTOXY ( IX, IY ) ELSECC ----- INPUT LINEC* IF ( LENGTH(STRING) .EQ. 0 ) THENCC -------- POSITION CURSOR ONLYC IF ( DOWN ) THEN( IF ( IPTR .LT. NUM ) THEN! IPTR = IPTR + 1 IY = IY + 1( IF ( IY .GT. 23 ) THENCC -------------- SCROLL UPC IY = 23( ISTART = ISTART + 1C CALL MLIB_WRITL2 ( NWRITE, IY+1, IPTR, IARRAY,0 $ IARRAY2 )* WRITE ( NWRITE, 940 ) CALL REVLF  ENDIF ELSE CALL REVLF ENDIF ELSE& IF ( IPTR .GT. 1 ) THEN! IPTR = IPTR - 1 IY = IY - 1& IF (IY .LT. 2 ) THENCC -------------- DOWN SCROLLC IY = 2" ISTART = IPTR+ CALL GOTOXY ( IX, IY ). WRITE ( NWRITE, 930 ) ESCA CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, IARRAY,0 $ IARRAY2 ) ENDIF  ENDIF% CALL GOTOXY ( IX, IY ) ENDIF ELSECC ------ MODIFY LINEC IL = 1 IA = 0;200 CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )% IF ( TYPE .EQ. 'E' ) THENE CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 ) GO TO 100 ENDIF1 IF (( TYPE .NE. 'I' ) .OR. ERR ) THEN CALL MBELL > CALL STAT ( IX, IY, ' Unintelli gible input. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )E CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 ) GO TO 100 ENDIF IA = IA + 1& IF ( IA .GT. NARRAY ) THEN CALL MBELL D CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )E CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 ) GO TO 100 ENDIFC!C ------- PUT NEW VALUE IN ARRAYC CALL RIGHT ( TOKE )! IF ( IA .EQ. 1 ) THEN1 READ ( TOKE, 950 ) IARRAY ( IPTR ) ELSE2 READ ( TOKE, 950 ) IARRAY2 ( IPTR ) ENDIF GO TO 200 ENDIF ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET CALL CLEAR RETURN900 FORMAT ( A80 )H910 FORMAT (///,' A command is a line with a single letter on it :',/,D $ ' A)dd - add a blank line to the end of the arrays',/,< $ ' B)egin - go to the beginning of the arrays',/,2 $ ' D)elete - delete the current line',/,6 $ ' E)nd - go to the end of the arrays',/,B $ ' I)nsert - insert a line before the indicated line',/,* $ ' Q)uit - exit the editor',/,- $ ' R)epaint - repaint the screen',/,< $ ' S)croll - change the direction of scrolling',/,* $ ' ? - produce this message',///,G $ ' Any other line is expected to be data. Enter ^Z (control/Z)',$ $ /,' to exit the editor.',//," $ ' Enter to continue.')920 FORMAT ( A )930 FORMAT ('+',A1,'M',$ )940 FORMAT ( / )950 FORMAT ( 10X,I10 ) ENDC C---END NAE2CC SUBROUTINE NAE3 ( NUM, MAX, IARRAY, IARRAY2, IARRAY3, ERROR )C*3C* *******************************3C*  *******************************3C* ** **3C* ** NAE3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM : C* NIFTY ARRAY EDITOR 3C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :>C* TO ENABLE THE SCREEN-ORIENTED EDITING OF 3 ARRAYS.C*C* METHODOLOGY :DC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.C*C* INPUT ARGUMENTS :2C* NUM - NUMBER OF ELEMENTS IN ARRAYS.-C* MAX - THE DIMENSION OF ARRAYS.*C* IARRAY - THE FIRST DATA ARRAY.+C* IARRAY2- THE SECOND DATA ARRAY.*C* IARRAY3- THE THIRD DATA ARRAY.C*C* OUTPUT ARGUMENTS :FC* ERROR - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.C*C* INTERNAL WORK AREAS :8C* STRING - TEMPORARY STORAGE FOR INPUT STRING.C*C* FILE REFERENCES :C* NREAD, NWRITEC*C* SUBPROGRAM REFERENCES :FC* CLEAR, MLIB_NSTAT, MLIB_WRITA3, GOTOXY, CAPS, LEFT,FC* MBELL, STAT, SLEEP, MLIB_WRITL3, REVLF, GETOKEC* RIGHT, SRESETC*C* ERROR PROCESSING :%C* CHECK FOR VALID COMMANDS.8C* CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.C*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :-C* VT-100 COMPATIBLE TERMINALS ONLY.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *80 STRING CHARACTER *20 TOKE CHARACTER *1 ESC, TYPE LOGICAL ERROR, DOWN, ERR7 DIMENSION IARRAY(MAX), IARRAY2(MAX), IARRAY3(MAX) DATA ESC/27/C,C NUM - THE NUMBER OF ELEMENTS IN IARRAY+C MAX - THE MAXIMUM DIMENSION OF IARRAY!C IARRAY - THE DATA TO BE EDITED!C IARRAY2- THE DATA TO BE EDITED!C IARRAY3- THE DATA TO BE EDITED7C NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )C ERROR - INTERNAL ERROR FLAG3C DOWN - .TRUE. IF THE DEFAULT DIRECTION IS DOWN:C IPTR - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO>C IX - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)3C IY - Y LOCATION OF CURSOR (BETWEEN 2 AND 24) C NREAD - KEYBOARD UNIT NUMBERC NWRITE - SCREEN UNIT NUMBERC STRING - INPUT BUFFERHC ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREENC% CALL MLIB_GET ('NWRITE',NWRITE)# CALL MLIB_GET ('NREAD',NREAD) ERROR = .FALSE. NARRAY = 3 IF ( NUM .GT. MAX ) THEN ERROR = .TRUE. RETURN ENDIF DOWN = .TRUE. IX = 1 IY = 2C:C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYSC IPTR = 0 IF ( NUM .GE. 1 ) IPTR = 1 ISTART = IPTR+ CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )H CALL MLIB_WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, ISTART ) CALL GOTOXY ( IX, IY )CC --- REPEAT UNTIL DONEC4100 READ ( NREAD, 900, END=1000, ERR=1000 ) STRING CALL CAPS ( STRING ) CALL LEFT ( STRING )$ IF (STRING(1:1) .EQ. 'A') THENCC ----- 'ADD' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELLB CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE IARRAY(NUM+1) = 0 IARRAY2(NUM+1) = 0 IARRAY3(NUM+1) = 0 NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ISTART = NUM - 21( IF (ISTART .LE. 0)ISTART = 1& IF (NUM .EQ. 0 )ISTART = 0D CALL MLIB_WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,% $ ISTART) IPTR = NUM# IY = MIN0 ( NUM+1, 23 )" IF (NUM .EQ. 0) IY = 2" CALL GOTOXY ( IX, IY ) ENDIF) ELSE IF (STRING(1:1) .EQ. 'B') THENCC ----- 'BEGIN' COMMANDC IPTR = 0! IF (NUM .GE. 1) IPTR = 1 ISTART = IPTRB CALL MLIB_WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,# $ ISTART ) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'D') THENCC ----- 'DELETE' COMMANDC IF (NUM .GT. 0) THEN NUM = NUM - 1% IF (IPTR .EQ. NUM+1) THEN IPTR = NUM" ISTART = ISTART - 1( IF ( ISTART .LE. 0 ) THEN ISTART = 1 IY = IY - 1 ENDIF ELSE$ DO 110 II = IPTR, NUM+ IARRAY(II) = IARRAY(II+1)- IARRAY2(II) = IARRAY2(II+1)- IARRAY3(II) = IARRAY3(II+1)110 CONTINUE; IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1- IF ( ISTART .LE. 0 )ISTART = 1 ENDIF IF (NUM .EQ. 0) THEN ISTART = 0 IY = 2 ENDIF1  CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )D CALL MLIB_WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,% $ ISTART) ENDIF CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'E') THENCC ----- 'END' COMMANDC ISTART = NUM - 21% IF (ISTART .LE. 0)ISTART = 1# IF (NUM .EQ. 0 )ISTART = 0B CALL MLIB_WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,# $ ISTART ) IPTR = NUM IY = MIN0 ( NUM+1, 23 ) IF (NUM .EQ. 0) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'I') THENCC ----- 'INSERT' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELLB CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE# IF (IPTR .LE. NUM) THEN( DO 120 II = NUM, IPTR, -1+  IARRAY(II+1) = IARRAY(II)- IARRAY2(II+1) = IARRAY2(II)- IARRAY3(II+1) = IARRAY3(II)120 CONTINUE IARRAY(IPTR) = 0 IARRAY2(IPTR) = 0 IARRAY3(IPTR) = 0 ELSE IARRAY(NUM+1) = 0! IARRAY2(NUM+1) = 0! IARRAY3(NUM+1) = 0 ENDIF NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )D CALL MLIB_WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,% $ ISTART)" CALL GOTOXY ( IX, IY ) ENDIFC) ELSE IF (STRING(1:1) .EQ. 'Q') THEN GO TO 1000C) ELSE IF (STRING(1:1) .EQ. 'R') THENCC ----- 'REPAINT' SCREENCB CALL MLIB_WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,# $ ISTART ) CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'S') THENC!C ----- 'SCROLL' DIRECTION TOGGLEC DOWN = .NOT. DOWN. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) CALL GOTOXY ( IX, IY )CG ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THENCC ----- 'HELP' COMMANDC CALL CLEAR WRITE ( NWRITE, 910 ) READ ( NREAD, 920 ) CALL CLEAR. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )B CALL MLIB_WRITA3 ( NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,# $ ISTART )  CALL GOTOXY ( IX, IY ) ELSECC ----- INPUT LINEC* IF ( LENGTH(STRING) .EQ. 0 ) THENCC -------- POSITION CURSOR ONLYC IF ( DOWN ) THEN( IF ( IPTR .LT. NUM ) THEN! IPTR = IPTR + 1 IY = IY + 1( IF ( IY .GT. 23 ) THENCC -------------- SCROLL UPC IY = 23( ISTART = ISTART + 1C CALL MLIB_WRITL3 ( NWRITE, IY+1, IPTR, IARRAY,5 $ IARRAY2, IARRAY3 )* WRITE ( NWRITE, 940 ) CALL REVLF  ENDIF ELSE CALL REVLF  ENDIF ELSE& IF ( IPTR .GT. 1 ) THEN! IPTR = IPTR - 1 IY = IY - 1& IF (IY .LT. 2 ) THENCC -------------- DOWN SCROLLC IY = 2"  ISTART = IPTR+ CALL GOTOXY ( IX, IY ). WRITE ( NWRITE, 930 ) ESCA CALL MLIB_WRITL3 ( NWRITE, IY, IPTR, IARRAY,5 $ IARRAY2, IARRAY3 ) ENDIF ENDIF% CALL GOTOXY ( IX, IY ) ENDIF ELSECC ------ MODIFY LINEC IL = 1 IA = 0;200 CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )% IF (  TYPE .EQ. 'E' ) THEND CALL MLIB_WRITL3 ( NWRITE, IY, IPTR, IARRAY, IARRAY2,& $ IARRAY3 ) GO TO 100 ENDIF1 IF (( TYPE .NE. 'I' ) .OR. ERR ) THEN CALL MBELL> CALL STAT ( IX, IY, ' Unintelligible input. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )C CALL MLIB_WRITL3 (NWRITE, IY, IPTR, IARRAY, IARRAY2,) $  IARRAY3) GO TO 100 ENDIF IA = IA + 1& IF ( IA .GT. NARRAY ) THEN CALL MBELLD CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )C CALL MLIB_WRITL3 (NWRITE, IY, IPTR, IARRAY, IARRAY2,) $ IARRAY3) GO TO 100 ENDIFC!C ------- PUT NEW VALUE IN ARRAYC CALL RIGHT ( TOKE )! IF ( IA .EQ. 1 ) THEN1 READ ( TOKE, 950 ) IARRAY ( IPTR )& ELSE IF ( IA .EQ. 2 ) THEN2 READ ( TOKE, 950 ) IARRAY2 ( IPTR ) ELSE2 READ ( TOKE, 950 ) IARRAY3 ( IPTR ) ENDIF GO TO 200 ENDIF ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET CALL CLEAR RETURN900 FORMAT ( A80 )H910 FO RMAT (///,' A command is a line with a single letter on it :',/,D $ ' A)dd - add a blank line to the end of the arrays',/,< $ ' B)egin - go to the beginning of the arrays',/,2 $ ' D)elete - delete the current line',/,6 $ ' E)nd - go to the end of the arrays',/,B $ ' I)nsert - insert a line before the indicated line',/,* $ ' Q)uit - exit the editor',/,- $ ' R)epaint - repaint the screen',/,< $ ' S)croll - change the direction of scrolling',/,* $ ' ? - produce this message',///,G $ ' Any other line is expected to be data. Enter ^Z (control/Z)',$ $ /,' to exit the editor.',//," $ ' Enter to continue.')920 FORMAT ( A )930 FORMAT ('+',A1,'M',$ )940 FORMAT ( / )950 FORMAT ( 10X,I10 ) ENDC C---END NAE3C0 SUBROUTINE RNAE ( NUM, MAX, ARRAY, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** RNAE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :%C* NIFTY ARRAY EDITOR (REAL)C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :=C* TO ENABLE THE SCREEN-ORIENTED EDITING OF 1 ARRAY.C*C* METHODOLOGY :DC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.C*C* INPUT ARGUMENTS :2C* NUM - NUMBER OF ELEMENTS IN ARRAYS.-C* MAX - THE DIMENSION OF ARRAYS.*C* ARRAY - THE FIRST DATA ARRAY.C*C* OUTPUT ARGUMENTS :FC* ERROR - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.C*C* INTERNAL WORK AREAS :8C*  STRING - TEMPORARY STORAGE FOR INPUT STRING.C*C* FILE REFERENCES :C* NREAD, NWRITEC*C* SUBPROGRAM REFERENCES :FC* CLEAR, MLIB_NSTAT, MLIB_WRITA, GOTOXY, CAPS, LEFT,GC* MBELL, STAT, SLEEP, MLIB_WRITL, REVLF, GETOKE,C* RIGHT, SRESETC*C* ERROR PROCESSING :%C* CHECK FOR VALID COMMANDS.8C* CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.C*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :-C* VT-100 COMPATIBLE TERMINALS ONLY.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *80 STRING CHARACTER *20 TOKE CHARACTER *1 ESC, TYPE LOGICAL ERROR, DOWN, ERR DIMENSION ARRAY(MAX) DATA ESC/27/C,C NUM  - THE NUMBER OF ELEMENTS IN IARRAY+C MAX - THE MAXIMUM DIMENSION OF IARRAY!C ARRAY - THE DATA TO BE EDITED7C NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )C ERROR - INTERNAL ERROR FLAG3C DOWN - .TRUE. IF THE DEFAULT DIRECTION IS DOWN:C IPTR - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO>C IX - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)3C IY - Y LOCATION OF CURSOR (BETWEEN 2 AND 24) C NREAD - KEYBOARD UNIT NUMBERC NWRITE - SCREEN UNIT NUMBERC STRING - INPUT BUFFERHC ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREENC GO TO 50; ENTRY RNAE1 ( NREAD, NWRITE, NUM, MAX, ARRAY, ERROR )50 CALL CLEAR% CALL MLIB_GET ('NWRITE',NWRITE)# CALL MLIB_GET ('NREAD',NREAD) ERROR = .FALSE. IF ( NUM .GT. MAX ) THEN ERROR = .TRUE. RETURN ENDIF NARRAY = 1 DOWN = .TRUE. IX = 1 IY = 2C:C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYSC IPTR = 0 IF ( NUM .GE. 1 ) IPTR = 1 ISTART = IPTR+ CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )4 CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART ) CALL GOTOXY ( IX, IY )CC --- REPEAT UNTIL DONEC4100 READ ( NREAD, 900, END=1000, ERR=1000 ) STRING CALL CAPS ( STRING ) CALL LEFT ( STRING )$ IF (STRING(1:1) .EQ. 'A') THENCC ----- 'ADD' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELL B CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE ARRAY(NUM+1) = 0 NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )# ISTART = MAX0(NUM-21,1)& IF (NUM .EQ. 0 )ISTART = 0: CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART ) IPTR = NUM' IY = MIN0 ( NUM+1, 23 )" IF (NUM .EQ. 0) IY = 2" CALL GOTOXY ( IX, IY ) ENDIF) ELSE IF (STRING(1:1) .EQ. 'B') THENCC ----- 'BEGIN' COMMANDC IPTR = 0! IF (NUM .GE. 1) IPTR = 1 ISTART = IPTR7 CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART ) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'D') THENCC ----- 'DELETE' COMMANDC IF (NUM .GT. 0) THEN NUM = NUM - 1% IF (IPTR .EQ. NUM+1) THEN IPTR = NUM" ISTART = ISTART - 1( IF ( ISTART .LE. 0 ) THEN ISTART = 1 IY = IY - 1 ENDIF ELSE$ DO 110 II = IPTR, NUM) ARRAY(II) = ARRAY(II+1)110 CONTINUE; IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1- IF ( ISTART .LE. 0 )ISTART = 1 ENDIF IF (NUM .EQ. 0) THEN  ISTART = 0 IY = 2 ENDIF1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ): CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART ) ENDIF CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'E') THENCC ----- 'END' COMMANDC ISTART = NUM - 21% IF (ISTART .LE. 0)ISTART = 1# IF (NUM .EQ. 0 )ISTART = 07 CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART ) IPTR = NUM  IY = MIN0 ( NUM+1, 23 ) IF (NUM .EQ. 0) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'I') THENCC ----- 'INSERT' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELL B CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE# IF (IPTR .LE. NUM) THEN( DO 120 II = NUM, IPTR, -1) ARRAY(II+1) = ARRAY(II)120 CONTINUE ARRAY(IPTR) = 0 ELSE ARRAY(NUM+1) = 0 ENDIF NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ): CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART )" CALL GOTOXY ( IX, IY ) ENDIFC) ELSE IF (STRING(1:1) .EQ. 'Q') THEN GO TO 1000C) ELSE IF (STRING(1:1) .EQ. 'R') THENCC ----- 'REPAINT' SCREENC7 CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART ) CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'S') THENC!C ----- 'SCROLL' DIRECTION TOGGLEC DOWN = .NOT. DOWN. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) CALL GOTOXY ( IX, IY )CG ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THENCC ----- 'HELP' COMMANDC CALL CLEAR WRITE ( NWRITE, 910 ) READ ( NREAD, 920 ) CALL CLEAR.  CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )7 CALL MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART ) CALL GOTOXY ( IX, IY ) ELSECC ----- INPUT LINEC* IF ( LENGTH(STRING) .EQ. 0 ) THENCC -------- POSITION CURSOR ONLYC IF ( DOWN ) THEN( IF ( IPTR .LT. NUM ) THEN! IPTR = IPTR + 1 IY = IY + 1( IF ( IY .GT. 23 ) THENCC -------------- SCROLL UPC IY = 23( ISTART = ISTART + 1B CALL MLIB_WRITL ( NWRITE, IY+1, IPTR, ARRAY )* WRITE ( NWRITE, 940 ) CALL REVLF  ENDIF ELSE CALL REVLF  ENDIF ELSE& IF ( IPTR .GT. 1 ) THEN! IPTR = IPTR - 1 IY = IY - 1& IF (IY .LT. 2 ) THENCC -------------- DOWN SCROLLC  IY = 2" ISTART = IPTR+ CALL GOTOXY ( IX, IY ). WRITE ( NWRITE, 930 ) ESC@ CALL MLIB_WRITL ( NWRITE, IY, IPTR, ARRAY ) ENDIF ENDIF% CALL GOTOXY ( IX, IY ) ENDIF ELSECC ------ MODIFY LINEC IL = 1 IA = 0;200 CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )% IF ( TYPE .EQ. 'E' ) THEN: CALL MLIB_WRITL ( NWRITE, IY, IPTR, ARRAY ) GO TO 100 ENDIFG IF (((TYPE .NE. 'R') .AND. (TYPE .NE. 'I')) .OR. ERR ) THEN CALL MBELL > CALL STAT ( IX, IY, ' Unintelligible input. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ): CALL MLIB_WRITL ( NWRITE, IY, IPTR, ARRAY ) GO TO 100 ENDIF IA = IA + 1&  IF ( IA .GT. NARRAY ) THEN CALL MBELL D CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ): CALL MLIB_WRITL ( NWRITE, IY, IPTR, ARRAY ) GO TO 100 ENDIFC!C ------- PUT NEW VALUE IN ARRAYC CALL RIGHT ( TOKE )- READ ( TOKE, 950 ) ARRAY ( IPTR ) GO TO 200 ENDIF ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET  CALL CLEAR RETURN900 FORMAT ( A80 )H910 FORMAT (///,' A command is a line with a single letter on it :',/,D $ ' A)dd - add a blank line to the end of the arrays',/,< $ ' B)egin - go to the beginning of the arrays',/,2 $ ' D)elete - delete the current line',/,6 $ ' E)nd - go to the end of the arrays',/,B $ ' I)nsert - insert a line before the indicated line',/,* $ ' Q)uit - exit the editor',/,- $ ' R)epaint - repaint the screen',/,< $ ' S)croll - change the direction of scrolling',/,* $ ' ? - produce this message',///,G $ ' Any other line is expected to be data. Enter ^Z (control/Z)',$ $ /,' to exit the editor.',//," $ ' Enter to continue.')920 FORMAT ( A )930 FORMAT ('+',A1,'M',$ )940 FORMAT ( / )950 FORMAT ( 10X,F10.0 ) ENDC C---END RNAEC9 SUBROUTINE RNAE2 ( NUM, MAX, ARRAY, ARRAY2, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** RNAE2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :'C* (REAL) NIFTY ARRAY EDITOR 2C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :>C* TO ENABLE THE SCREEN-ORIENTED EDITING OF 2 ARRAYS.C*C* METHODOLOGY :DC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.C*C* INPUT ARGUMENTS :2C* NUM - NUMBER OF ELEMENTS IN ARRAYS.-C* MAX - THE DIMENSION OF ARRAYS.*C* ARRAY - THE FIRST DATA ARRAY.+C* ARRAY2 - THE SECOND DATA ARRAY.C*C* OUTPUT ARGUMENTS :FC* ERROR - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.C*C* INTERNAL WORK AREAS :8C* STRING - TEMPORARY STORAGE FOR INPUT STRING.C*C* FILE REFERENCES :C* NREAD, NWRITEC*C* SUBPROGRAM REFERENCES :HC* CLEAR, MLIB_NSTAT, MLIB_WRITA2, GOTOXY, CAPS, LEFT,HC* MBELL, STAT, SLEEP, MLIB_WRITL2, REVLF, GETOKEC* RIGHT, SRESETC*C* ERROR PROCESSING :%C* CHECK FOR VALID COMMANDS.8C* CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.C*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :-C* VT-100 COMPATIBLE TERMINALS ONLY.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *80 STRING CHARACTER *20 TOKE CHARACTER *1 ESC, TYPE LOGICAL ERROR, DOWN, ERR' DIMENSION ARRAY(MAX), ARRAY2(MAX) DATA ESC/27/C+C NUM - THE NUMBER OF ELEMENTS IN ARRAY*C MAX - THE MAXIMUM DIMENSION OF ARRAY!C ARRAY - THE DATA TO BE EDITED!C ARRAY2 - THE DATA TO BE EDITED7C NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )C ERROR - INTERNAL ERROR FLAG3C DOWN - .TRUE. IF THE DEFAULT DIRECTION IS DOWN:C IPTR - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO>C IX - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)3C IY - Y LOCATION OF CURSOR (BETWEEN 2 AND 24) C NREAD - KEYBOARD UNIT NUMBERC NWRITE - SCREEN UNIT NUMBERC STRING - INPUT BUFFERHC ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREENC% CALL MLIB_GET ('NWRITE',NWRITE)# CALL MLIB_GET ('NREAD',NREAD) ERROR = .FALSE. NARRAY = 2 IF ( NUM .GT. MAX ) THEN  ERROR = .TRUE. RETURN ENDIF DOWN = .TRUE. IX = 1 IY = 2C:C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYSC IPTR = 0 IF ( NUM .GE. 1 ) IPTR = 1 ISTART = IPTR+ CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )= CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART ) CALL GOTOXY ( IX, IY )CC --- REPEAT UNTIL DONEC4100 READ ( NREAD, 900, END=1000, ERR=1000 ) STRING CALL CAPS ( STRING ) CALL LEFT ( STRING )$ IF (STRING(1:1) .EQ. 'A') THENCC ----- 'ADD' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELL B CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE ARRAY(NUM+1) = 0 ARRAY2(NUM+1) = 0 NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ISTART = NUM - 21(  IF (ISTART .LE. 0)ISTART = 1& IF (NUM .EQ. 0 )ISTART = 0C CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART ) IPTR = NUM# IY = MIN0 ( NUM+1, 23 )" IF (NUM .EQ. 0) IY = 2" CALL GOTOXY ( IX, IY ) ENDIF) ELSE IF (STRING(1:1) .EQ. 'B') THENCC ----- 'BEGIN' COMMANDC IPTR = 0! IF (NUM .GE. 1) IPTR = 1 ISTART = IPTR@ CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART ) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'D') THENCC ----- 'DELETE' COMMANDC IF (NUM .GT. 0) THEN NUM = NUM - 1% IF (IPTR .EQ. NUM+1) THEN IPTR = NUM" ISTART = ISTART - 1( IF ( ISTART .LE. 0 ) THEN ISTART = 1 IY = IY - 1 ENDIF ELSE$ DO 110 II = IPTR, NUM)  ARRAY(II) = ARRAY(II+1)+ ARRAY2(II) = ARRAY2(II+1)110 CONTINUE; IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1- IF ( ISTART .LE. 0 )ISTART = 1 ENDIF IF (NUM .EQ. 0) THEN ISTART = 0 IY = 2 ENDIF1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )C CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART ) ENDIF CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'E') THENCC ----- 'END' COMMANDC ISTART = NUM - 21% IF (ISTART .LE. 0)ISTART = 1# IF (NUM .EQ. 0 )ISTART = 0@ CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART ) IPTR = NUM IY = MIN0 ( NUM+1, 23 ) IF (NUM .EQ. 0) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'I') THENCC ----- 'INSERT' COMMANDC IF (NUM .EQ. MAX) THEN  CALL MBELL B CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE# IF (IPTR .LE. NUM) THEN( DO 120 II = NUM, IPTR, -1) ARRAY(II+1) = ARRAY(II)+ ARRAY2(II+1) = ARRAY2(II)120 CONTINUE ARRAY(IPTR) = 0 ARRAY2(IPTR) = 0 ELSE ARRAY(NUM+1) = 0  ARRAY2(NUM+1) = 0 ENDIF NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )C CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART )" CALL GOTOXY ( IX, IY ) ENDIFC) ELSE IF (STRING(1:1) .EQ. 'Q') THEN GO TO 1000C) ELSE IF (STRING(1:1) .EQ. 'R') THENCC ----- 'REPAINT' SCREENC@ CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART ) CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'S') THENC!C ----- 'SCROLL' DIRECTION TOGGLEC DOWN = .NOT. DOWN. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) CALL GOTOXY ( IX, IY )CG ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THENCC ----- 'HELP' COMMANDC CALL CLEAR WRITE ( NWRITE, 910 ) READ ( NREAD, 920 ) CALL CLEAR. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )@ CALL MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART ) CALL GOTOXY ( IX, IY ) ELSECC ----- INPUT LINEC* IF ( LENGTH(STRING) .EQ. 0 ) THENCC -------- POSITION CURSOR ONLYC IF ( DOWN ) THEN( IF ( IPTR .LT. NUM ) THEN! IPTR = IPTR + 1 IY = IY + 1( IF ( IY .GT. 23 ) THENCC -------------- SCROLL UPC IY = 23( ISTART = ISTART + 1B CALL MLIB_WRITL2 ( NWRITE, IY+1, IPTR, ARRAY,& $ ARRAY2 )* WRITE ( NWRITE, 940 ) CALL REVLF  ENDIF ELSE CALL REVLF  ENDIF ELSE& IF ( IPTR .GT. 1 ) THEN! IPTR = IPTR - 1 IY = IY - 1& IF (IY .LT. 2 ) THENCC -------------- DOWN SCROLLC IY = 2"  ISTART = IPTR+ CALL GOTOXY ( IX, IY ). WRITE ( NWRITE, 930 ) ESC@ CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, ARRAY,2 $ ARRAY2 ) ENDIF ENDIF% CALL GOTOXY ( IX, IY ) ENDIF ELSECC ------ MODIFY LINEC IL = 1 IA = 0;200 CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )% IF (  TYPE .EQ. 'E' ) THENC CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, ARRAY, ARRAY2 ) GO TO 100 ENDIFG IF (((TYPE .NE. 'R') .AND. (TYPE .NE. 'I')) .OR. ERR ) THEN CALL MBELL > CALL STAT ( IX, IY, ' Unintelligible input. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )C CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, ARRAY, ARRAY2 ) GO TO 100 ENDIF IA = IA + 1& IF ( IA .GT. NARRAY ) THEN CALL MBELL D CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )C CALL MLIB_WRITL2 ( NWRITE, IY, IPTR, ARRAY, ARRAY2 ) GO TO 100 ENDIFC!C ------- PUT NEW VALUE IN ARRAYC CALL RIGHT ( TOKE )! IF ( IA .EQ. 1 ) THEN0 READ ( TOKE, 950 ) ARRAY ( IPTR ) ELSE1 READ ( TOKE, 950 ) ARRAY2 ( IPTR ) ENDIF GO TO 200 ENDIF ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET  CALL CLEAR RETURN900 FORMAT ( A80 )H910 FORMAT (///,' A command is a line with a single letter on it :',/,D $ ' A)dd - add a blank line to the end of the arrays',/,< $ ' B)egin - go to the beginning of the arrays',/,2  $ ' D)elete - delete the current line',/,6 $ ' E)nd - go to the end of the arrays',/,B $ ' I)nsert - insert a line before the indicated line',/,* $ ' Q)uit - exit the editor',/,- $ ' R)epaint - repaint the screen',/,< $ ' S)croll - change the direction of scrolling',/,* $ ' ? - produce this message',///,G $ ' Any other line is expected to be data. Enter ^Z (control/Z)',$ $ /,' to exit the editor.',//," $ ' Enter to continue.')920 FORMAT ( A )930 FORMAT ('+',A1,'M',$ )940 FORMAT ( / )950 FORMAT ( 8X,F12.0 ) ENDC C---END RNAE2CA SUBROUTINE RNAE3 ( NUM, MAX, ARRAY, ARRAY2, ARRAY3, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** RNAE3 **3C* ** **3C*  *******************************3C* *******************************C*C* SUBPROGRAM : C* NIFTY ARRAY EDITOR 3C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :>C* TO ENABLE THE SCREEN-ORIENTED EDITING OF 3 ARRAYS.C*C* METHODOLOGY :DC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION.C*C* INPUT ARGUMENTS :2C* NUM - NUMBER OF ELEMENTS IN ARRAYS.-C* MAX - THE DIMENSION OF ARRAYS.)C* ARRAY - THE FIRST DATA ARRAY.*C* ARRAY2- THE SECOND DATA ARRAY.)C* ARRAY3- THE THIRD DATA ARRAY.C*C* OUTPUT ARGUMENTS :FC* ERROR - .TRUE. IF AN UNRECOVERABLE ERROR WAS ENCOUNTERED.C*C* INTERNAL WORK AREAS :8C* STRING - TEMPORARY STORAGE FOR INPUT STRING.C*C* FILE REFERENCES :C* NREAD, NWRITEC*C* SUBPROGRAM REFERENCES :FC* CLEAR, MLIB_NSTAT, MLIB_WRITA3, GOTOXY, CAPS, LEFT,GC* MBELL, STAT, SLEEP, MLIB_WRITL3, REVLF, GETOKE,C* RIGHT, SRESETC*C* ERROR PROCESSING :%C* CHECK FOR VALID COMMANDS.8C* CHECK FOR RIGHT NUMBER OF ENTRIES ON A LINE.C*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLE.C*%C* ASSUMPTIONS AND RESTRICTIONS :-C* VT-100 COMPATIBLE TERMINALS ONLY.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *80 STRING CHARACTER *20 TOKE CHARACTER *1 ESC, TYPE LOGICAL ERROR, DOWN, ERR4 DIMENSION ARRAY(MAX), ARRAY2(MAX), ARRAY3(MAX) DATA ESC/27/C+C NUM - THE NUMBER OF ELEMENTS IN ARRAY*C MAX - THE MAXIMUM DIMENSIO N OF ARRAY C ARRAY - THE DATA TO BE EDITED C ARRAY2- THE DATA TO BE EDITED C ARRAY3- THE DATA TO BE EDITED7C NARRAY - THE NUMBER OF ARRAYS ( 1 FOR THIS VERSION )C ERROR - INTERNAL ERROR FLAG3C DOWN - .TRUE. IF THE DEFAULT DIRECTION IS DOWN:C IPTR - THE ARRAY ELEMENT WE ARE PRESENTLY POINTING TO>C IX - X LOCATION OF CURSOR (ALWAYS 1 IN PRESENT VERSION)3C IY - Y LOCATION OF CURSOR (BETWEEN 2 AND 24) C NREAD - KEYBOARD UNIT NUMBERC NWRITE - SCREEN UNIT NUMBERC  STRING - INPUT BUFFERHC ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREENC% CALL MLIB_GET ('NWRITE',NWRITE)# CALL MLIB_GET ('NREAD',NREAD) ERROR = .FALSE. NARRAY = 3 IF ( NUM .GT. MAX ) THEN ERROR = .TRUE. RETURN ENDIF DOWN = .TRUE. IX = 1 IY = 2C:C --- DISPLAY INITIAL STATUS, DISPLAY FIRST PART OF ARRAYSC IPTR = 0 IF ( NUM .GE. 1 ) IPTR = 1 ISTART = IPTR+ CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )E CALL MLIB_WRITA3 ( NWRITE, NUM, ARRAY, ARRAY2, ARRAY3, ISTART ) CALL GOTOXY ( IX, IY )CC --- REPEAT UNTIL DONEC4100 READ ( NREAD, 900, END=1000, ERR=1000 ) STRING CALL CAPS ( STRING ) CALL LEFT ( STRING )$ IF (STRING(1:1) .EQ. 'A') THENCC ----- 'ADD' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELL B CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE ARRAY(NUM+1) = 0 ARRAY2(NUM+1) = 0 ARRAY3(NUM+1) = 0 NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ISTART = NUM - 21( IF (ISTART .LE. 0)ISTART = 1& IF (NUM .EQ. 0 )ISTART = 0A CALL MLIB_WRITA3 (NWRITE, NUM, ARRAY, ARRAY2, ARRAY3,% $ ISTART) IPTR = NUM#  IY = MIN0 ( NUM+1, 23 )" IF (NUM .EQ. 0) IY = 2" CALL GOTOXY ( IX, IY ) ENDIF) ELSE IF (STRING(1:1) .EQ. 'B') THENCC ----- 'BEGIN' COMMANDC IPTR = 0! IF (NUM .GE. 1) IPTR = 1 ISTART = IPTRH CALL MLIB_WRITA3 ( NWRITE, NUM, ARRAY, ARRAY2, ARRAY3, ISTART ) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'D') THENCC ----- 'DELETE' COMMANDC IF (NUM .GT. 0) THEN NUM = NUM - 1% IF (IPTR .EQ. NUM+1) THEN IPTR = NUM" ISTART = ISTART - 1( IF ( ISTART .LE. 0 ) THEN ISTART = 1 IY = IY - 1 ENDIF ELSE$ DO 110 II = IPTR, NUM) ARRAY(II) = ARRAY(II+1)+ ARRAY2(II) = ARRAY2(II+1)+ ARRAY3(II) = ARRAY3(II+1)110 CONTINUE;  IF ( ISTART+22 .GT. NUM )ISTART = ISTART - 1- IF ( ISTART .LE. 0 )ISTART = 1 ENDIF IF (NUM .EQ. 0) THEN ISTART = 0 IY = 2 ENDIF1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )A CALL MLIB_WRITA3 (NWRITE, NUM, ARRAY, ARRAY2, ARRAY3,% $ ISTART) ENDIF CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'E') THENCC ----- 'END' COMMANDC ISTART = NUM - 21% IF (ISTART .LE. 0)ISTART = 1# IF (NUM .EQ. 0 )ISTART = 0H CALL MLIB_WRITA3 ( NWRITE, NUM, ARRAY, ARRAY2, ARRAY3, ISTART ) IPTR = NUM IY = MIN0 ( NUM+1, 23 ) IF (NUM .EQ. 0) IY = 2 CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'I') THENCC ----- 'INSERT' COMMANDC IF (NUM .EQ. MAX) THEN CALL MBELL B CALL STAT ( IX, IY, ' Arrays full, insert ignored. ' ) CALL SLEEP ( 3 )1 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) ELSE# IF (IPTR .LE. NUM) THEN( DO 120 II = NUM, IPTR, -1) ARRAY(II+1) = ARRAY(II)+ ARRAY2(II+1) = ARRAY2(II)+ ARRAY3(II+1) = ARRAY3(II)120 CONTINUE ARRAY(IPTR) = 0 ARRAY2(IPTR) = 0 ARRAY3(IPTR) = 0 ELSE ARRAY(NUM+1) = 0 ARRAY2(NUM+1) = 0 ARRAY3(NUM+1) = 0 ENDIF NUM = NUM + 11 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )A CALL MLIB_WRITA3 (NWRITE, NUM, ARRAY, ARRAY2, ARRAY3,% $ ISTART)" CALL GOTOXY ( IX, IY ) ENDIFC) ELSE IF (STRING(1:1) .EQ. 'Q') THEN GO TO 1000C) ELSE IF (STRING(1:1) .EQ. 'R') THENCC ----- 'REPAINT' SCREENCH CALL MLIB_WRITA3 ( NWRITE, NUM, ARRAY, ARRAY2, ARRAY3, ISTART ) CALL GOTOXY ( IX, IY )C) ELSE IF (STRING(1:1) .EQ. 'S') THENC!C ----- 'SCROLL' DIRECTION TOGGLEC DOWN = .NOT. DOWN. CALL MLIB_NSTAT ( IX, IY, NUM, DOWN ) CALL GOTOXY ( IX, IY )CG ELSE IF ((STRING(1:1) .EQ. '?') .OR. (STRING(1:1) .EQ. 'H')) THENCC ----- 'HELP' COMMANDC CALL CLEAR WRITE ( NWRITE, 910 ) READ ( NREAD, 920 ) CALL CLEAR.  CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )H CALL MLIB_WRITA3 ( NWRITE, NUM, ARRAY, ARRAY2, ARRAY3, ISTART ) CALL GOTOXY ( IX, IY ) ELSECC ----- INPUT LINEC* IF ( LENGTH(STRING) .EQ. 0 ) THENCC -------- POSITION CURSOR ONLYC IF ( DOWN ) THEN( IF ( IPTR .LT. NUM ) THEN! IPTR = IPTR + 1 IY = IY + 1( IF ( IY .GT. 23 ) THENCC -------------- SCROLL UPC  IY = 23( ISTART = ISTART + 1B CALL MLIB_WRITL3 ( NWRITE, IY+1, IPTR, ARRAY,3 $ ARRAY2, ARRAY3 )* WRITE ( NWRITE, 940 ) CALL REVLF  ENDIF ELSE CALL REVLF  ENDIF ELSE& IF ( IPTR .GT. 1 ) THEN! IPTR = IPTR - 1 IY = IY - 1&  IF (IY .LT. 2 ) THENCC -------------- DOWN SCROLLC IY = 2" ISTART = IPTR+ CALL GOTOXY ( IX, IY ). WRITE ( NWRITE, 930 ) ESCH CALL MLIB_WRITL3 ( NWRITE, IY, IPTR, ARRAY, ARRAY2,+ $ ARRAY3 ) ENDIF ENDIF% CALL GOTOXY ( IX, IY ) ENDIF ELSECC ------ MODIFY LINEC  IL = 1 IA = 0;200 CALL GETOKE ( STRING, 80, IL, TOKE, TYPE, ERR )% IF ( TYPE .EQ. 'E' ) THENB CALL MLIB_WRITL3 ( NWRITE, IY, IPTR, ARRAY, ARRAY2,% $ ARRAY3 ) GO TO 100 ENDIFG IF (((TYPE .NE. 'R') .AND. (TYPE .NE. 'I')) .OR. ERR ) THEN CALL MBELL > CALL STAT ( IX, IY, ' Unintelligible input. ' ) CALL SLEEP ( 3 )4 C ALL MLIB_NSTAT ( IX, IY, NUM, DOWN )A CALL MLIB_WRITL3 (NWRITE, IY, IPTR, ARRAY, ARRAY2,( $ ARRAY3) GO TO 100 ENDIF IA = IA + 1& IF ( IA .GT. NARRAY ) THEN CALL MBELL D CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )A CALL MLIB_WRITL3 (NWRITE, IY, IPTR, ARRAY, ARRAY2,( $ ARRAY3) GO TO 100 ENDIFC!C ------- PUT NEW VALUE IN ARRAYC CALL RIGHT ( TOKE )! IF ( IA .EQ. 1 ) THEN0 READ ( TOKE, 950 ) ARRAY ( IPTR )& ELSE IF ( IA .EQ. 2 ) THEN1 READ ( TOKE, 950 ) ARRAY2 ( IPTR ) ELSE1 READ ( TOKE, 950 ) ARRAY3 ( IPTR ) ENDIF GO TO 200 ENDIF ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET  CALL CLEAR RETURN900 FORMAT ( A80 )H910 FORMAT (///,' A command is a line with a single letter on it :',/,D $ ' A)dd - add a blank line to the end of the arrays',/,< $ ' B)egin - go to the beginning of the arrays',/,2 $ ' D)elete - delete the current line',/,6 $ ' E)nd - go to the end of the arrays',/,B $ ' I)nsert - insert a line before the indicated line',/,* $ '  Q)uit - exit the editor',/,- $ ' R)epaint - repaint the screen',/,< $ ' S)croll - change the direction of scrolling',/,* $ ' ? - produce this message',///,G $ ' Any other line is expected to be data. Enter ^Z (control/Z)',$ $ /,' to exit the editor.',//," $ ' Enter to continue.')920 FORMAT ( A )930 FORMAT ('+',A1,'M',$ )940 FORMAT ( / )950 FORMAT ( 8X,F12.0 ) ENDC C---END RNAE3C: SUBROUTINE MLIB_WRITA ( NWRITE, NUM, ARRAY, ISTART )C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE ARRAYS (REAL)C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE ::C* TO WRITE A PORTION OF THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :0C* NWRITE - SCREEN LOGICAL UNIT NUMBER9C* NUM - THE NUMBER OF ENTRIES IN THE ARRAYS$C* ARRAY - THE DATA ARRAYAC* ISTART - THE FIRST LOCATION IN ARRAY TO BE DISPLAYEDC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :C* GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :'C* NON-STANDARD DATA STATEMENTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION ARRAY(1) CHARACTER *1 ESC DATA ESC/27/C IX = 1 IY = 2 CALL GOTOXY ( IX, IY ) WRITE ( NWRITE, 920 )ESC IF (ISTART .LE. 0) RETURN IFIRST = ISTART ILAST = ISTART + 21% IF (ILAST .GT. NUM) ILAST = NUM L = ILAST + 1 - IFIRST IF ( L .GT. 0 ) THEN! DO 100 I = IFIRST, ILAST, WRITE ( NWRITE, 900 )I, ARRAY(I)100 CONTINUE ENDIF RETURN'900 FORMAT(' ',I3,' ',F10.3,$ )!910 FORMAT(' ' )920 FORMAT('+',A1,'[J',$) ENDCC---END MLIB_WRITACC SUBROUTINE MLIB_WRITA2 ( NWRITE, NUM, ARRAY, ARRAY2, ISTART )C*3C* *******************************3C* *******************************3C* ** **4C* ** MLIB_WRITA2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE ARRAYSC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE ::C* TO WRITE A PORTION OF THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN8C* NUM - THE NUMBER OF ENTRIES IN THE ARRAYS(C* ARRAY - THE FIRST DATA ARRAY)C* ARRAY2- THE SECOND DATA ARRAYEC* ISTART - THE FIRST LOCATION IN THE ARRAYS TO BE DISPLAYEDC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :C* GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :'C* NON-STANDARD DATA STATEMENTC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*# DIMENSION ARRAY(1), ARRAY2(1) CHARACTER *1 ESC DATA ESC/27/C IX = 1 IY = 2 CALL GOTOXY ( IX, IY ) WRITE ( NWRITE, 920 )ESC IF (ISTART .LE. 0) RETURN IFIRST = ISTART ILAST = ISTART + 21% IF (ILAST .GT. NUM) ILAST = NUM L = ILAST + 1 - IFIRST IF ( L .GT. 0 ) THEN! DO 100 I = IFIRST, ILAST7 WRITE ( NWRITE, 900 )I, ARRAY(I), ARRAY2(I)100 CONTINUE ENDIF RETURN6900 FORMAT(' ',I3,' ',F12.5,' ',F12.5,$ )920 FORMAT('+',A1,'[J',$) ENDCC---END MLIB_WRITA2CA SUBROUTINE MLIB_WRITA3 (NWRITE, NUM, ARRAY, ARRAY2, ARRAY3,% $ ISTART)C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITA3 **3C* **  **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE ARRAYSC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE ::C* TO WRITE A PORTION OF THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN8C* NUM - THE NUMBER OF ENTRIES IN THE ARRAYS(C* ARRAY - THE FIRST DATA ARRAY)C* ARRAY2- THE SECOND DATA ARRAY(C* ARRAY3- THE THIRD DATA ARRAYEC* ISTART - THE FIRST LOCATION IN THE ARRAYS TO BE DISPLAYEDC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :C* GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :'C* NON-STANDARD DATA STATEMENTC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*. DIMENSION ARRAY(1), ARRAY2(1), ARRAY3(1) CHARACTER *1 ESC DATA ESC/27/C IX = 1 IY = 2 CALL GOTOXY ( IX, IY ) WRITE ( NWRITE, 920 )ESC IF (ISTART .LE. 0) RETURN IFIRST = ISTART ILAST = ISTART + 21% IF (ILAST .GT. NUM) ILAST = NUM L = ILAST + 1 - IFIRST IF ( L .GT. 0 ) THEN! DO 100 I = IFIRST, ILASTB WRITE ( NWRITE, 900 )I, ARRAY(I), ARRAY2(I), ARRAY3(I)100 CONTINUE ENDIF RETURNE900 FORMAT(' ',I3,' ',F12.4,' ',F12.4,' ',F12.4,$ )920 FORMAT('+',A1,'[J',$) ENDCC---END MLIB_WRITA3C7 SUBROUTINE MLIB_WRITL ( NWRITE, IY, IPTR, ARRAY )C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE LINE (REAL)C*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :=C* WRITE A SINGLE LINE FROM THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN9C* IY - THE ROW ON WHICH TO DISPLAY THE DATA9C* IPTR - THE INDEX INTO ARRAY TO BE DISPLAYED"C* ARRAY - THE DATA ARRAYC*C* FILE REFERENCES :C* NWRITEC*%C* TRANSPORTABILITY LIMITATION S :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 SCREENC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION ARRAY(1) CHARACTER *72 TC$ WRITE(T,900) IPTR, ARRAY(IPTR)* ISTAT = LIB$PUT_SCREEN ( T, IY, 1, ) IX = 1 CALL GOTOXY ( IX, IY  ) RETURN#900 FORMAT(' ',I3,' ',F10.3) ENDCC---END MLIB_WRITLC@ SUBROUTINE MLIB_WRITL2 ( NWRITE, IY, IPTR, ARRAY, ARRAY2 )C*3C* *******************************3C* *******************************3C* ** **4C* ** MLIB_WRITL2 **3C* ** **3C* *******************************3C*   *******************************C*C* SUBPROGRAM :C* WRITE LINEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :=C* WRITE A SINGLE LINE FROM THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN9C* IY - THE ROW ON WHICH TO DISPLAY THE DATACC*   IPTR - THE INDEX INTO THE DATA ARRAYS TO BE DISPLAYED(C* ARRAY - THE FIRST DATA ARRAY)C* ARRAY2- THE SECOND DATA ARRAYC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :#C* LIB$PUT_SCREEN, GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANG E HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*# DIMENSION ARRAY(1), ARRAY2(1) CHARACTER *72 TC2 WRITE(T,900) IPTR, ARRAY(IPTR), ARRAY2(IPTR)* ISTAT = LIB$PUT_SCREEN ( T, IY, 1, ) IX = 1 CALL GOTOXY ( IX, IY ) RETURN2900 FORMAT(' ',I3,' ',F12.5,' ',F12.5) ENDCC---END MLIB_WRITL2CH SUBROUTINE MLIB_WRITL3 ( NWRITE, IY, IPTR, ARRAY, ARRAY2, ARRAY3 )C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITL3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE LINEC*C* AUTHOR :C* ART RAGOSTAC*  MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :=C* WRITE A SINGLE LINE FROM THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN9C* IY - THE ROW ON WHICH TO DISPLAY THE DATACC* IPTR - THE INDEX INTO THE DATA ARRAYS TO BE DISPLAYED(C* ARRAY - THE FIRST DATA ARRAY)C* ARRAY2- THE SECOND DATA ARRAY(C* ARRAY3- THE THIRD DATA ARRAYC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :#C* LIB$PUT_SCREEN, GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*. DIMENSION ARRAY(1), ARRAY2(1), ARRAY3(1) CHARACTER *72 TC@ WRITE(T,900) IPTR, ARRAY(IPTR), ARRAY2(IPTR), ARRAY3(IPTR)* ISTAT = LIB$PUT_SCREEN ( T, IY, 1, ) IX = 1 CALL GOTOXY ( IX, IY ) RETURNA900 FORMAT(' ',I3,' ',F12.4,' ',F12.4,' ',F12.4) ENDCC---END MLIB_WRITL3C; SUBROUTINE MLIB_WRITA ( NWRITE, NUM, IARRAY, ISTART )C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE ARRAYSC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE ::C* TO WRITE A PORTION OF THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :0C* NWRITE - SCREEN LOGICAL UNIT NUMBER9C* NUM - THE NUMBER OF ENTRIES IN THE ARRAYS$C* IARRAY - THE DATA ARRAYBC* ISTART - THE FIRST LOCATION IN IARRAY TO BE DISPLAYEDC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :C* GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :'C* NON-STANDARD DATA STATEMENTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION IARRAY(1) CHARACTER *1 ESC DATA ESC/27/C IX = 1 IY = 2 CALL GOTOXY ( IX, IY ) WRITE ( NWRITE, 920 )ESC IF (ISTART .LE. 0) RETURN IFIRST = ISTART ILAST = ISTART + 21% IF (ILAST .GT. NUM) ILAST = NUM L = ILAST + 1 - IFIRST IF ( L .GT. 0 ) THEN! DO 100 I = IFIRST, ILAST- WRITE ( NWRITE, 900 )I, IARRAY(I)100 CONTINUE ENDIF RETURN$900 FORMAT(' ',I3,' ',I5,$ )!910 FORMAT(' ' )920 FORMAT('+',A1,'[J',$) ENDCC---END MLIB_WRITACE SUBROUTINE MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITA2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE ARRAYSC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE ::C* TO WRITE A PORTION OF THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN8C* NUM - THE NUMBER OF ENTRIES IN THE ARRAYS)C* IARRAY - THE FIRST DATA ARRAY*C* IARRAY2- THE SECOND DATA ARRAYEC* ISTART - THE FIRST LOCATION IN THE ARRAYS TO BE DISPLAYEDC*C* FILE REFERENCES :C*  NWRITEC*C* SUBPROGRAM REFERENCES :C* GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :'C* NON-STANDARD DATA STATEMENTC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*% DIMENSION IARRAY(1), IARRAY2(1) CHARACTER *1 ESC DATA ESC/27/C IX = 1 IY = 2 CALL GOTOXY ( IX, IY ) WRITE ( NWRITE, 920 )ESC IF (ISTART .LE. 0) RETURN IFIRST = ISTART ILAST = ISTART + 21% IF (ILAST .GT. NUM) ILAST = NUM L = ILAST + 1 - IFIRST IF ( L .GT. 0 ) THEN! DO 100 I = IFIRST, ILAST9 WRITE ( NWRITE, 900 )I, IARRAY(I), IARRAY2(I)100 CONTINUE ENDIF RETURN0900 FORMAT(' ',I3,' ',I5,' ',I5,$ )920 FORMAT('+',A1,'[J',$) ENDCC---END MLIB_WRITA2CD SUBROUTINE MLIB_WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3,% $ ISTART)C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITA3 **3C* ** **3C* *******************************3C*  *******************************C*C* SUBPROGRAM :C* WRITE ARRAYSC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE ::C* TO WRITE A PORTION OF THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN8C* NUM - THE NUMBER OF ENTRIES IN THE ARRAYS)C* IARRAY - THE FIRST DATA ARRAY*C* IARRAY2- THE SECOND DATA ARRAY)C* IARRAY3- THE THIRD DATA ARRAYEC* ISTART - THE FIRST LOCATION IN THE ARRAYS TO BE DISPLAYEDC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :C* GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :'C* NON-STANDARD DATA STATEMENTC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*1 DIMENSION IARRAY(1), IARRAY2(1), IARRAY3(1) CHARACTER *1 ESC DATA ESC/27/C IX = 1 IY = 2 CALL GOTOXY ( IX, IY ) WRITE ( NWRITE, 920 )ESC IF (ISTART .LE. 0) RETURN IFIRST = ISTART ILAST = ISTART + 21% IF (ILAST .GT. NUM) ILAST = NUM  L = ILAST + 1 - IFIRST IF ( L .GT. 0 ) THEN! DO 100 I = IFIRST, ILASTE WRITE ( NWRITE, 900 )I, IARRAY(I), IARRAY2(I), IARRAY3(I)100 CONTINUE ENDIF RETURN<900 FORMAT(' ',I3,' ',I5,' ',I5,' ',I5,$ )920 FORMAT('+',A1,'[J',$) ENDCC---END MLIB_WRITA3C8 SUBROUTINE MLIB_WRITL ( NWRITE, IY, IPTR, IARRAY )C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE LINEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C* C* PURPOSE :=C* WRITE A SINGLE LINE FROM THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN9C* IY - THE ROW ON WHICH TO DISPLAY THE DATA:C* IPTR - THE INDEX INTO IARRAY TO BE DISPLAYED#C* IARRAY - THE DATA ARRAYC*C* FILE REFERENCES :C* NWRITEC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :C*! VT-100 SCREENC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION IARRAY(1) CHARACTER *72 TC# WRITE(T,900)IPTR,IARRAY(IPTR)* ISTAT = LIB$PUT_SCREEN ( T, IY, 1, ) IX = 1 CALL GOTOXY ( IX, IY ) RETURN 900 FORMAT(' ',I3,' ',I5) ENDCC---END MLIB_W"RITLCB SUBROUTINE MLIB_WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 )C*3C* *******************************3C* *******************************3C* ** **8C* ** MLIB_WRITL2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRIT#E LINEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :=C* WRITE A SINGLE LINE FROM THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN9C* IY - THE ROW ON WHICH TO DISPLAY THE DATACC* IPTR - THE INDEX INTO THE DATA ARRAYS TO BE DISPLAYED)C* IARR$AY - THE FIRST DATA ARRAY*C* IARRAY2- THE SECOND DATA ARRAYC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :#C* LIB$PUT_SCREEN, GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC*****************%******************************************************C*% DIMENSION IARRAY(1), IARRAY2(1) CHARACTER *72 TC4 WRITE(T,900) IPTR, IARRAY(IPTR), IARRAY2(IPTR)* ISTAT = LIB$PUT_SCREEN ( T, IY, 1, ) IX = 1 CALL GOTOXY ( IX, IY ) RETURN,900 FORMAT(' ',I3,' ',I5,' ',I5) ENDCC---END MLIB_WRITL2CA SUBROUTINE MLIB_WRITL3 ( NWRITE, IY, IPTR, IARRAY, IARRAY2,' $ IARRAY3 )C*3C* &*******************************3C* *******************************3C* ** **4C* ** MLIB_WRITL3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE LINEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CE'NTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*C* PURPOSE :=C* WRITE A SINGLE LINE FROM THE ARRAYS BEING EDITED.C*C* INPUT ARGUMENTS :;C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN9C* IY - THE ROW ON WHICH TO DISPLAY THE DATACC* IPTR - THE INDEX INTO THE DATA ARRAYS TO BE DISPLAYED)C* IARRAY - THE FIRST DATA ARRAY*C* IARRAY2- THE SECOND DATA ARRAY)C* IARRAY3- THE THIRD DAT(A ARRAYC*C* FILE REFERENCES :C* NWRITEC*C* SUBPROGRAM REFERENCES :#C* LIB$PUT_SCREEN, GOTOXYC*%C* TRANSPORTABILITY LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 TERMINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*1 ) DIMENSION IARRAY(1), IARRAY2(1), IARRAY3(1) CHARACTER *72 TCC WRITE(T,900) IPTR, IARRAY(IPTR), IARRAY2(IPTR), IARRAY3(IPTR)* ISTAT = LIB$PUT_SCREEN ( T, IY, 1, ) IX = 1 CALL GOTOXY ( IX, IY ) RETURN8900 FORMAT(' ',I3,' ',I5,' ',I5,' ',I5) ENDCC---END MLIB_WRITL3C1 SUBROUTINE MLIB_NSTAT ( IX, IY, NUM, DOWN )C*3C* *******************************3C* ********************************3C* ** **3C* ** MLIB_NSTAT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* NAE STATUSC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 604-5558C*+C* PURPOSE :4C* TO DISPLAY THE STATUS OF THE NAE EDITOR.C*C* METHODOLOGY :)C* USE VT-100 CONTROL SEQUENCES.C*C* INPUT ARGUMENTS :(C* IX - X LOCATION OF CURSOR(C* IY - Y LOCATION OF CURSOR/C* NUM - NUMBER OF ENTRIES IN ARRAYS2C* DOWN - IS DOWN THE DEFAULT DIRECTION?C*C* SUBPROGRAM REFERENCES :<C* LIB$PUT_SCREEN, LIB$SET_CURSOR, LIB$SET_SCROLLC*%C* TRANSPORTABILITY LIMITATIONS :C* , NOT TRANSPORTABLE.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* 4-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *79 T CHARACTER *1 ESC LOGICAL DOWN DATA ESC/27/C IF ( DOWN ) THEN WRITE ( T, 900 ) NUM ELSE WRITE ( T, 910 ) NUM ENDIFC,C --- PUT MESSAGE ON LINE 1 IN REVERSE VIDEOC IFLAG = 2/ ISTAT = LIB$PUT_SCREEN ( T, 1, 1, IFLAG )C3C --- RESTORE CURSOR LOCATION AND SET SCROLL REGIONC' ISTAT = LIB$SET_CURSOR ( IY, IX )& ISTAT = LIB$SET_SCROLL ( 2, 24 ) RETURN 900 FORMAT( $' Entries=',I3,F $' Direction=Down Commands=A,B,D,E,I,R,S,?,^Z ') 910 FORMAT( $' Entries=',I3,F $' Direction=Up Commands=A,B,D,E,I,R,S,?,^Z ') ENDCC---END MLIB_NSTATCww .Jێ- 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* OUTPU0T 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 *(*) IPNAME1# 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_PIDCww3u1=ێ" FUNCTION NDEX (STRING, TARG)C*3C* *******************************3C* *******************************3C* ** **3C* ** NDEX **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* END INDEXC*C* AUTHOR 4: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 CHARACTE5RC*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 NDEXCww7@T;Uێ SUBROUTINE NUMERICC*3C* *******************************3C* *******************************3C* ** **3C* ** NUMERIC **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAGOSTA%MR8L.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:wێ SUBROUTINE OCTDEC ( O, I )C*3C* *******************************3C* *******************************3C* ** **3C* ** OCTDEC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* OCTAL TO DECIMALC*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 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 OCTDECCww=/sێ% 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 B܎- SUBROUTINE OPERW ( MESSAG, WHO, REPLY )C*3C* *******************************3C* *******************************3C* ** **3C* ** OPERW **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :+C* OPERATOR MESSAGE/WCAIT 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*D 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 OEF 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 *(*)F 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 CONTIGNUE 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 x* SUBROUTINE MLIB_Error (Isever, Text)C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** MLIB_Error ** 3C* ** ** 3C* ******************************* 3C* ******************************* C*C* AUTHOR : C* Arthur E. Ragosta T2C* Jʝ܎ SUBROUTINE ORDINAL (NUM)C*3C* *******************************3C* *******************************3C* ** **3C* ** ORDINAL **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta0C* RAGOSTKA%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 REFERENCESL :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 ORDINALCww NW-܎= SUBROUTINE PackOut (nout, in, out, iout, cstring, cend)C*3C* *******************************3C* *******************************3C* ** **3C* ** PackOut **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* ArthurO 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 PXT 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 OUTQC*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'tR 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. S 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) T 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 flushoutcwwV((ݎ SUBROUTINE PCALFA C*3C* *******************************3C* *******************************3C* ** **3C* ** PCALFA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PCALFAC*C* AUTHOR :C* W 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 PCALFACwwYpݎ. INTEGER FUNCTION Print_File ( fname, q )C*3C* *******************************3C* *******************************3C* ** **3C* ** Print_File **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 2ZC* 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 queue[C*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 st\ructure / 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_FileCww^@ގ" 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 PROMPTCwwaHOR :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* TRANSPORTABILITbY 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 HISTcORY :(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 PUTCCwwe@˟ގ SUBROUTINE PUTCHAR ( STR )C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTCHAR **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* Arthur E. Ragosta 0C* RAfGOSTA%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 PUTCHARCwwfter it*c3c ----- if the * is all there is, it always matchesRc( if (lw .ne. 1) then if (i .gt. 1) then: if (wild(1:i-1) .ne. notwild(1:i-1)) return endifN if (i .lt. lw) then1% ins = lnw - lw + i + 1 = if (wild(i+1:lw) .ne. notwild(ins:lnw)) returnA endifR endif else if (lw .ne. lnw) return iws = 1"10 i = index(wild(iws:),'%') if (i .neieDi8 function m2i ( month )" character *3 months(12), tmpA data months /'JAN', 'FEB', 'MAR', 'APR', 'MAY', 'JUN',b6 $ '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)) return 10 continue m2i = 0o return endec c---end m2ilcO$ 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 end c c---end i2m c ww;C* ** **4;C* *******************************4;C* *******************************;C* ;C* SUBPROGRAM :;C* LEFT JUSTIFYM;C* ;C* AUTHOR :;C* ART RAGOSTA;C* MS 219-3Y!;C*  TOKEN(TSIZE:TSIZE) = CHE TSIZE = TSIZE + 1L IPTR = IPTR + 1& IF (IPTR .GT. LL) GO TO 60 CH = LINE(IPTR:IPTR) ENDIF GO TO 32 C E ELSE IF (((CH .GE. '0') .AND. (CH .LE. '9')) .OR. (CH .EQ. '+')P9 $ .OR. (CH .EQ. '-') .OR. (CH .EQ. '.')) THEN C ,C ----- NUMERICAL TYPE... DEFAULT TO INTEGERC* TYPE = 'I'C =C --- CHECK FOR LEADING SIGN AS THESE MAY NOT DENOTE A NUMBER C3 IF ((CH .l`}jߎ# SUBROUTINE PUTSTRING (STRING)C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTSTRING **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PUTSTRINGC*C* AUTHOmR :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* LANGUnAGE 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 PUTSTRINGCwwpߎ% SUBROUTINE QSORT ( X, N, WORK )C*3C* *******************************3C* *******************************3C* ** **3C* ** QSORT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* QUICK SORTC*C* AUTqHOR :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 POINTErRS 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 (LEFsT(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 t 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 u 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)v 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 QSORTCwwx@ߎ SUBROUTINE QSORTI ( X, N )C*3C* *******************************3C* *******************************3C* ** **3C* ** QSORTI **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM : C* QUICK SORT (INTEGER)C*C* y 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* z 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) .G|T. 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. (WOR}K .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 QSORTRCwwU ߎ 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/5 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ގ} 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@Н葓 .title peek;Y; Author: Arthur E. Ragosta;G; Look at the byte at the specified location. Location by reference.;; i = peek (location); ; Example:; i = peek (%loc(x))G;A .entry peek,^m<>R: movl @4(ap),r1 ;address of location to r11 movb (r1),r0 ;move that sucker ret .endww SEND@N  RAGOSTA SENDW U  RAGOSTA SETIME9e `}q 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 READKEYCwwii᎓! SUBROUTINE READQ ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** READQ **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* READ QUIETC*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* 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൵, 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 MODIFYI-C* OLD - THE CHARACTER TO REPLACEE;C* NEW - THE CHARACTER WITH WHICH TO REPLACE IT C*C* OUTPUT ARGUMENTS :E(C* STRING - THE MODIFIED STRINGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77EC*C* CHANGE HISTORY : (C* 1-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGR CHARACTER *1 OLD, NEWUC  DO 10 I = 1, LEN(STRING)4 IF (STRING(I:I) .EQ. OLD) STRING(I:I) = NEW10 CONTINUEL RETURN ENDMC8C---END REPLACC wwARACTER7`5 SUBROUTINE REVLF GC*3C* ********************************3C* *******************************(3C* ** **(3C* ** REVLF **$3C* ** **,3C* *******************************3C* *******************************(C*C* SUBPROGRAM :$C* REVERSE LINE FEEDC*C* AUTHOR :0C* ART RAGOSTAIC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035 C* (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 77AC*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 REVLFCww@, INTEGER FUNCTION READT ( ITIME, BUFF )C*3C* *******************************3C* *******************************3C* ** **3C* ** READT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* READ WITH TIMEOUTC*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 HOLDING 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 CHARACTER7C* 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 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.NC*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.WC*C* OUTPUT ARGUMENTS :5&C* ANSWER - THE USER'S ANSWERC*C* FILE REFERENCES :C* NIN, NOUT C*C* SUBPROGRAM REFERENCES :;C* LENGTH, CLEAR, FIRST, BLANKS, RIGHT, MBELLSC*C* ERROR PROCESSING : BC* CHECK FOR ERRORS DURING CONVERSION OF INPUT TO INTEGER)C* CHECK RESPONSE AGAINST LIMITSIC*%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 77 C*C* CHANGE HISTORY : (C* 26-NOV-85 INITIAL VERSION<C* 29-JUN-90 CLEANED UP FOR OTHER MERLIB CHANGES6C* 17-APR-95 returns 0 on end of file (^Z)C*HC***********************************************************************C*& CHARACTER *(*) CHOICE(N), PROMPT CHARACTER *79 LINE CHARACTER *2 A CHARACTER *1 CC  INTEGER ANSWER, BLANKSCF IF (N .LT. 1) RETURN! CALL MLIB_GET ('NREAD',NIN) $ CALL MLIB_GET ('NWRITE', NOUT)C -C --- HOW MANY CHOICES WILL FIT ON 1 SCREEN ? C 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 = 18 ! ELSE IF (N .LT. 37) THENK NS = 36M ELSEC NS = 54( ENDIF ELSE IF (L .LT. 34) THEN IF (N .LT. 19) THEN NS = 18* ELSE* NS = 36* ENDIF ELSE NS = 18 ENDIF CE C --- NUMBER OF SCREENS REQUIREDC  NR = (N + NS - 1) / NSCAC --- DISPLAY CHOICES(CT IW = 1 IF (N .GT. 9) IW = 2 IF (N .GT. 99) IW = 3E 10 IS = 1 DO 100 I = 1, NR CALL CLEARB  WRITE(NOUT,900) PROMPTI WRITE(NOUT,910)C)/C --- PUT NEXT SCREEN FULL, WITH CHOICE NUMBERSPC. IE = MIN0(IS+17,N)Y DO 50 II=IS,IEUCC --------- ONE COLUMN WIDEOCI IF (NS .EQ. 18) THEN WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS) IS = IS + 1C(C --------- TWO COLUMNS WIDEC % ELSE IF (NS .EQ. 36) THENO WRITE(A,990) IS. LINE = A // '. ' // CHOICE(I@bD! 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, MLIB_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 SCOLORCww3& 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 THE 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 77C*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 f D SUBROUTINE SEARCH ( STRING, NSTRNG, TARGET, K, MATCHD, AMBIG )C*3C* *******************************3C* *******************************3C* ** **3C* ** SEARCH **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C*  BINARY SEARCHC*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* 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 OTHERWISEHC* 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 77C*C* CHANGE HISTORY :(C* 16-JAN-85 INITIAL VERSIONEC* 05-FEB-86 BUG FIXED FOR TARGET LARGER THAN MAX ELEMENTCC* 09-MAY-88 REMOVED REPLACEMENT FOR ABBREVIATED TARGETC*HC***********************************************************************C*" LOGICAL MATCH, MATCHD, AMBIG& CHARACTER *(*) STRING(1), TARGETC MATCHD = .FALSE. AMBIG = .FALSE.CC --- 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. RETURN" ELSE IF (I .GT. NSTRNG) THEN RETURN ENDIFCHC --- SINCE NO MATCH WAS FOUND, I SHOULD POINT TO THE NEXT LARGEST ENTRYC --- IN THE STRINGS ARRAYC L = LENGTH(TARGET) K = I5 CALL MLIB_COMPAR (TARGET, L, STRING(I), MATCHD) IF ( MATCHD ) THEN IF (I .LT. NSTRNG) THEN< CALL MLIB_COMPAR (TARGET, L, STRING(I+1), MATCH)' IF ( MATCH ) AMBIG = .TRUE. ENDIF ENDIF RETURN ENDCC---END SEARCHC; SUBROUTINE MLIB_COMPAR (TARGET, LTARG, STRING, MATCH)C*3C* *******************************3C* *******************************3C* ** **3C*  ** MLIB_COMPAR **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 STRING MATCHES A TARGET STRING UP TO A*C* SPECIFIED NUMBER OF CHARACTERSC*C* INPUT ARGUMENTS :'C* TARGET - THE TARGET STRINGCC* LTARG - THE NUMBER OF CHARACTERS IN "TARGET" TO CHECK2C* STRING - THE STRING WE'RE LOOKING FORC*C* OUTPUT ARGUMENTS :6C* MATCH - TRUE IF MATCHED, FALSE OTHERWISEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :+C* 8-MAR-1989 - INITIAL VERSIONC*HC***********************************************************************C*# CHARACTER *(*) TARGET, STRINGC MATCH = .FALSE.C>C --- IF THE TARGET IS LONGER THAN THE SEARCH STRING, NO MATCHC LS = LEN(STRING) IF (LTARG .GT. LS) RETURNCC --- COMPARE SUBSTRINGSC> IF (TARGET(1:LTARG) .EQ. STRING(1:LTARG)) MATCH = .TRUE. RETURN ENDCC---END MLIB_COMPARCww. 0) thenL iwp = iws + i - 1U? if (wild(iws:iwp-1) .ne. notwild(iws:iwp-1)) return  iws = iwp + 1`% if (iws .lt. lw) go to 10 elseM5 if (wild(iws:) .ne. notwild(iws:)) returnJ endif endif match_word = .true. RETURN ENDUCC---END match_wordC wwNKS @$ؓ RAGOSTA CAPITAL Nؓ RAGOSTA CAPS;=ؓ RAGOSTA LEFT# RAGOSTA IMAGE_N `֡@. SUBROUTINE PUTSTM ( NUNIT, LABEL, STMT )C*3C* *******************************C3C* ********************************3C* ** ** 3C* ** PUTSTM **A3C* ** ** 3C* *******************************3C* *******************************SC*C* SUBPROGRAM :M4C* PUT STATEMENT  C*C* AUTHOR :T4C* 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 :(rC* 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 *(*) STMTL CHARACTER *6 TLABELE CHARACTER *5 LABELC A IST = 1 ! POINTER TO NEXT LOCATION TO PRINT. L = LENGTH(STMT) ! LENGTH OF STMT@ LS = L  $ SUBROUTINE SEND ( USER, TEXT )C*3C* *******************************3C* *******************************3C* ** **3C* ** SEND **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SEND MESSAGEC*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 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 A0:). 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* 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, 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 ENDIF4 ISTAT = SYS$BRKTHRU ( ,TEXT(1:LT), USER(1:LU),= $ %VAL(TYPE), II,,,, %VAL(TIME),,) RETURN ENDC C---END SENDCww ` 5 SUBROUTINE SENDW ( USER, TEXT, NUMOK, NUMFAIL )C*3C* *******************************3C* *******************************3C* ** **3C* ** SENDW **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :!C* SEND MESSAGE 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 SERKC* 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  - 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 HAVE '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 SENDWCwwG  SUBROUTINE SETIMEC*3C* *******************************3C* *******************************3C* ** **3C* ** SETIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SET TIMEC*C* AUTHOR :C*  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 SETIMECwwf5e $ SUBROUTINE SLEEP ( REAL_TIME )C*3C* *******************************3C* *******************************3C* ** **3C* ** SLEEP **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* 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* 'REAL_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 SLEEPCwwsEQ. '-') .OR. (CH .EQ. '+')) THEN / IF (TSIZE .GT. LEN(TOKEN)) GO TO 60 # TOKEN(TSIZE:TSIZE) = CH  TSIZE = TSIZE + 1S IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOLR ELSE# CH = LINE(IPTR:IPTR)O ENDIF # IF ((CH .NE. '.') .AND.C7 $ ((CH .LT. '0') .OR. (CH .GT. '9'))) THENE TYPE = 'S'S RETURN  ENDIFU END} $ SUBROUTINE SORT ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **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 :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 SORT. 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 SORTCww % SUBROUTINE SORTI ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **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 :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* 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 SORTICww@ % SUBROUTINE SORTR ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **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 :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`x  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 DESCRIPTOR, $.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 SRESETCwwK# SUBROUTINE STAT ( IX, IY, T )C*3C* *******************************3C* *******************************3C* ** **3C* ** STAT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STATUS LINEC*C* AUTHOR :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 - THE 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 STATCww 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 CenterE%C* Moffett Field, Ca. 94035TC* (415) 604-5558C*C* DESCRIPTION :'C* Produce an error message. HC*C* INPUT ARGUMENTS :AC* ISEVER = severity; 0-Inform, 1-Warn, 2-Error, 3-FatalT,C* TEXT = the text of the messageC*C* SUBPROGRAM REFERENCES :C* MLIB_GETC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY : +C* 3-JUL-1990 - INITIAL VERSIONC*HC***********************************************************************C* character *(*) textc% call mlib_get ('NERROR',nerror) if (isever .eq. 0) then0E write(nerror,900) 'MERLIB Information', Text(1:length(Text))R" else if (isever .eq. 1) thenA write(nerror,900) 'MERLIB Warning', 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)) endif2 RETURN900 format(' ',A,' --- ',A)O END CAC---END MLIB_ErrorCR* SUBROUTINE MLIB_Get ( name, ivalue )C*3C* *******************************3C* ******************************* 3C* ** **3C* ** MLIB_Get **-3C* ** **W3C* ******************************* 3C* *******************************MC*C* AUTHOR :C* Arthur E. Ragosta m2C* RAGOSTA@MRL.SPAN.NASA.GOV (Internet)C* or.C* RAGOSTA%MRL.SPAN@AMES.ARC.NASA.GOV C* C* MS 219-3%C* !3 SUBROUTINE STRPSTM (STM, LENST, SSTM, LENSST)C*3C* *******************************3C* *******************************3C* ** **3C* ** STRPSTM **3C* ** **3C* *******************************3C* *******************************C*C* AUTHOR :C* L JURGELEITC* 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 AND 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 STRPSTMCwwK( SUBROUTINE SUBMIT ( FNAME, QUEUE )C*3C* *******************************3C* *******************************3C* ** **3C* ** SUBMIT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* SUBMIT BATCH JOBC*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 QUEUEC*C* SUBPROGRAM REFERENCES :"C* LIB$SIGNAL, SYS$SNDJBCC*%C* ASSUMPTIONS AND RESTRICTIONS :(C* 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  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 EUE+ 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 5 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$SNDJBCW, 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  4- 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_CANCELCww J* 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 @x3dint trim (char s[]){ int n; for (n=strlen(s)-1; n>=0; n--) if (s[n] != ' ') break; s[n+1] = '\0'; return n;}ww|1( 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.GOVrC* 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 right !a> SUBROUTINE FRMSTD ( VALIN, STRIN, VALOUT, STROUT, IERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** FRMSTD **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* FR"OM STANDARD UNITSC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 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'4C* STROUT - THE REQUESTED UNITS OF 'VALOUT'C*C* OUTPUT ARGUMENTS :/C* VALOUT - T#HE VALUE AFTER CONVERTING$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 UNITSC*C* SUBPROGRAM REFERENCES :C* TOSTD, MLIB_CMPARC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :(C* $ 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C*" CHARACTER *(*) STRIN, STROUT CHARACTER *255 STEMPC=C --- USE TOSTD TO CALCULATE THE CONVERSION FACTOR FOR STROUTC VTEMP = 1.06 CALL TOSTD ( VTEMP, STROUT, VTEMP, STEMP, IERR ) IF ( IERR .NE. 0 ) RETURNC3C --- VTEMP HAS THE FACTOR FOR THE NON-STD UNITS...2C --- DIVIDE AND MAKE SURE THE UNITS ARE THE SAMEC, CALL MLIB_CMPAR ( ST%RIN, STEMP, IERR )- IF (IERR .EQ. 0) VALOUT = VALIN / VTEMP RETURN ENDCC---END FRMSTDC= SUBROUTINE TOSTD ( VALIN, STRIN, VALOUT, STROUT, IERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** TOSTD **3C* ** **3C* ******************************&*3C* *******************************C*C* SUBPROGRAM :C* TO STANDARD UNITSC*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.C*C* METHODOLOGY :HC* PARSES THE I 'NPUT 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 UNITS=C* STROUT - THE STRING CONTAINING THE STA (NDARD UNITS!C* IERR - 0 = NO ERRORDC* 1 = ILLEGAL CHARACTERS IN UNITS OR BAD EXPONENT5C* 2 = UNKNOWN UNIT IN INPUT STRING7C* 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 )FOR REPLACEMENT OF NON-STD SYMBOLSGC* TOP, BOTTOM - ARRAYS TO HOLD THE UNITS EXTRACTED FROM STRINC*C* SUBPROGRAM REFERENCES :EC* LENGTH, MLIB_PARSE, MLIB_STD, MLIB_POLISH, MLIB_EVAL,C* MLIB_BUILD, CAPSC*C* ERROR PROCESSING :*C* ERRORS PASSED FROM SUBROUTINESC*%C* ASSUMPTIONS AND RESTRICTIONS :JC* THE INPUT UNITS STRING AND THE RESULTING OUTPUT STRING MUST BE)C* SHORTER THAN 255 CHARACTERS.C*C* LANGU*AGE AND COMPILER :C* ANSI FORTRAN 77C*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) LOGICAL ERRORC WORK =+ STRIN CALL CAPS ( WORK ) ERROR = .FALSE. IERR = 0 L = LENGTH ( WORK )C8C --- PASS 1, REPLACE '-' WITH '*' AND '**' WITH '^'C J = 0 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. ' ') THEN J =, J + 1 WORK(J:J) = WORK(I:I) ENDIF I = I + 1 IF ( I .LE. L )GO TO 5 WORK(J+1:) = ' 'CC --- PASS 2, PARSE INTO TOKENSC5 CALL MLIB_PARSE ( WORK, J, TOKE, NTOKE, ERROR ) IF ( ERROR ) THEN IERR = 1 RETURN ENDIFC6C --- PASS 3, REPLACE NON-STANDARD UNITS WITH STANDARDC1 CALL MLIB_STD ( FACTS, TOKE, NTOKE, ERROR ) IF ( NERR .NE. 0 ) THEN IF ( NERR .EQ. 1 ) THEN IERR = 2$ - ELSE IF ( NERR .EQ. 2 ) THEN IERR = 3 ENDIF RETURN ENDIFC'C --- PASS 4, CONVERT TO REVERSE POLISHC4 CALL MLIB_POLISH ( TOKE, NTOKE, FACTS, ERROR ) IF ( ERROR ) THEN IERR = 4 RETURN ENDIFC)C --- 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 .OUTPUT UNIT STRINGC9 CALL MLIB_BUILD ( STROUT, TOP, NTOP, BOTTOM, NBOT ) RETURN ENDC C---END TOSTDC< SUBROUTINE MLIB_BUILD ( STR, TOP, NTOP, BOTTOM, NBOT )C*3C* *******************************3C* *******************************3C* ** **3C* ** BUILD **3C* ** **3C* ****************/***************3C* *******************************C*C* SUBPROGRAM :C* BUILD OUTPUT LINEC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER%C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*C* PURPOSE :EC* BUILD THE STRING OF OUTPUT UNITS, CANCELLING UNITS ON TOPC* AND BOTTOM.C*C* INPUT ARGUMENTS :1C* TOP - UNITS WHICH ARE IN NUMERATOR"C*0 NTOP - NUMBER IN TOP)C* BOTTOM - UNITS IN DENOMINATOR%C* NBOT - NUMBER IN BOTTOMC*C* OUTPUT ARGUMENTS :3C* STR - THE TOTAL STRING OF OUTPUT UNITSC*C* INTERNAL 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* C1HANGE HISTORY :(C* 13-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *500 TSTR CHARACTER *(*) STR, CHARACTER *6 TOP(40), BOTTOM(40), WORKC STR = ' ' IS = 1C0C --- DELETE DUPLICATE ENTRIES ON TOP AND BOTTOMC I = 110 IF (NTOP .GT. 0) THEN DO 20 J = 1, NBOT+ IF (TOP(I) .EQ. BOTTOM(J)) THEN' BOTTOM(J) = BOTTOM(NBOT)! 2 TOP(I) = TOP(NTOP) NTOP = NTOP - 1 NBOT = NBOT - 1$ IF (I .LE. NTOP) THEN GO TO 10 ELSE GO TO 30 ENDIF ENDIF20 CONTINUE I = I + 1" IF (I .LE. NTOP) GO TO 10 ENDIFCBC --- REPLACE MULTIPLE ENTRIES WITH '**'N, ADD TOP UNITS TO STRINGC 30 I = 135 IF (I .LE. NTOP) THEN STR(IS:) = TOP(I)! IS = IS +3 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 ENDIF J = J + 1 GO TO 40 ENDIFC;C ----- IF THERE WERE MORE THAN ONE, REPLACE FIRST WITH **NC IF (IC .GT. 1) THEN WRITE(WORK4,900) IC CALL LEFT ( WORK )5 TSTR = '*' // WORK(1:LENGTH(WORK)) // '*' STR(IS:) = TSTR" IS = IS + LENGTH(TSTR) ENDIF I = I + 1 GO TO 35 ENDIF IF ( NTOP .EQ. 0 ) THEN STR = '1*' IS = 3 ENDIFC>C --- REPLACE LAST '*' WITH '/' UNLESS THERE IS NO DENOMINATORC IF (NBOT .LE. 0) THEN IF (NTOP .EQ. 0) THEN# STR = 'Non Dimensional' RE5TURN 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 6 IC = IC + 1* BOTTOM(J) = BOTTOM(NBOT)! NBOT = NBOT - 1 GO TO 50 ENDIF J = J + 1 GO TO 50 ENDIFC;C ----- IF THERE WERE MORE THAN ONE, REPLACE FIRST WITH **NC IF (IC .GT. 1) THEN! WRITE(WORK,900) IC! CALL LEFT ( WORK )8 TSTR = '*' // WORK(1:LENGTH(WORK)) // '*' STR(IS:) = TSTR% IS = IS7 + LENGTH(TSTR) ENDIF I = I + 1 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* ** 8 **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* COMPARE UNITSC*C* AUTHOR :C* ART RAGOSTAC* 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, IFGC* THEY ARE THE SAME, SUCCESS, OTHERWISE TH9E 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 :&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, QSORTC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION A:ND DATE :%C* VERSION I.0 24-SEP-85C*C* CHANGE HISTORY :(C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) S1, S2) CHARACTER *6 TOP(50), BOT(50), WORK LOGICAL ERRORC ERROR = .FALSE. IERR = 0 CALL CAPS ( S1 ) L = LENGTH ( S1 )C8C --- PASS 1, REPLACE '-' WITH '*' AND '**' WITH '^'C J = 0 I = 1 5 IF (;S1(I:I) .EQ. '-') THEN J = J + 1 S1(J:J) = '*'C0C --- ALL OTHER CHARACTERS EXCEPT ' ' GET COPIEDC% ELSE IF (S1(I:I) .NE. ' ') THEN J = J + 1 S1(J:J) = S1(I:I) ENDIF I = I + 1 IF ( I .LE. L )GO TO 5 S1(J+1:) = ' 'CC --- PASS 2, PARSE INTO TOKENSC1 CALL MLIB_PARSE ( S1, J, TOP, NTOP, ERROR ) IF ( ERROR ) THEN IERR = 1 RETURN ENDIFC K = LENGTH(S2)1 CALL< MLIB_PARSE ( S2, K, BOT, NBOT, ERROR ) BOT(NBOT+1) = ' ' IF ( ERROR ) THEN IERR = 1 RETURN ENDIFC?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 )' CALL QSORT ( BOT, NBOT, WORK ) D=O 10 I = 1,NTOP. IF ( TOP(I) .NE. BOT(I) ) GO TO 2010 CONTINUE ENDIF RETURN20 IERR = 5 RETURN ENDCC---END MLIB_CMPARC4 SUBROUTINE MLIB_COMPAR ( TAR, L, TEST, MATCH )C*3C* *******************************3C* *******************************3C* ** **3C* ** COMPAR **3C* ** > **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STRING COMPAREC*C* AUTHOR :C* ART RAGOSTAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415)694-5578C*C* PURPOSE :BC* TO COMPARE TWO STRINGS TO LESS THAN THERE FULL LENGTH.C*C* INPUT ARGUMENTS :1C* TAR - THE (POTENTIALLY) SHORT S?TRING<C* L - THE NUMBER OF NON-BLANK CHARACTERS IN TAR1C* TEST - THE STRING TO TEST TAR AGAINSTC*C* OUTPUT ARGUMENTS :BC* MATCH - SET TRUE IF TAR AND TEST MATCH FOR THE FIRST L0C* CHARACTERS, FALSE OTHERWISEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 16-JAN-85C*C* CHANGE HISTORY :(C* 16-JAN-85 INITIAL VERSIONC*HC*******************@****************************************************C* CHARACTER *(*) TAR,TEST LOGICAL MATCHC MATCH = .FALSE. DO 10 I=1,L- IF (TAR(I:I) .NE. TEST(I:I))GO TO 2010 CONTINUE MATCH = .TRUE. 20 RETURN ENDCC---END MLIB_COMPARCG SUBROUTINE MLIB_EVAL (TOKE, NTOKE, FACTS, TOP, NT, BOT, NB, FAC )C*3C* *******************************3C* *******************************3C* A ** **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* B 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 WHCICH ARE IN THE DENOMINATOR2C* NB - THE NUMBER OF ENTRIES 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* D 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************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 ETOKENSC$ IF ( TOKE(I) .EQ. '^') THEN TT = 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 F----- OTHERWISE THE TOKEN IS A UNITC ELSEC1C -------- 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 GNT = 0 NB = 0 ISP = 0 DO 200 I = 1, NTOKECAC ----- 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 H LT = LENGTH(T1) LB = LENGTH(B1) 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) = '*' I IB = IB + 115 CONTINUE ENDIF 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 T1J = TSTACK(ISP) B1 = BSTACK(ISP) ISP = 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 K B(LB:LB) = '*' ENDIF LT = LT + 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 L T = TSTACK(ISP) B = BSTACK(ISP) 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)) THENM 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 N 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 OIF (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: SUPBROUTINE MLIB_PARSE ( WORK, LW, TOKE, NTOKE, ERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** PARSE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PARSERC*C* AUTHOR :C* Q ART RAGOSTAC* MS 219-3 C* AMES RESEARCH 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* R 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*****************************************************************S******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 T((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'U) .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 RETUVRN ENDCC---END MLIB_PARSEC8 SUBROUTINE MLIB_POLISH ( TOKE, NTOKE, FACTS, ERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** POLISH **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM W:&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 XNOSTRAND 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 PYROCESSING :<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 ERRCZ 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 OU^TPUTC 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* a 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*b 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, LcIST CHARACTER *1 FIRST LOGICAL AMBIG,MATCH& DOUBLE PRECISION FACTS(1), KFACTH COMMON /MLIB$UNITS/ KNOWN(NUM), ALIAS(NUM), LIST(NLIS), KFACT(NUM)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, dTOKE(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 IeFAC = 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(fITOKE) = 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) gITOKE = 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/ KNOW hN(NUM), ALIAS(NUM), LIST(NLIS), KFACT(NUM)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 ', i '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 j'LITER' 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.280871 k9D-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'LB ', '- 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', 'DE mG ', '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 oi@> SUBROUTINE SEARCH1 ( STRING, NSTRNG, TARGET, K, MATCHD )C*3C* ********************************3C* ******************************* 3C* ** ** 3C* ** SEARCH1 ** 3C* ** ***3C* ********************************3C* *******************************C*C* SUBPROGRAM :)C* BIpNARY SEARCH FOR EXACT MATCHTC*C* AUTHOR :9C* ART RAGOSTAAC* MS 219-3 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035:C* (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* TARGqET - THE STRING TO LOOK FORC*C* OUTPUT ARGUMENTS ::;C* K - THE INDEX OF TARGET STRING (IF FOUND)S?C* MATCHD - TRUE IF TARGET WAS FOUND, FALSE OTHERWISEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77AC*C* CHANGE HISTORY :8C* 03-AUG-90 DELETED UNUSED VARIABLE "MATCH"(C* 16-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* LOGICAL MATCHD& CHARACTER *(*) STRING(1), TARGETC C --- BINARY SEARCH C  J = NSTRNG I = 1N5 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) THENCO C --- MATCH FOUND, K HOLDS INDEXC2 MATCHD = .TRUE. ELSE MATCHD = .FALSE.3 ENDIF1 RETURN END9C2C---END SEARCH1,C9ww, 235, 243, 251, 65000 /C LINE = STRING STRING = ' ' ! " " " 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 10T ENDIFH7 IF (LS .GT. 0) WRITE(NUNIT,900)TLABEL,STMT(IST:L)O RETURN900 FORMAT(A6,A) END CNC---END PUTSTMC wwBEEN INITIALIZED TO BLANKS )C=10 IF ((K .LT. ITAB(ITPTR)) .AND. (K .LT. LL)) THEN K tDIFAC*-C --- NUMBER FOR SURE (INTEGER OR WHOLE PART) C 435 IF ((CH .GE. '0') .AND. (CH .LE. '9')) THEN/ IF (TSIZE .GT. LEN(TOKEN)) GO TO 60L# TOKEN(TSIZE:TSIZE) = CH* TSIZE = TSIZE + 1Q IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOL5 ELSE# CH = LINE(IPTR:IPTR)  ENDIF. GO TO 35 ENDIFCNC --- CHECK FOR FRACTIONAL PARTC --- DECIMAL POINT?CO IF (CH .EQ. '.') 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)O ENDIFO TYPE = 'R'*6 IF ((CH .LT. '0') .OR. (CH .GT. '9')) THEN% IF (TSIZE .LE. 2) THEN) TYPE = 'S' RETURN v`9% SUBROUTINE WEKDAY ( TIME, DAY )C*3C* *******************************3C* *******************************3C* ** **3C* ** WEKDAY **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 :CC* TO CALCULATE THE DAY OF THE WEEK('SUNDAY', 'MONDAY'...)C*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 :7C* DAY - THE DAY OF THE WEEK (EG, 'MONDAY' ).C*C* SUBPROGRAM REFERENCES :C* x SYS$BINTIM, LIB$DAYC*C* ERROR PROCESSING :2C* DAY = 'ERROR' IF AN ERROR HAS OCCURREDC*%C* TRANSPORTABILITY LIMITATIONS :C* EVERYTHINGC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY :(C* 25-JAN-85 INITIAL VERSION)C* 16-JAN-86 CAPITALIZE INPUTC*HC***********************************************************************C* CHARACTER*23 TIME CHARACTER*9 DAYS(0:6), DAYH y DATA DAYS / 'WEDNESDAY', 'THURSDAY ', 'FRIDAY ', 'SATURDAY ',: $ 'SUNDAY ', 'MONDAY ', 'TUESDAY '/" INTEGER ITIME(2), SYS$BINTIMC CALL CAPS(TIME) DAY = 'ERROR'! I = SYS$BINTIM (TIME,ITIME) IF (.NOT. I) RETURN I = LIB$DAY (NDAYS,ITIME) IF (.NOT. I) RETURNC6C --- NDAYS IS THE NUMBER OF DAYS SINCE SYSTEM TIME 0.C I = MOD(NDAYS,7) DAY = DAYS(I) RETURN ENDCC---END WEKDAYCww{@(@! SUBROUTINE UNTAB ( STRING ) C*3C* ********************************3C* ********************************3C* ** ** 3C* ** UNTAB **t3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM : C* REMOVE TABSrC*C* AUTHO|R : C* ART RAGOSTATC* 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 HAVEeC* SIMILAR SPACING.C*C* INPUT ARGUMENTS :=C* STRING - STRING FROM WHICH TABS ARE TO BE REMOVED*C*C* OUTPUT ARGUMENTS :fDC* STRING - SAME STRING WITH BLAN}KS REPLACING TABS(INPLACE)C*C* INTERNAL WORK AREAS :=C* ITAB - AN ARRAY CONTAINING THE TAB STOP SETTINGS. 7C* LINE - TEMPORARY STORAGE FOR TABBED STRING.aC*C* SUBPROGRAM REFERENCES :C* LENGTHC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :i(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,*C $ 114, 122, 130, 138, 146, 154, 162, 170, 178, 186, 195, 203, - $ 211, 219, 227, 235, 243, 251, 65000 / Cc LINE = STRINGe STRING = ' ' L = LENGTH(LINE)n LL = LEN(STRING) K = 1 ITPTR = 1 DO 20 I = 1,L , IF ( LINE(I:I) .EQ. CHAR(9) ) THENC(C ------ FIND NEXT TAB STOPC A5 IF ((K .GE. ITAB(ITPTR)) .AND. (ITPTR .LT. 32)) THEN! ITPTR = ITPTR + 1c GO TO 5d ENDIFCeGC ------ SKIP BLANKS TO TAB STOP ( ALREADY BEEN INITIALIZED TO BLANKS )RC =10 IF ((K .LT. ITAB(ITPTR)) .AND. (K .LT. LL)) THEN  K = K + 1p GO TO 10 ENDIF ELSEC C ------ COPY NON-TAB CHARACTE RSCe$ STRING(K:K) = LINE(I:I) K = K + 1 ENDIF ! IF ( K .GT. LL ) RETURN)20 CONTINUE RETURN ENDpCe C---END UNTABYC,wwt ), call parse (file, ' ', 'TYPE', fpart )/ if (.not. match_word(wpart,fpart)) returncc --- version...c --- ";*" matches everything0c --- so does ";" although this is iffy at best$c --- otherwise, must match exactlyc/ call parse (wild, ' ', 'VERSION', wpart )8 if ((w ENDIF ENDIFRCEC ----- FRACTIONAL PARTCC 737 IF ((CH .GE. '0') .AND. (CH .LE. '9')) THEN2 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 ELSE & CH = LINE(IPTR:IPTR) ENDIF GO TO 37L ENDIF' ENDIF+ 1 # IF (I .EQ. (LC+1)) THEN*4 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 THERE ARE TWO CONSECUTIVE QUOTES, THEY WILL BE TREATED1C ---- AS CONCATENATED STRINGS (WHICH IS RIGHT))C"17 I = I + 1! IF (I .LE. LC) GO TO 13oC6C --- CONTINUE COPYING IF THERE IS A CONTINUATION CARDCt+20 CALL MLIB_GETCRD ( NREAD, CARD, EOF )E& IF (CARD(6:6) .NE. ' ') GO TO 1030 LENST = IPTR-1 RETURN ENDnCsC---END GETSTMC 1 SUBROUTINE MLIB_GETCRD ( NREAD, CARD, EOF ) C*3C* *******************************R3C*  *******************************T3C* ** **3C* ** MLIB_GETCRD ***3C* ** **,3C* *******************************o3C* ******************************* C*C* SUBPROGRAM :C* GET CARDC*C* AUTHOR : C* ART RAGOSTA C* MS 219-3 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (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 CODE FC* EOF - TRUE IF AN END OF FILE WAS ENCOUNTERED ON PREVIOUSC* READ C*C* OUTPUT ARGUMENTS :i2C* EOF - TRUE IF AN END OF FILE OCCURRED C* CARD - THE CARD READC*C* FILE REFERENCES :C* NREADiC*C* SUBPROGRAM REFERENCES :C*  UNTAB, MLIB_ERROR C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77iC*C* CHANGE HISTORY :w(C* 10/13/83 INITIAL VERSION$C* 01/24/84 VAX VERSION7C* 12/26/84 SAVE AND RESTORE OPTIONS ADDEDd/C* 04/26/88 GENERALIZED FOR MERLIB DC* 02/26/90 ADDED MORE COMPLETE DEC TAB SOURCE CHECKINGC*HC***********************************************************************C* PARAMETER (LC=72) CHARACTER `,R' SUBROUTINE YESNO ( ISYES, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** YESNO **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* 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'C*C* INPUT ARGUMENTS :KC* ISYES - (UPDATE) THE DEFAULT VALUE TO BE RETURNED IN THE EVENT1C* OF AN ERROR OR NULL ANSWER.C*C* OUTPUT ARGUMENTS :MC* ISYES - (UPDATE) A LOGICAL VALUE WHICH IS TRUE IF THE ANSWER WAS6C* YES, FALSE IF THE ANSWER WAS NO.IC* ERROR - LOGICAL FLAG SHOWING THAT THERE WAS AN INAPPROPRIATEHC* 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 LINEC*C* ERROR PROCESSING :HC* 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 77C*C* CHANGE HISTORY :(C* 31-AUG-84  INITIAL VERSIONC*HC***********************************************************************C* LOGICAL ISYES, ERROR CHARACTER *1 C CHARACTER *80 STRINGC ERROR = .FALSE.# CALL MLIB_GET ('NREAD',NUNIT). READ (NUNIT,900,END=1000,ERR=1000)STRINGC.C --- SEARCH FOR THE FIRST NON-BLANK CHARACTERC CALL FIRST (STRING, C, I)CC ------ CAPITALIZE IT.C. IF ((C .EQ. 'Y') .OR. (C .EQ. 'y')) THEN ISYES = .TRUE.3 ELSE IF ((C .EQ. 'N') .OR. (C .EQ. 'n')) THEN ISYES = .FALSE. ELSE IF (C .NE. ' ') THENC/C ------ FIRST CHARACTER WAS NEITHER 'Y' OR 'N'C ERROR = .TRUE. ENDIF RETURNC7C --- LEAVE ISYES AS DEFAULT RESPONSE, BUT RETURN ERRORC1000 ERROR = .TRUE. RETURN900 FORMAT(A) ENDC C---END YESNOCww瑓 .title poke;; Author: Arthur E. Ragosta;J; Put a byte into the specified location. Both parameters by reference.;"; call poke (location, value); ; Example:; i = %loc(x); call poke (i, 255); .entry poke,^m<>: movl @4(ap),r1 ;address of location to r16 movl 8(ap),r0 ;address of byte to r01 movb (r0),(r1) ;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@M3鑓 .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 @M?: SUBROUTINE SCALE (XMIN, XMAX, N, XMINP, XMAXP, DIST)C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** SCALE ** 3C* ** ** 3C* ******************************* 3C* *******************************TC*C* SUBPROGRAM :rC* SCALE C*C* AUTHOR :PC* C.R. LEWART,C* BELL TELEPHONE LABORATORIES, INCC* HOLMDEL, NJ 07733C* (coded by: AER)9C*C* REFERENCE:e%C* COMMUNICATIONS OF THE ACM C* VOLUME 16, 1973 C*C* PURPOSE :DC* GIVEN XMIN,XMAX AND N SCALE1 FINDS A NEW RANGE XMINP ANDAC* XMAXP DIVISIBLE INTO APPROXIMATELY N LINEAR INTERVALSWC* OF SIZE DISTC*C* INPUT ARGUMENTS :C* XMIN - DATA MINIMUMAC*  XMAX - DATA MAXIMUMG-C* N - TARGET NUMBER OF INTERVALS C*C* OUTPUT ARGUMENTS : C* XMINP - NEW MINIMUM3C* XMAXP - NEW MAXIMUM*&C* DIST - VALUE PER INTERVALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :R+C* 6-NOV-1987 - INITIAL VERSIONC*HC***********************************************************************C*7C VINT IS AN ARRAY OF ACCEPTABLE VALUES FOR DIST (TIMESLC AN INTEGER POWER OF 10)T7C SQR IS AN ARRAW OF GEOMETRIC MEANS OF ADJACENT VALUESe2C OF VINT, IT IS USED AS BREAK POINTS TO DETERMINE$C WHICH VINT VALUE TO ASSIGN TO DIST DIMENSION VINT(4), SQR(3)r> 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 SUPPLIED Ce- 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 N*C* 10 DEL = .00002 FN = NC "C FIND APPROXIMATE INTERVAL SIZE ACT A = (XMAX-XMIN)/FN AL = ALOG10(A) NAL = AL IF (A.LT.1.) NAL = NAL - 1CA4C A IS SCALED INTO VARIABLE NAMED B BETWEEN 1 AND 10CA 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 30e 20 CONTINUE I = 4rC C THE INTERVAL SIZE IS COMPUTEDNC: 30 DIST = VINT(I)*10.**NALo FM1 = XMIN/DIST  M1 = FM1 IF (FM1.LT.0.) M1 = M1 - 12 IF (ABS(FLOAT(M1)+1.-FM1).LT.DEL) M1 = M1 +1CR.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 - 1*3 IF (ABS(FM2+1.-FLOAT(M2)).LT.DEL) M2 = M2 - 1* XMAXP = DIST*FLOAT(M2)C5C ADJUST LIMITS TO ACCOUNT FOR ROUND-OFF IF NECESSARYlCn% IF (XMINP.GT.XMIN) XMINP = XMIN5% IF (XMAXP.LT.XMAX) XMAXP = XMAXr RETURN ENDlCp C---END SCALE C(ww .eq. 'NR') then ivalue = nread$ else if (short .eq. 'NW') then ivalue = nwrite else ivalue = nerror endif RETURN ENDS)' IF ((IS+18) .LE. N) THEN'$ WRITE(A,990) IS+189 LINE(40:) = A // '. ' // CHOICE(IS+18)P ENDIF IS = IS + 1CIC --------- 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) THEN'$ WRITE(A,990) IS+369 LINE(53:) = A // '. ' // CHOICE(IS+36)  ENDIF IS = IS + 1 ENDIF  WRITE(NOUT,900)LINEL50 CONTINUEC 0C ------ UPDATE STARTING POINTER FOR NEXT SCREENC IS = IS + NS - 18CI$C ------ PROMPT FOR ANSWER OR RETURNC  IF (I .EQ. NR) THEN IF (NR .NE. 1) THENT WRITE(NOUT,930) N ELSE  WRITE(NOUT,920) N ENDIF ELSET WRITE(NOUT,940)  ENDIFC C --- GET RESPONSEC($ READ(NIN,950,end=1000) LINECSC --- CHECK FOR HELP REQUESTEDC+# CALL FIRST ( LINE, CC, J )H 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 )& READ (LINE,960,ERR=30) ANSWER GO TO 40PC++C ------ ERROR, PROBABLY NON-DIGITS ENTERED C 30 CALL MBELL  WRITE(NOUT,970) N READ(NIN,950) LINE  GO TO 10 CE+C ------ CHECK FOR OR VALID ANSWER(C 40 IF (ANSWER .EQ. 0) THEN# IF (I .EQ. NR) GO TO 10( ELSER= IF ((ANSWER .GT. 0) .AND. (ANSWER .LE. N)) RETURNO CALL MBELL P WRITE(NOUT,970) NE READ(NIN,950) @}x SUBROUTINE STATUS ( T )C*3C* *******************************3C* *******************************3C* ** **3C* ** STATUS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STATUS LINEC*C* AUTHOR : C* 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* SUBROUTINE 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*C* 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 STATUSCww 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 - 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 ivalue = nread$ else if (short .eq. 'NW') then ivalue = nwrite else ivalue = nerror endif RETURN ENDCC---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 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* 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 :c* 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_SetCwwLINE GO TO 10 ENDIF100 CONTINUE. RETURN1000 answer = 0 return900 FORMAT(' ',A) 910 FORMAT(' ')::920 FORMAT(/' Please enter response (1-',I,') : ',$) 930 FORMAT+ $(/' Please enter response (1-',I, 2 $ ') or to see choices again : ',$) 940 FORMAT+ $(/' Please enter response (1-',I,(9 $ ') or to continue viewing choices : ',$)H950 FORMAT(A)960 FORMAT(74X,I5)>970 FORMAT(' Please *(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(1: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  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_GETCRDCwwC C ------ CHECK FOR EXPONENT CE3 IF ((CH .EQ. 'E') .OR. (CH .EQ. 'D')) THENM/ IF (TSIZE .GT. LEN(TOKEN)) GO TO 60P# TOKEN(TSIZE:TSIZE) = CHB TSIZE = TSIZE + 1M IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOLL ELSE# CH = LINE(IPTR:IPTR)C ENDIFB7 IF ((CH .NE. '+') .AND. (CH .NE. '-') .AND. 7 $ ((CH .LT. '0') .OR. (CH .GT. '9'))) THENF  IPTR = IPTR - 1 RETURNF ENDIF. TYPE = 'R'C 1C ------- IF WE GET THIS FAR, WE HAVE AN EXPONENT CR6 IF ((CH .EQ. '+') .OR. (CH .EQ. '-')) THEN2 IF (TSIZE .GT. LEN(TOKEN)) GO TO 60& TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1Y' IF ( IPTR .GT. LL ) THEN  CH = EOL ELSEN& CH = LINE(IPTR:IPTR)  ENDIF ENDIF 740 IF ((CH .GE. '0') .AND. (CH .LE. '9')) THENT2 IF (TSIZE .GT. LEN(TOKEN)) GO TO 60& TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1I' IF ( IPTR .GT. LL ) THENP CH = EOL ELSE & CH = LINE(IPTR:IPTR) ENDIF GO TO 40 ENDIFM ENDIFC 5C ------ OTHERWISE, RETURN THE SPECIAL CHARACTER ONLY CR 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 C60 IF ( CH .EQ. ' ' ) THEN- IPTR = IPTR + 1! IF ( IPTR .LE. LL ) THEN CH = LINE(IPTR:IPTR) GO TO 60 ENDIF ENDIFTESC*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 CHARACTERS 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 GETFORCwwE 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  d 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_zCwwM9, 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 for 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 MailCww`J0 SUBROUTINE UNIQUE ( NAME )C*3C* ********************************3C* ********************************3C* ** ** 3C* ** UNIQUE ** 3C* ** ** 3C* ********************************3C* ********************************C*C* AUTHOR :AC* Arthur E. Ragosta C* MS 219-1%C* NASA Ames Research Center %C* Moffett Field, Ca. 94035eC* (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.eC*C* OUTPUT ARGUMENTS :e7C* NAME - (CHARACTER*(14)) THE GENERATED NAMEC*C* SUBPROGRAM REFERENCES :C* LIB$DATE_TIME C*%C* ASSUMPTIONS AND RESTRICTIONS : C* NOT TRANSPORTABLErC*C* LANGUAGE AND COMPILER :C* VAX FORTRAN 77C*C* CHANGE HISTORY : +C* 28-JUN-1988 - INITIAL VERSIONR4C* 02-NOV-1992 - BUG FIXED FOR DAYS 01-09C*HC***********************************************************************C* CHARACTER *(*) NAMEi CHARACTER *23 D CD CALL LIB$DATE_TIME ( D )' IF (D(1:1) .EQ. ' ') D(1:1) = '0'eE NAME = D(5:6)//D(1:2)//D(10:11)//D(13:14)//D(16:17)//D(19:20)//r $ D(22:23) RETURN END C C---END UNIQUECLwwE OF STRING0C* IX - STARTING COLUMN FOR STRING 6C* =0 TO USE CURRENT CURSOR LOCATION7C* IY - ROW (COUNTING FROM TOP) FOR STRING C*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*  STRIP_EXC"򥿔 RAGOSTA STRIP_EXC@mrڕ RAGOSTA EDIT@3sڕ RAGOSTA EDIThJ0 RAGOSTA UNIQUEӓ1 RAGOSTA EDIT|1 RAGOSTA LEAPQ.~ RAGOSTA ANY+.~ RAGOSTA BLANKS q#/~ RAGOSTA CAPITALj/~ RAGOSTA CAPS>/~ RAGOSTA CAPSuP3~ RAGOSTA ICOUNT7+5~ RAGOSTA LENGTHc5~ RAGOSTA LEFTy56~ RA'򥿔# SUBROUTINE Strip_Exc (string)C*3C* *******************************3C* *******************************3C* ** **3C* ** Strip_Exc **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 :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 REFERENCES :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, skipping 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_ExcCwwC*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 STRINGtC*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 SEQUENCES C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77 C*C* CHANGE HISTORY :I+C* 28-FEB-1990 - INITIAL VERSION GC* 16-Jul-1992 - changed insert/overstrike to match terminaly6C* bug fixed when "^" entered(C* ^U bug fixedC*HC***********************************************************************C* include '($dvidef)'D character *(*) string  character *132 temp  character *3 key character *1 k(3)t logical insert equivalence (k(1),key)cT5 istat = lib$getdvi (dvi$_tt_insert,,'TT:',io,,)O insert = (io .eq. 1)% call mlib_get ('NWRITE',nwrite)n if (ixx .eq. 0) then call getxy (ix, iy) else ix = ixxt iy = iyy endifgct%c --- make sure it will fit on screen)cq( call get_term_size (nwterm,nlterm). ls = MIN0(len(string),(nwterm-ix+1))  temp = string 5 icol = 0cEc Display initial stringnce call gotoxy (ix, iy)$ write(nwrite,900) string(1:LS) call gotoxy (ix, iy)c)/c Loop until user enters ^Z or to exit c 10 call readkey ( key )CcC --- CONTROL KEYSC: if ((k(1) .eq. '^') .and. (length(key) .gt. 1)) thencsc ----- "A" Insert/Overstrikescf if (k(2) .eq. 'A') then# insert = (.not. insert) cs*c ----- "C" Cancel changes to this fieldc % else if (k(2) .eq. 'C') then  string = temp( go to 5 c c ----- "E" End of this field ci% else if (k(2) .eq. 'E') thenf( 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)  endift icol = ic c 3c ----- "G" Delete right (same as Remove, below) cl% else if (k(2) .eq. 'G') thenl" if (ls .ge. icol) then7 string(icol+1:) = string(icol+2:) // ' '( call save_cursorr2 write(nwrite,900) string(icol+1:ls)" call restore_cursor endifkc $c ----- "H" Begining of this fieldc % else if (k(2) .eq. 'H') then # call cursor_left (icol)  icol = 0ci,c ----- "I" Go to next word in text stringc % else if (k(2) .eq. 'I') thend. itemp = index(string(icol+1:),' ')/ if (itemp .eq. 0) itemp = ls - icol % call cursor_right (itemp)r icol = icol + itemp c c ----- "M","Z" returnc< else if ((k(2) .eq. 'M') .or. (k(2) .eq. 'Z')) then& write(nwrite,900) char(13) returncn c ----- "R"/"W" Repaint screenci< 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 endifCrC --- OTHER LABELED KEYSC-c --- DELete leftlc # 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)o call restore_cursorl endifc1c --- Remove (delete right) ... same as ^G, above c # else if (key .eq. 'REM') thenc if (ls .ge. icol) then 4 string(icol+1:) = string(icol+2:) // ' ' call save_cursor/ write(nwrite,900) string(icol+1:ls)  call restore_cursor endifcr$c --- LEFt arrow, move left in fieldc # else if (key .eq. 'LEF') then  if (icol .gt. 0) then call cursor_left (1) icol = icol - 1i endifcn&c --- RIGht arrow, move right in fieldcs# else if (key .eq. 'RIG') then1 if (icol .lt. ls) then ! call cursor_right (1)  icol = icol + 1  endifc=Fc --- 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 + 1Ac6c ------------ 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 editcww 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'/ * $' 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 sc reen, there will be a pause at the end'/G $' of each screen. In this case, you will be prompted to either'/GE $' enter a choice or hit to continue viewing choices.'/ZC $' 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) END C C---END MENUC'ww. (CH .GT. '9')) THEN% IF (TSIZE .LE. 2) THEN TY 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.NC*C*C* METHODOLOGY :C* SHELLSORT C*C* INPUT ARGUMENTS :0C* NUM - NUMBER OF ELEMENTS IN ARRAY'C* ARRAY - ARRAY TO BE SORTEDC*C* OUTPUT ARGUMENTS : C* INDX - INDEX ARRAYC*C* INTERNAL WORK AREAS :%C* TEMPA - USED DURING SWAPS C*%C* ASSUMPTIONS AND RESTRICTIONS :NBC* THE TYPE OF THE ARRAY 'ARRAY' AND THE VARIABLE 'TEMPA'CC* MUST BE SET FOR EACH TYPE OF SORT. FOR THIS PARTICULARIFC* IMPLEMENTATION, THE ARRAY IS CHARACTER WITH LENGTH <= 255.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77BC*C* CHANGE HISTORY :I(C* 03/12/84 INITIAL VERSIONC*HC***********************************************************************C* DIMENSION INDX(num)  INTEGER *8 ARRAY(num)U INTEGER *8 TEMPI, tempa= LOGICAL DONECE DO 10 I = 1, NUM INDX(I) = I10 CONTINUE  IF (NUM .LE. 1) RETURN JUMP = NUM20 JUMP = JUMP / 2030 DONE = .TRUE.  NJ = NUM-JUMPe DO 40 J = 1, NJ- I = J + JUMPH( IF (ARRAY(J) .GT. ARRAY(I ENDIF? CALL LIB$MOVC5 ( II, %VAL(I), 32, LEN(OUT), %REF(OUT))0 ENDIF( RETURN1000 parse= istat out = ' ' return ENDOC) C---END PARSE C ww TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1' IF ( IPTR .GT. LL ) THEN CH = EOL ELSE& CH = LINE(IPTR:IPTR) ENDIF GO TO 40 ENDIF END))THEN DONE = .FALSE. TEMPA = ARRAY(J) ARRAY(J) = ARRAY(I)S ARRAY(I) = TEMPA TEMPI = INDX(J)  INDX(J) = INDX(I)  INDX(I) = TEMPIE ENDIF40 CONTINUET IF (.NOT. DONE) GO TO 30 IF (JUMP .GT. 1) GO TO 20I RETURN END C C---END ISORTI80C wwCH .EQ. ' ' ) THEN IPTR = IPTR + 1! IF ( IPTR .LE. LL ) THEN CH = LINE(IPTR:IPTR) 봛.f RAGOSTA ISORTI8eg RAGOSTA GETFOR; IF ((CH .EQ. ',') .OR. (CH .EQ. ';')) IPTR = IPTR + 1 RETURN ENDCC---END GETOKECwweg1 SUBROUTINE GETFOR ( NQ, QUALS, NP, PARAMS )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFOR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET FOREIGNC*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 QUOTESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* CHANGE HISTORY :EC* 14-SEP-95 Fixed bug if Params and Quals different sizeCC* 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)) LP = LEN(PARAMS(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 CHARACTERS 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. LP) PARAMS(NP)(NC:NC) = COMMAN(I:I) NC = NC + 1 I = I + 1! IF (I .GT. IP) GO TO 300 GO TO 210 ENDIF GO TO 100C1C --- END OF LOOP WHILE LINE STILL HAS CHARACTERSC 300 RETURN ENDCC---END GETFORCww