% VAX-11 Librarian V04-00eÆ+:}a  kkk*I9(ASCIIBLANKSCAPSCATEG(<CENTER,CLEAR*CONTROL6COPY0CTIME5(CTLY2CURSOR:zDASCIIADECHEXDDECOCT_DEFAULTHDELETELDIR/ DISK_SPACEQEXISTSUFIRSTzFOPENYNGAUSSaGETCfGETCHARmGETCPRVvGETFDEVyGETFDIR}GETFILEGETFNAMEGETFORXGETFTYPE$GETFVERSGETIMEGETLINERMSIZE"GETUSERGETXYVGOPEN$GOTOXYGETOKEGETPRV)GETSTM GETSTRINGxGETTERM4 GETTERMSIZE"GETUSERGETXY4 GET_DEFAULTVGOPEN$GOTOXYGPALFAGRALFAHELPHEXDECIDIGITINTRPLdISORT KEYHITtKURV1 KURV2'LEFT+8LENGTH.LOWERJMACRO>^MBELLA`MENUOtMENU2eMERGEnMERGEItMERGER^6MERLIBOPERG2OPERWNPROMPTRPUTCWr PUTSTRING[QSORTbREADQ2GETLINMERLIBSORTIYESNOfihMESSAGEuNAE;<NDEX>,OCTDECAOPERG2OPERWPARSE&PCALFANPROMPTRPUTC:PUTSTMWr PUTSTRING[QSORT@QUOTAbREADQfREADTlRECALLqREPLACtREVLFx&RIGHT{2SCROLLfSEARCHSEARCH1.SENDSENDWpSETIME SLEEPSORTSORTISORTRSRESETSTATSTATUSrSUBMITTRANSL8,UNITSZUNTAB,VERIFYWEKDAYYESNOSORTRSRESETSTATSTATUSrSUBMITTRANSL8hUNIQUE,UNITSZUNTAB,VERIFYWEKDAYYESNO ܹ )! SUBROUTINE ASCII ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** ASCII **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* ASCII  C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO REPLACE TEXT STRINGS OF THE TYPE CREATED BY SUBROUTINE HC* DASCII WITH ASCII CHARACTERS (SEE DASCII). 5C* (E.G., BECOMES AN ESCAPE CHARACTER)C*C* INPUT ARGUMENTS :,C* STRING - STRING TO BE ASCIIFIED.C*C* OUTPUT ARGUMENTS :3C* STRING - ASCIIFIED STRING ( IN PLACE ).C*C* INTERNAL WORK AREAS :BC* TABLE - ASCII MNEMONIC STRINGS FOR CONTROL CHARACTERS.C*C* RESTRICTIONS :C* NONEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.1 1-DEC-1987C*C* CHANGE HISTORY :9C*  9-MAY-1988 STRING UPDATE CHANGED TO INPLACEGC* 1-DEC-1987 STRING LENGTH PARAMETERIZED AND RAISED TO 1000(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING% CHARACTER *3 TABLE(0:32), THREEB DATA TABLE /'NUL', 'SOH', 'STX', 'ETX', 'EOT', 'ENQ', @ $ 'ACK', 'BEL', ' BS', ' HT', ' LF', ' VT', ' FF',@ $ ' CR', ' SO', ' SI', 'DLE', 'DC1', 'DC2', 'DC3',@ $ 'DC4', 'NAK', 'SYN', 'ETB', 'CAN', ' EM', 'SUB',9 $ 'ESC', ' FS', ' GS', ' RS', ' US', 'DEL' /C L = LEN ( STRING ) IW = 0 IS = 0CLC --- DO WHILE NUMBER OF CHARACTERS IN WORK < NUMBER OF CHARACTERS IN STRINGC100 IS = IS + 1& IF (STRING(IS:IS) .EQ. '<') THEN IT = IS + 4= IF ((IT .LE. L) .AND. (STRING(IT:IT) .EQ. '>')) THENC4C ------ IT APPEARS TO BE AN ASCII REPRESENTATIONC  IS = IS + 1 IT = IT - 1! THREE = STRING(IS:IT)CAC ------ SEE IF THE TEXT STRING IS AN ASCII CHARACTER MNEMONICC DO 110 I = 0,32, IF (THREE .EQ. TABLE(I)) THEN IW = IW + 1% IF (I .EQ. 32) THEN. STRING(IW:IW) = CHAR(127) ELSE, STRING(IW:IW) = CHAR(I) ENDIF IS = IS + 3* IF (IS .LT. L) GO TO 100 GO TO 1000 ENDIF110 CONTINUEC(C ------ NOT IN TABLE, SEE IF NUMERICC DO 120 I = 1,3G IF((THREE(I:I) .LT. '0') .OR. (THREE(I:I) .GT. '9'))THEN IW = IW + 1% STRING(IW:IW) = '<' GO TO 200 ENDIF120 CONTINUECC ------ ALL DIGITSC! READ ( THREE, 900 ) I5 IF ((I .LE. 255) .AND. (I .GE. 128)) THENCC ------ OK, ITS NUMERICC IS = IS + 3 IW = IW + 1& STRING(IW:IW) = CHAR(I)' IF (IS .LT. L) GO TO 100 GO TO 1000 ELSEC>C ----- NOT NUMERIC, MUST BE COINCIDENCE... SEND IT VERBATIMC IW = IW + 1" STRING(IW:IW) = '<' ENDIF ENDIF ENDIF200 IW = IW + 1# STRING(IW:IW) = STRING(IS:IS) IF ( IS .LT. L ) GO TO 100CC --- END DO WHILEC1C --- OUTPUT STRING FULL OR INPUT STRING DEPLETEDC1000 STRING(IW+1:) = ' ' RETURN900 FORMAT (I3) ENDC C---END ASCIICwwꔖ" SUBROUTINE BLANKS ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** BLANKS **3C* **  **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* REMOVE BLANKS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 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 REMOVEDC*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 77C*C* VERSION AND DATE :&C* VERSION I.0 15-OCT-84 C*C* CHANGE HISTORY :(C* 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC L = LEN(STRING) I = 1 DO 10 J = 1, L' IF (STRING(J:J) .NE. ' ') THEN% STRING(I:I) = STRING(J:J) I = I + 1 ENDIF10 CONTINUEC=C --- IF THE OUTPUT STRING IS LESS THAN FULL, PAD WITH BLANKSC' IF ( I .LE. L ) STRING(I:L) = ' ' RETURN ENDCC---END BLANKSCwwG  SUBROUTINE CAPS ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** CAPS **3C* **  **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* CAPITALIZE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO REPLACE A STRING WITH THE SAME STRING BUT ONLY CAPITAL HC* LETTERS. C*C* INPUT ARGUMENTS :1C* STRING - THE STRING TO BE CAPITALIZEDC*C* OUTPUT ARGUMENTS :+C* STRING - THE CAPITALIZED STRINGC*%C* TRANSPORTABILITY LIMITATIONS : C* USES AN RTL LIBRARY.:C* A MORE TRANSPORTABLE VERSION IS COMMENTED OUT.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 CONTIGUOUSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 1-OCT-84 C*C* CHANGE HISTORY :(C* 1-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC"C IC = ICHAR('A') - ICHAR('a')C  DO 10 I = 1, LEN(STRING)BC IF ((STRING(I:I) .GE. 'a') .AND. (STRING(I:I) .LE. 'z')):C $ STRING(I:I) = CHAR( IC + ICHAR(STRING(I:I)) )C10 CONTINUEC+ ISTAT = STR$UPCASE ( STRING, STRING ) RETURN ENDC C---END CAPSCww`[~^Mڏ- SUBROUTINE CATEG ( STRING, TYPE, FORM )C*3C* *******************************3C* *******************************3C* **  **3C* ** CATEG **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* FIND THE TYPE OF A STRING C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFET !T FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :JC* TO CATEGORIZE A STRING AS EITHER A LOGICAL, INTEGER, FLOATING,HC* E-FLOATING, D-FLOATING, OR ALPHANUMERIC. HC* 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-85 C*C* CHANGE HISTORY :(C* 8-FEB-85 INITIAL VERSIONC*HC*****************************************#******************************C*! CHARACTER *(*) STRING, FORM CHARACTER *1 TYPE, LETC CALL BLANKS ( STRING ) L = LENGTH ( STRING ) CALL CAPS ( STRING )C;C --- DEFAULT TYPE IS ALPHANUMERIC, DEFAULT FORMAT IS 'Ann'C TYPE = 'A' LF = LEN ( STRING ) IFM = 1 IF (LF .GT. 9) IFM = 2 IF (LF .GT. 99) IFM = 3 WRITE ( FORM, 900 ) LF 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.') T%HEN 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 ((STRIN)G(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 CATEGCwwl8f)" SUBROUTINE CENTER ( STRING )C*3C* *******************************3C* *******************************3C* ** * **3C* ** CENTER **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* CENTER C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4+C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO REPLACE A STRING WITH THE SAME STRING, CENTERED HC* AROUND THE POINT (LENGTH/2). C*C* INPUT ARGUMENTS :!C* STRING - INPUT STRINGC*C* OUTPUT ARGUMENTS :,C* STRING - OUTPUT STRING (INPLACE)C*C* INTERNAL WORK AREAS :/C* LINE - TEMPORARY STORAGE FOR STRING,C*C* SUBPROGRAM REFERENCES :C* LEFT, LENGTHC*%C* ASSUMPTIONS AND RESTRICTIONS :C* LEN(STRING) <= 255C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 15-OCT-84 C*C* CHANGE HISTORY :(C* 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC3C --- 'LL' IS THE LENGTH OF THE TEXT TO BE- CENTERED@C --- 'N' IS THE NUMBER OF BLANKS TO BE INSERTED BEFORE THE TEXTC CALL LEFT ( STRING ) LL = LENGTH ( STRING )% N = ( LEN(STRING) - LL ) / 2 IF ( N .EQ. 0 ) RETURNC$C --- COPY TEXT INTO PROPER LOCATIONC STRING(N+1:) = STRINGCC --- CLEAR LEADING SPACESC STRING(1:N) = ' ' RETURN ENDCC---END CENTERCwwV5) SUBROUTINE CLEAR C*3C* ******************************* .3C* *******************************3C* ** **3C* ** CLEAR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* CLEAR SCREEN C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 / 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :IC* CLEAR A CRT SCREEN OR ADVANCE THE PAGE ON A HARDCOPY TERMINALC*C* METHODOLOGY :KC* USES VMS UTILITY. COMMENTED, TRANSPORTABLE(?) VERSION SENDS HC* . C*C* FILE REFERENCES :<C* 0 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 ML1IB_GET CALL(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C*C CHARACTER *1 ESCC DATA ESC/27/! ISTAT = LIB$ERASE_PAGE(1,1)C$C CALL MLIB_GET("NWRITE",NWRITE)#C WRITE(NWRITE,900)ESC,CHAR(12)C900 FORMAT(2A1)C RETURN ENDC C---END CLEARCww@C^ SUBROUTINE CTIME ( ATIME )C*3C* *******************************3C* 2 *******************************3C* ** **3C* ** CTIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* CLOCK TIMEC*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* 3 (415) 694-5578C*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* INPUT ARGUMENTS :C* NONEC*C* OUTPUT ARGUMENTS :HC* ATIME - THE PRESENT CLOCK TIME IN "HH:MM AM/PM" (A8) FORMAT.C*C* INTERNAL WORK AREAS :C* NONEC*C* COMMON BLOCKS :C* NONEC*C* FILE REFERENCES :4C* NONEC*C* DATA BASE ACCESS :C* NONEC*C* SUBPROGRAM REFERENCES :C* TIMEC*C* ERROR PROCESSING :C* NONEC*%C* TRANSPORTABILITY LIMITATIONS :6C* TIME IS A NON-STANDARD BUILTIN SUBROUTINE.C*%C* ASSUMPTIONS AND RESTRICTIONS :C* NONEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 31-AUG-84C*C* CHANGE HISTORY :(C*5 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) = ' '2 ATIME(2:2) = CHAR(ICHAR(ATIME(2:2))-2)+ ELSE IF (ATIME(2:2) .LE. '1') THEN ATIME(1:1) = ' '2 ATIME(2:2) = CHAR(ICHAR(ATIME(2:2))+8) ELSE ATIME(1:1)6 = '1'2 ATIME(2:2) = CHAR(ICHAR(ATIME(2:2))-2) ENDIF 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 CTIMECwwj)& SUBROUTINE STOP_Y (USER_ROUTINE)C*3C* *******************************3C* *******************************3C* ** 7 **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) 694-5578C*C* PURPOSE :BC* MAKE IT EASY FOR8 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* OUTPUT ARGUMENTS :C* NONEC*C* COMMON BLOCKS :C* NONEC*C* SUBPROGRAM REFERENCES :#C* LIB$DISABLE, MLIB_ESTABC*%C* ASSUMPTIONS AND RESTRICTION9S :2C* DON'T EVEN THINK ABOUT TRANSPORTING ITC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 25-APR-1988C*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_ROUTI:NE ) 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_YCwwi" SUBROUTINE DASCII ( STRING )C*3C* *******************************3C* <*******************************3C* ** **3C* ** DASCII **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* DEASCII C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 = 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* REPLACE ALL NON-PRINTABLE CHARACTERS WITH A TEXT STRING HC* DENOTING THE CHARACTER. FOR THE CHARACTERS FROM ASCII 0 TO GC* ASCII 31 AND ASCII 127, THE STRING IS THE THREE CHARACTER HC* MNEMONIC IN BRACKETS (EG, ). FOR THE CHARACTERS FROM HC* ASCII >128 TO ASCII 255, THE STRING IS A THREE DIGIT NUMBER HC* 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* VERSION AND DATE :&?C* VERSION I.1 1-DEC-87C*C* CHANGE HISTORY :*C* 1-DEC-87 MAX PARAMETERIZED(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (MAX=1000) CHARACTER *(MAX) WORK CHARACTER *(*) STRING% CHARACTER *3 TABLE(0:32), THREEB 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 WORK = ' ' DO 100 I = 1, LCC --- TEST FOR PRINTABILITYCE IF ((STRING(I:I) .LT. ' ') .OR. (STRING(I:I) .GT. '~')) THEN& IC = ICHAR ( STRING(I:I) ) IW = IW + 1+ IF ( IW+4 .GT. MAX ) GO TO 1000 A WORK(IW:IW) = '<' IW = IW + 1C*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+2) = THREE IW = IW + 3 WORK(IW:IW) = '>' ELSE IW = IBW + 1' IF (IW .GT. MAX) GO TO 1000% WORK(IW:IW) = STRING(I:I) ENDIF100 CONTINUE1000 STRING = WORK RETURN900 FORMAT(I3) ENDCC---END DASCIICww "j SUBROUTINE DECHEX ( I, H )C*3C* *******************************3C* *******************************3C* ** **3C* ** DECHEX **3C* C ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* DECIMAL TO HEXADECIMAL C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 D C*C* PURPOSE :HC* TO CONVERT A DECIMAL INTEGER TO A HEXADECIMAL STRING HC* 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 RESTRICTIEONS :<C* 'I' MUST BE FOUR BYTES AND 'H' EIGHT CHARACTERS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 22-FEB-85 C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *8 HC WRITE(H,900)I RETURN900 FORMAT(Z8) ENDCC---END DECHEXCwwrn F SUBROUTINE DECOCT ( I, O )C*3C* *******************************3C* *******************************3C* ** **3C* ** DECOCT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* DECIMAL TO OCTAL C*C* AUT GHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO CONVERT A DECIMAL INTEGER TO A HEXADECIMAL STRING HC* REPRESENTING THAT NUMBER. C*C* INPUT ARGUMENTS :"C* I - THE DECIMAL HNUMBERC*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* VERSION AND DATE :&C* VERSION I.0 22-FEB-85 C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIIONC*HC***********************************************************************C* CHARACTER *16 OC WRITE(O,900)I RETURN900 FORMAT(O16) ENDCC---END DECOCTCww7&o( SUBROUTINE DELETE ( FNAME, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** DELETE **3C* J ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* DELETE FILE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 K C*C* PURPOSE :HC* DELETE A FILE FROM THE DEFAULT OR SPECIFIED DIRECTORY. C*C* METHODOLOGY :HC* USES THE NON-TRANSPORTABLE DEC 'DELETE' EXTENSION TO THE HC* CLOSE STATEMENT. C*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).LC*C* FILE REFERENCES :AC* 0 - DUMMY UNIT REQUIRED BY OPEN AND CLOSE STATEMENTS.C*C* ERROR PROCESSING :9C* ERR= IS CHECKED ON OPEN AND CLOSE STATEMENTS.C*%C* TRANSPORTABILITY LIMITATIONS :IC* THE "DELETE" STATUS OPTION OF THE CLOSE STATEMENT IS NON-ANSIC* STANDARD.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 31-AUG-84 C*C* CHANGE HISTORY :(C*M 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FNAME LOGICAL ERRORC ERROR = .TRUE.4 OPEN (UNIT=0,FILE=FNAME,STATUS='OLD',ERR=1000)- CLOSE (UNIT=0,STATUS='DELETE',ERR=1000) ERROR = .FALSE.C 1000 RETURN ENDCC---END DELETECww]:& SUBROUTINE DIR ( STRING, ERROR )C*3C* *******************************3C* N *******************************3C* ** **3C* ** DIR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* DIRECTORY DISPLAY C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 O 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* DISPLAY THE DIRECTORY AT THE TERMINAL. C*C* METHODOLOGY :HC* SPAWNS A SUBTASK WITH THE DIRECTORY COMMAND. C*C* INPUT ARGUMENTS :JC* STRING - A COMMAND OR QUALIFIER STRING THAT IS APPENDED TO THE;C* P 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 AHC* 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* TRANSQPORTABILITY LIMITATIONS :@C* USES HIGHLY NON-TRANSPORTABLE OPERATING SYSTEM CALL.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 31-AUG-84 C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING LOGICAL ERROR EXTERNAL SS$_NORMALC; ISTAT = LIB$SPAWN ( 'DIRECTORYR '//STRING,,,,,,,,,,, )) ERROR = ISTAT .NE. %LOC(SS$_NORMAL) RETURN ENDC C---END DIRCww`o' LOGICAL FUNCTION EXISTS ( FNAME )C*3C* *******************************3C* *******************************3C* ** **3C* ** EXISTS **3C* ** **3C* ****************************S***3C* *******************************C*C* SUBPROGRAM :4C* FILE EXISTANCE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO DETERMINE IF A FILE EXISTS ON THE SPE TCIFIED OR DEFAULT HC* DIRECTORY. C*C* METHODOLOGY :HC* OPENS THE FILE AS AN OLD FILE AND CHECKS TO SEE IF THIS HC* CREATES AN ERROR. IF IT DOES, THE FILE PROBABLY DOESN'T HC* 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 TRUUE 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* VERSION AND DATE :&C* VERSION I.0 31-AUG-84 C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC*********************V**************************************************C* CHARACTER *(*) FNAMEC EXISTS = .FALSE.4 OPEN (UNIT=0,STATUS='OLD',FILE=FNAME,ERR=1000) CLOSE (UNIT=0) EXISTS = .TRUE.C 1000 RETURN ENDCC---END EXISTSCwwVwG* SUBROUTINE FIRST ( STRING, CHAR, I )C*3C* *******************************3C* *******************************3C* ** **3C* W ** FIRST **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* FIRST CHARACTER C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIFX 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO RETRIEVE THE FIRST NON-BLANK CHARACTER FROM A STRING HC* 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 FORTRANY 77C*C* VERSION AND DATE :&C* VERSION I.0 22-FEB-85 C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING CHARACTER *1 CHARC LENST = LEN(STRING) DO 10 J = 1,LENST' IF (STRING(J:J) .NE. ' ') THEN CHAR = STRING(J:J) I = J RETURN ENDIF10 CONTINUE I = 0Z CHAR = ' ' RETURN ENDCC---END FIRST Cww@^&)/ SUBROUTINE GAUSS ( A, Y, COEF, N, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GAUSS **3C* ** **3C* *******************************3C* ****************[***************C*C* SUBPROGRAM :4C* GAUSSIAN ELIMINATION C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :HC* 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 :HC* IF A ZERO APPEARS ON THE DIAGONAL AND CAN'T BE REMOVED, THE C* MATRIX I^S SINGULAR.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 5-MAR-85 C*C* CHANGE HISTORY :(C* 5-MAR-85 INITIAL VERSIONC*HC***********************************************************************C*% DIMENSION A(N,N), Y(N), COEF(N) LOGICAL ERRORC ERROR = .FALSE. N1 = N - 1 DO 50 I = 1, N1 AMAX = ABS(A(I,I)) L = I I1 _= I+1C+C ----- FIND LARGEST ELEMENT IN THIS COLUMNC DO 10 J = I1, N* IF (ABS(A(J,I)) .GT. AMAX)THEN! AMAX = ABS(A(J,I)) L = J ENDIF10 CONTINUEC>C ----- IF THE LARGEST ELEMENT IS ZERO, THE MATRIX IS SINGULARC IF (AMAX .EQ. 0.0)THEN ERROR = .TRUE. RETURN ELSECHC -------- IF THE LARGEST ELEMENT IS NOT ALREADY ON THE DIAGONAL, PUT IT"C -------- THERE BY SWAPP`ING 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 ROWaC 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 b 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 ENDCC---END GAUSS Cww)% CHARACTER FUNCTION GETC ( NIN )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETC ** c3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* GET CHARACTER C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-55d78 C*C* PURPOSE :HC* GET A SINGLE CHARACTER FROM THE INPUT UNIT... HC* TAKE CARE OF NEW LINES AND END-OF-FILE 0C* 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 eENDLINEC*C* FILE REFERENCES :C* NINC*C* SUBPROGRAM REFERENCES :C* MLIB_ERROR, LENGTHC*%C* TRANSPORTABILITY LIMITATIONS :C* NONEC*%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* VERSION AND DATE :&C* VERSION I.0 10-SEP-85 C*C* CHANGE HISTfORY :(C* 10-SEP-85 INITIAL VERSIONC*HC***********************************************************************C*( PARAMETER (LMAX=133,NSTART=LMAX+1) CHARACTER *(LMAX) LINE LOGICAL EOF SAVE NPTR, LPTR, EOF, LINE# DATA NPTR/NSTART/, LPTR/LMAX/ DATA EOF/.FALSE./C;C --- END OF LINE WAS REACHED ON LAST ENTRY... GET NEW LINEC IF (NPTR .GT. LPTR) THEN IF ( EOF ) H $ CALL MLIB_ERROR(3,'GETC','Attempted get after engd 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 GETCCwwh@q)& SUBROUTINE GETCHAR ( CH, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETCHAR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :&C* GET CHARACTER C*C* i AUTHOR :4C* ART RAGOSTA 4C* MS207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 JC* NOTE: THIS ROUTINE IS BASED ON THE DECUS ROUTINE 'READKEY' BY R.F.WRENC*C* PURPOSE :CC* THIS ROUTINE WAITS UNTIL A SINGLE KEYSTROKE IS ENTERED.C*C* OUTPUT ARGUMENTS :AC* CH - jTHE 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 VALUEk 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* VERSION AND DATE :&C* VERSION I.0 28-FEB-85 C*C* CHANGE HISTORY :(C* 28-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* IMPLICIT INTEGER (A-Z)B EXTERNAL SS$_NORMAL, IO$_TTYREADALL, IO$M_TIMED, IO$M_NOECHO% l EXTERNAL SS$_WASCLR, SS$_WASSET2 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 (ISTAT .NE. %LmOC(SS$_NORMAL)) THEN ERROR = .TRUE. RETURN ENDIFC)C --- ALLOCATE AN EVENT FLAG AND CLEAR ITC( ISTAT = LIB$GET_EF(KEYBOARD_EF). IF (ISTAT .NE. %LOC(SS$_NORMAL)) THEN ERROR = .TRUE. RETURN ENDIF. ISTAT = SYS$CLREF (%VAL(KEYBOARD_EF))/ IF (ISTAT .NE. %LOC(SS$_WASCLR) .AND.. $ ISTAT .NE. %LOC(SS$_WASSET)) THEN ERROR = .TRUE. RETURN ENDIFD n READ_FUNC = %LOC(IO$_TTYREADALL) .OR. %LOC(IO$M_TIMED) .OR.& $ %LOC(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,,)E IF ((IOSB(1).NE.%LOC(SS$_NORMAL)) .OR. (IOSB(2) .NE. 1)) CH = 0 RETURN ENDCC---END GETCHARCww oiZ-*$ SUBROUTINE GETCPRV ( N, PRIV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETCPRV **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :.C* GET CURRENT PRIVILEGES pC*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*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 CONTqAINING 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 :5C* JPI$_AUTHPRIV, JPI$_CURPRIV, SYS$GETJPIWC*%C* TRANSPORTABILITY LIMITATIONS :(C* ABSOLUTELY NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.r0 12-APR-85 C*C* CHANGE HISTORY :(C* 12-APR-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) PRIV(1)% CHARACTER *10 ALL1(32), ALL2(7) INTEGER *2 ITEM(2)8 INTEGER *4 MASK1(32), MASK2(7), ITMLST(3), QUAD(2)% EQUIVALENCE (ITEM(1),ITMLST(1))CC --- ITEM CODESC, EXTERNAL JPI$_AUTHPRIV, JPI$_CURPRIVC+C --- PRIVILEGE NAMES IN THE FIRST QUADWORDC? DATA ALLs1 / '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 t ', $ '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,< u $ 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(2v) = %LOC( JPI$_CURPRIV )! ITMLST(2) = %LOC( QUAD(1) ) ITMLST(3) = %LOC( LENG )0 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 + 1w PRIV(N) = ALL2(I) ENDIF20 CONTINUE RETURN ENDCC---END GETCPRVCww&)( SUBROUTINE GETFDEV ( IUNIT, FDEV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFDEV **3C* ** **3C* **************************x*****3C* *******************************C*C* SUBPROGRAM :4C* GET FILE DEVICE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :0C* GET THE NAME OF THE DEVICE ON WHICH 5yC* THE FILE 'IUNIT' RESIDES C*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUMENTS :#C* FDEV - THE DEVICE NAME C*C* INTERNAL WORK AREAS :;C* WORK - TEMP VARIABLE TO HOLD THE 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 7z7C*C* VERSION AND DATE :&C* VERSION I.0 24-DEC-86 C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FDEV CHARACTER *100 WORKC FDEV = ' ', INQUIRE(UNIT=IUNIT,NAME=WORK,ERR=1000) I = INDEX(WORK,':')$ IF (I .NE. 0) FDEV = WORK(1:I) 1000 RETURN ENDCC---END GETFDEVCww ҳ[q( SUBR{OUTINE GETFDIR ( IUNIT, FDIR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFDIR **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* GET FILE DIRECTORY C*C* A|UTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :9C* GET THE NAME OF THE DIRECTORY WHICH CONTAINS C* THE FILE 'IUNIT' C*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUME}NTS :=C* FDIR - THE FULL DIRECTORY NAME INCLUDING BRACKETSC*C* INTERNAL WORK AREAS :;C* WORK - TEMPORARY VARIABLE TO HOLD THE FULL FILE C* SPECIFICATIONC*C* FILE REFERENCES :C* IUNITC*C* ERROR PROCESSING :1C* FDIR WILL BE ' ' IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 24-DEC-86 C*C* CHANGE HISTORY :GC*~ 14-OCT-87 MODIFIED TO INCLUDE BRACKETS IN DIRECTORY NAME(C* 24-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FDIR CHARACTER *100 WORKC FDIR = ' ', INQUIRE(UNIT=IUNIT,NAME=WORK,ERR=1000) I = INDEX(WORK,'[') J = INDEX(WORK,']') IF (I .GE. J) RETURN FDIR = WORK(I:J) 1000 RETURN ENDCC---END GETFDIRCww),  SUBROUTINE GETFILE ( INFILE, OUTFILE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFILE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GETFILEC*C* AUTHOR :C*  Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE :IC* RETRIEVE THE NEXT FILE NAME FROM A LIST (INCLUDING WILDCARDS)C*C* INPUT ARGUMENTS :3C* INFILE - THE STRING CONTAINING THE LISTC*C* OUTPUT ARGUMENTS :-C* OUTFILE - NEXT NAME FROM THE LISTHC* (IF "INFILE" CHANGES, WE START OVER AT FIRST FILE)C*C* COMMON BLOCKS :C* NONEC*C* SUBPROGRAM REFERENCES :!C* LENGTH, LIB$FIND_FILEC*%C* ASSUMPTIONS AND RESTRICTIONS :8C* ONLY TEN FILESPECS MAY BE INCLUDED IN A LIST9C* EACH FILESPEC MUST BE LESS THAN 81 CHARACTERSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 10-MAY-1988C*C* CHANGE HISTORY :+C* 10-MAY-1988 - INITIAL VERSIONC*HC***********************************************************************C*$ CHARACTER *(*) INFILE, OUTFILE# CHARACTER *80 WFILE, LIST(10) INCLUDE '($RMSDEF)' DATA WFILE/'????????'/CC --- NEW FILE NAME?C" IF (INFILE .NE. WFILE ) THEN" LENFILE = LENGTH (INFILE)# IF (LENFILE .EQ. 0) RETURN WFILE = INFILE NL = 0 IL = 1 ICON = 0C@C --- IF ITS A LIST, PARSE INPUT LINE INTO INDIVIDUAL FILE SPECSC, IF ((INDEX(INFILE,',') .NE. 0) .OR.) $ (INFILE(1:1) .EQ. '(')) THEN* IF (INFILE(1:1) .EQ. '(') THEN IPTR = 2 ELSE IPTR = 1 ENDIF NPTR = IPTR10 IPTR = IPTR + 10 IF (INFILE(IPTR:IPTR) .EQ. ',') THEN NL = NL + 1- LIST(NL) = INFILE(NPTR:IPTR-1) NPTR = IPTR + 1 IPTR = NPTR5 ELSE IF (INFILE(IPTR:IPTR) .EQ. ')') THEN  NL = NL + 1- LIST(NL) = INFILE(NPTR:IPTR-1)! IPTR = LENFILE + 1 NPTR = IPTR ENDIF+ IF (IPTR .LE. LENFILE) GO TO 10C C --- MISSING RIGHT PARENTHESIS?C$ IF (IPTR .GT. NPTR) THEN NL = NL + 1+ LIST(NL) = INFILE(NPTR:IPTR) ENDIFC"C --- OTHERWISE, A SINGLE FILESPECC ELSE NL = 1 LIST(NL) = INFILE ENDIF  ENDIFC,C --- GET NEXT NAME FOR THE CURRENT FILESPECC920 ISTAT = LIB$FIND_FILE (LIST(IL), OUTFILE, ICON,,,,)@ IF ((ISTAT .EQ. RMS$_NMF) .OR. (ISTAT .EQ. RMS$_FNF)) THENC9C --- ALL DONE FOR THIS FILESPEC, SEE IF THERE IS ANOTHERC ICON = 0 IF (IL .GE. NL) THEN OUTFILE = ' ' ELSE IL = IL + 1 GO TO 20 ENDIF ENDIF RETURN ENDCC---END GETFILECww )* SUBROUTINE GETFNAME ( IUNIT, FNAME )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFNAME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* GET FILE NAME  C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :?C* GET THE FILE NAME ASSOCIATED WITH THE UNIT 'IUNIT' C*C* INPUT ARGUMENTS :7C* IUNIT - THE LOGICAL UNIT NUMBER OF THE FILEC*C* OUTPUT ARGUMENTS :?C* FNAME - THE FILE NAME ONLY (LESS DIRECTORY NAME ANDC* '.' SUFFIX)C*C* INTERNAL WORK AREAS :AC* WORK - TEMPORARY VARIABLE USED TO HOLD FULL FILE NAMEC* C* FILE REFERENCES :C* IUNITC*C* ERROR PROCESSING :,C* FNAME = ' ' IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 24-DEC-86 C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FNAME CHARACTER *100 WORKC FNAME = ' ', INQUIRE(UNIT=IUNIT,NAME=WORK,ERR=1000) I = INDEX(WORK,']') J = NDEX(WORK,'.') - 1 IF (J .LE. I) RETURN FNAME = WORK(I+1:J) 1000 RETURN ENDCC---END GETFNAMECwwUA1 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 207-5 C*  AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415)694-5578C*C* PURPOSE :DC* 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 :2C* BLANKS CAN BE USED ONLY AS DELIMITERS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :C* VERSION I.1 C*C* CHANGE HISTORY :>C* 18-NOV-86 COMMAND LINE INCREASED TO 255 FROM 80(C* 24-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *255 COMMAN' CHARACTER *(*) QUALS(1),PARAMS(1) EXTERNAL SS$_NORMALC IP = 0 NQ = 0 NP = 0 LS = LEN(QUALS(1))C0C --- RETURN COMMAND LINE (LESS FOREIGN COMMAND)C) ISTAT = LIB$GET_FOREIGN(COMMAN,,IP), IF (ISTAT .NE. %LOC(SS$_NORMAL))RETURN IF (IP .LE. 0 )RETURN I = 1C0C --- LOOP WHILE LINE STILL HAS CHARACTERS IN ITC&100 IF ( COMMAN(I:I) .EQ. '/' ) THENC3C --- A QUALIFIER... GET FIRST, NON-BLANK CHARACTERC105 I = I + 1' IF (COMMAN(I:I) .EQ. ' ') THEN$ IF (I .GE. IP) GO TO 300 GO TO 105 ENDIF 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. ' ') .OR. (COMMAN(I:I) .EQ. '/')) $ GO TO 1208 IF (NC .LE. LS ) QUALS(NQ)(NC:NC) = COMMAN(I:I) I = I + 1 NC = NC + 1 GO TO 110'120 IF (COMMAN(I:I) .EQ. ' ') THEN I = I + 1$ IF (I .GT. IP) GO TO 300 GO TO 120 ENDIF GO TO 100 ELSEC7C --- PARAMETER... FIRST CHARACTER IS ALREADY NON-BLANKC NP = NP + 1 NC = 1  PARAMS(NP) = ' 'C4C --- ADD CHARACTERS UNTIL A BLANK OR SLASH IS FOUNDC@210 IF ((COMMAN(I:I) .EQ. ' ') .OR. (COMMAN(I:I) .EQ. '/')) $ GO TO 2208 IF (NC .LE. LS) PARAMS(NP)(NC:NC) = COMMAN(I:I) I = I + 1 NC = NC + 1 GO TO 210'220 IF (COMMAN(I:I) .EQ. ' ') THEN I = I + 1$ IF (I .GT. IP) GO TO 300 GO TO 220 ENDIF GO TO 100 ENDIFC1C --- END OF LOOP WHILE LINE STILL HAS CHARACTERSC 300 RETURN ENDCC---END GETFORCww !)* SUBROUTINE GETFTYPE ( IUNIT, FTYPE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFTYPE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* GET FILE TYPE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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*C* FILE REFERENCES :C* IUNIT C*C* ERROR PROCESSING :2C* FTYPE WILL BE ' ' IF AN ERROR OCCURREDC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 24-DEC-86 C*C* CHANGE HISTORY :=C* 14-OCT-87 MODIFIED TO INCLUDE DOT IN FILE TYPE(C* 24-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FTYPE CHARACTER *100 WORKC FTYPE = ' '/ INQUIRE (UNIT=IUNIT, NAME=WORK, ERR=1000) I = NDEX(WORK,'.') J = INDEX(WORK,';') - 1 IF (I .GT. J) RETURN FTYPE = WORK(I:J) 1000 RETURN ENDCC---END GETFTYPECww |xq) SUBROUTINE GETFVERS (IUNIT, FVERS )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETFVERS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C*  GET FILE VERSION C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* GET THE VERSION NUMBER OF THIS FILE C*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 - VARIABLE 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* VERSION AND DATE :&C* VERSION I.0 24-DEC-86 C*C* CHANGE HISTORY :BC* 14-OCT-87 MODIFIED TO INCLUDE SEMI COLON IN VERSION(C* 24-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) FVERS CHARACTER *100 WORKC FVERS = ' ', INQUIRE(UNIT=IUNIT,NAME=WORK,ERR=1000) I = INDEX(WORK,';') FVERS = WORK(I:) 1000 RETURN ENDCC---END GETFVERSCwwa)( SUBROUTINE GETIME ( TOTAL, DELTA )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* GET TIME C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :9C* EXTRACT TOTAL CPU TIME (SINCE CALL TO SETIME):C* AND DELTA CPU TIME (SINCE LAST CALL TO GETIME)=C* NOTE: CPU TIMES ARE ONLY ACCURATE TO 1/100 SECONDC*C* OUTPUT ARGUMENTS :"C*  TOTAL - TOTAL CPU TIME"C* DELTA - DELTA CPU TIMEC*C* SUBPROGRAM REFERENCES :C* LIB$STAT_TIMERC*%C* TRANSPORTABILITY LIMITATIONS :.C* USES SYSTEM ROUTINE LIB$STAT_TIMERC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 17-DEC-86 C*C* CHANGE HISTORY :(C* 17-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* SAVE OLDC# CALL LIB$STAT_TIMER(2,ITIME,) TOTAL = 0.01*FLOAT(ITIME) DELTA = TOTAL-OLD OLD = TOTAL RETURN ENDCC---END GETIMECww:X)4 SUBROUTINE GETLIN ( NREAD, ERROR, LINE, LENG )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETLIN **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* GET LINE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578  C*C* PURPOSE :HC* READ ONE OR MORE LINES OF INPUT, CAPITALIZE, DELETE COMMENTSHC* AND CONTINUE READING IF CONTINUATION SPECIFIED (...). C*C* INPUT ARGUMENTS :1C* NREAD - UNIT FROM WHICH TO READ INPUTC*C* OUTPUT ARGUMENTS :>C* ERROR - AN ERROR WAS ENCOUNTERED DURING INPUT, 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* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :C* VERSION I.1C*C* CHANGE HISTORY :5C* 10-MAY-88 LENGTH OF LINE MADE VARIABLE(C* 3-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER*(*) LINE CHARACTER*132 STRING LOGICAL ERROR, CONTC ERROR = .FALSE. LENG = 1 LINE = ' ' CONT = .TRUE. LMAX = LEN(LINE)C&C --- WHILE CONTINUE FLAG IS SET DO...C10 IF ( CONT ) THEN# READ ( NREAD, 900 ) STRING CALL CAPS ( STRING ) JJ = LENGTH ( STRING ) DO 20 J = 1, JJC5C ------ EXCLAMATION MEANS REST OF LINE IS COMMENTARYC/ IF ( STRING(J:J) .EQ. '!' )GO TO 30) LINE(LENG:LENG) = STRING(J:J) LENG = LENG + 1$ IF (LENG .GT. LMAX) THEN ERROR = .TRUE. RETURN ENDIF20 CONTINUE30 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 - 1B 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 GO TO 10 ENDIFCC --- END OF DO WHILEC RETURN900 FORMAT ( A ) ENDCC---END GETLINCww-*> SUBROUTINE GETOKE ( LINE, LL, IPTR, TOKEN, TYPE, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETOKE **3C*  ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET TOKENC*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*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.6C* 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 C*C* INPUT ARGUMENTS :)C* LINE - THE LINE TO BE PARSED.6C* LL - THE LAST CH ARACTER TO SCAN IN LINE.?C* IPTR - THE LOCATION FROM WHICH PARSING IS TO BEGIN.C*C* OUTPUT ARGUMENTS :@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 LINE:C* ERROR - AN ERROR OCCURRED IN PARSING THE LINE.C*%C* TRANSPORTABILITY LIMITATIONS :/C* NON-STANDARD DATA STATEMENT FOR EOLC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :C* VERSION I.4C*C* CHANGE HISTORY :FC* 10-MAY-88 TOKEN CHANGED TO CHARACTER *(*), CHECK LENGTH:C* 25-JUN-87 FIXED TO ALLOW LOWERCASE LETTERS +C*  IN 'A' TYPE TOKENS<C* 20-MAY-87 ERROR IN END OF LINE HANDLING FIXED3C* 25-MAR-86 COLON REMOVED AS DELIMITER?C* 4-NOV-85 FIXED TO ALLOW NUMBERS STARTING WITH .(C* 3-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) LINE, TOKEN CHARACTER *1 EOL,CH,TYPE INTEGER TSIZE LOGICAL ERROR DATA EOL/13/C IF ( IPTR .LT. 1 ) THEN IPTR = 1# ELSE IF ( IPTR .GT. LL ) THEN TYPE = 'E' RETURN ENDIFCC --- SKIP LEADING BLANKSC10 CH = LINE(IPTR:IPTR) IF ( CH .EQ. ' ' ) THEN IPTR = IPTR + 1! IF ( IPTR .GT. LL ) THEN TYPE = 'E' RETURN ENDIF GO TO 10 ENDIFC4C --- IF CHARACTER IS DELIMITER, RETURN A NULL VALUEC TOKEN = ' ' TSIZE = 10 IF ((CH .EQ. ',') .OR. (CH .EQ. ';')) THEN TYPE = 'N'C)C --- FIRST CHARACTER WAS NOT A DELIMITERC7 ELSE IF (((CH .GE. 'A') .AND. (CH .LE. 'Z')) .OR.6 $ ((CH .GE. 'a') .AND. (CH .LE. 'z'))) THENCC ----- ALPHABETIC TOKENC TYPE = 'A'C?C ------- WHILE (CH IN ALPHA+DIGITS) PACK CHARACTERS INTO TOKENC,30 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) ENDIF5 IF (((CH .GE. 'A') .AND. (CH .LE. 'Z')) .OR.5 $ ((CH .GE. 'a') .AND. (CH .LE. 'z')) .OR.: $ ((CH .GE. '0') .AND. (CH .LE. '9'))) GO TO 30C&C ----- END WHILE (CH IN ALPHA+DIGITS)CF ELSE IF (((CH .GE. '0') .AND. (CH .LE. '9')) .OR. (CH .EQ. '+') 9 $ .OR. (CH .EQ. '-') .OR. (CH .EQ. '.')) THENC,C ----- NUMERICAL TYPE... DEFAULT TO INTEGERC TYPE = 'I'C=C --- CHECK FOR LEADING SIGN AS THESE MAY NOT DENOTE A NUMBERC3 IF ((CH .EQ. '-') .OR. (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 = EOL ELSE# CH = LINE(IPTR:IPTR) ENDIF# IF ((CH .NE. '.') .AND.7 $ ((CH .LT. '0') .OR. (CH .GT. '9'))) THEN TYPE = 'S' RETURN ENDIF ENDIFC-C --- NUMBER FOR SURE (INTEGER OR WHOLE PART)C435 IF ((CH .GE. '0') .AND. (CH .LE. '9')) THEN/ IF (TSIZE .GT. LEN(TOKEN)) GO TO 60# TOKEN(TSIZE:TSIZE) = CH TSIZE = TSIZE + 1 IPTR = IPTR + 1$ IF ( IPTR .GT. LL ) THEN CH = EOL ELSE# CH = LINE(IPTR:IPTR) ENDIF  GO TO 35 ENDIFCC --- CHECK FOR FRACTIONAL PARTC --- DECIMAL POINT?C 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 = EOL ELSE# CH = LINE(IPTR:IPTR) ENDIF TYPE = 'R'6 IF ((CH .LT. '0') .OR. (CH .GT. '9')) THEN%  IF (TSIZE .LE. 2) THEN TYPE = 'S' RETURN ENDIF ENDIFCC ----- FRACTIONAL PARTC737 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 37 ENDIF ENDIFCC ------ CHECK FOR EXPONENTC3 IF ((CH .EQ. 'E') .OR. (CH .EQ. 'D')) 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 = EOL ELSE# CH = LINE(IPTR:IPTR) ENDIF8 IF ((CH .NE. '+') .AND. (CH .NE. '-') .AND. 7 $ ((CH .LT. '0') .OR. (CH .GT. '9'))) THEN IPTR = IPTR - 1 RETURN ENDIF TYPE = 'R'C1C ------- IF WE GET THIS FAR, WE HAVE AN EXPONENTC6 IF ((CH .EQ. '+') .OR. (CH .EQ. '-')) 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 ENDIF740 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 40 ENDIF ENDIFC5C ------ OTHERWISE, RETURN THE SPECIAL CHARACTER ONLYC ELSE TYPE = 'S' TOKEN(1:1) = CH IPTR = IPTR + 1 IF (IPTR .GT. LL) THEN CH = EOL ELSE CH = LINE(IPTR:IPTR) ENDIF ENDIFC(C --- SKIP SPACES AND DELIMITER (IF ANY)C60 IF ( CH .EQ. ' ' ) THEN IPTR = IPTR + 1! IF ( IPTR .LE. LL ) THEN CH = LINE(IPTR:IPTR) GO TO 60 ENDIF ENDIF; IF ((CH .EQ. ',') .OR. (CH .EQ. ';')) IPTR = IPTR + 1 RETURN ENDCC---END GETOKECww>.# SUBROUTINE GETPRV ( N, PRIV )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETPRV **3C* **  **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* GET PRIVILEGES C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPO SE :HC* TO CHECK THE PRIVILEGES ALLOWED BY THE SYSUAF FILE AND HC* 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 :5C* JPI$_AUTHPRIV, JPI$_CURPRIV, 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 12-APR-85 C*C* CHANGE HISTORY :(C* 12-APR-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) PRIV(1)% CHARACTER *10 ALL1(32), ALL2(7) INTEGER *2 ITEM(2)8 INTEGER *4 MASK1(32), MASK2(7), ITMLST(3), QUAD(2)% EQUIVALENCE (ITEM(1),ITMLST(1))CC --- ITEM CODESC, EXTERNAL JPI$_AUTHPRIV, JPI$_CURPRIVC+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) = %LOC( JPI$_AUTHPRIV )! ITMLST(2) = %LOC( QUAD(1) ) ITMLST(3) = %LOC( LENG )0 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 GETPRVCwwpbv+; SUBROUTINE GETSTM ( NREAD, STMT, LENST, CLABEL, EOF )C* 4C* **LzxL* SUBROUTINE TRANSL8 ( LOGIC, PHYSIC )C*3C* ********************************3C* ********************************3C* ** ** 3C* ** TRANSL8 ** 3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM : C* TRANSLATE LOGICAL C*C* AUTHOR :*C* Arthur E. Ragosta C* MS 219-3%C* NASA Ames Research CenterA%C* Moffett Field, Ca. 94035,C* (415) 694-5578C*C* PURPOSE :9C* TRANSLATE A LOGICAL NAME INTO A PHYSICAL NAMETC*C* INPUT ARGUMENTS : C* LOGIC - LOGICAL NAMEC*C* OUTPUT ARGUMENTS :A0C* 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 TRANSLATION C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77TC*C* VERSION AND DATE :'C* VERSION I.0 - 20-JUN-1988IC*C* CHANGE HISTORY :+C* 20-JUN-1988 - INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($LNMDEF)'  INCLUDE '($SSDEF)'" CHARACTER *(*) LOGIC, PHYSIC CHARACTER *40 LOGC DIMENSION ITMLST(4)* INTEGER*2 ITEM(2)D% EQUIVALENCE (ITEM(1),ITMLST(1))E INTEGER SYS$TRNLNMC  LOGC = LOGIC CALL CAPS(LOGC)D PHYSIC = ' '0 ITEM(1) = LEN(PHYSIC)* ITEM(2) = LNM$_STRING* ITMLST(2) = %LOC(PHYSIC) ITMLST(3) = %LOC(LP) ITMLST(4) = 0 CH=C --- SEARCH USER-SPECIFIC (E.G., PROCESS, JOB) TABLES AT THE .C --- HIGHEST PRIORITY, THEN GROUP AND SYSTEMCO10 LL = LENGTH ( LO GC )+ IF (LOGC(LL:LL) .EQ. ':') LL = LL - 1 A ISTAT = SYS$TRNLNM ( , 'LNM$PROCESS', LOGC(1:LL),, ITMLST ) ' IF (ISTAT .EQ. SS$_NOLOGNAM) THEN @ ISTAT = SYS$TRNLNM ( , 'LNM$JOB', LOGC(1:LL),, ITMLST )* IF (ISTAT .EQ. SS$_NOLOGNAM) 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 )T  ENDIF ENDIF ENDIF( PHYSIC (LP+1:) = ' 'CDC --- DO MULTIPLE TRANSLATIONSC % IF (ISTAT .EQ. SS$_NORMAL) THENX LOGC = PHYSIC GO TO 10C ENDIF: RETURN ENDTCPC---END TRANSL8C ww IPTR = IPTR + 1SC #C --- QUOTED STRING COPIED VERBATIM C + ELSE IF (CARD(I:I) .EQ. '''') THEN C 'C --- MAKE SURE NOT A DIRECT ACCESS I/ODCT/ IF (((STMT(1:5) .EQ. 'READ(') .OR. 1 $ (STMT(1:6) .EQ.=O1 SUBROUTINE PARSE (SPEC, DEFAULT, PART, OUT) C*3C* *******************************)3C* ******************************* 3C* ** **N3C* ** PARSE ** 3C* ** **O3C* ******************************* 3C* *******************************C*C* SUBPROGRAM :GC* PARSE,C*C* AUTHOR : C* Arthur E. RagostaIC* MS 219-3%C* NASA Ames Research Centern%C* Moffett Field, Ca. 94035 C* (415) 694-5578C*C* PURPOSE :7C* PARSE A FILE SPECIFICATION (OR PART OF ONE) 1C* EMULATES THE LEXICAL FUNCTION F$PARSEEC*C* INPUT ARGUMENTS :/C* SPEC - INPUT (PARTIAL) FILE SPECECC* DEFAULT - DEFAULT SPEC FOR MISSING PARTS (IF BLANK, USE(+C* CURRENT NODE, ETC.).&C* PART - THE PART WANTED:BC* 'NODE', 'DEVICE', 'DIRECTORY', 'NAME', 3C* 'TYPE', 'VERSION', 'FULL' C*C* OUTPUT ARGUMENTS :*(C* OUT - THE PART REQUESTEDC*C* SUBPROGRAM REFERENCES :2C* TRANSL8, SYS$PARSE, EXIT, LIB$MOVC5C*%C* ASSUMPTIONS AND RESTRICTIONS : C* NOT TRANSPORTABLE.HC* ASSUMES CURRENT DIRECTORY AND FILE TYPE '.DAT' IF NONE GIVENC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77SC*C* VERSION AND DATE :A'C* VERSION I.0 - 20-JUN-1988 C*C* CHANGE HISTORY :2+C* 20-JUN-1988 - INITIAL VERSION*C*HC***********************************************************************C* INCLUDE '($FABDEF)'R INCLUDE '($NAMDEF)'A RECORD /FABDEF/ FABG RECORD /NAMDEF/ NAM - CHARACTER *(*) SPEC, DEFAULT, PART, OUT INTEGER SYS$PARSEI INTEGER *2 IIECU: IF (PART(1:2) .EQ. 'NO') THEN ! NODE I = INDEX(SPEC,'::')  IF (I .NE. 0) THEN  OUT = SPEC(1:I+1)E ELSE# I = INDEX(DEFAULT,'::')  IF (I .NE. 0) THEN# OUT = DEFAULT(1:I+1)  ELSE+ CALL TRANSL8('SYS$NODE',OUT)* ENDIF " ENDIF ELSE *% NAM.NAM$L_ESA = %LOC ( OUT ) $ NAM.NAM$B_ESS = LEN ( OUT )% NAM.NAM$B_NOP = NAM$V_SYNCHKN" 3 NAM.NAM$B_BID = NAM$C_BID" NAM.NAM$B_BLN = NAM$C_BLNCE) FAB.FAB$L_DNA = %LOC ( DEFAULT )*( FAB.FAB$B_DNS = LEN ( DEFAULT )& FAB.FAB$L_FNA = %LOC ( SPEC )% FAB.FAB$B_FNS = LEN ( SPEC )% FAB.FAB$L_NAM = %LOC ( NAM )H" FAB.FAB$B_BID = FAB$C_BID" FAB.FAB$B_BLN = FAB$C_BLN"C " ISTAT = SYS$PARSE ( FAB )* IF (.NOT. ISTAT) CALL EXIT(ISTAT)C ? IF (PART(1:2) .EQ. 'DE') THO TO 10C.C --- CHECK FOR VAX TAB CONTINUATION EXTENSIONC& IF (CARD(1:1) .EQ. CHAR(9)) THENB IF ((CARD(2:2) .GE. '1') .AND. (CARD(2:2) .LE. '9')) THEN' CARD = ' $' // CARD(3:) ENDIF ENDIF CALL UNTAB(CARD) RETURNC100 EOF = .TRUE. RETURN900 FORMAT ( A ) ENDCC---END MLIB_GETCRDCww ]٩*# SUBROUTINE GETSTRING (STRING)C*3C* *******************************3C* *******************************3C* ** **3C* ** GETSTRING **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GETSTRINGC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*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* INPUT ARGUMENTS :C* NONEC*C* OUTPUT ARGUMENTS :(C* STRING - THE STRING RETURNEDC*C* COMMON BLOCKS :C* NONEC*C* SUBPROGRAM REFERENCES :2C* SYS$ASSIGN, SYS$QIOW, LIB$PUT_OUTPUTC*%C* ASSUMPTIONS AND RESTRICTIONS :'C* NOT EVEN REMOTELY PORTABLE.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :C* VERSION I.1C*C* CHANGE HISTORY ::C* 10-MAY-1988 - MODIFIED TO USE LIB$PUT_OUTPUT+C* 27-NOV-1987 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING CHARACTER *1 C" INTEGER SYS$ASSIGN, SYS$QIOW BYTE BYTE  LOGICAL ERRORF 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/C! CALL GET_TERM_SIZE (LW, LS) LS = LEN(STRING) LW8 = LW - 8 I = 0 J = 1 STRING = ' ') NO_TERMINATORS(2) = %LOC(TERM_MASK)C"C --- ASSIGN AN IO CHANNEL FOR TT:C , ISTAT = SYS$ASSIGN ('TT', TERM_CHAN,,)- IF (ISTAT .NE. %LOC(SS$_NORMAL)) RETURNCA READ_FUNC = %LOC(IO$_TTYREADALL) .OR. %LOC(IO$M_TIMED) .OR.< $ %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),4 $ %VAL(999), NO_TERMINATORS,,)G IF ((IOSB(1).NE.%LOC(SS$_NORMAL)) .OR. (IOSB(2) .NE. 1)) BYTE = 0D IF ((BYTE .EQ. 26) .OR. (BYTE .EQ. 25)) THEN ! ^Y or ^Z< CALL LIB$PUT_OUTPUT ( CHAR(27)//' Exit '//CHAR(27)) RETURN ENDIF IF (BYTE .EQ. 13) THEN2 CALL LIB$PUT_OUTPUT ( CHAR(13)//CHAR(10)) BYTE = 32 J = 0 ENDIF J = J + 1 I = I + 1 STRING(I:I) = C1 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 ENDCC---END GETSTRINGCww%뙏' SUBROUTINE GETTERM ( USER, TERM )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETTERM **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :3C* GET TERMINAL NAME FOR USER C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*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* SUBPROGRAM REFERENCES :C* JPI$_TERMINALC* 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 12-APR-85 C*C* CHANGE HISTORY :(C* 12-APR-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) USER, TERM CHARACTER *8 TT INTEGER *2 ITEM(2)# INTEGER *4 ITMLST(3), IOSB(2)% EQUIVALENCE (ITEM(1),ITMLST(1))( EXTERNAL JPI$_TERMINAL, SS$_NORMALC TERM = ' 'C%C --- USE GETJPI TO GET TERMINAL NAMEC ITEM(1) = 8% ITEM(2) = %LOC(JPI$_TERMINAL) ITMLST(2) = %LOC( TT ) ITMLST(3) = %LOC( LENG ) LU = LENGTH(USER)? ISTAT = SYS$GETJPIW ( ,, USER(1:LU), ITMLST, IOSB,, )5 IF ( IOSB(1) .NE. %LOC(SS$_NORMAL) ) GO TO 1000 TERM = TTC 1000 RETURN ENDCC---END GETTERMCwws@8** SUBROUTINE GET_TERM_SIZE (WID, LENG)C*3C* *******************************3C* *******************************3C* **  **3C* ** GET_TERM_SIZE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET_TERM_SIZEC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE :6C*  RETURN THE TERMINALS WIDTH AND PAGE LENGTHC*C* INPUT ARGUMENTS :C* NONEC*C* OUTPUT ARGUMENTS :#C* WID - WIDTH IN COLUMNS!C* LENG - LENGTH IN ROWSC*C* COMMON BLOCKS :C* NONEC*C* SUBPROGRAM REFERENCES :C* LIB$GETDVIC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 22-DEC-1987C*C* CHANGE HISTORY :+C* 22-DEC-1987 - INITIAL VERSIONC*HC***********************************************************************C* INTEGER WID, SS$_NORMAL7 EXTERNAL DVI$_DEVBUFSIZ, DVI$_TT_PAGE, SS$_NORMALC WID = 0 LENG = 0" ITEM = %LOC(DVI$_DEVBUFSIZ)+ ISTAT = LIB$GETDVI(ITEM,,'TT:',WID,,) ITEM = %LOC(DVI$_TT_PAGE), ISTAT = LIB$GETDVI(ITEM,,'TT:',LENG,,) RETURN ENDCC---END GET_TERM_SIZECww"X! SUBROUTINE GETUSER ( USER )C*3C* *******************************3C* *******************************3C* ** **3C* ** GETUSER **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :-C* GET USER NAME C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*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* JPI$_USERNAME, 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 7 JUNE 1985C*C* CHANGE HISTORY :-C* 07-JUN-1985 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) USER INTEGER *2 ITEM(2)# INTEGER *4 ITMLST(4), IOSB(2)% EQUIVALENCE (ITEM(1),ITMLST(1))CC --- ITEM CODEC( EXTERNAL JPI$_USERNAME, SS$_NORMALCC --- FILL ITMLSTC ITEM(1) = 12' ITEM(2) = %LOC( JPI$_USERNAME ) ITMLST(2) = %LOC( USER ) ITMLST(3) = %LOC( LENG ) ITMLST(4) = 04 ISTAT = SYS$GETJPIW ( ,,, ITMLST, IOSB,, )C9 IF ( IOSB(1) .NE. %LOC(SS$_NORMAL) ) USER = 'ERROR' RETURN ENDCC---END GETUSERww* 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 207-5 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415)694-5578C*C* PURPOSE :;C* TO RETRIEVE THE X AND Y LOCATION OF THE CURSOR.C*C* METHODOLOGY :(C* USE VT-100 CONTROL SEQUENCE.C*C* INPUT ARGUMENTS :C* NONEC*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, LEFT-HAND CORNER OF THE SCREEN.C*C* INTERNAL WORK AREAS :C* NONEC*C* COMMON BLOCKS :C* NONEC*C* FILE REFERENCES :C* NONEC*C* DATA BASE ACCESS :C* NONEC*C* SUBPROGRAM REFERENCES :C* NONEC*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.7C* USES THE NON-STANDARD $ FORMAT DESCRIPTIOR.C*%C* ASSUMPTIONS AND RESTRICTIONS :9C* THE TERMINAL MUST BE ASSIGNED TO 'SYS$INPUT'.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :C* VERSION I.1 C*C* CHANGE HISTORY :;C* 10-MAY-88 REPLACE OLD CHARACTER I/O ROUTINES(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *10 STRING CHARACTER *1 ESC BYTE C LOGICAL ER DATA ESC/27/C IX = 0 IY = 0CC --- QUERY TERMINALC( CALL LIB$PUT_OUTPUT ( 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 ) IX I = J + 2 J = INDEX(STRING,'R') - 1 IF (J .LT. I) RETURN READ (STRING(I:J),920) IY0 IF ((IX .LE. 0) .OR. (IX .GE. 133)) IX = 1 IF (IY .LE. 0) IY = 1 IF (IY .GE. 25) IY = 25  RETURN920 FORMAT ( I ) ENDC C---END GETXYCwwκu*C SUBROUTINE GOPEN ( NIN, NOUT, NUNIT, NEW, PROMPT, TYPE, ERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** GOPEN **3C* ** **3C* *******************************3C*  *******************************C*C* SUBPROGRAM :4C* GENERAL PURPOSE OPEN C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* GENERAL PURPOSE SUBPROGRAM TO OPEN A FILE  C*C* INPUT ARGUMENTS :5C* NIN - LOGICAL UNIT NUMBER FOR KEYBOARD3C* NOUT - LOGICAL UNIT NUMBER FOR PROMPT6C* NUNIT - UNIT NUMBER FOR FILE TO BE OPENED&C* NEW - FLAG FOR NEW FILE"C* PROMPT - PROMPT STRING:C* TYPE - DEFAULT FILE TYPE TO BE USED IF USER )C* DOESN'T ENTER A TYPEC*C* OUTPUT ARGUMENTS :C* ERR - ERROR FLAGC*C* FILE REFERENCES :C* NOUT, NIN, NUNITC*C* ERROR PROCESSING :?C* ERR = TRUE IF ERROR OPENING FILE OR NO DATA ENTERED)C* C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 18-DEC-86 C*C* CHANGE HISTORY :(C* 18-DEC-86 INITIAL VERSIONC*HC***********************************************************************C*! CHARACTER *(*) TYPE, PROMPT CHARACTER *80 TEMP, FNAME LOGICAL ERR, NEWC ERR = .FALSE.CC --- ASK FOR FILE NAMEC WRITE(NOUT,900) PROMPT READ(NIN,910) TEMP LT = LENGTH(TEMP)CC --- IF NOTHING ENTERED, EXITC IF (LT .EQ. 0) THEN ERR = .TRUE. RETURN ENDIFCC --- CHECK FOR FILE EXTENSIONC I = LT$10 IF ((TEMP(I:I) .NE. '.') .AND.$ $ (TEMP(I:I) .NE. ']') .AND.$ $ (TEMP(I:I) .NE. ':')) THEN I = I - 1 IF (I .GT. 0) GO TO 10  ENDIF5 IF ((I .GT. 0) .AND. (TEMP(I:I) .EQ. '.')) THEN FNAME = TEMP ELSE * FNAME = TEMP(1:LT) // '.' // TYPE ENDIFCC --- OK, OPEN ITC  IF ( NEW ) THEN= OPEN(UNIT=NUNIT,STATUS='NEW',CARRIAGECONTROL='LIST', $ FILE=FNAME,ERR=1000) ELSE: OPEN(UNIT=NUNIT,STATUS='OLD',FILE=FNAME,ERR=1000) ENDIF RETURNC1000 ERR=.TRUE. RETURN900 FORMAT(' ',A,$)910 FORMAT(A) ENDC C---END GOPENCwwh[+" 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 207-5 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415)694-5578C*C* PURPOSE :AC* TO POSITION THE CURSOR AT THE GIVEN X AND Y LOCATION.C*C* METHODOLOGY :)C* USE VT-100 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* VERSION AND DATE :%C* VERSION I.0 30-JAN-85C*C* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *9 STRINGC IF (IX .LE. 0) IX = 1 IF (IX .GE. 133) IX = 80 IF (IY .LE. 0) IY = 1 IF (IY .GE. 25) 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 GPALFA ( NWRITE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GPALFA **3C* **  **3C* *******************************3C* *******************************C*C* SUBPROGRAM :(C* GP-29 TERMINAL TO ALPHA MODEC*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :FC* TO RETURN A GP-29 TERMINAL TO TEXT MODE. C*C* INPUT ARGUMENTS :=C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE TERMINALC*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* VERSION AND DATE :'C* VERSION I.0 19-AUG-1985C*C* CHANGE HISTORY :*C*  19-AUG-1985 INITIAL VERSIONC*HC***********************************************************************C* WRITE(NWRITE,900) CHAR(2) RETURN900 FORMAT(' ',A1,$) ENDCC---END GPALFACwwb" SUBROUTINE GRALFA ( NWRITE )C*3C* *******************************3C* *******************************3C* ** **3C* ** GRALFA ** 3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :*C* GRAPHON TERMINAL TO ALPHA MODEC*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578  C*C* PURPOSE :HC* TO RETURN A GRAPHON TERMINAL TO TEXT MODE. C*C* INPUT ARGUMENTS :=C* NWRITE - THE LOGICAL UNIT NUMBER FOR THE TERMINALC*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* VERSION AND DATE :&C* VERSION I.0 22-FEB-85 C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* WRITE(NWRITE,900) CHAR(27) RETURN900 FORMAT(' ',A1,'2') ENDCC---END GRALFACww`a%- SUBROUTINE HELP ( LIBR, STRING, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** HELP **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* HELP C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035  4C* (415) 694-5578 C*C* PURPOSE :HC* TO INTERFACE WITH A VMS-FORMAT HELP FILE HC* FROM WITHIN A FORTRAN PROGRAM. C*C* METHODOLOGY :HC* CALL THE SYSTEM-SPECIFIC ROUTINE, LBR$OUTPUT_HELP C*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* VERSION AND DATE :&C* VERSION I.0 12-SEP-84 C*C* CHANGE HISTORY :(C* 12-SEP-84 INITIAL VERSIONC*HC***********************************************************************C*, EXTERNAL LIB$PUT_OUTPUT, LIB$GET_INPUT! CHARACTER *(*) STRING, LIBR LOGICAL ERROR EXTERNAL SS$_NORMALC; ISTAT = LBR$OUTPUT_HELP(LIB$PUT_OUTPUT,,STRING,LIBR,, $ LIB$GET_INPUT)) ERROR = ISTAT .NE. %LOC(SS$_NORMAL) RETURN ENDC C---END HELPCww I SUBROUTINE HEXDEC ( H, I )C*3C* *******************************3C* *******************************3C* ** **3C* ** HEXDEC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* HEXADECIMAL TO DECIMAL C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO CONVERT A HEXADECIMAL STRING INTO THE DECIMAL INTEGER HC* 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* VERSION AND DATE :&C* VERSION I.0 22-FEB-85 C*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@޻X( FUNCTION IDIGIT ( NUMBER, NDIGIT )C*3C* *******************************3C* *******************************3C* ** **3C* ** IDIGIT **3C* ** **3C*  *******************************3C* *******************************C*C* SUBPROGRAM :2C* EXTRACT DIGIT C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE ::C* EXTRACT THE DIGIT 'NDIGIT' LOCATIONS FROM THE 6C* 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* VERSION AND DATE :&C* VERSION I.0 18-DEC-86 C*C* CHANGE HISTORY :(C*  18-DEC-86 INITIAL VERSIONC*HC***********************************************************************C*% IF ( NDIGIT .LT. 1 ) NDIGIT = 1 NUM = NUMBER NDIG = NDIGIT - 1 DO 10 I = 1,NDIG NUM = NUM / 1010 CONTINUE N = NUM / 10 IDIGIT = NUM - N*10 RETURN ENDCC---END IDIGITCww`Ig+2 SUBROUTINE INTRPL ( L, X, Y, N, U, V, IERR )C*3C* ******************************* 3C* *******************************3C* ** **3C* ** INTRPL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* INTERPOLATE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*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* VERSION AND DATE :&C* VERSION I.0 18-DEC-86 C*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 --- PRELIMINARY PROCESSINGC 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 INTRPLCwwg++ SUBROUTINE ISORT ( ARRAY, NUM, INDX )C*3C* *******************************3C* *******************************3C* ** **3C* ** ISORT **3C* ** **3C* *******************************3C*   *******************************C*C* SUBPROGRAM :GC* SORT ARRAY - THE INPUT ARRAY IS SORTED AS WELL AS THE ARRAYEC* 'INDX'. THEREFORE, INDX CAN BE USED TO PRINT6C* ANY NUMBER OF RELATED ARRAYS.C*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER&C* MOFFETT FIELD, CALIF 94035C* (415)694-5578C*C* PURPOSE :0C* PRODUCE A SORTED INDEX POINTER ARRAY 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* VERSION AND DATE :*C* VERSION I.0 MARCH 12, 1984C*C* CHANGE HISTORY :(C* 03/12/84 INITIAL VERSIONC*HC***********************************************************************C*! DIMENSION ARRAY(1), INDX(1) CHARACTER *(*) ARRAY CHARACTER *255 TEMPA INTEGER TEMPI LOGICAL DONEC DO 1 0 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 ISORTCww4M+' SUBROUTINE KEYHIT ( CHAR, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** KEYHIT **3C* ** **3C* ************************ *******3C* *******************************C*C* SUBPROGRAM :4C* KEY HIT C*C* AUTHOR :4C* ART RAGOSTA 4C* MS207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 JC* NOTE: THIS ROUTINE IS BASED ON THE DECUS ROUTINE 'READKEY' BY R.F.WRENC*C*C* PURPOSE :HC* THIS ROUTINE CHECKS THE KEYBOARD TO SEE IF A KEY HAS BEEN HC* STRUCK. IF SO, THE ASCII VALUE OF THE CHARACTER IS RETURNEDHC* 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* VERSION AND DATE :&C* VERSION I.0 28-FEB-85 C*C* CHANGE HISTORY :(C* 28-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* IMPLICIT INTEGER (A-Z)B EXTERNAL SS$_NORMAL, IO$_TTYREADALL, IO$M_TIMED, IO$M_NOECHO% EXTERNAL SS$_WASCLR, SS$_WASSET2 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:C/ ISTAT = SYS$ASSIGN ('TT', TERM_CHAN,,)4 IF (ISTAT .NE. %LOC(SS$_NORMAL)) GO TO 1000C)C --- ALLOCATE AN EVENT FLAG AND CLEAR ITC( ISTAT = LIB$GET_EF(KEYBOARD_EF)4 IF (ISTAT .NE. %LOC(SS$_NORMAL)) GO TO 1000. ISTAT = SYS$CLREF (%VAL(KEYBOARD_EF))/ IF (ISTAT .NE. %L OC(SS$_WASCLR) .AND.4 $ ISTAT .NE. %LOC(SS$_WASSET)) GO TO 1000D READ_FUNC = %LOC(IO$_TTYREADALL) .OR. %LOC(IO$M_TIMED) .OR.& $ %LOC(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,,)E IF ((IOSB(1).NE.%LOC(SS$_NORMAL)) .OR. (IOSB(2).NE.1)) CHAR = 0 RETURN1000 ERROR = .TRUE. RETURN ENDCC---END KEYHITCwwKh+> SUBROUTINE KURV1 ( N, X, Y, SLP1, SLPN, XP, YP, TEMP, S, $ SIGMA )C*3C* *******************************3C* *******************************3C* ** **3C* ** KURV1 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* KURVE 1 C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415)694-5578 C*C* REFERENCE :<C* 'SIX SUBPROG RAMS FOR CURVE FITTING USING SPLINES<C* UNDER TENSION' BY A.K. CLINE, COMMUNICATIONS OF.C* THE ACM, APRIL, 1974, VOL. 17, #4C*C* PURPOSE :HC* THIS SUBROUTINE DETERMINES THE PARAMETERS NECESSARY TO HC* COMPUTE A SPLINE UNDER TENSION PASSING THROUGH A SEQUENCE HC* OF PAIRS IN THE PLANE. C*C* INPUT ARGUMENTS :.C* N - NUMBER OF POINTS TO BE FIT%C* X - ARRAY OF X VALUE S%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 POSITIVE,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* VERSION AND DATE :&C* VERSION I.0 18-DEC-86 C*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 --- TWO 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 + DELS2/ 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 "@}?S? SUBROUTINE KURV2 ( T, XS, YS, N, X, Y, XP, YP, S, SIGMA )C*3C* *******************************3C* *******************************3C* ** **3C* ** KURV2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* KURV #E 2 C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* REFERNECE :=C* 'SIX SUBPROGRAMS FOR CURVE FITTING USING SPLINES )C* UNDER TENSION' BY A.K. CLINE<C* COMMUNICATIONS OF THE ACM, APRI$L 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* VERSION AND DATE :&C* VERSION I.0 18-DEC-86 C*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 CON'TINUEC*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 }M+ SUBROUTINE LEFT ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** ) LEFT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* LEFT JUSTIFY C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C** (415) 694-5578 C*C* PURPOSE :HC* REPLACES A STRING WITH THE SAME STRING LESS LEADING BLANKS. HC* 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 :9C* STRING - THE LEFT JUSTIFIED STRING (INPLACE).C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* + VERSION I.0 15-OCT-84 C*C* CHANGE HISTORY :(C* 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC& IF (STRING(1:1) .NE. ' ') RETURN L = LEN(STRING)C$C --- FIND FIRST NON-BLANK CHARACTERC DO 10 I=1,L+ IF (STRING(I:I) .NE. ' ') GO TO 2010 CONTINUEC C --- ALL CHARACTERS WERE BLANK C RETURNC20 STRING = STRING(I:L) , RETURN ENDC C---END LEFTCww M+ FUNCTION LENGTH ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** LENGTH **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRA-M :C* LENGTHC*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*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 ARGUM.ENTS :-C* STRING - THE STRING TO BE CHECKEDC*C* OUTPUT ARGUMENTS :-C* LENGTH - THE LENGTH OF THE STRINGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 15-OCT-84C*C* CHANGE HISTORY :(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 ENDIF RETURN ENDCC---END LENGTHCww@x ! SUBROUTINE LOWER ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** LOWER **3C* ** **3C* 0 *******************************3C* *******************************C*C* SUBPROGRAM :*C* LOWER CASE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO REPLACE1 A STRING WITH THE SAME STRING BUT WITH CAPITAL 8C* LETTERS REPLACED WITH LOWER CASE. C*C* INPUT ARGUMENTS :-C* STRING - THE STRING TO BE CHNAGEDC*C* OUTPUT ARGUMENTS :*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 2ALPHABET AND LOWER CASE ALPHABET CONTIGUOUSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 1-OCT-84 C*C* CHANGE HISTORY :(C* 1-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING DATA IC /32/C DO 10 I = 1, LEN(STRING)A IF ((STRING(I:I) .GE. 'A') .AND. (STRING(I:I) .LE. 'Z'))9 $ ST3RING(I:I) = CHAR( IC + ICHAR(STRING(I:I)) )10 CONTINUE RETURN ENDC C---END LOWERCww@r+;@; This file contains MACRO-32 source code for MERLIB routines.C; Some of these routines are duplicated in the FORTRAN version ofE; the source code for transportability reasons. The MACRO versions; are more efficient.; .title length;; Author: Arthur E. Ragosta;F; Return the true length of a string; i.e., the location o 4EN ! DEVICEU II = NAM.NAM$B_DEV: CALL LIB$MOVC5 ( II, %VAL(NAM.NAM$L_DEV), 32, 2 $ LEN(OUT), %REF(OUT))B ELSE IF (PART(1:2) .EQ. 'DI') THEN ! DIRECTORY II = NAM.NAM$B_DIR: CALL LIB$MOVC5 ( II, %VAL(NAM.NAM$L_DIR), 32, 2 $ LEN(OUT), %REF(OUT))= ELSE IF (PART(1:2) .EQ. 'NA') THEN ! NAME* II = NAM.NAM$B_NAME ; CALL LIB$M 5OVC5 ( II, %VAL(NAM.NAM$L_NAME), 32, r2 $ LEN(OUT), %REF(OUT))= ELSE IF (PART(1:1) .EQ. 'T') THEN ! TYPE II = NAM.NAM$B_TYPE*; CALL LIB$MOVC5 ( II, %VAL(NAM.NAM$L_TYPE), 32, H2 $ LEN(OUT), %REF(OUT))@ ELSE IF (PART(1:1) .EQ. 'V') THEN ! VERSION II = NAM.NAM$B_VER: CALL LIB$MOVC5 ( II, %VAL(NAM.NAM$L_VER), 32, 2 $ LEN(OUT), %REF (OUT)), ELSE IF ((PART(1:1) .NE. 'F') .AND.J $ (PART(1:1) .NE. ' ')) THEN ! FULL ELSE ILLEGAL OUT = ' ': ENDIF ENDIFTC* RETURN END C C---END PARSESC ww- 20-JUN-1988IC*C* CHANGE HISTORY :+C* 20-JUN-1988 - INITIAL VERSIONC*HC***********************************************************************C* INCLUDE '($LNMDEF)'  INCLUDE '($SSDEF)'" CHARACTER *(*) LOGIC, PHYSIC7m2O. SUBROUTINE COPY (Infile, Outfile, ISTAT)C++ CEC Author: Jonathan Welch#C MODIFIED: ART RAGOSTA JUNE 1988(CIC Functional Description:C OC Copies one file to another. Currently works for sequential files only.CCYC Formal Arguments: CLC Infile"C VMS Usage : char_string'C type : character stringH C access : read only$C mechanism : by descriptorC 0C The name of the input file to be copie8d.C1C OutfileY"C VMS Usage : char_string'C type : character stringN C access : read only$C mechanism : by descriptorCM.C The name of the output file to create.CC Implicit inputs:C$ C noneCRC Implicit outputs:TCT C noneCFC Completion Status:C)8C SS$_NORMAL Function completed successfully.CO>C Any RMS value returned by the following RMS functions:CIC $CONNECTC $CREAT9E C $GET C $OPEN C $PUTC C--L INCLUDE '($FABDEF)'  INCLUDE '($RABDEF)'  INCLUDE '($RMSDEF)'  INCLUDE '($SSDEF)'C K BYTE Buffer(65535) ! Buffer to hold each record as it is read inI7 BYTE Header(2) ! Holds 2 byte VFC header 2 BYTE In(255) ! Name of input file3 BYTE Out(255) ! Name of output fileSCE1 CHARACTER*(*) Infile ! Passed parametersN CHARACTER*(*) OutfileRCT  RAGOSTA GETSTMۉU RAGOSTA GETSTM`1U RAGOSTA GETSTM࠼Z RAGOSTA GETSTM xZ RAGOSTA GETSTMZ RAGOSTA PUTSTM^؞Z RAGOSTA GETSTM:` RAGOSTA MACROxغ` RAGOSTA MACRO [xa RAGOSTA DEFAULT#f{a RAGOSTA DISK_SPACE#@]}a RAGOSTA DISK_SPACE ;`yZ. SUBROUTINE PUTSTM ( NUNIT, LABEL, STMT )C*3C* ********************************3C* ********************************3C* ** ** 3C* ** PUTSTM **S3C* ** ** 3C* ********************************3C* ********************************C*C* SUBPROGRAM :*4C* PUT STATEMENT < C*C* AUTHOR : 4C* LAURA JURGELEIT 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :5C* WRITE A FORTRAN STATEMENT TO UNIT 'NUNIT'OC*C* COMMON BLOCKS :C* NONEC*C* FILE REFERENCES :C* NUNIT C*C* LANGU=AGE AND COMPILER :C* ANSI FORTRAN 77 C*C* VERSION AND DATE :S&C* VERSION I.1 1 JUN 1988C*C* CHANGE HISTORY : 8C* 1-JUN-88 GENERALIZED AND PUT INTO MERLIB(C* 3-SEP-86 INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (LC=72,LL=LC-6)  CHARACTER *(*) STMT  CHARACTER *(LC) CARD CHARACTER *6 TLABEL* CHARACTER *5 LABELCDA IST = 1 W ! POINTER TO NEXT LOCATION TO PRINTB. L = LENGTH(STMT) ! LENGTH OF STMT@ LS = L ! " " " YET TO BE PRINTED TLABEL = LABEL10 IF (LS .GT. LL) THEN5 WRITE (NUNIT,900) TLABEL, STMT(IST:IST+LL-1)* TLABEL = ' $' LS = LS-LL* IST = IST + LL GO TO 10L ENDIF 7 IF (LS .GT. 0) WRITE(NUNIT,900)TLABEL,STMT(IST:L)H RETURN900 FORMAT(A6,A) END C C---END PUTSTMC ?3 #1025,(r2),(r1) ; recall buffer to BUFFER ret .ENDww@l} SUBROUTINE MBELL ( NUNIT )C*3C* *******************************3C* *******************************3C* ** **3C* ** MBELL **3C* ** **3C* *******************************3C* ****************@***************C*C* SUBPROGRAM :4C* RING BELL C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* RING THE TERMINALS BELL. C*C* METHODOLOAGY :HC* 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 77BC*C* VERSION AND DATE :&C* VERSION I.0 31-AUG-84 C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C** WRITE ( NUNIT, 900 )CHAR(27),CHAR(7)900 FORMAT(2A1,$) RETURN ENDC C---END MBELLCww`fMڏ> SUBROUTINE MENU ( NIN, NOUT, CHOICE, N, PROMPT, ANSWER )C*3C* *******************************3C* C *******************************3C* ** **3C* ** MENU **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* MENU C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 D 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* THIS SUBPROGRAM PRESENTS A LIST OF OPTIONS TO THE USER AND HC* REQUESTS A CHOICE BE MADE. ALL ERROR CHECKING IS DONE, AND HC* PAGINATION FOR REQUESTS WITH MANY CHOICES IS HANDLED. C*C* INPUT ARGUMENTS :2C* NIN - THE INPUT LOGICAL UNIT NUMBER3C* E NOUT - THE OUTPUT LOGICAL UNIT NUMBER,C* CHOICE - THE TEXT OF THE CHOICES4C* N - THE NUMBER OF ENTRIES IN CHOICEEC* PROMPT - THE TEXT OF THE PROMPT TO BE PRODUCED AT THE TOP#C* OF EACH PAGE.C*C* OUTPUT ARGUMENTS :&C* ANSWER - THE USER'S ANSWERC*C* FILE REFERENCES :C* NIN, NOUTC*C* SUBPROGRAM REFERENCES :;C* LENGTH, CLEAR, FIRST, BLANKS, RIGHT, MBELLC*C* ERROR PROCESSINFG :BC* CHECK FOR ERRORS DURING CONVERSION OF INPUT TO INTEGER)C* CHECK RESPONSE AGAINST LIMITSC*%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 77C*C* VERSION AND DATE :&C* VERSION I.0 26-NOV-85 C*C* CHANGE HISTORY :(GC* 26-NOV-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) CHOICE(N) CHARACTER *(*) PROMPT CHARACTER *79 LINE CHARACTER *2 A CHARACTER *1 CC INTEGER ANSWERC IF (N .LT. 1) RETURNC-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 .LTH. 19) THEN NS = 18! ELSE IF (N .LT. 37) THEN NS = 36 ELSE NS = 54 ENDIF ELSE IF (L .LT. 34) THEN IF (N .LT. 19) THEN NS = 18 ELSE NS = 36 ENDIF ELSE NS = 18 ENDIFC C --- NUMBER OF SCREENS REQUIREDC NR = (N + NS - 1) / NSCC --- DISPLAY CHOICESC 10 IS = 1 DO 100 I = 1, NR CALL CLEAR WRITEI(NOUT,900) PROMPT WRITE(NOUT,910)C/C --- PUT NEXT SCREEN FULL, WITH CHOICE NUMBERSC IE = MIN0(IS+17,N) DO 50 II=IS,IECC --------- ONE COLUMN WIDEC IF (NS .EQ. 18) THEN WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS) IS = IS + 1CC --------- TWO COLUMNS WIDEC% ELSE IF (NS .EQ. 36) THEN WRITE(A,990) IS. LINE = A // '. ' // CHOICE(IS)' J IF ((IS+18) .LE. N) THEN$ WRITE(A,990) IS+189 LINE(40:) = A // '. ' // CHOICE(IS+18) ENDIF IS = IS + 1CC --------- 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+3K6) .LE. N) THEN$ WRITE(A,990) IS+369 LINE(53:) = A // '. ' // CHOICE(IS+36) ENDIF IS = IS + 1 ENDIF WRITE(NOUT,900)LINE50 CONTINUEC0C ------ UPDATE STARTING POINTER FOR NEXT SCREENC IS = IS + NS - 18C$C ------ PROMPT FOR ANSWER OR RETURNC IF (I .EQ. NR) THEN IF (NR .NE. 1) THEN WRITE(NOUT,930) ELSE WRILTE(NOUT,920)  ENDIF ELSE WRITE(NOUT,940) ENDIFCC --- GET RESPONSEC READ(NIN,950) LINECC --- CHECK FOR HELP REQUESTEDC# CALL FIRST ( LINE, CC, J ) IF (CC .EQ. '?') THEN CALL CLEAR WRITE(NOUT,980) N READ(NIN,950) LINE GO TO 10 ENDIFCC ------ DECODE ANSWERC CALL BLANKS ( LINE ) LL = LENGTH ( LINE ) CALL RIGHMT ( LINE )& READ (LINE,960,ERR=30) ANSWER GO TO 40C+C ------ ERROR, PROBABLY NON-DIGITS ENTEREDC30 CALL MBELL ( NOUT ) WRITE(NOUT,970) N READ(NIN,950) LINE GO TO 10C+C ------ CHECK FOR OR VALID ANSWERC 40 IF (ANSWER .EQ. 0) THEN# IF (I .EQ. NR) GO TO 10 ELSE = IF ((ANSWER .GT. 0) .AND. (ANSWER .LE. N)) RETURN CALL MBELL ( NOUT ) WRITE(NOUT,970) NN READ(NIN,950) LINE GO TO 10 ENDIF100 CONTINUE RETURN900 FORMAT(' ',A)910 FORMAT(' '),920 FORMAT(/' Please enter response : ',$) 930 FORMATG $(/' Please enter response or to see choices again : ',$) 940 FORMAT: $(/' Please enter response or to continue ', $ 'viewing choices : ',$)950 FORMAT(A)960 FORMAT(74X,I5)>970 FORMAT(' Please respond with a number from 1 to',I5,////. $' Enter '' O?'' 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 screen, there will be a pause at the end'/G $' of each Pscreen. In this case, you will be prompted to either'/E $' enter a choice or hit to continue viewing choices.'/C $' On the last screen of the display, entering will'/1 $' redisplay all choices from the start.'///7 $' Please enter to go back to the menu.')990 FORMAT(I2) ENDC C---END MENUCww"[F SUBROUTINE MENU2 ( NIN, NOUT, CHOICE, N, TITLE, PROMPT, ANSWER )C*3C* ************************Q*******3C* *******************************3C* ** **3C* ** MENU2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :8C* MENU, TOO C*C* AUTHOR :4C* ART RAGOSTA 4C* RMS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* THIS SUBPROGRAM PRESENTS A LIST OF OPTIONS TO THE USER AND HC* REQUESTS A CHOICE BE MADE. ALL ERROR CHECKING IS DONE, AND HC* PAGINATION FOR REQUESTS WITH MANY CHOICES IS HANDLED. FC* (BASICALLY THE SAME AS MENU, BUT HAS USER-INPUST OF BOTTOM C* PROMPT)C*C* INPUT ARGUMENTS :2C* NIN - THE INPUT LOGICAL UNIT NUMBER3C* NOUT - THE OUTPUT LOGICAL UNIT NUMBER,C* CHOICE - THE TEXT OF THE CHOICES4C* N - THE NUMBER OF ENTRIES IN CHOICEDC* TITLE - THE TEXT TO BE PRODUCED AT THE TOP OF EACH PAGE:C* PROMPT - THE PROMPT AT THE BOTTOM OF EACH PAGEC*C* OUTPUT ARGUMENTS :&C* ANSWER - THE USER'S ANSWERC*C* FILE REFERENCES :C*T NIN, NOUTC*C* SUBPROGRAM REFERENCES :;C* LENGTH, CLEAR, FIRST, BLANKS, RIGHT, MBELLC*C* ERROR PROCESSING :BC* CHECK FOR ERRORS DURING CONVERSION OF INPUT TO INTEGER)C* CHECK RESPONSE AGAINST LIMITSC*%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 ANUD COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE&C* VERSION I.0 26-NOV-85 C*C* CHANGE HISTORY :5C* 21-AUG-87 ADDED VARIABLE BOTTOM PROMPT(C* 26-NOV-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) CHOICE(N)" CHARACTER *(*) PROMPT, TITLE CHARACTER *79 LINE CHARACTER *2 A CHARACTER *1 CC INTEGER ANSWERC IF (N .LT.V 1) RETURNC-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) THEN NS = 36 ELSE NS = 54 ENDIF ELSE IF (L .LT. 34) THEN IF (N .LT. 19) THEN NS = 18 ELSE NS = 36 ENDIF ELSE W NS = 18 ENDIFC C --- NUMBER OF SCREENS REQUIREDC NR = (N + NS - 1) / NSCC --- DISPLAY CHOICESC 10 IS = 1 DO 100 I = 1, NR CALL CLEAR WRITE(NOUT,900) TITLE WRITE(NOUT,910)C/C --- PUT NEXT SCREEN FULL, WITH CHOICE NUMBERSC IE = MIN0(IS+17,N) DO 50 II=IS,IECC --------- ONE COLUMN WIDEC IF (NS .EQ. 18) THEN WRITE(A,990) IS. LINE = A // '. ' // CHXOICE(IS) IS = IS + 1CC --------- TWO COLUMNS WIDEC% 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 + 1CC --------- THREE COLUMNS WIDEC ELSE WRITE(A,990) IS. LINE = A // '. Y ' // 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)LINE50 CONTINUEC0C ------ UPDATE STARTING POINTER FOR NEXT SCREENC Z IS = IS + NS - 18C$C ------ PROMPT FOR ANSWER OR RETURNC IF (I .EQ. NR) THEN IF (NR .NE. 1) THEN WRITE(NOUT,930) ELSE% WRITE(NOUT,920) PROMPT ENDIF ELSE WRITE(NOUT,940) ENDIFCC --- GET RESPONSEC READ(NIN,950) LINECC --- CHECK FOR HELP REQUESTEDC# CALL FIRST ( LINE, CC, J ) IF (CC .EQ. '?') THEN CALL CLEAR [ WRITE(NOUT,980) N READ(NIN,950) LINE GO TO 10 ENDIFCC ------ DECODE ANSWERC CALL BLANKS ( LINE ) LL = LENGTH ( LINE ) CALL RIGHT ( LINE )& READ (LINE,960,ERR=30) ANSWER GO TO 40C+C ------ ERROR, PROBABLY NON-DIGITS ENTEREDC30 CALL MBELL ( NOUT ) WRITE(NOUT,970) N READ(NIN,950) LINE GO TO 10C+C ------ CHECK FOR OR VALID ANSWERC 40 \ IF (ANSWER .EQ. 0) THEN# IF (I .EQ. NR) GO TO 10 ELSE = IF ((ANSWER .GT. 0) .AND. (ANSWER .LE. N)) RETURN CALL MBELL ( NOUT ) WRITE(NOUT,970) N READ(NIN,950) LINE GO TO 10 ENDIF100 CONTINUE RETURN900 FORMAT(' ',A)910 FORMAT(' ')920 FORMAT(/' ',A,$) 930 FORMATG $(/' Please enter response or to see choices again : ',$) 940 FORMAT: $(/' Please enter r ]esponse or to continue ', $ 'viewing choices : ',$)950 FORMAT(A)960 FORMAT(74X,I5)>970 FORMAT(' Please respond with a number from 1 to',I5,////. $' Enter ''?'' at the prompt for help.'//% $' Enter to continue.')980 FORMAT(//,A $' Please make a selection from the list of choices given.'/D $' Your response should be an integer number from 1 to',I5,'.'/E $' The number associated with each choice is shown immediately'/* $' before tha ^t choice in the menu.'//E $' If the number of choices is too great for all of them to be'/H $' displayed on a single screen, there will be a pause at the end'/G $' of each screen. In this case, you will be prompted to either'/E $' enter a choice or hit to continue viewing choices.'/C $' On the last screen of the display, entering will'/1 $' redisplay all choices from the start.'///7 $' Please enter to go back to the menu.')990 FO_RMAT(I2) ENDC C---END MENUCwwr+6 SUBROUTINE MLIB_ERROR (ISEVER, SUBPROGRAM, TEXT)C*3C* *******************************3C* *******************************3C* ** **3C* ** MERROR **3C* ** **3C* *******************************3C* *******************************`C*C* SUBPROGRAM :C* MERLIB ERRORC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE :>C* USED INTERNALLY BY MERLIB TO OUTPUT ERROR MESSAGESC*C* INPUT ARGUMENTS :5C* ISEVER - SEVERITY CODE =0 INFORMATIVE1C* =1 WARNING/C* =2 ERROaR5C* =3 FATAL ERRORC*C* SUBPROGRAM REFERENCES :(C* LIB$PUT_OUTPUT, LENGTH, EXITC*%C* ASSUMPTIONS AND RESTRICTIONS :CC* LIB$PUT_OUTPUT IS NON-STANDARD; A MORE PORTABLE VERSION C* IS SHOWN IN COMMENTSC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 26-APR-1988C*C* CHANGE HISTORY :+C* 26-APR-1988 - INITIAL VERSIONC*HbC***********************************************************************C*% CHARACTER *(*) SUBPROGRAM, TEXT CHARACTER *132 TEMP CHARACTER *1 CODE(0:3) DATA CODE/'I','W','E','F'/CFC --- IF CALL INCORRECT, SET IT FATAL AND SAY WHY BUT LEAVE SUBPROGRAMC --- NAME UNCHANGEDC4 IF ((ISEVER .LT. 0) .OR. (ISEVER .GT. 3)) THEN ISEVER = 3- TEXT = 'Illegal call to MLIB_ERROR.' ENDIFC LT = LENGTH(TEXT). IF ((LT + LENGTH(ScUBPROGRAM)) .GT. 120) , $ LT = 120 - LENGTH(SUBPROGRAM)' WRITE (TEMP, 900 ) CODE(ISEVER), 8 $ SUBPROGRAM(1:LENGTH(SUBPROGRAM)), TEXT(1:LT)/ CALL LIB$PUT_OUTPUT(TEMP(1:LENGTH(TEMP)))" IF (ISEVER .GE. 3) CALL EXIT RETURN'900 FORMAT('%MERLIB-',A,'-',A,', ',A) ENDCC---END MERRORC' SUBROUTINE MLIB_GET (NAME, VALUE)C*3C* *******************************3C* *******************************3C* d ** **3C* ** MLIB_GET **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* MERLIB GETC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C*e PURPOSE :4C* RETURN A VALUE USED INTERNALLY BY MERLIBC*C* INPUT ARGUMENTS :.C* NAME - C*8 NAME OF VALUE REQUESTEDC*C* OUTPUT ARGUMENTS :EC* VALUE - REAL VALUE RETURNED (COULD BE INTEGER OR LOGICAL C* INTERNALLY)C*C* COMMON BLOCKS :C* MLIB$INTERNALC*C* SUBPROGRAM REFERENCES :C* SEARCHC*%C* ASSUMPTIONS AND RESTRICTIONS :@C* DATA STATEMENT IN ROUTINE IS NOT STANDARD FOR COMMONfC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 26-APR-1988C*C* CHANGE HISTORY :+C* 26-APR-1988 - INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (NUM=2), COMMON / MLIB$INTERNAL / NAMES, VALUES# CHARACTER *8 NAMES(NUM), NAME INTEGER IVALUES(NUM) REAL VALUES(NUM)) EQUIVALENCE (IVALUES(1), VALUES(1))g LOGICAL MATCH, AMBIGC( DATA NAMES/'NREAD ', 'NWRITE '/ DATA IVALUES/5,6/C6 CALL SEARCH (NAMES, NUM, NAME, I, MATCH, AMBIG ) VALUE = VALUES(I) RETURN ENDCC---END MLIB_GETC' SUBROUTINE MLIB_SET (NAME, VALUE)C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_SET **3C* h ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* MERLIB SETC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE :5C* SET A VALUE IN THE INTERNAL MERLIB COMMONC*C* INPUT ARGUMENTS :C* i NAME - NAME TO SETGC* VALUE - VALUE TO SET (MAY BE INTEGER OR LOGICAL INTERNALLY)C*C* COMMON BLOCKS :C* MLIB$INTERNALC*C* SUBPROGRAM REFERENCES :C* SEARCHC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 26-APR-1988C*C* CHANGE HISTORY :+C* 26-APR-1988 - INITIAL VERSIONC*HC***********************************************************************jC* PARAMETER (NUM=2), COMMON / MLIB$INTERNAL / NAMES, VALUES# CHARACTER *8 NAMES(NUM), NAME INTEGER IVALUES(NUM) REAL VALUES(NUM)) EQUIVALENCE (IVALUES(1), VALUES(1)) LOGICAL MATCH, AMBIGC6 CALL SEARCH (NAMES, NUM, NAME, I, MATCH, AMBIG ) VALUES(I) = VALUE RETURN ENDww1[+ SUBROUTINE START_MESSC*3C* *******************************3C* ************************k*******3C* ** **3C* ** START_MESS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* START MESSAGEC*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*lC* PURPOSE :BC* RESTORE THE BROADCAST OF MESSAGES STOPPED BY STOP_MESS7C* DISPLAY ANY MESSAGES THAT HAVE BEEN TRAPPEDC*C* COMMON BLOCKS :C* MLIB$MESSAGEC*C* SUBPROGRAM REFERENCES :>C* SMG$SET_BROADCAST_TRAPPING, SMG$DELETE_PASTEBOARD,$C* LIB$STOP, LIB$PUT_OUTPUTC*%C* TRANSPORTABILITY LIMITATIONS : C* USES SYSTEM ROUTINESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DmATE :C* VERSION I.1C*C* CHANGE HISTORY :#C* 12-MAY-88 CLEANED UP(C* 24-DEC-86 INITIAL VERSIONC*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,)2C IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))) nISTAT = SMG$DELETE_PASTEBOARD(ID,0)2C IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))CC --- DISPLAY TRAPPED MESSAGESFC --- 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 STOoP_MESSC*3C* *******************************3C* *******************************3C* ** **3C* ** STOP_MESS **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STOP MESSAGEC*C* AUTHOR :C* ART RAGOSTAC* MS 2p07-5 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*C* PURPOSE :2C* BEGIN INTERCEPTON OF TERMINAL MESSAGESC*C* INTERNAL WORK AREAS :)C* MESSES - 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* q USES SYSTEM ROUTINESC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 24-DEC-86C*C* CHANGE HISTORY :(C* 24-DEC-86 INITIAL VERSIONC*HC***********************************************************************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_BROADCASrT_TRAPPING# INTEGER SMG$DELETE_PASTEBOARD EXTERNAL MLIB_TRAPCC --- TRAP BROADCAST MESSAGESC- ISTAT = SMG$CREATE_PASTEBOARD (ID,,,,1)2C IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT)): ISTAT = SMG$SET_BROADCAST_TRAPPING (ID,MLIB_TRAP,ID)2C IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))C C --- NUMBER OF MESSAGES TRAPPEDC NMESS = 0 RETURN ENDCC---END STOP_MESSC! SUBROUTINE MLIB_TRAP ( ID )C*3C* ****s***************************3C* *******************************3C* ** **3C* ** MLIB_TRAP **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* TRAP MESSAGEC*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTtER$C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*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 TRANSPORTABLEuC*%C* ASSUMPTIONS AND RESTRICTIONS :<C* NOT A USER ENTRY POINT - USED ONLY BY STOP_MESS.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C* VERSION I.0 5-JAN-87C*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 CHvARACTER *2000 MESSES CHARACTER *2000 LONG' INTEGER SMG$GET_BROADCAST_MESSAGEC3 ISTAT = SMG$GET_BROADCAST_MESSAGE(ID,LONG,LW)2C IF (.NOT. ISTAT) CALL LIB$STOP(%VAL(ISTAT))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_TRAPCwwç\+? SUBROU wTINE NAE ( NREAD, NWRITE, NUM, MAX, IARRAY, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** NAE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* NIFTY ARRAY EDITOR x C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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* y ON A VT100-COMPATIBLE TERMINAL.C*C* INPUT ARGUMENTS :2C* NREAD - KEYBOARD LOGICAL UNIT NUMBER.0C* NWRITE - SCREEN LOGICAL UNIT NUMBER.2C* NUM - NUMBER OF ELEMENTS IN ARRAYS.-C* MAX - 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.zC*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 RESTR{ICTIONS :,C* VT100-COMPATIBLE TERMINALS ONLY.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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) 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 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 NWR}ITE - SCREEN UNIT NUMBERC STRING - INPUT BUFFERHC ISTART - THE FIRST ELEMENT IN THE ARRAY TO BE DISPLAYED ON THE SCREENC GO TO 50; ENTRY NAE1 ( NREAD, NWRITE, NUM, MAX, IARRAY, ERROR )50 CALL CLEAR 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 )5 CALL MLIB_WRITA ( NWRITE, NUM, IARRAY, 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 ( NWRITE )B 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 )# ISTART = 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 MBELL ( NWRITE )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+ 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 ( NWRITE ) ENDIF ELSE' CALL REVLF ( NWRITE ) 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 ( NWRITE )> CALL STAT ( IX, IY, ' Unintelligible input. ' ) CALL SLEEP ( 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 MBELL ( NWRITE )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, IARRAY ) GO TO 100 ENDIFC"C ------- PUT NEW VALUE IN ARRAY C CALL RIGHT ( TOKE ). READ ( TOKE, 950 ) IARRAY ( IPTR ) GO TO 200 ENDIF  ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET ( NWRITE ) 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 NAEC8 SU BROUTINE NAE2 ( NREAD, NWRITE, NUM, MAX, IARRAY,( $ IARRAY2, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** NAE2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :0C*  NIFTY ARRAY EDITOR 2 C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :CC* TO ENABLE THE SCREEN-ORIENTED EDITING OF 2 ARRAYS. C*C* METHODOLOGY :HC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION. C*C* INPUT ARGUMENTS :2C* NREAD - KEYBOARD LOGICAL UNIT NUMBER.0C* NWRITE - SCREEN LOGICAL UNIT NUMBER.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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 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 MBELL ( NWRITE )B 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 MBELL ( NWRITE )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+ 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 + 1D CALL MLIB_WRITL2 ( NWRITE, IY+1, IPTR, IARRAY, 0 $ IARRAY2 )* WRITE ( NWRITE, 940 )* CALL REVLF ( NWRITE ) ENDIF ELSE' CALL REVLF ( NWRITE ) 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 ) ESCB  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 ( NWRITE )> CALL STAT ( IX, IY, ' Unintelligible 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 ( NWRITE )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 ARRAY C 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 ( NWRITE ) 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 NAE2C8 SUBROUTINE NAE3 ( NREAD, NWRITE, NUM, MAX, IARRAY,1 $ IARRAY2, IARRAY3, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** NAE3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :0C* NIFTY ARRAY EDITOR 3 C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :CC* TO ENABLE THE SCREEN-ORIENTED EDITING OF 3 ARRAYS. C*C* METHODOLOGY :H C* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION. C*C* INPUT ARGUMENTS :2C* NREAD - KEYBOARD LOGICAL UNIT NUMBER.0C* NWRITE - SCREEN LOGICAL UNIT NUMBER.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 :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 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 MBELL ( NWRITE )B 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 = 0E 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 = IPTRC 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 )E 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 = 0C 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 MBELL ( NWRITE )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+ 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 )E 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' SCREENCC 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 )C 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 + 1D CALL MLIB_WRITL3 ( NWRITE, IY+1, IPTR, IARRAY, 5 $ IARRAY2, IARRAY3 )* WRITE ( NWRITE, 940 )* CALL REVLF ( NWRITE ) ENDIF ELSE' CALL REVLF ( NWRITE ) 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 ) ESCB 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 ( NWRITE )> CALL STAT ( IX, IY, ' Unintelligible input. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )D CALL MLIB_WRITL3 (NWRITE, IY, IPTR, IARRAY, IARRAY2, ) $ IARRAY3) GO TO 100 ENDIF IA = IA + 1& IF ( IA .GT. NARRAY ) THEN$ CALL MBELL ( NWRITE )D CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )D CALL MLIB_WRITL3 (NWRITE, IY, IPTR, IARRAY, IARRAY2, ) $ IARRAY3) GO TO 100 ENDIFC"C ------- PUT NEW VALUE IN ARRAY C 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 ( NWRITE ) 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 NAE3C? SUBROUTINE RNAE ( NREAD, NWRITE, NUM, MAX, ARRAY, ERROR )C*3C* *******************************3 C* *******************************3C* ** **3C* ** RNAE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :8C* NIFTY ARRAY EDITOR (REAL) C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5  4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :=C* TO ENABLE THE SCREEN-ORIENTED EDITING OF 1 ARRAY.C*C* METHODOLOGY :HC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION. C*C* INPUT ARGUMENTS :2C* NREAD - KEYBOARD LOGICAL UNIT NUMBER.0C* NWRITE - SCREEN LOGICAL UNIT NUMBER.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 :HC* CLEAR, MLIB_NSTAT, MLIB_WRITA, GOTOXY, CAPS, LEFT, HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 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 ( NWRITE )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 ( NWRITE )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 ( NWRITE ) ENDIF ELSE' CALL REVLF ( NWRITE ) 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 ( NWRITE )> 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 ( NWRITE )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 ARRAY C CALL RIGHT ( TOKE )- READ ( TOKE, 950 ) ARRAY ( IPTR ) GO TO 200 ENDIF ENDIF GO TO 100CC --- END REPEAT UNTILC1000 CALL SRESET ( NWRITE ) 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 RNAEC8 SUBROUTINE RNAE2 ( NREAD, NWRITE, NUM, MAX, ARRAY,' $ ARRAY2, ERROR )C*3C* *******************************3C*  *******************************3C* ** **3C* ** RNAE2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :7C* (REAL) NIFTY ARRAY EDITOR 2 C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5  4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :CC* TO ENABLE THE SCREEN-ORIENTED EDITING OF 2 ARRAYS. C*C* METHODOLOGY :HC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION. C*C* INPUT ARGUMENTS :2C* NREAD - KEYBOARD LOGICAL UNIT NUMBER.0C* NWRITE - SCREEN LOGICAL UNIT NUMBER.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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 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 ( NWRITE )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 ( NWRITE )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 + 1C CALL MLIB_WRITL2 ( NWRITE, IY+1, IPTR, ARRAY, & $ ARRAY2 )* WRITE ( NWRITE, 940 )* CALL REVLF ( NWRITE ) ENDIF ELSE' CALL REVLF ( NWRITE ) 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, 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 ( NWRITE )> 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 ( NWRITE )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 ARRAY C 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 ( NWRITE ) CALL CLEAR RETURN900 FORMAT ( A 80 )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 RNAE2C8 SUBROUTINE RNAE3 ( NREAD, NWRITE, NUM, MAX, ARRAY,/ $ ARRAY2, ARRAY3, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** RNAE3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :0C* NIFTY ARRAY EDITOR 3 C*C* AUTHOR :4C* ART RAGOSTA 4C*  MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :CC* TO ENABLE THE SCREEN-ORIENTED EDITING OF 3 ARRAYS. C*C* METHODOLOGY :HC* USES DEC RUN TIME LIBRARY CALLS FOR SCREEN MANIPULATION. C*C* INPUT ARGUMENTS :2C* NREAD - KEYBOARD LOGICAL UNIT NUMBER.0C* NWRITE - SCREEN LOGICAL UNIT NUMBER.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 :HC* CLEAR, MLIB_NSTAT, MLIB_WRITA3, GOTOXY, CAPS, LEFT, HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 DIMENSION 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 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 ( NWRITE )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 = 0B 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 )B 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 ( NWRITE )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 )B 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 + 1C CALL MLIB_WRITL3 ( NWRITE, IY+1, IPTR, ARRAY, 3 $ ARRAY2, ARRAY3 )* WRITE ( NWRITE, 940 )* CALL REVLF ( NWRITE ) ENDIF ELSE' CALL REVLF ( NWRITE ) 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 ( NWRITE )> CALL STAT ( IX, IY, ' Unintelligible input. ' )  CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )B CALL MLIB_WRITL3 (NWRITE, IY, IPTR, ARRAY, ARRAY2, ( $ ARRAY3) GO TO 100 ENDIF IA = IA + 1& IF ( IA .GT. NARRAY ) THEN$ CALL MBELL ( NWRITE )D CALL STAT ( IX, IY, ' Extra data on line ignored. ' ) CALL SLEEP ( 3 )4 CALL MLIB_NSTAT ( IX, IY, NUM, DOWN )B  CALL MLIB_WRITL3 (NWRITE, IY, IPTR, ARRAY, ARRAY2, ( $ ARRAY3) GO TO 100 ENDIFC"C ------- PUT NEW VALUE IN ARRAY C 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 ( NWRITE ) 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* ** **4C* ** MLIB_WRITA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C*  WRITE ARRAYS (REAL)C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 :4C* WRITE ARRAYS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035  4C* (415) 694-5578 C*C* PURPOSE :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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_WRITA2CB SUBROUTINE MLIB_WRITA3 (NWRITE, NUM, ARRAY, ARRAY2, ARRAY3, % $ ISTART)C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_WRITA3 **3C* **   **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WRITE ARRAYS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C*   PURPOSE :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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* ** **4C* ** MLIB_WRITL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* WRITE LINE (REAL)C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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 LIMITATIONS :C* NOT TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* VT-100 SCREENC*C* LANGUAGE AND COMPILER :C*  ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 :4C*  WRITE LINE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*C* CHANGE 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_WRITL2C H SUBROUTINE MLIB_WRITL3 ( NWRITE, IY, IPTR, ARRAY, ARRAY2, ARRAY3 )C*3C* *******************************3C* *******************************3C* ** **4C* ** MLIB_WRITL3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WRITE LINE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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* **  **4C* ** MLIB_WRITA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WRITE ARRAYS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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',$) ENDC !C---END MLIB_WRITACE SUBROUTINE MLIB_WRITA2 ( NWRITE, NUM, IARRAY, IARRAY2, ISTART )C*3C* *******************************3C* *******************************3C* ** **8C* ** MLIB_WRITA2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :"4C* WRITE ARRAYS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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 TER$MINALC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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) RET%URN 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_WRITA2CE SUBROUTINE MLIB_WRITA3 (NWRITE, NUM, IARRAY, IARRAY2, IARRAY3, % $ & ISTART)C*3C* *******************************3C* *******************************3C* ** **4C* ** MLIB_WRITA3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WRITE ARRAYS C*C* AUT 'HOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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 ENTRI(ES 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* LANGUAG)E AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 IF*IRST = 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* ** **8C* ** MLIB_WRITL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WRITE LINE C*C* AUTHOR :4C* ART RAGOSTA , 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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_WRITLC B SUBROUTINE MLIB_WRITL2 ( NWRITE, IY, IPTR, IARRAY, IARRAY2 )C*3C* *******************************3C* **********************/*********3C* ** **8C* ** MLIB_WRITL2 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WRITE LINE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* 0 AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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 1ARRAY*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* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*C* CHANGE HISTORY :(C* 2 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_WRITL2C B SUBROUTINE MLIB_WRITL3 ( NWRITE, IY, IPTR, IARRAY, IARRAY2, ' $ 3 IARRAY3 )C*3C* *******************************3C* *******************************3C* ** **4C* ** MLIB_WRITL3 **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WRITE LINE C*C* 4 AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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 WHIC5H 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 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*6 LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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 G7OTOXY ( IX, IY ) RETURN8900 FORMAT(' ',I3,' ',I5,' ',I5,' ',I5) ENDCC---END MLIB_WRITL3C 1 SUBROUTINE MLIB_NSTAT ( IX, IY, NUM, DOWN )C*3C* *******************************3C* *******************************3C* ** **3C* ** MLIB_NSTAT **3C* ** **3C* **********************8*********3C* *******************************C*C* SUBPROGRAM :4C* NAE STATUS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO DISPLAY THE STATUS OF THE NAE E9DITOR. C*C* METHODOLOGY :HC* 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 ARRAYS3C* 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 TR:ANSPORTABLE.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 4-FEB-85 C*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_NSTATCwwm)" FUNCTION NDEX (STRING, TARG)C*3C* *******************************3C* *******************************3C* ** **3C* ** NDEX **3C* ** **3C* *******************************3C* *******************************C*C* SUB=PROGRAM :C* END INDEXC*C* AUTHOR :C* L JURGELEITC* MS 207-5 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C* (415) 694-5578C*C* PURPOSE :=C* FIND THE FIRST OCCURRENCE OF THE SPECIFIED TARGET1C* CHARACTERS FROM THE END OF THE STRINGC*C* INPUT ARGUMENTS :/C* STRING - CHARACTER STRING TO SEARCH-C* TARG - CHARACTERS TO SEARCH FORC*C* OUTPUT ARGUMENTS :9C*> NDEX - POSITION IN STRING OF TARGET CHARACTERC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 15-DEC-1987C*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 NDEXCwwOI SUBROUTINE OCTDEC ( O, I )C*3C* *******************************3C* *******************************3C* ** @ **3C* ** OCTDEC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* OCTAL TO DECIMAL C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETAT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO CONVERT AN OCTAL STRING INTO THE DECIMAL NUMBER HC* 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* LBANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 22-FEB-85 C*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 OCTDECCwwh/% SUBROUTINE OPER ( MESSAG, WHO )C*3C* C *******************************3C* *******************************3C* ** **3C* ** OPER **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* OPERATOR MESSAGE C*C* AUTHOR :4C* ART RAGOSTA D 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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 :EAC* 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* VERSION AND DATE :&C* VERSION I.0 F25-JUL-85 C*C* CHANGE HISTORY :(C* 25-JUL-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) MESSAG, WHO CHARACTER *132 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, G4, 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:132) = MESSAG ! USER MESSAGEC! ISTAT = SYS$SNDOPR(MSGBUF,) REHTURN ENDC C---END OPERCww9ݸ- SUBROUTINE OPERW ( MESSAG, WHO, REPLY )C*3C* *******************************3C* *******************************3C* ** **3C* ** OPERW **3C* ** **3C* *******************************3C* *******************************C*C* S IUBPROGRAM :4C* OPERATOR MESSAGE/WAIT FOR REPLY C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO SEND A MESSAGE TO AN OPERATOR'S CONSOLE AND WAIT FOR A HC* REPLY. J C*C* INPUT ARGUMENTS :7C* MESSAG - THE TEXT OF THE MESSAGE TO BE SENTOC* WHO - THE OPERATOR TO RECEIVE THE MESSAGE (EG,'CENTRAL','TAPES')C*C* OUTPUT ARGUMENTS :HC* REPLY - THE TEXT STRING ENTERED BY THE OPERATOR, OR AN ERROR3C* MESSAGE(FIRST WORD IS 'ERROR')C*C* INTERNAL WORK AREAS :AC* MSGBUF - THE BUFFER FOR THE MESSAGE AND COMMAND CODESFC* OPER,IOPER - THE OPERATOR TARGET CODESK IN ASCII AND BINARYC*C* FILE REFERENCES :!C* 0 - READ FROM MAILBOXC*C* SUBPROGRAM REFERENCES :.C* SYS$SNDOPR, SYS$CREMBX, SYS$DASSGNC*C* ERROR PROCESSING :EC* THE STATUS OF THE PREVIOUS SYSTEM SERVICE CALL IS CHECKEDC* BEFORE CONTINUING.C*%C* TRANSPORTABILITY LIMITATIONS :$C* HIGHLY NON-TRANSPORTABLEC*%C* ASSUMPTIONS AND RESTRICTIONS ::C* NO CHECK IS PERFORMED TO SEE IF 'WHO' IS VALIDC*C* LLANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 25-JUL-85 C*C* CHANGE HISTORY :(C* 25-JUL-85 INITIAL VERSIONC*HC***********************************************************************C*' CHARACTER *(*) MESSAG, WHO, REPLY CHARACTER *132 MSGBUF# CHARACTER *2 OPERS(11), DUMMY" INTEGER *2 IOPER(11), IDUMMY EQUIVALENCE (DUMMY,IDUMMY)C8C --- OPERATOR TARGET CODES FROM SYSLIB:STMARLET($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 MSNGBUF(5:8) = ' '6 MSGBUF(9:132) = 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')( O 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 OPERWCwww?) SUBROUTINE PROMPT ( NUNIT, STRING )C*3C* *******************************3C* *******************************3C* ** **3C* P ** PROMPT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* PROMPT C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 940Q35 4C* (415) 694-5578 C*C* PURPOSE :HC* PRODUCE A PROMPT TO THE TERMINAL WITHOUT A . C*C* METHODOLOGY :HC* NON-TRANSPORTABLE DEC '$' FIELD DESCRIPTOR IN THE FORMAT. C*C* INPUT ARGUMENTS :CC* NUNIT - THE LOGICAL UNIT NUMBER TO RECEIVE THE PROMPT.,C* STRING - THE TEXT OF THE PROMPT.C*C* FILE REFERENCES : C* NUNIT - OUTPUT UNIT.C*%C* TRANSPORTABILITRY LIMITATIONS :=C* USES DEC-SPECIFIC '$' FIELD DESCRIPTOR IN FORMAT.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 31-AUG-84 C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC WRITE ( NUNIT, 900 )STRING900 FORMAT (' ', A, $ ) RETURN ENDCC---ENSD PROMPTCww 2O+! SUBROUTINE PUTC ( C, NOUT )C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* PUT CHARACTETR C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :6C* PUT A SINGLE CHARACTER TO THE OUTPUT FILE.C*C* INPUT ARGUMENTS :)C* C - THE CHARACTER TO OUTPUT0C* NOUT- THE OUTPUT LOGUICAL UNIT NUMBERC*C* SUBPROGRAM REFERENCES :C* MLIB_ERRORC*%C* TRANSPORTABILITY LIMITATIONS :EC* THE SAVE STATEMENT (WHICH IS COMMENTED) MAY BE NEEDED ON C* 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* 'LISVT'" ON THE VAX.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 10-SEP-85 C*C* CHANGE HISTORY :(C* 10-SEP-85 INITIAL VERSIONC*HC***********************************************************************C*# PARAMETER (LMAX=132,NSTART=0) CHARACTER *(LMAX) LINE CHARACTER CC SAVE NPTR, LINE DATA NPTR/NSTART/CC --- END OF LINE, WRITE BUFFERC IF (C .EQ.W 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 Xerror on write.') RETURN900 FORMAT(A)910 FORMAT( ) ENDC C---END PUTCCww@GwO+# SUBROUTINE PUTSTRING (STRING)C*3C* *******************************3C* *******************************3C* ** **3C* ** PUTSTRING **3C* ** **3C* *******************************3C* Y *******************************C*C* SUBPROGRAM :C* PUTSTRINGC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*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, LZIB$PUT_OUTPUTC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NOT TRANSPORTABLEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 22-DEC-1987C*C* CHANGE HISTORY :+C* 22-DEC-1987 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC LS = LENGTH ( STRING ) IF (LS .EQ. 0) RETURNC! CALL GET_TER[M_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)) THEN GO TO 20 ELSE J = I + IW - 1 ENDI\F ENDIF, CALL LIB$PUT_OUTPUT ( STRING(I:J) ) I = J + 1 GO TO 10 ENDIF RETURN ENDCC---END PUTSTRINGCww@~)% SUBROUTINE QSORT ( X, N, WORK )C*3C* *******************************3C* *******************************3C* ** **3C* ** QSORT **3C* ** ] **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* QUICK SORT C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :^HC* QUICK SORT A CHARACTER ARRAY <C* REF: "SOFTWARE TOOLS" BY KERNIGHAN AND PLAUGERC*C* INPUT ARGUMENTS :C* X - ARRAY TO SORT(C* N - NUMBER OF ELEMENTS IN NC* WORK - WORK STRINGC*C* INTERNAL WORK AREAS :;C* LEFT, RIGHT - TEMPORARY STORAGE FOR POINTERS TO,C* SIMULATE RECURSIONC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND D_ATE :&C* VERSION I.0 24-SEP-85 C*C* CHANGE HISTORY :(C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) X(N), WORK CHARACTER *80 TEMP! INTEGER LEFT(40), RIGHT(40)C LEFT(1) = 1 RIGHT(1) = N ISP = 1CC --- DO WHILE ISP > 0C10 IF (ISP .GT. 0) THEN, IF (LEFT(ISP) .GE. RIGHT(ISP)) THEN ISP = ISP - 1 ELSE ` I = LEFT(ISP) J = RIGHT(ISP) WORK = X(J) MID = (I+J) / 2" IF ((J-I) .GT. 5) THENE IF (((X(MID) .LT. WORK) .AND. (X(MID) .GT. X(I))) .OR.F $ ((X(MID) .GT. WORK) .AND. (X(MID) .LT. X(I)))) THENCC --- SWAP X(MID) WITH X(J)C TEMP = X(MID) X(MID) = X(J) X(J) = TEMPH ELSE IF (((X(I) .LT. X(MID)) .AND. (X(I) .GT. WORK)) .OR.Ca $ ((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))) THbEN 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(IScP) - 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 QSORTCwwd2P+! SUBROUTINE READQ ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** READQ **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* READ QUIETC*C* AUTHOR :C* e Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*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 :fC* NOT TRANSPORTABLE.;C* WILL BOMB IF UNABLE TO ASSIGN TERMINAL CHANNEL.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 12-MAY-1988C*C* CHANGE HISTORY :+C* 12-MAY-1988 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING" INTEGER SYS$ASSIGN, SYS$QIOW INTEGER *2 CHAN DATA CHAN/0/( g EXTERNAL IO$_READVBLK, IO$M_NOECHOC IF (CHAN .LE. 0) THEN+ ISTAT = SYS$ASSIGN('TT:', CHAN,, ) IF (.NOT. ISTAT)F $ CALL MLIB_ERROR(3,'READQ','Unable to access terminal.') ENDIFC10 ISTAT = SYS$QIOW (, %VAL(CHAN), %VAL(%LOC(IO$_READVBLK) .OR. = $ %LOC(IO$M_NOECHO)),,,, %REF(STRING),/ $ %VAL(LEN(STRING)),,,,) RETURN ENDC C---END READQCwwER+1 SUBROUTIhNE READT ( ITIME, BUFF, NUM, IRET )C*3C* *******************************3C* *******************************3C* ** **3C* ** READT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* READ WITH TIMEOUTC*C* AUTHOR :C* i ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :EC* TO READ AN ARRAY OF CHARACTERS 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 DATA4jC* NUM - THE NUMBER OF CHARACTERS ENTERED5C* IRET - =0 FOR NORMAL RETURN ( OR ^Z)1C* =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* ANSI FORTRAN 77C*C* VERSION AND DATE :C* VERSION I.1C*C* CHANGE HISTORY :4C* k 12-MAY-88 OUTPUT CHANGED TO CHARACTER(C* 27-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) BUFF INTEGER*2 IOSB(4)D EXTERNAL IO$_READVBLK, IO$M_TIMED, IO$M_TRMNOECHO, SS$_TIMEOUT EXTERNAL SS$_NORMAL1 INTEGER SS$_NORMAL, SS$_TIMEOUT, SYS$ASSIGN LOGICAL LINIT SAVE LINIT DATA LINIT/.FALSE./C IF (.NOT. LINIT) THEN, ISTAT = SYS$ASSIGN l('TT:', ICHAN,,). IF (ISTAT .NE. %LOC(SS$_NORMAL)) THEN IRET = -1 RETURN ENDIF LINIT = .TRUE. ENDIFC NUM = LEN(BUFF)< IFUNC = %LOC(IO$_READVBLK) .OR. %LOC(IO$M_TRMNOECHO) IF (ITIME .GE. 0) THEN IT = ITIME, IFUNC = IFUNC .OR. %LOC(IO$M_TIMED) ELSE IT = 0 ENDIFF ISTAT = SYS$QIOW (,%VAL(ICHAN), %VAL(IFUNC), IOSB,,, %REF(BUFF),, $ %VAL(NUM), m%VAL(IT),,,) NUM = IOSB(2)- IF (IOSB(1) .EQ. %LOC(SS$_NORMAL)) THEN IRET = 03 ELSE IF (IOSB(1) .EQ. %LOC(SS$_TIMEOUT)) THEN IRET = 1 ELSE IRET = -1 ENDIF RETURN ENDC C---END READTCww ]+( SUBROUTINE RECALL ( COMMAND, NUM )C*3C* *******************************3C* *******************************3C* ** **3nC* ** RECALL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* RECALLC*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER$C* MOFFETT FIELD, CA 94035C*C* PURPOSE :CC* TO RETURN THE "NUM"th MOST RECENTLY ENTERED DCL COMMANDC*C* o ARGUMENTS:6C* COMMAND - THE TEXT OF THE COMMAND (OUTPUT)NC* NUM - THE COMMAND NUMBER (1 = MOST RECENT, 20 = LAST ) (INPUT)C*C* SUBPROGRAM REFERENCES :C* MLIB_RECALLC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 5-MAY-1987C*C* CHANGE HISTORY :C*HC***********************************************************************C* CHARACTER *(*) COMMAND CHARACpTER *1025 BUFFC/ IF ((NUM .LT. 1) .OR. (NUM .GT. 20)) THEN NN = 1 ELSE NN = NUM ENDIFC:C --- IBUFF POINTS TO THE LENGTH OF THE CURRENT COMMAND...8C --- COMMANDS ARE STORED IN REVERSE ORDER IN A CIRCULARC --- BUFFER OF 1025 BYTESC$ CALL MLIB_RECALL (BUFF, IBUFF) COMMAND = ' '6 IC = MIN0(ICHAR(BUFF(IBUFF:IBUFF)),LEN(COMMAND))C *C --- SCAN BACKWARDS FOR REQUESTED COMMANDC5 IF (NN .GT. 1) THEN+ ISKIP = ICHARq(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 ENDCrC---END RECALLCww`, SUBROUTINE REPLAC ( STRING, OLD, NEW )C*3C* *******************************3C* *******************************3C* ** **3C* ** REPLAC **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* s REPLACE CHARACTER C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO REPLACE ALL OCCURRENCES OF A CHARACTER IN A STRING WITH HC* ANOTHER CHARACTER. tC*C* INPUT ARGUMENTS :)C* STRING - THE STRING TO MODIFY-C* OLD - THE CHARACTER TO REPLACE;C* NEW - THE CHARACTER WITH WHICH TO REPLACE ITC*C* OUTPUT ARGUMENTS :(C* STRING - THE MODIFIED STRINGC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 1-FEB-85 C*C* CHANGE HISTORY :(C* 1-FEB-85 INITIAL VERSIONC*HC*******************************u****************************************C* CHARACTER *(*) STRING CHARACTER *1 OLD, NEWC DO 10 I = 1, LEN(STRING)4 IF (STRING(I:I) .EQ. OLD) STRING(I:I) = NEW10 CONTINUE RETURN ENDCC---END REPLACCww! SUBROUTINE REVLF ( NWRITE )C*3C* *******************************3C* *******************************3C* ** **3C* v ** REVLF **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :,C* REVERSE LINE FEED C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 w 4C* (415) 694-5578 C*C* PURPOSE :HC* SEND A REVERSE LINEFEED TO A TERMINAL. C*C* INPUT ARGUMENTS :EC* NWRITE - THE FORTRAN LOGICAL UNIT NUMBER OF THE TERMINAL.C*C* FILE REFERENCES :C* NWRITEC*%C* TRANSPORTABILITY LIMITATIONS :FC* THE VERSION GIVEN IS FOR A VT100, BUT A MORE TRANSPORTABLE&C* VERSION IS COMMENTED OUT.7C* USES THE NON-STANDARD FORMAT DxESCRIPTOR, $.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 30-JAN-85 C*C* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *1 ESC DATA ESC/27/C WRITE ( NWRITE, 900 )ESC#C WRITE ( NWRITE, 910 )CHAR(11) RETURN900 FORMAT ( '+',A1,'[A',$)C910 FORMAT ( '+',A1,$) ENyDC C---END REVLFCww@! SUBROUTINE RIGHT ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** RIGHT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :5C* z RIGHT JUSTIFY C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :CC* REPLACES A STRING WITH THE SAME STRING RIGHT JUSTIFIED.C*C* INPUT ARGUMENTS :6C* STRING - THE STRING TO BE RIGHT JU{STIFIED.C*C* OUTPUT ARGUMENTS ::C* STRING - THE RIGHT JUSTIFIED STRING (INPLACE).C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 15-OCT-84 C*C* CHANGE HISTORY :(C* 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRINGC L = LEN(STRING)C#C --- FIND LAST NON-BLANK CHARACTERC DO| 10 I=L,1,-1+ IF (STRING(I:I) .NE. ' ') GO TO 2010 CONTINUEC C --- ALL CHARACTERS WERE BLANK C RETURN20 IF (I .NE. L) THEN& STRING(L-I+1:L) = STRING(1:I) STRING(1:L-I) = ' ' ENDIF RETURN ENDC C---END RIGHTCww #. SUBROUTINE SCROLL ( NWRITE, ITOP, IBOT )C*3C* *******************************3C* *******************************3C* ** } **3C* ** SCROLL **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* SCROLL REGION C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER ~4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* ON A VT100 TERMINAL, DEFINE A PORTION OF THE SCREEN TO BE HC* USED FOR A SCROLL REGION AND PLACE THE CURSOR IN THE FIRST HC* LINE OF THAT REGION. NOTE: USE SRESET BEFORE EXITING YOUR <C* 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* NWRITE - THE LOGICAL UNIT NUMBER FOR THE SCREEN=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* VERSION AND DATE :&C* VERSION I.0 22-FEB-85 C*C* CHANGE HISTORY :(C* 22-FEB-85 INITIAL VERSIONC*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+ WRITE (NWRITE,900) CHAR(27),ITOP,IBOT RETURN.900 FORMAT(' ',A1,'[',I,';',I,'r',$) ENDCC---END SCROLLCww6)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 207-5 C* AMES RESEARCH CENTER'C* MOFFETT FIELD, CALIF 94035C* (415)694-5578C*C* PURPOSE :HC* TO SEARCH AN ARRAY OF CHARACTER STRINGS FOR A TARGET STRING,HC* IF NO EXACT MATCH IS FOUND CHECK FOR NON-AMBIGUOUS ABREVIATIC*C* METHODOLOGY :C* BINARY S EARCHC*C* INPUT ARGUMENTS :NC* STRING - THE ARRAY OF CHARACTER STRINGD TO SEARCH(MUST BE SORTED)6C* NSTRNG - 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* ASSUMPTIONS AND RESTRICTIONS :AC* IT IS A GOOD IDEA TO ALWAYS HAVE SENTINALS IN STRING GC* (E.G., ' ' FOR THE FIRST ENTRY AND 'ZZZZ' FOR THE LAST).C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION :C* VERSION I.2C*C* CHANGE HISTORY :CC* 09-MAY-88 REMOVED REPLACEMENT FOR ABBREVIATED TARGETEC* 05-FEB-86 BUG FIXED FOR TARGET LARGER THAN MAX ELEMENT(C* 16-JAN-85 INITIAL VERSIONC*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)5 CALL MLIB_COMPAR (TARGET, L, STRING(I), MATCHD) IF ( MATCHD ) THEN K = I IF (I .LT. NSTRNG) THEN< CALL MLIB_COMPAR (TARGET, L, STRING(I+1), MATCH)' IF ( MATCH ) AMBIG = .TRUE. ENDIF ENDIF RETURN ENDCC---END SEARCHCwwݚH> SUBROUTINE SEARCH1 ( STRING, NSTRNG, TARGET, K, MATCHD )C*3C* *******************************3C* *******************************3C* ** **3C* ** SEARCH1 **3C* ** **3C*  *******************************3C* *******************************C*C* SUBPROGRAM :6C* BINARY SEARCH FOR EXACT MATCH C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :HC* TO SEARCH AN ARRAY OF CHARACTER STRINGS FOR A TARGET STRING.C*C* METHODOLOGY :HC* BINARY SEARCH 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* TARGET - THE STRING TO LOOK FORC*C* OUTPUT ARGUMENTS :;C* K - THE INDEX OF TARGET STRING (IF FOUND)?C* MATCHD - TRUE IF TARGET WAS FOUND, FALSE OTHERWISEC*%C* ASSUMPTIONS AND RESTRICTIONS :LC* IT IS A GOOD IDEA TO ALWAYS HAVE SENTINALS IN STRING (EG, 'A '9C* FOR THE FIRST ENTRY AND 'ZZZZ' FOR THE LAST.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 16-JAN-85 C*C* CHANGE HISTORY :(C* 16-JAN-85 INITIAL VERSIONC*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 ENDIF MATCHD = .FALSE. RETURN  ENDCC---END SEARCH1Cww tN㝏$ SUBROUTINE SEND ( USER, TEXT )C*3C* *******************************3C* *******************************3C* ** **3C* ** SEND **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4 C* SEND MESSAGE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* SEND A MESSAGE TO A USER, A TERMINAL, OR ALL USERS ON THE HC* 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, 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* 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* VERSION AND DATE :&C* VERSION I.0 16-APR-85 C*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 = LENGTH ( TEXT ) IF (LT .EQ. 0) LT = 1 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 SENDCwwU㝏5 SUBROUTINE SENDW ( USER, TEXT, NUMOK, NUMFAIL )C*3C* *******************************3C* *******************************3C* ** **3C* ** SENDW **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :0C* SEND MESSAGE AND WAIT C*C* AUTHOR :4C* ART RAGOSTA 4C*  MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* 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 USERKC* 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* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 16-APR-85 C*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 = LENGTH ( TEXT ) IF (LT .EQ. 0) LT = 1 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 ENDIF7 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 SENDWCww!d SUBROUTINE SETIMEC*3C* *******************************3C* *******************************3C* ** **3C* ** SETIME **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* SET TIME C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* START THE CPU TIME CLOCK RUNNING C*C*  SUBPROGRAM REFERENCES :C* LIB$INIT_TIMERC*%C* TRANSPORTABILITY LIMITATIONS :C* USES SYSTEM ROUTINEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 22-DEC-86 C*C* CHANGE HISTORY :(C* 22-DEC-86 INITIAL VERSIONC*HC***********************************************************************C* STATUS=LIB$INIT_TIMER() RETURN ENDCC---END SETIMECww@tϨ$ SUBROUTINE SLEEP ( REAL_TIME )C*3C* *******************************3C* *******************************3C* ** **3C* ** SLEEP **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* SLEEP  C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415)694-5578 C*C* PURPOSE :HC* PUT THIS PROGRAM TO SLEEP FOR 'REAL_TIME' SECONDS C*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* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 23-DEC-86 C*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) RETURN3 IF (REAL_TIME .GT. 7200.0) REAL_TIME = 7200.0 RTIME = REAL_TIME I = RTIME / 3600.0 WRITE ( HOUR, 900 ) I RTIME = RTIME - 3600.0*I I = RTIME / 60.0 WRITE ( MIN, 900 ) I RTIME = RTIME - 60.0*I I = RTIME WRITE ( SEC, 900 ) I RTIME = RTIME - I I = 100.0*RTIME WRITE ( FRAC, 900 ) IG BTIME = '0000 '// HOUR // ':' // MIN // ':' // SEC // '.' // FRAC) ISTAT = SYS$BINTIM ( BTIME, ITIME ) CALL SYS$SCHDWK (,,ITIME,) CALL SYS$HIBER RETURN900 FORMAT(I2.2) ENDC C---END SLEEPCww@$㝏$ SUBROUTINE SORT ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C*  ** SORT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :FC* SORT ARRAY - THE INPUT ARRAY IS SORTED USING A SHELL SORT.C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :1C* REPLACE AN ARRAY WITH A SORTED ARRAY.C*C* METHODOLOGY :-C* SHELLSORT C*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* VERSION AND DATE :*C* VERSION I.0 MARCH 12, 1984C*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@Eo+% SUBROUTI NE SORTI ( ARRAY, NUM )C*3C* *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :FC* SORT ARRAY - THE INPUT ARRAY IS SORTED USING A SHELL SORT.*C* (INTEGER VERSION)C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :1C* REPLACE AN ARRAY WITH A SORTED ARRAY.C*C* METHODOLOGY :-C* SHELLSORT C*C* INPUT ARGUMENTS :'C* ARRAY - ARRAY TO BE SORTED0C* NUM - NUMBER OF ELEMENTS IN ARRAYC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :*C* VERSION I.0 MARCH 12, 1984C*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 SORTICwwHo+% SUBROUTINE SORTR ( ARRAY, NUM )C*3C*  *******************************3C* *******************************3C* ** **3C* ** SORT **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :FC* SORT ARRAY - THE INPUT ARRAY IS SORTED USING A SHELL SORT.'C* (REAL VERSION)C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :1C* REPLACE AN ARRAY WITH A SORTED ARRAY.C*C* METHODOLOGY :-C* SHELLSORT C*C* INPUT ARGUMENTS :'C* ARRAY - ARRAY TO BE SORTED0C* NUM - NUMBER OF ELEMENTS IN ARRAYC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :*C* VERSION I.0 MARCH 12, 1984C*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 SORTICww`5 㝏" SUBROUTINE SRESET ( NWRITE )C*3C* *******************************3C*  *******************************3C* ** **3C* ** SRESET **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* STATUS RESET C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5  4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :HC* TO RESET THE VT-100 SCREEN AFTER USING STATUS. C*C* METHODOLOGY :HC* USES VT-100 CONTROL SEQUENCES. C*C* INPUT ARGUMENTS :MC* NWRITE - THE FORTRAN LOGICAL UNIT NUMBER ASSIGNED TO THE SCREEN.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* VERSION AND DATE :&C* VERSION I.0 30-JAN-85 C*C* CHANGE HISTORY :(C* 30-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *1 ESC DATA ESC/27/C(C --- RESET SCROLL REGION TO FULL SCREENC WRITE ( NWRITE, 900 ) ESCCC --- CLEAR SCREENC CALL CLEAR RETURN900 FORMAT('+',A1,'[1;24r',$) ENDCC---END SRESETCww SUBROUTINE FRMSTD ( VALIN, STRIN, VALOUT, STROUT, IERR )C*3C* *******************************3C* *******************************3C*  ** **3C* ** FRMSTD **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* FROM STANDARD UNITS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER  4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*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 - THE VALUE AFTER CONVERTING$C* IERR -= 0 FOR NO ERROR-C*  = 1-4 FOR ERROR IN TOSTD HC* = 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* VERSION AND DATE :&C* VERSION I.0 24-SEP-85 C*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 ( STRIN, 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 :4C* TO STANDARD UNITS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* CONVERTS A VALUE WITH NON-STANDARD UNI TS TO THE EQUIVALENT HC* VALUE WITH STANDARD UNITS AND RETURNS THE STANDARD UNITS. C*C* METHODOLOGY :HC* PARSES THE INPUT UNITS, REPLACES EACH ONE WITH AN EQUIVALENTJC* STANDARD UNIT AND A SCALE FACTOR, MULTIPLIES THE SCALE FACTORSHC* 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 STANDARD 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 :HC* 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* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.1 13-SEP-85C*C* CHANGE HISTORY :FC* 13-SEP-85 EFFICIENCY IMPROVED, BETTER UNITS CONVERSIONS(C* 7-FEB-85 INITIAL VERSIONC*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 FACTORSCH 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 :4C* BUILD OUTPUT LINE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5  4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* BUILD THE STRING OF OUTPUT UNITS, CANCELLING UNITS ON TOP HC* AND BOTTOM. C*C* INPUT ARGUMENTS :1C* TOP - UNITS WHICH ARE IN NUMERATOR"C* 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-85 C*C* CHANGE 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)! 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 + 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(WORK,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' RETURN 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 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 = IS + 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* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* COMPARE UNITS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* COMPARE THE CALCULATED UNITS WITH THE REQUESTED UNITS, IF HC* THEY ARE THE SAME, SUCCESS, OTHERWISE THE REQUESTED NON-STD HC* 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 AND DATE :&C* VERSION I.0 24-SEP-85 C*C* CHANGE HISTORY :(C* 24-SEP-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) S1, S2) CHARACTER *6 TOP(50), BOT(50), WORK LOGICAL 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 ) DO 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 :4C* STRING COMPARE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :HC* TO COMPARE TWO STRINGS TO LESS THAN THERE FULL LENGTH. C*C* INPUT ARGUMENTS :1C* TAR - THE (POTENTIALLY) SHORT STRING<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-85 C*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* ** **3C* ** EVAL **3C* ** **3C* *******************************3C* *******************************C*C* S UBPROGRAM :4C* EVALUATE C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO EVALUATE THE REVERSE POLISH STRING, RESULTING IN A HC* FINAL SCALE FACTOR AND THE PROPER UNIT S. C*C* INPUT ARGUMENTS :8C* TOKE - THE LIST OF TOKENS IN REVERSE POLISH2C* NTOKE - THE NUMBER OF TOKENS IN 'TOKE'>C* FACTS - THE SCALE FACTORS FOR EACH ENTRY IN 'TOKE'C*C* OUTPUT ARGUMENTS :@C* TOP - THE LIST OF UNITS WHICH ARE IN THE NUMERATOR2C* NT - THE NUMBER OF ENTRIES IN 'TOP'BC* BOT - THE LIST OF UNITS WHICH ARE IN THE DENOMINATOR2C* NB - THE NUMBER OF 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-85 C*C* CHANGE HISTORY :(C* 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 TOKENSC$ 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 ----- 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 NT = 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 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) = '*' 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 T1 = 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 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 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)) THEN LB1 = LB1 + 1 B1(LB1:LB1) = '*' ENDIF  LT1 = LT1 + 1 LB1 = LB1 + 1 IF (LB .GT. 0 ) THEN) T1(LT1:LT1+LB-1) = B(1:LB) ENDIF IF (LT .GT. 0 ) THEN) B1(LB1:LB1+LT-1) = T(1:LT) ENDIF ISP = ISP + 1 TSTACK(ISP) = T1 BSTACK(ISP) = B1CFC ----- OTHERWISE THE TOKEN IS A UNIT, PUT IT ON THE TOP SIDE OF STACKC ELSE ISP = ISP + 1! TSTACK(ISP) = TOKE(I)  BSTACK(ISP) = ' ' ENDIF200 CONTINUEC4C --- NOW PARSE THE TOP STRINGS INTO ARRAYS OF UNITSC T = TSTACK(ISP) B = BSTACK(ISP) LT = LENGTH ( T ) LB = LENGTH ( B ) NT = 0 NB = 0 I = 1205 NT = NT + 1 INT = 1 TOP(NT) = ' '210 TOP(NT)(INT:INT) = T(I:I) INT = INT + 1 I = I + 1 IF (I .GT. LT) GO TO 250$ IF (T(I:I) .NE. '*') GO TO 210 I = I + 1  IF (I .LE. LT) GO TO 205C 250 I = 1 IF (LB .EQ. 0) GO TO 1000300 NB = NB + 1 INT = 1 BOT(NB) = ' '310 BOT(NB)(INT:INT) = B(I:I) INT = INT + 1 I = I + 1 IF (I .GT. LB) GO TO 1000$ IF (B(I:I) .NE. '*') GO TO 310 I = I + 1 IF (I .LE. LB) GO TO 300 1000 RETURN900 FORMAT ( I6 ) ENDCC---END MLIB_EVALC: SUBROUTINE MLIB_PARSE ( WORK, LW, TOKE, NTOKE, ERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** PARSE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* PARSER C*C* AUTHOR :4C* ART RAGOSTA 4C*  MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :5C* PARSE THE STRING INTO AN ARRAY OF TOKENS..C* NOTE: THE ONLY VALID SYMBOLS ARE -LC* UNITS, EXPONENTS, '*', '^', '/', '(', AND ')'C*C* INPUT ARGUMENTS :+C* WORK - THE STRING TO BE PARSEDC*C* OUTPUT ARGUMENTS :'C* TOKE - THE ARRAY OF TOKENS.C* NTOKE - THE NUMBER OF TOKENS FOUND5C* ERR - 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-85 C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) WORK CHARACTER *6 TOKE(1) LOGICAL ERRC I = 1 NTOKE = 0C&C --- ALL UNITS BEGIN WITH A CHARACTERC?100 IF ((WORK(I:I) .GE. 'A') .AND. (WORK(I:I) .LE. 'Z')) THEN NTOKE = NTOKE + 1 INT = 1 TOKE(NTOKE) = ' '110 IF (INT .LE. 6) THEN, TOKE(NTOKE)(INT:INT) = WORK(I:I) INT = INT + 1 ENDIF  I = I + 1" IF (I .GT. LW) GO TO 1000G IF ((WORK(I:I) .GE. 'A') .AND. (WORK(I:I) .LE. 'Z')) GO TO 110CC --- NUMBERS USED AS EXPONENTSCD ELSE IF ((WORK(I:I) .GE. '0') .AND. (WORK(I:I) .LE. '9')) THEN NTOKE = NTOKE + 1 INT = 1 TOKE(NTOKE) = ' ')210 TOKE(NTOKE)(INT:INT) = WORK(I:I) IF (INT .GT. 2) THEN ERR = .TRUE. RETURN ENDIF INT = INT + 1 I = I + 1"  IF (I .GT. LW) GO TO 1000G IF ((WORK(I:I) .GE. '0') .AND. (WORK(I:I) .LE. '9')) GO TO 210C#C --- OPERATORS ARE ( ) * / ^CB ELSE IF ((WORK(I:I) .EQ. '(') .OR. (WORK(I:I) .EQ. ')') .OR.B $ (WORK(I:I) .EQ. '*') .OR. (WORK(I:I) .EQ. '/') .OR.) $ (WORK(I:I) .EQ. '^')) THEN NTOKE = NTOKE + 1 TOKE(NTOKE) = WORK(I:I) I = I + 1C#C --- NO OTHER CHARACTERS ARE VALIDC ELSE  ERR = .TRUE.  RETURN ENDIF IF (I .LE. LW) GO TO 100 1000 RETURN ENDCC---END MLIB_PARSEC8 SUBROUTINE MLIB_POLISH ( TOKE, NTOKE, FACTS, ERR )C*3C* *******************************3C* *******************************3C* ** **3C* ** POLISH **3C* ** **3C* *******************************3C*  *******************************C*C* SUBPROGRAM :4C* POLISH NOTATION CONVERSION C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CALIF 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* TO REPLACE THE UNITS ARRAY (WHICH IS IN ALGEBRAIC  HC* NOTATION) WITH THE EQUIVALENT REVERSE POLISH STRING. C*C* METHODOLOGY :HC* USE THE STACK COMPILATION TECHNIQUE, REFERENCE: HC* KATZAN, "ADVANCED PROGRAMMING", VAN NOSTRAND REINHOLD CO, HC* NEW YORK, 1970. C*C* INPUT ARGUMENTS :8C* TOKE - THE LIST OF TOKENS IN ALGEBRAIC FORM4C* NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'C*C* OUTPUT ARGUMENTS :7C*  TOKE - THE NEW LIST IN REVERSE POLISH FORM4C* NTOKE - THE NUMBER OF ELEMENTS IN 'TOKE'7C* ERR - SET TRUE FOR UNMATCHED PARENTHESES.C*C* INTERNAL WORK AREAS :5C* ISTACK, STACK - TEMPORARY OPERATOR STACKSC*C* ERROR PROCESSING :<C* CHECK EACH RIGHT PAREN FOR A MATCHING LEFT PARENC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :&C* VERSION I.0 7-FEB-85 C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C*% CHARACTER *6 TOKE(1), STACK(20)+ DOUBLE PRECISION FACTS(1), FSTACK(20) DIMENSION ISTACK(20) LOGICAL ERRC ISP = 1 IPOLE = 0 ISTACK ( ISP ) = -1 STACK ( ISP ) = ' ' FSTACK ( ISP ) = 0.D0CC --- ALL TOKENSC DO 100 I = 1, NTOKECC ----- '(' STACK IT ONLYC# IF (TOKE(I) .EQ. '(') THEN ISP = ISP + 1! STACK(ISP) = TOKE(I) ISTACK(ISP) = 0" FSTACK(ISP) = FACTS(I)C/C ----- ')' UNSTACK UNTIL MATCHING '(' IS FOUNDC( ELSE IF (TOKE(I) .EQ. ')') THEN 20 IF (ISP .LE. 1) THEN ERR = .TRUE. RETURN ENDIF( IF (ISTACK(ISP) .NE. 0) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1% IF (IPOLE .LE. 0) THEN ERR = .TRUE. RETURN ENDIF GO TO 20 ENDIF ISP = ISP - 1C@C ----- '*' OR '/' ... UNSTACK ANY '^', '*', OR '/' ON THE STACKC* ELSE IF ((TOKE(I) .EQ. '*') .OR. * $ (TOKE(I) .EQ. '/')) THEN(30 IF (ISTACK(ISP) .GE. 8) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1 GO TO 30 ENDIF ISP = ISP + 1! STACK(ISP) = TOKE(I)" FSTACK(ISP) = FACTS(I) ISTACK(ISP) = 8C,C ----- '^' ... UNSTACK ANY '^' ON THE STACKC( ELSE IF (TOKE(I) .EQ. '^') THEN(40 IF (ISTACK(ISP) .GE. 9) THEN IPOLE = IPOLE + 1( TOKE(IPOLE) = STACK(ISP)) FACTS(IPOLE) = FSTACK(ISP) ISP = ISP - 1 GO TO 40 ENDIF ISP = ISP + 1! STACK(ISP) = TOKE(I)" FSTACK(ISP) = FACTS(I) ISTACK(ISP) = 9C8C ----- UNITS AND EXPONENTS GET MOVED DIRECTLY TO OUTPUTC ELSE IPOLE = IPOLE + 1" TOKE(IPOLE) = TOKE(I)# FACTS(IPOLE) = FACTS(I) ENDIF100 CONTINUE NTOKE = IPOLEC?C --- THERE MAY STILL BE OPERATORS ON THE STACK... UNSTACK THEMC300 IF (ISP .GT. 1) THEN NTOKE = NTOKE + 1& IF (STACK(ISP) .EQ. '(') THEN ERR = .TRUE. RETURN ENDIF! TOKE(NTOKE) = STACK(ISP)" FACTS(NTOKE)= FSTACK(ISP) ISP = ISP - 1 GO TO 300 ENDIF RETURN ENDCC---END MLIB_POLISHC6 SUBROUTINE MLIB_STD ( FACTS, TOKE, NTOKE, NERR )C*3C* *******************************3C*  *******************************3C* ** **3C* ** STD **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* STANDARDIZEC*C* AUTHOR :C* ART RAGOSTAC* MS 207-5 C* AMES RESEARCH CENTER(C* MOFFETT FIELD, CALIF 94035C* (415) 694-5578C*C* PURPOSE :?C* TO REPLACE NON-STANDARD UNITS WITH THEIR EQUIVALENT6C* STANDARD UNITS AND RESULTING SCALE FACTOR.C*C* INPUT ARGUMENTS :=C* TOKE - ARRAY OF (POTENTIALLY) NON-STANDARD UNITS-C* NTOKE - NUMBER OF ENTRIES IN TOKEC*C* OUTPUT ARGUMENTS :6C* TOKE - THE ARRAY WITH ONLY STANDARD UNITS-C* NTOKE - NUMBER OF ENTRIES IN TOKEBC* FACTS - ARRAY WITH SCALE FACTORS FOR EACH UNIT IN TOKE2C* NERR - = 1 IF UNIT COULD NOT BE FOUND,C* = 2 IF UNIT IS AMBIGUOUSC*C* INTERNAL WORK AREAS :EC* TEMP - USED TO STORE TOKENS UNTIL ALL UNITS ARE REPLACEDC*C* COMMON BLOCKS :C* MLIB$UNITSC*C* SUBPROGRAM REFERENCES :C* SEARCHC*C* ERROR PROCESSING :)C* IF A UNIT ISN'T FOUND, ABORT.C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :%C*  VERSION I.0 7-FEB-85C*C* CHANGE HISTORY :(C* 7-FEB-85 INITIAL VERSIONC*HC***********************************************************************C* PARAMETER (NUM=49,NLIS=29)9 CHARACTER *6 TOKE(1), TEMP(100) ,KNOWN, ALIAS, LIST 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, TOKE(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 IFAC = 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(ITOKE) = 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) ITOKE = 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=49,NLIS=29)+ CHARACTER *6 KNOWN, ALIAS, LIST " DOUBLE PRECISION KFACT H COMMON /MLIB$UNITS/ KNOWN(NUM), ALIAS(NUM), LIST(NLIS), KFACT(NUM)C 2C --- KNOWN UNITS (BOTH STANDARD AND NON-STANDARD)C;C --- NOTE: THE FOLLOWING ARRAY MUST BE IN ALPHABETIC ORDERCH DATA KNOWN / 'ATM OS ', 'BAR ', 'BTU ', 'CM ', H $ 'DEGREE', 'DYNE ', 'ERG ', 'FATHOM', 'FEET ', H $ 'FPS ', 'FT ', 'GALLON', 'GM ', 'GRAMS ', H $ 'HOURS ', 'HP ', 'HR ', 'INCHES', 'JOULES', H $ 'KG ', 'KILOGR', 'KILOME', 'KM ', 'KNOTS ', H $ 'L ', 'LB ', 'LITERS', 'M ', 'METERS', H $ 'MILES ', 'MINUTE', 'MPH ', 'N ', 'NAUTMI', H $ 'NEWT ON', 'PASCAL', 'PINTS ', 'POUNDS', 'PSI ', H $ 'QUARTS', 'RADIAN', 'REV ', 'S ', 'SECOND', D $ 'SLUGS ', 'TONS ', 'WATTS ', 'YARDS ', 'YD '/C:C --- THE CONVERSION FACTOR TO GET FROM 'KNOWN' TO 'ALIAS'CCC --- IMPORTANT!!! THE CONVERSION FACTORS FOR 'GAL' AND 'LITER' AREFC --- THE CUBE ROOT OF THE ACTUAL CONVERSION FACTOR SINCE 'EVAL' WILL%C --- CUBE THEM WHEN IT SEES 'FT^3'.CG DATA KFACT / 2.11536D3, 2.0896347D3,  7.783D2, 3.28084D-2, H $1.0D0, 2.2481D-6, 7.376D-8, 6.0D0, 1.0D0, I $1.0D0, 1.0D0, 5.11317368D-1,6.8465014D-5,6.8465014D-5, L $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,H $3.2808719D-1,1.0D0, 3.2808719D-1, 3.28084D0, 3.28084D0, H $5.28D3, 6.0D1, 1.4666667D0, 2.2481D-1, 6.0761157D3, G $2.2481D-1, 2.0885531 D-2,2.55658684D-1,1.0D0, 1.44D2, I $3.22109757D-1,5.7295779D1,3.6D2, 1.0D0, 1.0D0, A $1.0D0, 2.0D3, 7.376D-1, 3.0D0, 3.0D0/C9C --- THE EQUIVALENT STANDARD UNIT OR POINTER INTO 'LIST'CH DATA ALIAS / '- 18', '- 18', '- 25', 'FT ', H $ 'DEG ', 'LB ', '- 25', 'FT ', 'FT ', H $ '- 8', 'FT ', '- 13', 'SLUG ', 'SLUG ', H $ 'SEC ', '- 1', 'SEC ', 'FT ', '- 25', H $ 'SLUG ', 'SLUG ', 'FT ', 'FT ', '- 8', H $ '- 13', 'LB ', '- 13', 'FT ', 'FT ', H $ 'FT ', 'SEC ', '- 8', 'LB ', 'FT ', H $ 'LB ', '- 18', '- 13', 'LB ', '- 18', H $ '- 13', 'DEG ', 'DEG ', 'SEC ', 'SEC ', D $ 'SLUG ', 'LB ', '- 1', 'FT ', 'FT '/CFC --- THIS LIS T 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 ',E $ '/ ', 'SEC ', ') ', '( ', 'FT ', D $ '/ ', 'SEC ', ') ', '( ', 'FT ', A $ '^ ', '3 ', ') ', '( ', 'LB ',A $ '/ ', 'FT ', '^ ', '2 ', ') ',D $ '( ', 'FT ', '* ',  'LB ', ') '/ ENDCC --- END BLOCK DATA MLIB$DATACww15t! SUBROUTINE UNTAB ( STRING )C*3C* *******************************3C* *******************************3C* ** **3C* ** UNTAB **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* REMOVE TABS C*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 C*C* PURPOSE :HC* REPLACE A STRING WITH THE SAME STRING WHERE TABS ARE HC* REPLACED BY AN APPROPRIATE NUMBER OF BLANKS TO HAVE HC* SIMILAR SPACING. C*C* INPUT ARGUMENTS :=C* STRING - STRING FROM WHICH TABS ARE TO BE REMOVEDC*C* OUTPUT ARGUMENTS :DC* STRING - SAME STRING WITH BLANKS REPLACING TABS(INPLACE)C*C* INTERNAL WORK AREAS :=C* ITAB - AN ARRAY CONTAINING THE TAB STOP SETTINGS.7C* LINE - TEMPORARY STORAGE FOR TABBED STRING.C*C* SUBPROGRAM REFERENCES :C* LENGTHC*%C* TRANSPORTABILITY LIMITATIONS :JC* THE NON-STANDARD DATA STATEMENT SETS TAB CHARACTER TO ASCII 9.2C* ( TRANSPORTABLE VERSION IS COMMENTED )C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :(C* VERSION I.1 29-july-1985C*C* CHANGE HISTORY :2C* 29-JUL-85 ITPTR FIXED (INITIALIZED)(C* 15-OCT-84 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STRING CHARACTER *255 LINE CHARACTER *1 TAB 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, 10000 /C#C --- NON-STANDARD DATA STATEMENT :C DATA TAB/9/C5C --- STANDARD REPLACEMENT FOR ABOVE DATA STATEMENT :C TAB = CHAR ( 9 )C LINE = STRING STRING = ' ' L = LENGTH(LINE) LL = LEN(STRING) K = 1 ITPTR = 1 DO 20 I = 1,L( IF ( LINE(I:I) .EQ. TAB ) THENCC ------ FIND NEXT TAB STOPC*5 IF ( K .GE. ITAB(ITPTR)) THEN! ITPTR = ITPTR + 1 GO TO 5 ENDIFCGC ------ SKIP BLANKS TO TAB STOP ( ALREADY BEEN INITIALIZED TO BLANKS )C*10 IF ( K .LT. ITAB(ITPTR)) THEN K = K + 1 GO TO 10 ENDIF ELSEC C ------ COPY NON-TAB CHARACTERSC$ STRING(K:K) = LINE(I:I) K = K + 1 ENDIF! IF ( K .GT. LL ) RETURN20 CONTINUE RETURN ENDC C---END UNTABCww wkm+, LOGICAL FUNCTION VERIFY ( STR1, STR2 )C*3C* *******************************3C* *******************************3C* **  **3C* ** VERIFY **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* VERIFY C*C* AUTHOR :4C* ART RAGOSTA 4C* MS207-5 4C* AMES RESEARCH CENTER 4C*  MOFFETT FIELD, CALIF. 94035 4C* (415)694-5578 C*C* PURPOSE :HC* TO VERIFY THAT EACH CHARACTER IN STR1 ALSO APPEARS IN STR2. C* EFFICIENCY NOTES :EC* 1. THE RAREST LETTER(S) SHOULD APPEAR FIRST IN 'STR2'.IC* 2. THE LENGTHS OF 'STR1' AND 'STR2' SHOULD BE AS SMALL AS KC* 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*C* 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-85 C*C* CHANGE HISTORY :(C* 17-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) STR1,STR2C L1 = LEN(STR1) 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 2010 CONTINUE RETURN20 CONTINUE VERIFY = .TRUE. RETURN ENDCC---END VERIFYCww@t% SUBROUTINE WEKDAY ( TIME, DAY )C*3C*  *******************************3C* *******************************3C* ** **3C* ** WEKDAY **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :4C* WEEKDAY C*C* AUTHOR :4C* ART RAGOSTA  4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD. CALIF 94035 4C* (415)694-5578 C*C* PURPOSE :DC* TO CALCULATE THE DAY OF THE WEEK('SUNDAY', 'MONDAY'...) C*C* METHODOLOGY :HC* 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* 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* VERSION AND DATE :C* VERSION I.1C*C* CHANGE HISTORY :)C*  16-JAN-86 CAPITALIZE INPUT(C* 25-JAN-85 INITIAL VERSIONC*HC***********************************************************************C* CHARACTER*23 TIME CHARACTER*9 DAYS(0:6), DAYH 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 (ABS(I) .GT. 1) RETURN I = LIB$DAY(NDAYS,ITIME) IF (ABS(I) .GT. 1) RETURNC6C --- NDAYS IS THE NUMBER OF DAYS SINCE SYSTEM TIME 0.C I = MOD(NDAYS,7) DAY = DAYS(I) RETURN ENDCC---END WEKDAYCww@86Et. SUBROUTINE YESNO ( NUNIT, ISYES, ERROR )C*3C* *******************************3C* *******************************3C* ** **3C* ** YESNO   **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* GET YES/NO ANSWERC*C* AUTHOR :4C* ART RAGOSTA 4C* MS 207-5 4C* AMES RESEARCH CENTER 4C* MOFFETT FIELD, CA 94035 4C* (415) 694-5578 ! C*C* PURPOSE :HC* GET THE ANSWER TO A YES/NO TYPE QUESTION C*C* METHODOLOGY :KC* SEARCH FOR THE FIRST NON-BLANK CHARACTER. COMPARE TO 'Y' OR 'N'C*C* INPUT ARGUMENTS :BC* NUNIT - THE FORTRAN LOGICAL UNIT NUMBER FOR RESPONSE.KC* ISYES - (UPDATE) THE DEFAULT VALUE TO BE RETURNED IN THE EVENT1C* OF AN ERROR OR NULL ANSWER.C*C* OUTPUT ARGUMENTS :MC* ISYES - (UP "DATE) 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* VERSION AND DATE :&C* VERSION I.0 31-AUG$-84 C*C* CHANGE HISTORY :(C* 31-AUG-84 INITIAL VERSIONC*HC***********************************************************************C* LOGICAL ISYES, ERROR CHARACTER *1 C CHARACTER *80 STRINGC ERROR = .FALSE.. READ (NUNIT,900,END=1000,ERR=1000)STRINGC.C --- SEARCH FOR THE FIRST NON-BLANK CHARACTERC DO 10 I=1,80 C = STRING(I:I) IF (C .NE. ' ') THENCC ------ CAPITALIZE IT.C4 IF ((C .EQ. %'Y') .OR. (C .EQ. 'y')) THEN ISYES = .TRUE.9 ELSE IF ((C .EQ. 'N') .OR. (C .EQ. 'n')) THEN ISYES = .FALSE. ELSE C/C ------ FIRST CHARACTER WAS NEITHER 'Y' OR 'N'C ERROR = .TRUE. ENDIF RETURN ENDIF10 CONTINUEC0C --- THE ENTIRE LINE WAS BLANK... LEAVE DEFAULTC RETURNC7C --- LEAVE ISYES AS DEFAULT RESPONSE, BUT RETURN ERRORC1000 ERROR = .TRUE. RETURN900 FORMAT(A80) ENDC C---END YESNOCww' ʽ\m.! SUBROUTINE PCALFA ( NUNIT )C*3C* *******************************3C* *******************************3C* ** **3C* ** PCALFA **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* PCALFAC*C* AUTHOR :(C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE :FC* RETURN A PC (USING THE KERMIT VT100 EMULATOR) TO TEXT MODEC*C* INPUT ARGUMENTS :6C* NUNIT - THE LOGICAL UNIT NUMBER FOR THE PCC*%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* VERSION AND DATE :'C* VERSION I.0 - 16-MAY-1988C*C* CHANGE HISTORY :+C* 16-MAY-1988 - INITIAL VERSIONC*HC***********************************************************************C* WRITE(NUNIT,900) CHAR(27) RETURN900 FORMAT(' ',A1,'[?38l',$) ENDCC---END PCALFACww ;\Z; SUBROUTINE GETSTM ( NREAD, STMT, LENST, CLABEL, EOF )5C* 4C* ******************************* 4C* ******************************* 4C* ** ** 4C* ** GETSTM ** 4C* ** ** 4C* ******************************* 4C* ******************************* C* C* SUBPROGRAM : C* +m57/ 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 Surfac-e 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' IF (C.EQ.'C' .OR. C.EQ.'Y' .OR.: $ C.LT ..'A' .OR. C.GT.'Z') CALL EXIT('10000004'X)C0 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))) ENDww 0:}a1 SUBROUTINE DISK_SPACE (DEVICE, TOTAL, FREE)*eJ* Determines the number of free blocks remaining on the disk unitG* whose logical name is DEVICE. The argument must be a charactertJ* string containing the logical name of the pack; a trailing colon* is optional.*oA* The routine will return 0 if an incorrect logical name isI1* specified, or if the pack is not mounted.I*D7* Alan L. Zirkle Naval Surface Warfare Cente1r)#* Code K53P4* 16 Nov 1983 Dahlgren, Virginia 22448*n* mods: Art Ragosta*p IMPLICIT INTEGER (A-Z) INCLUDE '($DVIDEF)'L CHARACTER*(*) DEVICE CHARACTER*63 FILE_NAME INTEGER ITMLST(7)g INTEGER *2 ITEMLST(12)( EQUIVALENCE (ITEMLST(1),ITMLST(1)) FILE_NAME = DEVICE ITEMLST(1) = 4" ITEMLST(2) = DVI$_FREEBLOCKS ITMLST(2) = %LOC(FREE)R ITMLST(3) = %LOC(LF)S ITEMLST(7) = 4 ITEMLST(8) = DVI$_MAXBLOCK ITMLST(5) = %LOC(TOTAL) ITMLST(6) = %LOC(LT). ITMLST(7) = 0G STATUS = SYS$GETDVIW(,,FILE_NAME(1:LENGTH(FILE_NAME)),ITMLST,,,,) IF (.NOT.STATUS) THEN FREE = 0 TOTAL = 0 ENDIF RETURN ENDww3@4X.:% SUBROUTINE CURSOR (IX, IY, CHR)C*3C* *******************************,3C* *******************************r3C* ** ** 3C* ** CURSOR **3C* ** **3C* *******************************a3C* *******************************AC*C* SUBPROGRAM :GC* CURSORC*C* AUTHOR 6:'C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center %C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE : >C* RETURN THE CURSOR LOCATION FOR A TEK 4014 EMULATORC*C* INPUT ARGUMENTS :C* NONEC*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* 5lY87$ SUBROUTINE GET_DEFAULT (DIR_STRING)***D* Returns, in the character string DIR_STRING, the name of the cur-D* rent default device and directory. The string DIR_STRING must be>* long enough to contain the name, or this routine will abort.**1* Alan L. Zirkle Naval Surface Weapons Center* Code K105)* 9 Nov 1983 Dahlgren, Virginia 22448*C IMPLICIT INTEGER (A-Z)C CHARACTER*(*) DIR_STRING LOGICAL ARG_EXISTC3 STATUS = SYS$TRNLOG(' SYS$DISK',LEN1,DIR_STRING,,,)- IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))C0 STATUS = SYS$SETDDIR(,LEN2,DIR_STRING(LEN1+1:))- IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))C LEN1 = LEN1 + LEN27 IF (LEN1.LT.LEN(DIR_STRING)) DIR_STRING(LEN1+1:) = ' ' ENDww7 READT, GRALFAC*%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 77 C*C* VERSION AND DATE : 'C* VERSION I.0 - 27-MAY-1988 C*C* CHANGE HISTORY : +C* 27-MAY-1988 - INITIAL VERSION*C*HC***********************************************************************C*! CHARACTER *88 STRING,STRING1H CHARACTER *2 GIN CHARACTER *1 CHRCI GIN = CHAR(27) // CHAR(26)% CALL MLIB_GET ('NWRITE',NWRITE)R WRITE(NWRITE,900) GINA' CALL READT(999,STRING1,NUM1,IRET)( IF (NUM1 .EQ. 0) THENC( CALL READT(999,STRING,NUM,IRET) ELSE NUM = NUM1R STRING = STRING1 ENDIFU9 IF (NUM .GT. 4) STRING = STRING(2:5) // STRING(1:1) # IX1 = ICHAR(STRING(2:2)) - 32 # IX2 = ICHAR(STRING(1:1)) - 32 # IY1 = ICHAR(STRING(4:4)) - 32 # IY2 = ICHAR(STRING(3:3)) - 32I IX = IX1 + 32*IX2I IY = IY1 + 32*IY2  CHR = STRING(5:5)G RETURN900 FORMAT(' ',A2,$) END,CC---END CURSORC-wwURSORCww : INTEGER*2 Isi:C.A INTEGER SYS$CREATE, SYS$CONNECT, SYS$GET, SYS$OPEN, SYS$PUT C)7 RECORD /Fabdef/ Fab_in ! Input File Access BlockE* RECORD /Fabdef/ Fab_out ! Output FAB9 RECORD /Rabdef/ Rab_in ! Input Record Access Block * RECORD /Rabdef/ Rab_out ! Output RABC E 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 Address 8 Fab_in.FAB$B_FNS = LEN(I `nfile) ! File Name SizeCUE Rab_in.RAB$B_BLN = RAB$C_BLN ! Identify Rab as a valid RABO" 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 recordSCNK DO Loop = 1, LEN(Infile) ! Make character string descriptorsT, I<GET STATEMENT C* C* AUTHOR : C* ART RAGOSTA C* MS 219-3!C* AMES RESEARCH CENTER *'C* MOFFETT FIELD, CALIF 94035 *C* (415) 694-5578 C* 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 CODE*C*C* OUTPUT ARGUMENTS : 6C* STMT - THE STATEMENT (MIN=US BLANKS, TABS)"C* LENST - LENGTH OF STMTC* C* COMMON BLOCKS : C* NONEC* SC* SUBPROGRAM REFERENCES : (C* MLIB_GETCRD, LENGTH, CAPITALC*C* RESTRICTIONS : FC* WILL NOT HANDLE A STATEMENT WITH AN EXCLAMATION POINT IN AC* C* LANGUAGE AND COMPILER : RC* ANSI FORTRAN 77OC* C* VERSION AND DATE : C* VERSION II.2C* C* CHANGE HISTORY :F4C* 07/11/88 ADDED DEC TAB SOURCE FORMATAC* > 04/26/88 CLEANED UP FOR MERLIB. FIXED ! HANDLING.NEC* 09/15/86 MODIFIED TO NOT REMOVE BLANKS FROM CHARACTER "C* STRINGS)C* 01/24/84 CONVERTED TO VAX )C* 10/13/83 INITIAL VERSION *C* *HC***********************************************************************C*  PARAMETER (LC=72)H CHARACTER *(*) STMTH CHARACTER *(LC) CARD CHARACTER *5 CLABELH CHARACTER *1 CAP LOGICAL NOT_INIT, EO?FO SAVE NOT_INIT, CARDR DATA NOT_INIT/.TRUE./ C AC --- FIRST TIME THROUGH WE WON'T HAVE A LOOK-AHEAD CARD, GET ONEOCT IF ( NOT_INIT ) THEN EOF = .FALSE.. CALL MLIB_GETCRD ( NREAD, CARD, EOF ) NOT_INIT = .FALSE.. ENDIFC  LS = LEN ( STMT ), STMT = ' ' IPTR = 1 CLABEL = CARD(1:5)C BC --- COPY ONLY NON-BLANK CHARACTERS, EXCEPT FOR CHARACTER STRINGSCG10 I = 7C13 IF ((CARD(I:I) .NE. '''')X .AND. (CARD(I:I) .NE. ' ') .AND. + $ (CARD(I:I) .NE. CHAR(9))) THENNK IF (CARD(I:I) .EQ. '!') GO TO 20 ! EXCLAMATION POINT COMMENT# CALL CAPITAL(CARD(I:I))L' STMT(IPTR:IPTR) = CARD(I:I)5 IPTR = IPTR + 1 CF#C --- QUOTED STRING COPIED VERBATIM CL+ ELSE IF (CARD(I:I) .EQ. '''') THEN ' STMT(IPTR:IPTR) = CARD(I:I)O IPTR = IPTR + 1 C BC --- CHARACTER STRING, COPY, INCLUDING BLANKS, UNTIL MATCHING "'"A;;5 SUBROUTINE QUOTA (DISK, CUIC, USED, PERM, IRET) C*3C* *******************************T3C* ******************************* 3C* ** ** 3C* ** QUOTA **C3C* ** **'3C* ******************************* 3C* *******************************_C*C* SUBPROGRAM : C* QUOTA C*BC* AUTHOR :*C* Arthur E. Ragosta C* MS 219-3%C* NASA Ames Research Center %C* Moffett Field, Ca. 94035 C* (415) 694-5578C*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)AEC* CUIC - THE UIC TO CHECK IN "[NUM,NUM]" (CHARACTER) FORMAT2,C* (CBLANK TO CHECK CALLER)C*C* OUTPUT ARGUMENTS :9C* USED - BLOCKS USED+C* PERM - PERMANENT QUOTA (BLOCKS)R1C* IRET - 0 FOR SUCCESS, ISTAT OTHERWISETC*C* SUBPROGRAM REFERENCES ::C8 SYS$ASSGN, LIB$GETJPI, SYS$QIOW, SYS$DASSGNC*%C* ASSUMPTIONS AND RESTRICTIONS :O2C* DON'T EVEN THINK ABOUT TRANSPORTING IT:C* USES "FORSYSDEF.TLB[$FIBDEF, $IODEF, $JPIDEF]"C*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77LC*DC* VERSION AND DATE :'C* VERSION I.0 - 2-JUN-1988 C*C* CHANGE HISTORY :A+C* 2-JUN-1988 - INITIAL VERSIONOC*HC***********************************************************************C* IMPLICIT INTEGER (A-Z) INCLUDE '($IODEF)' INCLUDE '($FIBDEF)' INCLUDE '($JPIDEF)'N CHARACTER *(*) CUIC, DISK  CHARACTER *16 TEMP8 DIMENSION IOSB(2), P1(2), P2(2), P4(10), XQUOTA(8) INTEGER *2 DISK_CHAN RECORD /FIBDEEF1/ FIBC*C --- ASSIGN DISK CHANNEL*C* IF (DISK .EQ. ' ') THEN ENDIFA, ISTAT = SYS$ASSIGN (DISK, DISK_CHAN,,)! IF (.NOT. ISTAT) GO TO 1000OCCC --- GET NUMERIC UIC$C  IF (CUIC .NE. ' ') THENe LC = LENGTH(CUIC) IC = INDEX(CUIC,',')C 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)!G CALL OCTDEC (TEMP, IUIC)) I = LC * IF (CUIC(I:I) .EQ. ']') I = I - 1 TEMP = CUIC(IC+1:I) CALL RIGHT(TEMP)A CALL OCTDEC(TEMP, JUIC) UIC = 65536*IUIC + JUIC ELSE. ISTAT = LIB$GETJPI (JPI$_UIC,,,UIC,,)$ IF (.NOT. ISTAT) GO TO 1000 ENDIF XQUOTA(2) = UICNC%C --- SEE I/O REFERENCE MANUAL, VOL 1C IFUNC = IO$_ACPCONTROL+ FIB.FIB$W_CNTRLFUNC = FIB$C_EXA_QUOTAN/ P1(1) = 64 H ! 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 QUOTACww9 QUOTA͚D RAGOSTA MACRO`@=L JURGELEIT GETSTM@L RAGOSTA GETSTM :|IL RAGOSTA TRANSL8pUqL RAGOSTA GETSTM ܸxL RAGOSTA TRANSL8ZO RAGOSTA PARSEa2O RAGOSTA COPYvP RAGOSTA UNIQUE2vP RAGOSTA UNIQUE[Q RAGOSTA MERGE Q RAGOSTA MERGEIqEQ RAGOSTA MERGER`.Q RAGOSTA FOPENXUK!l`;@; This file contains MACRO-32 source code for MERLIB routines.C; Some of these routines are duplicated in the FORTRAN version ofE; the source code for transportability reasons. The MACRO versions; are more efficient.;; ;  .title length;u; Author: Arthur E. Ragosta;eF; Return the true length of a string; i.e., the location of the lastF; non-blank character. Since FORTRAN's strings are non-dynamic, theD; function skips ONLY spacLes (not NULs, control characters, etc.).; 7; LS = LENGTH( 'A STRING ' ) ! Note, LS is 8 ;  .entry length,^m<> = movl 4(ap),r1 ;location of descriptor to r1 - movzwl (r1),r0 ;length to r0 / subl3 #1,4(r1),r1 ;location to r1 (LOOP: cmpb (r1)[r0],#32 ;space ?;n bneq done;r.; beql next ;replace previous line with these+; cmpb (r1)[r0],#09 ;to skip tabs too; bneq done;NEXT:;A= M sobgtr r0,loop ;check for zero length stringi DONE: reti .end ; ;I;=;h .title blanks; ; Author: Arthur E. Ragosta; A; Remove all embedded blanks from a string (left justifies) and^); returns the resulting strings length. ; ; INTEGER BLANKS$; STRING = 'This is a string.'; I = BLANKS ( STRING )r; (; Results in STRING = 'Thisisastring.'; and I = 14;a) .entry blanks,^mc9 movl 4(ap), Nr2 ;loc of descriptor to r2 . movzwl (r2),r3 ;length to r3* movl r3,r4 ;copy to r4 for later length0 movl 4(r2),r1 ;location to r1 clrl r2 ;input pointer=0e clrl r6 ;output pointer=09loop: cmpb (r1)[r2],#32 ;space in original string?  beql nexts- movb (r1)[r2],(r1)[r6] ;move non-blank bytes # incl r6 ;output increased by onee%next: incl r2 ;next input character9 sobgtr r3,loop ;check for end of string O subl2 r6,r4 ;remaining length/ movc5 #0,(sp),#32,r4,(r1)[r6] ;pad with blanks ( movl r6,r0 ;length of squeezed string ret .end >;; ; ;l .title left; ; Author: Arthur E. Ragosta; ; Left justify a string;;g,; STRING = ' This is a string.'; CALL LEFT ( STRING ); 3; Results in STRING = 'This is a string. ' ;s* .entry left,^m9 movl 4(ap),r0 ;loc of descriptor to r0. Pmovzwl (r0),r6 ;length to r6' movl r6,r3 ;copy to r3 for later use]0 movl 4(r0),r1 ;location to r1 movl r1,r7 ; and r7%loop: cmpb (r1)+,#32 ;space ? bneq out+ sobgtr r6,loop ;if still characters left  clrl r0 ret ;all blank out: decl r1( movc5 r6,(r1),#32,r3,(r7) ;move and pad decl r75loop1: cmpb (r7)[r6],#32 ;check backwards for blanks. bneq out1 sobgtr r6,loop1out1: movl r6,r0 ret .end r;n;t;; .tiQtle right ;h; Author: Arthur E. Ragosta; @; Right justify a string and return location of first nonblank;r; CHARACTER *10 STRING; STRING = 'A string'7; CALL RIGHT ( STRING ) ;r$; Results in STRING = ' A string'; + .entry right,^m 9 movl 4(ap),r0 ;loc of descriptor to r0l1 subl3 #1,4(r0),r7 ;location to r7,. movzwl (r0),r0 ;length to r0+ movl r0,r1 ;copy of length for later use5R'loop: cmpb (r7)[r0],#32 ;space ?  bneq out+ sobgtr r0,loop ;if still characters leftu ret ;all blank out: incl r7- subl3 r0,r1,r6 ;r6 now has number of blanks 2 movc3 r0,(r7),(r7)[r6] ;move non-blank characters$ movc5 #0,(sp),#32,r6,(r7) ;pad only ret .end y;a;a;m; .title CAPITAL ;p; Author: Arthur E. Ragosta;r9; Capitalize first character of a string (fast version) ;(; STRING = 'abc.' ; CALL CAPITAL ( STRING )1;1S; Results in STRING = 'Abc.';p .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't$ bgtr out ; nope... get out$ subb2 #32,(r1) ; zero that cap bitout: ret .end ;t; ;e;m .title lower ;l; Author: Arthur E. Ragosta;p+; Make all capital characters lower case.;;g$; STRING =T 'This Is A String.'; CALL LOWER ( STRING ) ;o+; Results in STRING = 'this is a string.'#; .entry lower,^m<>9 movl 4(ap),r1 ;loc of descriptor to r1?. movzwl (r1),r0 ;length to r05 subl3 #1,4(r1),r1 ;location(-1) to r1nloop: cmpb (r1)[r0],#64# bleq next ;Less than "A"?l cmpb (r1)[r0],#90 bgtr next ;Greater than "Z"? , addb2 #32,(r1)[r0] ;Its a CAP... lower it!7next: sobgtr r0,loop ;checUk for end of stringo ret .end L;L;R;L; .title caps;; Author: Arthur E. Ragosta;T+; Make all lowercase characters capitals. ; $; STRING = 'This Is A String.'; CALL CAPS ( STRING );t+; Results in STRING = 'THIS IS A STRING.' ;G .entry caps,^m<>9 movl 4(ap),r1 ;loc of descriptor to r1/. movzwl (r1),r0 ;length to r0* subl3 #1,4(r1),r1 ;location to r1loop: cmpb (r1)[r0],#96# V bleq next ;Less than "a"?  cmpb (r1)[r0],#122t bgtr next ;Greater than "z"? ' subb2 #32,(r1)[r0] ;Its LC... CAP it! 7next: sobgtr r0,loop ;check for end of stringo ret .end ;;d;s;  .title mlib_recall ;l; Author: Arthur E. Ragosta;tL; Return the recall buffer ( the buffer used by the ^B line edit descriptor,; for storage of the last 20 DCL commands).;n(; CALL MLIB_RECALL ( BUFFER, IPTR );rG; Where BUFFER is an array of BYTES a nd 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: ?; LINK 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 r0ww SAVE NOT_INIT, CARDN DATA NOT_INIT/.TRUE./IC AC --- FIRST TIME THROUGH WE WON'T HAVE A LOOK-AHEAD CARD, GET ONEFCN IF ( NOT_INIT ) THEN EOF = .FALSE.. CALL MLIB_GETCRD ( NREAD, CARD, EOF ) NOT_INIT = .FALSE.P ENDIFSC  LS = LEN ( STMT )  STMT = ' ' IPTR = 1 CLABEL = CARD(1:5)COBC --- COPY ONLY NON-BLANK CHARACTERS, EXCEPT FOR CHARACTER STRINGSCN10 I = 7C13 IF ((CARD(I:I) .NE. '''')YC. 15 I = I + 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)C IPTR = IPTR + 1 , IF(CARD(I:I) .NE. '''') GO TO 15 ENDIF17Z I = I + 1! IF (I .LE. LC) GO TO 13TC 6C --- CONTINUE COPYING IF THERE IS A CONTINUATION CARDC)+20 CALL MLIB_GETCRD ( NREAD, CARD, EOF ) & IF (CARD(6:6) .NE. ' ') GO TO 1030 LENST = IPTR-1 RETURN END CRC---END GETSTMC 1 SUBROUTINE MLIB_GETCRD ( NREAD, CARD, EOF )GC* Y4C* ******************************* 4C* ******************************* 4C* ** ** 4C* [ ** MLIB_GETCRD ** 4C* ** ** 4C* ******************************* 4C* ******************************* C* IC* SUBPROGRAM : C* GET CARD TC* RC* AUTHOR : C* ART RAGOSTA C* MS 207-5 :!C* AMES RESEARCH CENTER D'C* MOFFETT FIELD, CALIF 94035 EC* (415)965-5578 C* NC* PURPOSE : 0C* RETRIEVE THE NEXT NON-COMMEN\T CARD. C* EC* INPUT ARGUMENTS :?C* NREAD - THE LOGICAL UNIT NUMBER FOR THE SOURCE CODENFC* EOF - TRUE IF AN END OF FILE WAS ENCOUNTERED ON PREVIOUSC* READ*C*C* OUTPUT ARGUMENTS :*2C* EOF - TRUE IF AN END OF FILE OCCURRED C* CARD - THE CARD READC*C* COMMON BLOCKS : C* NONEC* C* FILE REFERENCES : RC* NREAD C* C* SUBPROGRAM REFERENCES : C* UNTAB, MLIB_ERROR*C* *]C* LANGUAGE AND COMPILER : C* ANSI FORTRAN 77*C* *C* VERSION AND DATE : C* VERSION II.4C* C* CHANGE HISTORY : /C* 04/26/88 GENERALIZED FOR MERLIB*7C* 12/26/84 SAVE AND RESTORE OPTIONS ADDEDL$C* 01/24/84 VAX VERSION)C* 10/13/83 INITIAL VERSION C* RHC***********************************************************************C* R PARAMETER (LC=72)M CHARACTER *(LC) CARD LOGICAL EOFR^CI IF (EOF) CALL MLIB_ERROR O@ $ (3,'GETCRD','Attempt to read past end of file.')'10 READ ( NREAD, 900, END=100 ) CARDFCL"C --- SKIP COMMENT AND BLANK CARDSC = IF ((CARD(1:1) .EQ. 'C') .OR. (CARD(1:1) .EQ. '*') .OR. ( $ (CARD(1:1) .EQ. 'c')) GO TO 10C*/C --- CHECK FOR VAX FORTRAN 'D_LINES' EXTENSION CA: IF ((CARD(1:1) .EQ. 'D') .OR. (CARD(1:1) .EQ. 'd'))  $ CARD(1:1) = ' 'C.C --- CHECK FOR VAX TAB CONTINUATION EXTENSIONC4& IF (CARD(1:1) .EQ. CHAR(9)) THENB IF ((CARD(2:2) .GE. '1') .AND. (CARD(2:2) .LE. '9')) THEN' CARD = ' $' // CARD(3:) ELSE ' CARD = ' ' // CARD(2:)I ENDIF ENDIF*! IF (CARD .EQ. ' ') GO TO 10* RETURNC*100 EOF = .TRUE. CARD = ' ' RETURN900 FORMAT ( A ) ENDACOC---END MLIB_GETCRD)CLwwB_ERROR f@ $ (3,'GETCRD','Attempt to read past end of file.')'10 READ ( NREAD, 900, END`PZxa SUBROUTINE DEFAULT (DIR_STRING)* D* Returns, in the character string DIR_STRING, the name of the cur-D* rent default device and directory. The string DIR_STRING must be>* long enough to contain the name, or this routine will abort.*(1* Alan L. Zirkle Naval Surface Warfare Centeru* Code K53)* 9 Nov 1983 Dahlgren, Virginia 22448.*h IMPLICIT INTEGER (A-Z)  CHARACTER*(*) DIR_STRINGc3 STATUS = SYS$TRNLOG('SYS$DISK',LEN1,DIR_STRING,,,)s- IF (.NOT.ST an(Loop) = ICHAR(Infile(Loop:Loop)); END DO ! into byte 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_FN bA = %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 (.N cOT. 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 d.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 COPYCwwfcCQ. SUBROUTINE MERGE ( A, NA, B, NB, C, NC )C*3C* ******************************* 3C* ******************************* 3C* ** ** 3C* ** MERGE ** 3C* ** ** 3C* ******************************* 3C* *******************************SC*C* SUBPROGRAM : C* MERGEAC*C* g AUTHOR : C* Arthur E. Ragosta C* MS 219-3%C* NASA Ames Research Center %C* Moffett Field, Ca. 94035 C* (415) 694-5578C*C* PURPOSE :FC* PERFORM A MERGE OPERATION ON TWO (SORTED) CHARACTER ARRAYSC*C* INPUT ARGUMENTS :C* A - FIRST ARRAY(C* NA - NUMBER OF ELEMENTS IN AC* B - SECOND ARRAY (C* NB - NUMBER OF ELEMENTS IN BC*C* OUTPUT ARGUMENTS : C* C - MERGED ARRAYAkEC* NC - NUMBER OF ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSE*GC* DUPLICATES ARE DROPPED) C*C* SUBPROGRAM REFERENCES :C* NONEC*%C* ASSUMPTIONS AND RESTRICTIONS : C* NONEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77$C*C* VERSION AND DATE : 'C* VERSION I.0 - 29-JUN-1988C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSIONC*HC*********************iA\P SUBROUTINE UNIQUE ( NAME )C*3C* *******************************3C* *******************************3C* ** **3C* ** UNIQUE **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* UNIQUEC*C* AUTHOR :C*j Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE :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* VERSION AND DATE :'C* VERSION I.0 - 28-JUN-1988C*C* CHANGE HISTORY :+C* 28-JUN-1988 - INITIAL VERSIONC*HC***********************************************************************C* CHARACTER *(*) NAME CHARACTER *23 DC CALL LIB$DATE_TIME ( D )E NAME = D(5:6)//D(1:2)//D(10:11)//D(13:14)//D(16:17)//D(19:20)// $ D(22:23) RETURN ENDCC---END UNIQUECwwl**************************************************C*' CHARACTER *(*) A(NA), B(NB), C(1)C NC = 0, IF (NA .EQ. 0) THEN ! COPY B TO C DO 10 I = 1,NB NC = NC + 1 C(NC) = B(I)10 CONTINUE RETURN ENDIFC, IF (NB .EQ. 0) THEN ! COPY A TO C DO 20 I = 1,NA NC = NC + 1 C(NC) = A(I)20 CONTINUE RETURN ENDIFC IA = 1 IB = 1mD100 IF (A(IA) .GT. B(IB)) THEN ! COPY SMALLER ELEMENT TO C NC = NC + 1 C(NC) = B(IB) IB = IB + 1K IF (IB .GT. NB) THEN ! IF SMALLER ARRAY IS EMPTY, K DO 110 I = IA, NA ! COPY REMAINDER OF OTHER ARRAY  NC = NC + 1 C(NC) = A(I) 110 CONTINUE RETURN ENDIF% ELSE IF (A(IA) .LT. B(IB)) THEN NC = NC + 1 C(NC) = A(IA)  IA = IA + 1K IF (IA .GT. NA) THEN ! IF SMALLER ARRAY IS EMPTY, K DO 120 I = IB, NB ! COPY REMAINDER OF OTHER ARRAY  NC = NC + 1 C(NC) = B(I) 120 CONTINUE RETURN ENDIFG ELSE ! EQUAL.... DELETE ONE OF THEM IA = IA + 1 ENDIF GO TO 100 ENDC C---END MERGECwwoQ/ SUBROUTINE MERGEI ( A, NA, B, NB, C, NC )C*3C* *******************************3C* *******************************3C* ** **3C* ** MERGEI **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* MERGE INTEGERSpC*C* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*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 - MERGEqD ARRAYEC* NC - NUMBER OF ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSEGC* DUPLICATES ARE DROPPED)C*C* SUBPROGRAM REFERENCES :C* NONEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NONEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 29-JUN-1988C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSIONC*HC*************r**********************************************************C* INTEGER A(NA), B(NB), C(1)C NC = 0, IF (NA .EQ. 0) THEN ! COPY B TO C DO 10 I = 1,NB NC = NC + 1 C(NC) = B(I)10 CONTINUE RETURN ENDIFC, IF (NB .EQ. 0) THEN ! COPY A TO C DO 20 I = 1,NA NC = NC + 1 C(NC) = A(I)20 CONTINUE RETURN ENDIFC IA = 1 IB = 1sD100 IF (A(IA) .GT. B(IB)) THEN ! COPY SMALLER ELEMENT TO C NC = NC + 1 C(NC) = B(IB) IB = IB + 1K IF (IB .GT. NB) THEN ! IF SMALLER ARRAY IS EMPTY, K DO 110 I = IA, NA ! COPY REMAINDER OF OTHER ARRAY  NC = NC + 1 C(NC) = A(I) 110 CONTINUE RETURN ENDIF% ELSE IF (A(IA) .LT. B(IB)) THEN NC = NC + 1 C(NC) = A(IA)  IA = IA + 1K IF (IA .GT. NA) THEN ! IF SMALLER ARRAY IS EMPTY, K DO 120 I = IB, NB ! COPY REMAINDER OF OTHER ARRAY  NC = NC + 1 C(NC) = B(I) 120 CONTINUE RETURN ENDIFG ELSE ! EQUAL.... DELETE ONE OF THEM IA = IA + 1 ENDIF GO TO 100 ENDC C---END MERGECwwudEQ/ SUBROUTINE MERGER ( A, NA, B, NB, C, NC )C*3C* *******************************3C* *******************************3C* ** **3C* ** MERGER **3C* ** **3C* *******************************3C* *******************************C*C* SUBPROGRAM :C* MERGE REALSC*vC* AUTHOR :C* Arthur E. RagostaC* MS 219-3%C* NASA Ames Research Center%C* Moffett Field, Ca. 94035C* (415) 694-5578C*C* PURPOSE :AC* PERFORM A MERGE OPERATION ON TWO (SORTED) REAL ARRAYSC*C* INPUT ARGUMENTS :C* A - FIRST ARRAY(C* NA - NUMBER OF ELEMENTS IN AC* B - SECOND ARRAY(C* NB - NUMBER OF ELEMENTS IN BC*C* OUTPUT ARGUMENTS :C* C - MERGED ARwRAYEC* NC - NUMBER OF ELEMENTS IN C (NOTE: NC <> NA + NB BECAUSEGC* DUPLICATES ARE DROPPED)C*C* SUBPROGRAM REFERENCES :C* NONEC*%C* ASSUMPTIONS AND RESTRICTIONS :C* NONEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77C*C* VERSION AND DATE :'C* VERSION I.0 - 29-JUN-1988C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSIONC*HC*****************x******************************************************C*" DIMENSION A(NA), B(NB), C(1)C NC = 0, IF (NA .EQ. 0) THEN ! COPY B TO C DO 10 I = 1,NB NC = NC + 1 C(NC) = B(I)10 CONTINUE RETURN ENDIFC, IF (NB .EQ. 0) THEN ! COPY A TO C DO 20 I = 1,NA NC = NC + 1 C(NC) = A(I)20 CONTINUE RETURN ENDIFC IA = 1 IB = 1Dy100 IF (A(IA) .GT. B(IB)) THEN ! COPY SMALLER ELEMENT TO C NC = NC + 1 C(NC) = B(IB) IB = IB + 1K IF (IB .GT. NB) THEN ! IF SMALLER ARRAY IS EMPTY, K DO 110 I = IA, NA ! COPY REMAINDER OF OTHER ARRAY  NC = NC + 1 C(NC) = A(I) 110 CONTINUE RETURN ENDIF% ELSE IF (A(IA) .LT. B(IB)) THEN NC = NC + 1 C(NC) = A(IA) IA = IA + 1K IF (IA .GT. NA) THEN ! IF SMALLER ARRAY IS EMPTY, K DO 120 I = IB, NB ! COPY REMAINDER OF OTHER ARRAY  NC = NC + 1 C(NC) = B(I) 120 CONTINUE RETURN ENDIFG ELSE ! EQUAL.... DELETE ONE OF THEM IA = IA + 1 ENDIF GO TO 100 ENDC C---END MERGECww {`.QC 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) 694-5578C*C* PURPOSE :BC* 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* ASSUMPTIONS AND RESTRICTIONS :C* NONEC*C* LANGUAGE AND COMPILER :C* ANSI FORTRAN 77~C*C* VERSION AND DATE :'C* VERSION I.0 - 29-JUN-1988C*C* CHANGE HISTORY :+C* 29-JUN-1988 - INITIAL VERSIONC*HC***********************************************************************C** CHARACTER *(*) FNAME, DEFNAME, PROMP LOGICAL NEW, ERROR CHARACTER *80 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) THEN4 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) ENDC C---END FOPENCww ATUS) CALL LIB$STOP(%VAL(STATUS)) 0 STATUS = SYS$SETDDIR(,LEN2,DIR_STRING(LEN1+1:))- IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))< LEN1 = LEN1 + LEN2(7 IF (LEN1.LT.LEN(DIR_STRING)) DIR_STRING(LEN1+1:) = ' 'z RETURN ENDwwo r0/ subl3 #1,4(r1),r1 ;location to r1*(LOOP: cmpb (r1)[r0],#32 ;space ?;  bneq done; .; beql next ;replace previous line with these+; cmpb (r1)[r0],#09 ;to skip tabs too; bneq done;NEXT:; = Zi{a, INTEGER FUNCTION DISK_SPACE(PACK_NAME)* J* Determines the number of free blocks remaining on the disk unitJ* whose logical name is PACK_NAME. 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 isN1* specified, or if the pack is not mounted. * 7* Alan L. Zirkle Naval Surface Warfare Centerp#* Code K53 4* 16 Nov 1983 Dahlgren, Virginia 22448*3* mods: Art Ragosta *g IMPLICIT INTEGER (A-Z) CHARACTER*(*) PACK_NAME2 CHARACTER*63 FILE_NAME+ PARAMETER ( DVI$_FREEBLOCKS = '2A'X )] INTEGER ITMLST(4)a INTEGER *2 ITEMLST(2)R( EQUIVALENCE (ITEMLST(1),ITMLST(1)) FILE_NAME = PACK_NAMEe ITEMLST(1) = 4" ITEMLST(2) = DVI$_FREEBLOCKS" ITMLST(2) = %LOC(FREEBLOCKS) ITMLST(3) = %LOC(LF) ITMLST(4) = 0gG STATUS = SYS$GETDVIW(,,FILE_NAME(1:LENGTH(FILE_NAME)),ITMLST,,,,) % IF (.NOT.STATUS) FREEBLOCKS = 0  DISK_SPACE = FREEBLOCKS RETURN ENDRwwa; ; Left justify a stringL;R,; STRING = ' This is a string.'; CALL LEFT ( STRING );*3; Results in STRING = 'This is a string. 'E;($ .entry left,^m9 movl 4(ap),r0 ;loc of descriptor to r0I. movzwl (r0),r5 ;length to r5' movl r5,r3 ;copy to r3 for later useI0 movl 4(r0),r1 ;location to r1 movl r1,r2 ; and r2%loop: cmpb (r1)+,#32 ;space ? bneq out+ sobgtr r5,loop ;if still characters leftI ret ;all blank out: decl r1( movc5 r5,(r1),#32,r3,(r2) ;move and pad ret .end ; ;L;L;C .title right ; ; Author: Arthur E. Ragosta;E@; Right justify a string and return location of first nonblank; ; CHARACTER *10 STRING; STRING = 'A string' ; CALL RIGHT ( STRING )T;.$; Results in STRING = ' A string';T+ .entry right,^m 9 movl 4(ap),r0 ;loc of descriptor to r0A1 subl3 #1,4(r0),r7 ;location to r7U. movzwl (r0),r0 ;length to r0+ movl r0,r1 ;copy of length for later useT'loop: cmpb (r7)[r0],#32 ;space ?R bneq out+ sobgtr r0,loop ;if still characters leftS ret ;all blank out: incl r7- subl3 r0,r1,r6 ;r6 now has number of blanksE2 movc3 r0,(r7),(r7)[r6] ;move non-blank characters$ movc5 #0,(sp),#32,r6,(r7) ;pad only ret .end ; ; ;L;I .title CAPITAL';; Author: Arthur E. Ragosta;i9; 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 outO cmpb (r1),#122 ; 'z'_$ bgtr out ; nope... get out$ subb2 #32,(r1) ; zero that cap bitout: ret .end U;=; ; ; .title lowerE;M; Author: Arthur E. Ragosta;(+; Make all capital characters lower case. ;*$; STRING = 'This Is A String.'; CALL LOWER ( STRING )*;*+; Results in STRING = 'this is a string.' ;  .entry lower,^m<>9 movl 4(ap),r1 ;loc of descriptor to r1 . movzwl (r1),r0 ;length to r05 subl3 #1,4(r1),r1 ;location(-1) to r1 loop: cmpb (r1)[r0],#64# bleq next ;Less than "A"?* cmpb (r1)[r0],#90 bgtr next ;Greater than "Z"? , addb2 #32,(r1)[r0] ;Its a CAP... lower it!7next: sobgtr r0,loop ;check for end of string, ret .end ; ;5;5;7 .title caps;P; Author: Arthur E. Ragosta;E+; Make all lowercase characters capitals.A;M$; STRING = 'This Is A String.'; CALL CAPS ( STRING ); +; Results in STRING = 'THIS IS A STRING.'W;E .entry caps,^m<> 9 movl 4(ap),r1 ;loc of descriptor to r1 . movzwl (r1),r0 ;length to r0* subl3 #1,4(r1),r1 ;location to r1loop: cmpb (r1)[r0],#96# bleq next ;Less than "a"?  cmpb (r1)[r0],#122 bgtr next ;Greater than "z"?S' subb2 #32,(r1)[r0] ;Its LC... CAP it! 7next: sobgtr r0,loop ;check for end of stringR ret .end R;N;D;T .title mlib_recall4;*; 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).;V(; CALL MLIB_RECALL ( BUFFER, IPTR );VG; Where BUFFER is an array of BYTES and IPTR is the location in BUFFER*I; of the most recent command length. BUFFER is a circular queue of 1025;; bytes. The format is LENGTH, NUL, COMMAND, NUL, LENGTH. ; ; Link thusly: ,?; LINK X.OBJ,MERLIB/LIB,SYS$SYSTEM:DCLDEF.STB/SEL,SYS.STB/SELD;0 $SSDEF+ .entry mlib_recall,^m 9 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 r0.4 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 ww RETURNCO100 EOF = .TRUE. RETURN900 FORMAT ( A ) ENDC C---END MLIB_GETCRDGC'wwAND. (CARD(2:2) .LE. '9')) THEN' CARD = ' $' // CARD(3:) ELSEF' CARD = ' ' // C 4 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 wwARD(3:) ELSEQ' CARD = ' ' // CARD(2:)  ENDIF ENDIF0! IF (CARD .EQ. ' ') GO TO 10- RETURNC100 EOF = .TRUE. RETURN900 FORMAT ( A ) ENDCC---END MLIB_GETCRDCww