% VAX-11 Librarian V04-00@Ӛ@/prFFF5q2 7 ALLMOUNT ARGCNT.MARzASCFADhASK.MAR BIGCHARS.MAR- BINDEC.FOR3BIN_STRING.MAR4BOXPAGEG BSET_Q.MAR9 BTEST_Q.MARc0 CHECK_DATEhvCHECK_IDk CHECK_READqd CHECK_TIMEs8CLEAR2uRCLEAR2D2vpCLEAR4xx CLEAR4_REST{COMP_TIMES.MARCOMP_TIMES.MARP_TIMES.MAROMP_TIMES.MAR{COMP_TIMES.MAROMP_TIMES.MARCOMP_TIMES.MARCOMP_TIMES.MARROMP_TIMES.MARCOMP_TIMES.MARKSDEVOWNER DISUSER_FLAGNDOUB%CONVERT_MACRO_DEFS.FORCREATE_LOGNAME; DECBIN.FOR DEGRADZ DELETE_BLANKSDEVOWNERNDOUBPENABLE_CTRLY_AST FILESPECS  FILL_STRING FLIP] GETDESCR.MARGETPID8 GET_CURSOR GET_ELEMENTh GET_OWNER ^ GET_SPEED^ GET_SPEEDR ^ GET_SPEED ^ GET_SPEED^ GET_SPEEDGET_OWNER ^ GET_SPEEDEED^ GET_SPEED^ GET_SPEEDNAME/IFID2 JBCSHELL.MARBJOBMODEDJOBTYPFxJULMINHJULSEC?COMP_TIMES.MAR GET_SPEED READ_LINEYMP_OR_NOCTORY" GET_TERMTYPE) GET_USERINFO, GET_USERNAME/IFID2 JBCSHELL.MARBJOBMODEDJOBTYPFxJULMINHJULSECO LSHIFT_STRING MAILMSG.FOR( MAILRRR.MARMAPDEXMINJULPAGERADDEGRANDOM READ_LINEIS.FOR READ_LINE READ_LINE READ_LINE READ_LINE READ_LINE READ_LINE READ_LINESCREENSCROLL2SETDEFSET_MODESET_PROCESSNAMESNDOPR STRING_LENGTHXSTRIPD 6RESET_TERMINALRFRDSCREEN^ SETDEF.FORSET_MODESET_PROCESSNAMEk SNDOPR.MAR STRING_LENGTHn STRIPD.MAR  TITLE.FOR( TRAN_LOGNAMEUSER_DIRECTORYU VAXUSERS.FORfVT_TITLE YES_OR_NOYMP YES_OR_NOYMPOR_NOYMPOYMPOR_NOYMPES_OR_NOYMPYMP @)@c***************************************************************c***** ALLMOUNTc*****)c***** AUTHOR: P.B.Wischow 21 June 1984c*****.c***** MODIFIED: J.A.Hammack 31 January 1985?c***** Supplied longwords instead of words to $mount=c***** to allow higher addresses (longer programs)c*****$c***** P.B.Wischow 15 April 1985 c***** Update to VAX/VMS V4.1c*****Cc***** DESCRIPTION: This routine will allocate and mount a magneitc@c***** tape. It mounts the tape as "foreign" and inserts aBc***** user supplied logical name in the Process Logical Namec***** Table.c*****c***** PARAMETERS: c*****Rc***** return1: Error in routine, control is returned to the calling program. c***** Ic***** recordsize: Size of the logical records in bytes or characters.(c***** (passed,integer*2)c*****9c***** blocksize: Size of the logical blocks in bytes.(c***** (passed,integer* 2)c*****Bc***** lognam: Logical name to be associated with the allocated5c***** tape drive. (passed,character*6)c*****6c***** physnam: Physical name the allocated device..c***** (returned, character*6)c*****0c***** SUBROUTINES REQUIRED: VAX System Services#c***** GETPID%c***** DEVOWNERc*****@c***************************************************************; subroutine allmount(*,recordsize,blocksize,logn am,physnam) implicit integer*4 (a-z) integer*2 recordsize,blocksize0 character*6 lognam,physnam, device_a/'_MSA0:'/ character*6 device_b/'_MSB0:'/ include '($SSDEF)' include '($MNTDEF)' include '($SYSSRVNAM)', integer*2 mnt_list(32) /4,mnt$_devnam,4*0, * 4,mnt$_blocksize,4*0, * 4,mnt$_recordsiz,4*0, * 4,mnt$_lognam,4*0, * 4,mnt$_flags,6*0/% equivalence (longword1,mnt_list(3)),% 1 (longword2,mnt_list(9)),& 2 (longword3,mnt_list(15)),& 3 (longword4,mnt_list(21)),% 4 (longword5,mnt_list(27)) call GETPID(pid) call DEVOWNER(devpid,'_MSA0:')' status=SYS$ALLOC(device_a,,physnam,,) if(status .ne. ss$_normal)then physnam='_MSA0:'9 if (devpid.eq.pid.or.status.eq.ss$_devalralloc) then ) if(status.eq.ss$_devmount) goto 20 go to 15 end if! call DEVOWNER(devpid,'MSB0:')) status=SYS$ALLOC(device_b,,physnam,,)' if(status .eq. ss$_normal) goto 15  physnam='_MSB0:'8 if (devpid.eq.pid.or.status.eq.ss$_devalralloc) then) if(status.eq.ss$_devmount) goto 20 go to 15 end if write(6,11)511 format(/,' *** NO FREE DRIVES AVAILABLE ***',/) return 1 end if15 write(6,16) physnam516 format(/,' *** MOUNT TAPE ON DEVICE ',a6,' ***',/) flags=mnt$m_foreign longword1=%loc(physnam) longword2=%loc(blocksize) longword3=%loc(recordsize) longword4=%loc(lognam) longword5=%loc(flags) status=SYS$MOUNT (mnt_list)- if(.not. status) call LIB$STOP(%val(status)) return20 write(6,21) physnam721 format(/,' *** ',a6,' DEVICE ALREADY MOUNTED ***',/) return endww^¦q .TITLE ARGCNT .IDENT /1/;+;A; A fortran callable subroutine to return the number of argumentsA; passed to the previously called subroutine. The call to ARGCNTK; must immediately follow the subroutine statement or as soon as possible).; Normal usage is as follows.;"; SUBROUTINE FOO(N1,N2,N3,.....NN) ; . . . . .6; CALL ARGCNT(NARG) ! NARG IS THE NUMBER OF ARGUMENTS; ! ACTUALLY PASSED TO FOO; ; Written by:; James G. Downward; KMS Fusion, Inc.; P.O. Box 1567; Ann Arbor, Mich. 48106; 01-Apr-1982;- .ENTRY ARGCNT,02 MOVL @8(FP),@4(AP) ; BUMP PREVIOUS CALLS COUNTER RET ; INTO NARG AND RETURN .ENDwwZQ+ CHARACTER * 4 FUNCTION ASCFAD ( AD )C;C** FUNCTION TO CONVERT AN ASCII DOUBLET TO AN ASCII STRINGC INTEGER AD(2)C BYTE ASCARY(4) CHARACTER * 4 ASCSTR# EQUIVALENCE ( ASCARY,ASCSTR )C* ASCARY(1) = LIB$EXTZV( 9, 7, AD(1) )* ASCARY(2) = LIB$EXTZV( 0, 7, AD(1) )* ASCARY(3) = LIB$EXTZV( 9, 7, AD(2) )* ASCARY(4) = LIB$EXTZV( 0, 7, AD(2) )C ASCFAD = ASCSTR RETURN ENDww` .Title Ask .IDENT /2.13/;+3; This routine is similar to the DCL cmd INQUIRE. '; It MUST be invoked via a foreign cmd.; Command format:;1; $ASK [/qualifiers] symbol-name "prompt-string";; Command qualifiers;$; /TIMEOUT=n ! time out in seconds+; /DEFAULT=default-string ! default answer&; /GLOBAL ! Same as INQUIRE command.; /UPPERCASE ! Force upper case input ; JGD1;; Notes:;J; o Escape sequences are passed to the symbol and are three charactersE; long, followed by the two symbols. This assumes ANSI escape D; sequences (VT100) are being sent. Won't work with VT52 term inals.K; However, VT2xx terminals can send longer escape sequences which are; also caught.K; o If Control-Z is input to the prompt, a ^Z is returned to the symbol2; o The symbol-name MUST be a valid DCL symbolH; o The double quotes surrounding the prompt-string MUST be present!?; o The radix of the timeout count is assumed to be decimalQ; o There may be NO double quotes surrounding the ALPHANUMERIC default-string; ; Written by: ; Mark Paulk; System Development Corp; 4810 Bradford Blvd NW; Huntsville, Al 35805; (205)-837-7610; Taken from [VAX82B.SDC.ASK];; Modified by:; James G. Downward; KMS Fusion, Inc.; PO Box 1567; Ann Arbor, Mich. 48106; (313)-769-8500; 29-March-1983); JGD1 Added /UPPER to force upper to!; lowercase conversion. By !; default, input now can be "; lower case unless /UPPER is#; specified. Allow Escape Seq!; to be passed. Allow ^Z to; be returned if entered.;!; JGD2 Allow VT2xx Escape seq$; JGD3 Very minor bug fix ADDL->#; ADDW. ASK works without this"; change, but right is right.;(; JGD4 Correct V4.0 Link warning msg;; ; Phil Smith; Digital Equipment Corp.; 7200 Poe Ave; Dayton, Ohio 45414; (513) 898-0920; 26-Jul-1985+; PRS1 Converted TRNLOG system service $; call to TRNLNM system serivce'; call using dynamic buffer sizes.&; Allows unlimited terminal name &; strings. This change needed to %; enable V4.0 to work on cluster; system.;- $TpaDef $CliServDef $LnmDef ; PRS1 Equals = ^X3D Quote = ^X22 .Psect AskData,NoExe+TParseBlk: .Long Tpa$K_Count0, Tpa$M_Abbrev .Blkb Tpa$K_Length0 - 8LocalQualSeen: .Long 1GlobalQualSeen: .Long 0DefQualSeen: .Long 0TimeQualSeen: .Long 0"UpperQualSeen: .Long 0 ; JGD1TimeOutCnt: .Long 0CmdBuf: .Blkb 255CmdDesc: .Long 255,CmdBuf0Request: .Long Cli$K_DefLocal@8 ! Cli$K_CliServSymName:: .Quad 0SymValue:: .Long 0,AnswerPrompt: .Quad 0DefAnswer: .Quad 0Answer:: .Blkb 255LogNam: .ASCID /SYS$COMMAND/(TabNam: .ASCID /LNM$FILE_DEV/ ; PRS1'Ilist: .Word lnm$c_namlength ; PRS1 .Word lnm$_string ; PRS1 .Long Term ; PRS1 .Long TermDesc ; PRS1 .Long 0 ; PRS1)TermDesc: .Long lnm$c_namlength ; PRS1 .Address Term ; PRS1&Term: .Blkb lnm$c_namlength ; PRS1Channel: .Long 0Iosb: .Quad 0-TMO: .Long Cli$K_DefLocal@8 ! Cli$K_CliServTMO_Name: .LONG 8,TMO_SYMTMO_Value:: .Long 1,TMO_VALTMO_VAL: .ASCII /F/TMO_SYM: .ASCII /$TIMEOUT/ .Psect AskCodeStart: .Word ^M<># Pushal TParseBlk + Tpa$L_StringCnt Clrl -(Sp) Pushal CmdDesc6 Calls #3,G^Lib$Get_Foreign ; Correct call mode JGD4 Blbs R0,10$ Brw Done-10$: Moval CmdBuf,TParseBlk + Tpa$L_StringPtr Pushal QualKey Pushal QualState Pushal TParseBlk Calls #3,G^Lib$TParse Blbs R0,20$ Brw Done220$: $TrnLnm_S - ; Translate logical name ; PRS1 LogNam=LogNam, - ; PRS1 TabNam=TabNam, - ; PRS1 Itmlst=Ilist ; PRS1 Blbs R0,25$ Brw Done25$: Cmpb #27,Term Bneq 28$ Subl2 #4,TermDesc Addl2 #4,TermDesc+4028$: $Assign_S Chan = Channel, DevNam = TermDesc Blbs R0,30$ Brw Done30$: Blbs TimeQualSeen,40$: Blbs UpperQualSeen,35$ ; If Force Uppercase branch ; JGD1D $Qiow_S Chan=Channel,Func=#Io$_ReadP rompt!Io$M_Escape,- ; JGD1: Iosb=Iosb,P1=Answer,P2=#255,P5=Prompt+4,P6=Prompt ; JGD1 Brw 50$ ; JGD1P35$: $Qiow_S Chan=Channel,Func=#Io$_ReadPrompt!Io$M_Escape!Io$M_Cvtlow,-;JGD1: Iosb=Iosb,P1=Answer,P2=#255,P5=Prompt+4,P6=Prompt ; JGD1 Brw 50$ ; JGD1&40$: Blbs UpperQualSeen,45$ ; JGD1# $Qiow_S Chan=Channel,- ; JGD17 Func=#Io$_ReadPrompt!Io$M_Escape!Io$M_Timed,- ; JGD1 Iosb=Iosb,- ; JGD1B P1=Answer,P2=#255,P3=TimeOutCnt,P5=Prompt+4,P6=Prompt ; JGD1 Brw 50$ ; JGD1'45$: $Qiow_S Chan=Channel,- ; JGD1A Func=#Io$_ReadPrompt!Io$M_CvtLow!Io$M_Escape!Io$M_Timed,-; JGD1 Iosb=Iosb,- ; JGD1B P1=Answer,P2=#255,P3=TimeOutCnt,P5=Prompt+4,P6=Prompt ; JGD150$:  Blbs R0,55$ ; JGD1 Jmp Done ; JGD155$:, CMPB Answer,#27 ; Was escape seen? ; JGD1 BNEQ 56$ ; If NEQ no ; JGD1-; Movl #3,Iosb+2 ; Set proper length ; JGD1?; ADDL Iosb+6,Iosb+2 ; Set proper length for esc seq ; JGD2> ADDW Iosb+6,Iosb+2 ; Set proper length for esc seq ; JGD356$: ; JGD1& Cmpb Iosb+4,#26 ; Was it ^Z ; JGD1# Bneq 58$ ; No, continue ; JGD11 Movl #1,Iosb+2 ; Yes, set propper length ; JGD10 Movb #26,Answer ; Set ^Z in the buffer ; JGD1'58$: Movzwl Iosb+2,SymValue ; JGD1 Bneq 60$ Movq DefAnswer,SymValue4 Cmpw Iosb,#SS$_TimeOut ; Did we timeout ; JGD1 Bneq 60$0 Movb #84,TMO_VAL ; Yes, so show we did ; JGD1N $Qiow_S Chan=Channel,Func=#Io$_WriteVBlk,P1=@SymValue+4,P2=SymValue,P4=#060$: Blbc GlobalQualSeen,70$2 Movl #Cli$K_DefGlobal@8!Cli$K_CliServ,Request70$: Pushal Request Calls #1,G^Sys$Cli, Pushal TMO ; Set the timeout flag ; JGD1+ Calls #1,G^Sys$Cli ; in $TIMEOUT ; JGD1 Done: Ret .Psect AskTables $Init_State QualState,QualKey $State Begin $Tran '/',Switch $Tran TPA$_SYMBOL,,StoreVarName $State( $Tran TPA$_LAMBDA,TPA$_EXIT,StorePrompt $State Switch% $Tran 'LOCAL',Begin,,1,LocalQualSeen' $Tran 'GLOBAL',Begin,,1,GlobalQualSeen( $Tran 'TIMEOUT',TimeOut,,1,TimeQualSeen' $Tran 'DEFAULT',Default,,1,DefQualSeen2 $Tran 'UPPERCASE',Begin,,1,UpperQualSeen ; JGD1 $State TimeOut $Tran Equals $State& $Tran TPA$_DECIMAL,Begin,,,TimeOutCnt $State Default $Tran Equals $State% $Tran TPA$_SYMBOL,Begin,StoreDefault $End_StateStoreDefault: .Word 0" Movq Tpa$L_TokenCnt(AP),DefAnswer RetStoreVarName: .Word 0 Movq Tpa$L_TokenCnt(AP),SymName RetStor ePrompt: .Word 0 Clrl R0 Movl Tpa$L_StringCnt(AP),Prompt Bleq 10$ Subl2 #3,Prompt Bleq 10$$ Movl Tpa$L_StringPtr(AP),Prompt + 4 Addl2 #2,Prompt + 4 Incl R010$: Ret .End Startww,#15) .TITLE BIGCHARS - GENERATE LARGE LETTERS .SBTTL DECLARATIONS $SSDEF $DSCDEF;4; THIS ROUTINE WILL FORMAT A WIDE LINE OF CHARACTERS; ! .psect BIGCHARS_DATA, long,noexeRET_LEN:.blkw 1 ROWS: .blkl 1POINTR: .blkl 1DESCR: .blkq 1SPACING:.blkw !a@Hc***********************************************************************:c This routine will display the title for Vax Professional=c workstation tasks. Input is the title (passed as a literalg;c string). The terminal type must be previously defined byE$c the global symbol "TERMINAL_TYPE".Hc*********************************************************************** program title implicit integer*2(a-z)3 integer*4 status, LIB$GET_FOREIGN, LIB$GET_SYMBOL character*30 iti"tleT character*10 ident character*1 cesc, cnull, cbell character*3 dblu,dbll character*4 rvid, cbold, cnorm character*7 type0 character*80 spaces, command! character*100 titleu,titlel,msgC2 character*100 blank_lineu,blank_linel,blank_line" data cesc/27/, cnull/0/, cbell/7/@ status = LIB$GET_SYMBOL(%descr('TERMINAL_TYPE'),%descr(type),,) if (.not.status) goto 99999 spaces = ' '0' status = LIB$GET_FOREIGN(command,,len)^. if (len.eq.0) goto 99999 ! No parameters!!! com#ma = INDEX(command,',')0- if (comma.eq.0) then ! No identity phrase0 ititle = command(1:len)4 ititle_length = lenO ident_length = 0 else, ititle = command(1:comma-1)D ititle_length = comma - 17 ident = command(comma+1:len) ident_length = len - comma ^ end ifO9 if (type.ne.'UNKNOWN') then ! If a VT100 type terminalO cbold=cesc//'[1m', cnorm=cesc//'[0m'1 save_length=ititle_length1! ititle_length=ititle_length+4: pre_length=(40-Ititl $e_Length)/2 ! # of prefill spaces2 dblU=cesc//'#3' ! Convert to dbl ht top line2 dblL=cesc//'#4' ! Convert to dbl ht bot line& rvid=cesc//'[7m' ! Reverse video: blank_linel=dbll//rvid//spaces(1:ititle_length)//cnorm itemp=ident_length/2 !' fill_length=ititle_length - itemp ! if (ident_length.eq.0) then0 blank_line = blank_linel elseS blank_line=rvid//spaces(1:fill_length)//ident(1:ident_length) ! Insert Ident:3 call STRING_LENGTH(blan %k_line,length) E if (2*itemp.lt.ident_length) then ! Compensate for odd length+ blank_line=blank_line(1:length)//O: * spaces(1:fill_length-1)//cnorm ! Ident strings elseL+ blank_line=blank_line(1:length)//H& * spaces(1:fill_length)//cnorm end if ! end if !;= titleU=DblU//Rvid//' '//cnorm//' '//Ititle(1:save_length),+ * //' '//cnorm//Rvid//' '//cnormC= titleL=DblL//Rvid//' '//cnorm//' '//Ititle(1:sav&e_length) ( * //' '//cnorm//Rvid//' '//cnorm* call STRING_LENGTH(blank_linel,length)< write(*,1001) spaces(1:pre_length),Blank_Linel(1:length)1001 format('+',a,a,a) % call STRING_LENGTH(titleu,length)C7 write(*,1000) spaces(1:pre_length),TitleU(1:length) % call STRING_LENGTH(titlel,length)E7 write(*,1000) spaces(1:pre_length),TitleL(1:length) 1000 format(1x,a,a,a)) call STRING_LENGTH(blank_line,length)  if (ident_length.eq.0) then > write(*,1 '000) spaces(1:pre_length),blank_line(1:length) else? write(*,1000) spaces(1:pre_length),spaces(1:pre_length),h * Blank_line(1:length) end if else , call STRING_LENGTH(ititle,ititle_length)7 length=(80-Ititle_Length)/2 ! # of prefill spacesPK call FILL_STRING(titlel,'*',ititle_length+4) ! Fill top line with stars 8 titlel = spaces(1:length)//titlel(1:ititle_length+4)6 write(*,1100) titlel(1:length+ititle_length+4)1100 format(1x,a)% titl eu = spaces(1:length)//'* '//n' * ititle(1:ititle_length)//' *'a2 write(*,1100) titleu(1:length+ititle_length+4)6 write(*,1100) titlel(1:length+ititle_length+4)5 length=(80-ident_Length)/2 ! # of prefill spacess* write(*,1200) spaces(1:length+2),ident1200 format(/,1x,a,a) end if 99999 end ww pushaq DESCR7 calls #2,G^STR$UPCASE ; Translate string to uppercase ret- .entry BIGCHARS, ^Mstart1:10$: cmpl #7,rows ; Done?? ) 74 .TITLE MACRO MAILRRR (Return Receipt Requested)I;========================================================================b ;= =;= Name : Hunter Goatley =v;;= Program : MAILRRR.MAR (MAIL Return Receipt Requested) =#+;= Language : VAX-11 MACRO-32 assembler =e<;= Purpose : Show whether or not VMS mail has been read by =;= the receiver =o!;= Date : September 4, 1985 = (;= System : VAX 11/785 VAX/VMS v4.1 =;= Shop : WKU/ACRS =e ;= * =9;= Suggestion : "Mail Call", Gary C. Kessler, THE DEC =0/;= PROFESSIONAL, March 1985, Vol. 4, No. 3, = ;= pp. 45-48 = e ;= =I;======================================================================== ;= =?;= This VAX-11 MACRO program shows whether or not a VMS mail = ?;= message has been read by the receiver of the message. The =h=;= VMS MAIL utility provides no means of determining if a =o8;= message sent by a user was read by the receiver. = ;= + =@;= This version must either be installed with SYSPRV privilege =A;= or executed by users with SYSPRV, since the program accesses =F7;= both SYSUAF.DAT and the receiver's MAIL.MAI file. =; ;= =@;= The executing user is assumed to be the sender. He/she is =?;= prompted for the name of the receiver. The program checks = =;= the SYSUAF.DAT file to make sure the username entered is =a>;= valid; if not, a message is printed to the screen and the =@;= program prompts for a name ag ,ain. If the user has a SYSUAF =@;= record, its default login device and directory are obtained =A;= and the program tries to open a MAIL.MAI file there. If the =s@;= file is not there or cannot be opened, a message is printed =?;= stating that the receiver has no messages from the sender. =$=;= Otherwise, the header for each MAIL message is read from =t>;= the MAIL file and the sender field is checked for a match =A;= with the executing username. If there is a match, the date, =s=;= subject -, and status are printed. If a message is in the =t@;= NEWMAIL folder, it is assumed that it has not been read; if =@;= it is in any other folder, it is assumed to have been read. =?;= The program exits on either ^Z, ^C, or at the prompt. =E@;= If the program is interrupted (by ^Y), the scrolling region =B;= for the screen will still be set -- always exit by one of the =';= three methods described above. =. ;= =I;===============================================================.=========* ;= =#;= System services used : =N ;= =4;= $ASSIGN Assign an I/O channel to the terminal = ;= =;= $EXIT Return to VMS =* ;= =;= $QIOW All terminal I/O =1 ;= =I;========================================================================* ;= =5;= VAX Record Management Services (RMS) used : =a ;= =(;= $CLOSE Close SYSUAF and MAIL.MAI = ;= =+;= $CONNECT Associate a RAB with a file =Y ;= I =1;= $FAB Create a Fiel Access Block for SYSUAF =%;= and the user's MAIL.MAI file = ;= =6;= $FAB_STORE Macro to store the specific MAIL.MAI =;= file name in the FAB = ;= =0;= $GET Get records from SYSUAF and MAIL.MAI = ;= =*;= $OPEN Open SYSUAF.DAT and MAIL.MAI = ;= =3;= $RAB Create a Record Access Block for SYSUAF =o;= and MAIL.MAI = ;= =I;=======================================================================0nd if start=1100 do i=start,168 if (temp(17-i:17-i).eq.'1') total=total+2**(incre-1) incre=incre+1 end do if (neg) total=-(total+1) write(6,300) binary, total-300 format(' BINARY: ',a,2x,'DECIMAL: ',i6,/) goto 1 endww髓P;*******************************************************************************F .TITLE BIN_STRING - Convert INTEGER number to binary character string'; written by: P.B.Wischow 9 Dec 1986;.; FORTRAN call: call BIN_1STRING(value,string)@; The number of bits converted is dependent on the length of the; passed character string.P;*******************************************************************************) .psect BIN_STRING_CODE,exe,rd,nowrt,long( .entry BIN_STRING,^M$ movl @4(ap),r5 ; Number to convert5 movq @8(ap),r6 ; Output character string descriptor* movzwl r6,r8 ; Get # of bits to convert$ subl2 #1,r8 ; Adjust index by one%LOOP: bbs #0,r5,SET ; Is LSB set ???5 mov6b #^A/0/,(r7)[r8] ; Set the "string" bit to zero brb CONT9SET: movb #^A/1/,(r7)[r8] ; Set the "string" bit to zero5CONT: ashl #-1,r5,r5 ; Shift value left for next bit) decl r8 ; Decrement index for "string" cmpw r8,#0 ; Are we done ??? bgeq LOOP ; Do it again !!! ret .endww@ s[`KC Subroutine BORDER is used by the Low Frequency data processing systemFC to draw chart boundaries, axes, and labels for CALCOMP plotting$C routines. The argumeSPOOL ELTRAN.MARGEOBATHLANDMASKNTRANMASKREADTAPEREAD_HARRIS.FORTYPEPAGEUOPEN_PRINT.MAR'ї WISCHOW BIN_STRING.MAR#Sţ WISCHOW BIN_STRING 4KP;*******************************************************************************F .TITLE BIN_STRING - Convert INTEGER number to binary character string'; written by: P.B.Wischow 9 Dec 1986 ;r.; FORTRAN call: call BIN_STRING(value,string)@; The number of bits converted is dependent on the length of the; passed character string.P;*******************************************************************************) .psect BIN_STRING_CODE,exe,rd,nowrt,longl( .entry BIN_STRING5,^M$ movl @4(ap),r5 ; Number to convert5 movq @8(ap),r6 ; Output character string descriptorr* movzwl r6,r8 ; Get # of bits to convert$ subl2 #1,r8 ; Adjust index by one%LOOP: bbs #0,r5,SET ; Is LSB set ???S5 movb #^A/0/,(r7)[r8] ; Set the "string" bit to zerol brb CONTo9SET: movb #^A/1/,(r7)[r8] ; Set the "string" bit to zeroc5CONT: ashl #-1,r5,r5 ; Shift value left for next bitA) decl r8 ; Decrement index for "string"* cmpw r8,#0 ; Are we done ???t bgeq LOOP ; Do it again !!! ret .endswwe*12H DATA declass /'CLASSIFIED BY: OPNAVINST S5513.5A-27 REVIEW ON: OADR'/( save = rlone ! save original longitude"C convert all strings to uppercase CALL STR$UPCASE (tics,otics) CALL STR$UPCASE (class,oclass) CALL STR$UPCASE (coast,ocoast) CALL STR$UPCASE (title,otitle)C compute chart size in inches xsize = (rlone - rlonw) * scale: ysize = (ymp(rlatn * 60.) - ymp(rlats * 60.))/60. * scaleC draw frame; CAL7L PLOT (1.,1.,-3) ! set origin so Versatec doesn't clip- z2 = 0.6 ! draw frame 0.6 inches from chart- DO i = 1,3 ! draw 3 times to make it darker CALL PLOT (-z2,-z2,3) x2 = xsize + z2 CALL PLOT (x2,-z2,2) y2 = ysize + z2 CALL PLOT (x2,y2,2) CALL PLOT (-z2,y2,2) CALL PLOT (-z2,-z2,2)@ z2 = z2 + 0.0075 ! move pen out z2 inches to make frame wider END DO/C initialize variables for lower longitude axis4 lat = rlats ! initialize for labels below th8e axis ymove = -0.2 ! y fudge factor xmove = -0.05 ! x fudge factor dist = -0.05 ! tic mark length x = 0. ! left edge y = 0. ! bottom of chart= symp = ymp(rlats * 60.) ! lower latitude in meridional parts1 heavy = lonstp * 60 ! heavy tic every 60 minutes< xcount = (rlone - rlonw) * 60 ! number of longitude minutes4 ticint = scale/60 ! distance between tics in inchesI IF (rlone .lt. rlonw) rlone = rlone + 360. ! convert to 360 degree world0 IF (lonstp .eq. 1) THEN ! lab9el every 5 minutes istep = 5 else ! label every degreee istep = 60 END IF( DO loop = 1,2 ! do both longitude axes C plot longitude tic marks/ DO i = 0,xcount,istep ! loop based on lonstp. x = i * ticint ! x is distance in inchesK IF (mod(i,heavy) .ne. 0 .and. tics .eq. 'TICS') THEN ! normal tic hereC normal tic marks CALL PLOT (x,y,3) CALL PLOT (x,y + dist,2) ELSE ! heavy tic here+ IF (mod(i,heav:y) .eq. 0) THEN C plot heavy tic and label CALL PLOT (x,y,3) !D CALL PLOT (x - 0.015,y + dist,2) ! plotting a triangle here+ CALL PLOT (x + 0.015,y + dist,2) ! CALL PLOT (x,y,2) !; lon = x/scale + rlonw ! compute current longitudeJ IF (lon .ge. 360.) lon = lon - 360. ! convert to 360 degree worldT IF (lon .gt. 180. .and. label .ne. '360') lon = lon - 360. ! convert to 180 ! degree world: xmove = -;0.15 ! fudge factors for 3 char labels ethel = 0.15 ! IF (lon .lt. 0) THEN letter = 'W' ELSE letter = 'E' END IFE IF (label .eq. '360') letter = ' ' ! no letters in 360 worldH IF (abs(lon - 180.) .lt. 0.5) letter = ' '! this is 180 degreesD IF (abs(2 * lon) .lt. 1.0) letter = ' ' ! this is 0 degreesD IF (lon.lt.0..and.label.eq.'360') THEN ! neg degrees to 360 world= temp = lon + 360. < ! 180 degrees < temp < 360 degrees ELSE ! 180 world8 temp = abs(lon) ! need positive number ENDIF: lon = abs(lon) ! need positive number for labelK IF (lon .lt. 99.5) xmove = -0.10 ! fudge factors for 2 char labels* IF (lon .lt. 9.5) xmove = -0.02 !I IF (lon .lt. 99.5) ethel = .10 ! fudge factors for 1 char labels( IF (lon .lt. 9.5) ethel = .08 !G CALL NUMBER (x + xmove,y + ymove,0.1,temp,0,-1) ! plot lo=nL call symbol (x + ethel,y + ymove,0.1,letter,jim,0,1) ! 'E' or 'W' END IF END IF END DO!C reset loop for upper axis4 label = '180' ! + - 180 labels for upper axis) x = 0. ! reset to left side of chartG y = ((ymp(rlatn * 60.) - symp)/60.) * scale ! reset to top of chart( dist = 0.05 ! reset tic mark length7 ymove = 0.10 ! reset fudge factor for top of chart END DO-C initialize variables for both latitude axes x =? 0. ! reset to left edge3 xmove = -0.345 ! new fudge factors for left axis ymove = -0.05 !' dist = -0.05 ! reset tic mark length< ycount = (rlatn - rlats) * 60 ! number of tic marks to draw, heavy = latstp * 60 ! number of heavy tics/ ascale = scale/60. ! scale in minutes for YMP IF (latstp .eq. 1) THEN3 istep = 5 ! tic marks every 5 minutes ELSE* istep = 60 ! tic marks every degree END IF' DO loop = 1,2 ! do latitude axes? DO i = 0,ycount,istep  T y = (ymp(float(i) + (rlats * 60.)) - symp) * ascale ! current position in incN IF (mod(i,heavy) .ne. 0 .and. tics .eq. 'TICS') THEN! normal tic here CALL PLOT (x,y,3)# CALL PLOT (x + dist,y,2) ELSE ! heavy tic here( IF (mod(i,heavy) .eq. 0) THENA CALL PLOT (x,y,3) ! draw a triangle for heavy tics) CALL PLOT (x + dist,y - 0.015,2) !) CALL PLOT (x + dist,y + 0.015,2) @! CALL PLOT (x,y,2) ! lat = float (i/60) + rlats! IF (lat .lt. 0) THEN letter = 'S' ELSE letter = 'N' END IFM IF (lat .lt. 0.5 .and. lat .gt. -0.5) letter = ' ' ! this is 0 degrees abslat = abs(lat)H IF (abslat .ge. 10.) THEN ! adjust offset for 2 digit label fred = 0.20 ELSE fred = 0.11 END IFN A IF (loop .eq. 1 .and. letter .eq. ' ') THEN ! move label a little6 zero = 0.11 ! if there is no E or W. ELSE ! and this is left axis zero = 0.0 END IFA IF (loop .eq. 1 .and. abslat .lt. 10.) THEN ! another shift2 zero = zero + 0.05 ! for 1 digit labels, fred = fred + 0.05 ! on left axis END IFF CALL NUMBER (x + xmove + zero,y + ymove,0.1,abslat,0,-1) ! plotO call symbol (xB + xmove + fred,y + ymove,0.1,letter,jim,0,1) ! 'N' or 'S END IF END IF END DO@ x = (rlone - rlonw) * scale ! reset for right side of chart xmove = 0.11 ! dist = 0.05 !. lat = rlats ! reset to southernmost lat END DO $C draw box around chart limits CALL PLOT (0,0,3) CALL PLOT (xsize,0,2)! CALL PLOT (xsize,ysize,2) CALL PLOT (0,ysize,2) CALL PLOT (0,0,2)C plot tCitle> call symbol (0.0,-0.5,0.07,title,jim,0,72) ! bottom of chartB call symbol (2.0,ysize + 0.35,0.14,title,jim,0,72) ! top of chart1 status = lib$date_time (date) ! retrieve dateC call symbol (-.45,.05,0.07,date,jim,90.,17) ! plot in left margin: call get_username (username,length) ! retrieve usernameI call symbol (-.45,1.38,0.07,username,jim,90.,length) ! plot on left edgeC plot classification CALL NEWPEN (3) ! red penG IF (class .ne. ' ' .and. xsizeD .gt. 10.) CALL ! if classified andI 1 SYMBOL (xsize - 9.,-.40,0.10,declass,jim,0,54) ! chart is big enough, ! plot declass messageF call symbol (0,ysize + 0.30,0.21,class,jim,0,6) ! plot classificationK call symbol (xsize - 1.26,-.50,0.21,class,jim,0,6) ! in upper left & lower ! right corners CALL NEWPEN (1) ! black pen*C plot WDBII coastlines if requested2C ( point density is automatically scaled)5 IF (coast .eq. 'COAST') THEN ! coastlines reEquested8 dense = (1.0 - scale) * 50.0 ! compute point density9 IF (scale .ge. 1.0) dense = 1.0 ! max density possible; IF (scale .lt. 0.1) dense = 45.0 ! min density practical= CALL CALCIA (rlats,0.,rlatn,0.,rlonw,0.,rlone,0.,0. 1 ,0.,scale,dense) END IF- rlone = save ! restore original longitude RETURN ENDww_O5 CHARACTER class*6, head*72, tics*4, label*3, coast*5% PRINT *,' TEST OF BORDER SUBROUTINEF'9 PRINT *,' TYPE IN VALUES FOR SCALE,RLONW,RLONE,RLATS,RLA *TN,LATSTP,LONSTP'> READ(5,*,ERR=100) SCALE,RLONW,RLONE,RLATS,RLATN,LATSTP,LONSTP9 PRINT *,' TYPE IN VALUES FOR TICS,CLASS,COAST,LABEL,HEAD% *, TYPING IN ONE VALUE PER LINE' READ(5,10,ERR=100) tics 10 FORMAT(A) READ(5,10,ERR=100) class READ(5,10,ERR=100) coast READ(5,10,ERR=100) label READ(5,10,ERR=100) head$ PRINT *,tics,class,coast,label,head CALL PLOTS (0,0,0)8 CALL BORDER(SCALE,RLOMNW,RLONE,RLATS,RLATN,LATSTP,LONSTP# *,HEAD,tics,class,coast,label) CALL PLOT (0,0,999) STOP ' '! 100 PRINT *,'ERROR DURING READ' ENDww`/5Jc************************************************************************* c BOXPAGEHc This routine outputs to logical name FOR006 (Fortran unit 6)Cc three lines of large text. Each line may be up to ten charactersc in length. c0c FORTRAN call: call BOXPAGE(line1,line2,line3)c>c Where: line1, liHjWJ;*************************************************************************) .TITLE BSET_Q - Set bits of a quad word h;n1; This routine will set the specified bit (0-63).;*+; FORTRAN call: status = BSET_Q(qword,35)**; This sets bit 35 of the quadword QWORD.;(-; Written by P.B. Wischow 24 November 1986cJ;************************************************************************* .PSECT BSET_Q,exe,rd,nowrt,long .entry BSET_Q, ^MSstart:/ movaq @4(ap 8), r5 ; Address of quadword to set(( movl @8(ap), r7 ; Bit to set (0 -> 63)& movl #1,r8 ; Load bit to shift left0 cmpb r7, #31 ; Which longword to set (1 or 2)L bgtr SECOND ; If bit to set is greater than 31 then look at 2nd longword6 ashl r7, r8, r8 ; Shift bit left to correct location3 bisl2 r8, (r5) ; Set specified bit... return brb RETURN ; Return3 ASECOND: subb2 #32, r7 ; Decrement bit count for second longwordG6 ashl r7, r8, r8 ; Shift bit left to coJ=n o.PAGE .SUBTITLE Storage Area);rI;======================================================================== ;= =*;= D E F I N E D S T O R A G E = ;= =I;========================================================================p;nTAB= 9eLF = 102CR = 13lESC= 27c;2!;================================;= =*;= MACRO library calls =;= =*!;================================.;L $RMSDEF $RABDEF $FABDEF;d';*** File Access Block for KSYSUAF.DAT f; +SYSFAB: $FAB FNM=, -B' FAC=GET, - ; File Access GET onlyt9 SHR= ; Allow other access to go one ; while searching*;*);*** Record Access Block for SYSUAF.DAT *;*SYSRAB:.- $RAB FAB=SYSFAB, - ; The File Access Block ( RAC=KEY, - ; Record Access --- keyed, KRF=0, - ; Key of Reference (position 0)( KSZ=8, - ; Key size --- 8 characters, KBF=TESTNAME, - ; Key buffer is TESTNAME/ USZ=1420, - ; Size of Lbuffer to receive rec . UBF=SYSREC ; Addr of buffer to receive rec;o$;*** File Access Block for MAIL.MAI;tMAILFAB:, $FAB FAC=GET, - ; File ACcess => GET only6 SHR= ; Allow other access to go on% ; The filename will be added at  ; at run-time r;&;*** Record Access Block for MAIL.MAI;cMAILRAB:. $RAB FAB=MAILFAB, - ; The File Access block( RAC=SEQ, - ; Sequential organization+ ROP=WAT, - ; Wait until I/O is complete$ KRF=1, - ; The key of reference . USZ=200, - ; The size of buffer to receive/ UBF=MAILREC ; The addr of buffer to receiveh;r!JPI_LIST: ; $GETJPI item list(# .WORD 12 ; ... Get the username* .WORD JPI$_USERNAME .ADDRESS USERNAME .LONG UN_LEN* .LONG 0;*+USERNAME: ; Buffer to hold the username  .BLKB 12 ; of the sender:+TESTNAME: ; Buffer to hold the username 0 .ASCII / / ; of the receiver .=.+20 2UN_LEN: .LONG 0 ; The length of the sender naNECOND ; If bit to test is greater than 31 then look at 2nd longwordA bbs r7, (r5), SET ; Test for bit set...if so , return TRUE brb CLEAR ASECOND: subb2 #32, r7 ; Decrement bit count for second longword: bbs r7, 4(r5), SET ; Test for bit set in second longword! ; ...if so , return TRUE/CLEAR: clrl r0 ; Bit NOT set ... return FALSE ret-SET: mnegl #1, r0 ; Bit set ... return TRUE ret .endwwT`*c Subroutine VAXCIA plots WDBII Ocoastlines+c for VERSATEC or CALCOMP graphics packagesc on any VAX-11.*c This subroutine was written 21 August 84+c by Jim Hammack. It is based on a routine%c written by Jan Depner & Jim Hammackc for UNIVAC computers in 1982.+c More information about the WDBII plotting+c system (UNIVAC based) may be found in the,c NAVOCEANO Technical Note, "A New Technique1c for Storing and Accessing the WDBII Coastline",+c TN 8300-03-82 by Jan C. Depner & James A. c Hammack.#c slatd = lPatitude degrees minimum#c slatm = latitude minutes minimum#c nlatd = latitude degrees maximum#c nlatm = latitude minutes maximum$c wlond = longitude degrees minimum$c wlonm = longitude minutes minimum$c elond = longitude degrees maximum$c elonm = longitude minutes maximumc xoffset = x offset in inchesc yoffset = y offset in inches%c scale = scale in inches per degreec gap = increment for plottingc (every 'gap' points),c NOTE! ALL ARGUMENTS ARE PASSED AS REAL*4Q1c Latitude and longitude may be passed as decimal+c degrees with the minutes portion as zero.>c Ex: CALL VAXCIA (20.5,0.,30.,0.,165.,0.,175.,0.,0.,0.,1.,1.)c#c Longitudes may be +-180 or 0-360.+c They may wrap around to 720 if necessary.,c This routine uses YMP to convert latitudes-c for Mercator projection. A similar function+c may be substituted for other projections., subroutine calcia (slatd,slatm,nlatd,nlatm,5 1 wlond,wlonm,elond,elonm,xoffset,yoffset,scale,gap) iRnteger array (27), words real nlat,nlatd,nlatm logical continuation,first! dimension ylon(1718), ylat(1718)4 open (unit=20,file='GRAVLIB$GENERAL:CIAMAPFIL.DAT',7 1 access='direct',form='unformatted',recl=27,readonly, 2 status='old')Ec call ELTRAN(20,5,1,0,'DISK$SYSTEM:[GRAVLIB.GRAPHICS]CIAMAPFIL.DAT',c * status) length = 0c define area boundaries. slat = (slatd+(slatm/60.)*sign(1.,slatd))+90.. nlat = (nlatd+(nlatm/60.)*sign(1.,nlatd))+90.* wlon = (wlond+(wlonm/60.)S*sign(1.,wlond))* elon = (elond+(elonm/60.)*sign(1.,elond)) slatmin = ymp((slat-90.)*60.)#c convert longitudes to 0-360 world% if (wlon .lt. 0.) wlon = wlon + 360.% if (elon .lt. 0.) elon = elon + 360.' if (elon .lt. wlon) elon = elon + 360.&c take integer parts for loop counting lats = slat latn = nlat lone = elon lonw = wlon( if (nlat - latn .ne. 0.)latn = latn + 10c round gap to nearest integer and print credits igap = gap + 0.5 print 40, igap c get starteTdc load record number into 'key'* 10 key = lats*360 + mod(lonw+180,360) + 1c clear continuation flag continuation = .false.c read data file 20 read (20'key,err=30) array(c20 call eltran (20,14,key,108,array,st)/c if (status .ne. 108) stop 'VAXCIA read error'c check for continuationc ( bit 21 of word 27 is set): if (continuation .or. ibits (array(27),21,1) .eq. 0) thenc set continuation flag continuation = .true./c determine number of words used in Uthis record c and continuation record number! words = ibits (array(27),16,5)" number = ibits (array(27),0,16))c convert from minutes to degrees decimal do j = 1,words3 if (j .eq. 27) then ! this record is continued key = number. go to 20 ! read continuation end if) declat = (ibits(array(j),16,16))/1000.( declon = (ibits(array(j),0,16))/1000. xlat = lats + (declat-1)/60. xlon = lonw + (declon-1)/60.+c check to see if poinVt is within plot area0 if (xlon .ge. wlon .and. xlon .le. elon .and., 1 xlat .ge. slat .and. xlat .le. nlat) thenc convert to inches length = length + 1! xlatm = ymp ((xlat-90.)*60.): ylat (length) = ((xlatm-slatmin)/60.)*scale + yoffset0 ylon (length) = (xlon-wlon)*scale + xoffsetc check distance between points" call dstchk (xlat,xlon,first)( if (first) then ! gap was too big c plot arrays? if (length .gt. 1) call crvplt (ylon,ylatW,length-1,igap)2c load last point into first word for next segment8c ylat (1) = ((xlatm-slatm)/60.)*scale + yoffset4c ylon (1) = (xlon - wlon) * scale + xoffset length = 0 end if end if end do end ifc flush buffer& if (.not. first .and. length .gt. 1) ( 1 call crvplt (ylon,ylat,length-1,igap)c reset counter length = 0c increment longitude lonw = lonw + 1.c if edge of plot, reset lon and increment lat if X(lonw .ge. lone) then lonw = wlon lats = lats + 1 end if3c if LATS exceeds LATN, this is the end of the plot if (lats .ge. latn) then call plot (0,0,-3) close (20)7c call eltran (20,6,0,0,0,status) ! close data file return end if0c if not finished, return to read another record go to 10 c messages!30 stop 'VAXCIA fatal read error'B40 format (///,' WDBII Coastline plotted by Code 8321 VAX-11 @ 1version (21 August 84)'/,24x,'Point spacYing index is ',I2,///) endC<C SUBROUTINE CALLED BY CALCIA AND MAPCIA TO PLOT ARRAYS.C#c Modified 20 Aug 84 by Jim Hammackc to plot every 'igap' points- SUBROUTINE CRVPLT (YLON,YLAT,KNTR,igap)& DIMENSION YLON(1718),YLAT(1718)# CALL PLOT (YLON(1),YLAT(1),3) DO 10 I=2,KNTR,igap% 10 CALL PLOT (YLON(I),YLAT(I),2)) if(i.ne.kntr) then !draw to last point$ call plot(ylon(kntr),ylat(kntr),2) end if RETURN ENDC>C SUBROUZTINE CALLED BY CALCIA AND MAPCIA TO CHECK FOR MAX C DISTANCE BETWEEN POINTS.C) SUBROUTINE DSTCHK (XLAT,XLON,first) common olxlat,olxlon logical first DATA RAD /0.00029089/ first = .false. XLTM=(XLAT-90)*60.0 AL=ABS(XLTM*RAD)H CONV=(111415.13*COS(AL)-94.55*COS(3.*AL)+.012*COS(5.*AL))/(60.0*18 152.0) A=ABS(XLAT-OLXLAT) B=(ABS(XLON-OLXLON))*CONV CC=A*A+B*B C=SQRT(CC) CHK=.010. IF (XLAT.LT.45.OR.XLAT.GT.13[5.) CHK=.017" IF (C.GT.CHK) first = .true. OLXLAT=XLAT OLXLON=XLON RETURN END FUNCTION YMP (Z) DATA AP /0.7853981634/ Y = ABS(Z) * 0.290888209E-03 T = TAN (AP+Y*0.5)* YM = 7915.7045*ALOG10(T)-23.268932*SIN(Y) YMP = YM*SIGN(1.0,Z) RETURN ENDww$Ic************************************************************************ c*** CHBNDc***Jc*** This subroutine takes a nine character ascii chart name Gc*** and \returns the lower right and upper left corner positions in -c*** degrees and the chart scale. c***7c*** A chart scale of 0 is returned for invalid input.c***>c*** LP8M contains the number of minutes of latitude for eachAc*** ps4 chart number band. c***Dc*** The chart scale is returned as a 0 if the name is not a proper&c*** ps4 chart number. Pc*** ] "c*** Written by Jim Braud, JUNE 84-c*** Modified for VAX by Jim Hammack, JUNE 84Ic************************************************************************5 subroutine chbnD1(name,lllat,lllon,urlat,urlon,ips) real lp8m  character*9 name dimension lp8m(16) < data lp8m/360,420,420,360,360,360,300,300,240,240,180,180, ; 1 180,120,360,240/  real lllat,lllon  ips=0 c***** unpack chart name *****  DECODE (2,10,name(1:2)) ii DECODE (2^,10,name(3:4)) jj DECODE (1,10,name(6:6)) kk DECODE (1,10,name(7:7)) ll DECODE (1,10,name(8:8)) mm DECODE (1,10,name(9:9)) nn10 format (i2),c***** check for invalid chart numbers *****& if (ii .le. 0 .or. ii .gt. 86) return( if (ii .gt. 36 .and. ii .le. 50) return& if (jj .le. 0 .or. jj .gt. 16) return)c***** check for negative latitude ***** if (ii .ge .50) then ii = ii - 50 ils = -1 else ils = 1 end if"c***** determine chart scale ***** ips = 6_4' if (0 .eq. nn) ips = 32' if (0 .eq. mm + nn) ips = 16& if (0 .eq. ll + mm + nn) ips = 8& if (0 .eq. kk + ll + mm + nn) ips = 4!c***** one more error check *****. if (ips .gt. 4 .and. name(5:5) .ne. '-') then ips = 0 return end if 60 iorg=4$c***** test for above 64 degrees  xl=600.  if(jj.le.14)go to 65  if(ii.le.24)go to 63 *c***** up here chart can only go up to 24 ips=0 return >c***** `cut scale in half again and adjust longitude per chartc***** (15 instead of 10) 63 ips=ips/2  xl=900.  iorg=IORG/2 $c****** calculate right longitude ?65 urlon=xl*(ii-1)+int(kk/3)*xl/2+int(ll/3)*xl/4+int(mm/3)*xl/8= 1 +int(nn/3)*xl/16 Dc***** calculate left longitude = lllon=urlon+xl/ips*iorg cDc***** adjust signs and convert to degrees. a = if(urlon.eq.10800..and.lllon.gt.10800.)urlon=urlon-21600. = if(lllon.eq.10800..and.urlon.gt.10800.)lllon=lllon-21600. = if(urlon.gt.10800.)urlon=urlon-21600. = if(lllon.gt.10800.)lllon=lllon-21600. = urlon=-urlon/60. = lllon=-lllon/60. Dc***** calculate upper latitude = urlat=-180*ils b = do 70 i=1,jj B70 urlat=urlat+lp8m(i)*ils ? urlat=urlat-int(mod(kk,4)/2)*lp8m(jj)/2 F 1 -int(mod(ll,4)/2)*lp8m(jj)/4 F 2 -int(mod(mm,4)/2)*lp8m(jj)/8 F 3 -int(mod(nn,4)/2)*lp8m(jj)/16 ? if(ils.lt.0)urlat=lp8m(jj)+urlat Fc***** calculate lower latitude and convert to degrees. ? lllat=(urlat-lp8m(jj)/ips*iorg)/60. ? urlat=urlat/60. ? return ? end ww) implicit integer*4(a-z) real alat,alon,blat,blon character*9 chartnumber 1 write(6,10)$10 format(' ENTER CHART NUMBER: ',$) rea dd(5,20) chartnumber 20 format(a)5 call CHBND(chartnumber,alat,alon,blat,blon,ps_scale)5 write(6,30) chartnumber,alat,alon,blat,blon,ps_scale@30 format(//,' chartnumber=',a9,/,' alat=',f8.2,/,' alon=',f8.2,= * /,' blat=',f8.2,/,' blon=',f8.2,/,' ps_scale=',i6,//) goto 1 endww`; C CHECK_DATE3C This subroutine will take a date string which is4C rigidly formatted (DD-MMM-YYYY) and check it for C correctness.C C call CHECK_DATE(*,date)C C WHERE:'C e Return = Error...invalid date stringc return1 = valid date string0C Date = CHARACTER*11 date string in formatC DD-MMM-YYYY whereC DD - 1 to 31C MMM - JAN ...DEC$C YYYY - Current_year toC Current_year+1 subroutine check_date (*,date) implicit integer*2(a-z) character*11 date ! character*11 tdate ! character*36 month_list ! logical*1 leap integer*4 STR$UPCASE9 data month_list /'JANFEBMARAPRMAYJUNJULAUGSEPOCTNfOVDEC'/ tdate=date leap=.FALSE. !! call STRING_LENGTH(tdate,length)? if (length.eq.10.or.length.eq.11) then ! Date too short error6 status=STR$UPCASE(tdate(1:length),tdate(1:length))D if (length.eq.10) tdate(1:11)='0'//tdate(1:10) ! Make std format8 if (tdate(3:3).eq.'-'.and. ! If not in DD-MMM-YYYY% * tdate(7:7).eq.'-') then 8 pos=INDEX(month_list,tdate(4:6)) ! A valid month4 if (pos.ne.0) then ! Error if invalid monthCC***** Convert str ging data to integers for numeric comparison *****? read(tdate(1:2),10,ERR=9000) day ! Convert to integer10 format(i2) !? read(tdate(8:11),20,ERR=9000) year ! Convert to integer year20 format(i4) ! tmp = year/4 !7 if ((4*tmp).eq.year) leap=.TRUE. ! Must be leap Year9 if (day.ge.1.and.day.le.31) then ! Check for valid day'C***** Sanity check for leap year *****. if (.not.leap) then ! IF not leap yearG if (tdate(4:6).eq.'FEB'.and. ! FE hB is special, last day isE * day.gt.28) goto 9000 ! 28 (except for leap year) else G if (tdate(4:6).eq.'FEB'.and. ! FEB is special, last day is= * day.gt.29) goto 9000 ! 29 in leap year end if !/C***** Check for months with only 30 days *****G pos=INDEX('APRJUNSEPNOV',tdate(4:6)) ! Check if month has 30 days3 if (pos.gt.0.and. ! If 31 entered, then bad5 * day.gt.30) goto 9000 ! date formati return1 end if end if end if end if9000 return ! iNVALID DATE endww@ओIc************************************************************************ c CHECK_IDBc The routine checks to see if the current user has the specified c identifier in the UAF.c1c FORTRAN call: call CHECK_ID(*100,id_to_check)c c Where:3c return: Specified identifier IS in the c users UAF entry.c -c return1: Specified identifier IjS NOT in c the users UAF entry.c 5c id_to_check: Identifier to look for in currentc users UAF entry.c (passed, character*(*))cIc************************************************************************# subroutine check_id(*,id_to_check) implicit integer*4(a-z) integer*2 len include '($SYSSRVNAM)' include '($SSDEF)' include '($JPIDEF)' dimension uic(2) character*(*) id_to_check character*39 name 8 status = LIB$GETJPIk(JPI$_UIC,,,uic,,) ! Get users UIC- if (.not.status) call LIB$STOP(%val(status))' context1 = 0 ! Reset the contexts" context2 = 0 ! " " "A500 status = SYS$FIND_HELD(uic,id,,context1) ! Get an identifier! if (status.eq.SS$_NOSUCHID) then' return1 ! No identifier matchs else0 if (.not.status) call LIB$STOP(%val(status)) end if& call STRING_LENGTH(id_to_check,idlen)M status = SYS$IDTOASC(%val(id),namelen,name,,,context2) ! Convert id to ASCII- if (.lnot.status) call LIB$STOP(%val(status))E if (name(1:namelen).eq.id_to_check(1:idlen)) then ! Check for match@ status = SYS$FINISH_RDB(context2) ! Clear database context@ status = SYS$FINISH_RDB(context1) ! Clear database context0 if (.not.status) call LIB$STOP(%val(status)) return else print*,name(1:namelen) P goto 500 ! No match...look again end if endww`hCh6 subroutine check_read(text,text_lenmgth,return_status) implicit integer*2(a-z) character*(*) text character*255 temptext, character*1 cesc,ctrl_z,cr, key_hit, ctrl_b data cr /13/ data ctrl_z /26/ data ctrl_b /02/ data cesc /27/ esc_position = INDEX(text,cesc)0 if (esc_position.ne.0) then ! have escape seq1 key_hit = text(esc_position+2:esc_position+2), text_length = text_length-esc_position-2 if (text_length.gt.0) then, temptext = text(1:text_length) text = temptext ennd if) if (key_hit.eq.'A') then ! up arrow return_status = 2/ else if (key_hit.eq.'B') then ! down arrow return_status = 3/ else if (key_hit.eq.'C') then ! left arrow return_status = 40 else if (key_hit.eq.'D') then ! right arrow return_status = 5/ else if (key_hit.eq.'P') then ! keypad PF1 return_status = 60 else if (key_hit.eq.'Q') then ! keypad PF2  return_status = 70 else if (key_hit.eq.'R') then ! keypad PF3 o return_status = 80 else if (key_hit.eq.'S') then ! keypad PF4  return_status = 9- else if (key_hit.eq.'p') then ! keypad 0 return_status = 10- else if (key_hit.eq.'q') then ! keypad 1 return_status = 11- else if (key_hit.eq.'r') then ! keypad 2 return_status = 12- else if (key_hit.eq.'s') then ! keypad 3 return_status = 13- else if (key_hit.eq.'t') then ! keypad 4 return_status = 14- else if (key_hit.eq.p'u') then ! keypad 5 return_status = 15- else if (key_hit.eq.'v') then ! keypad 6 return_status = 16- else if (key_hit.eq.'w') then ! keypad 7 return_status = 17- else if (key_hit.eq.'x') then ! keypad 8 return_status = 18- else if (key_hit.eq.'y') then ! keypad 9 return_status = 192 else if (key_hit.eq.'n') then ! keypad period return_status = 201 else if (key_hit.eq.'M') then ! keypad ENTER return_statqus = 211 else if (key_hit.eq.'l') then ! keypad comma return_status = 221 else if (key_hit.eq.'m') then ! keypad minus return_status = 23 else 3 return_status = -2 ! undefined key was hit end if ! return6 else if (INDEX(text,ctrl_z) .ne. 0) then ! if CTRL_Z return_status = 1% else if (text(1:1) .eq. ctrl_b .and., * text_length.eq.1) then ! if CTRL_B return_status = 248 else if (INDEX(text,cr).ne.0.and.text_length.eq.1r) then return_status = -1 end if text_length = text_length - 1 return endww|< C Check_Time%C Subroutine to check that the input.C time to be sure it lies within valid boundsC%C CALL Check_Time(time,length,Ierror)C;C Where time Character*5 Time string in format HH:MM+C length I*2 Length of time stringc return errorc return1 valid timeC:C This subroutine will accept as valid times of the format<C 1:mm, 01:mm, 10:mms, etc. Times of the format 10:m however9C are not valid. Valid hours range from 0 - 23 and validC minutes range from 0 - 59.C- subroutine check_time (*,time) implicit integer*2(a-z) character*5 ttime, time ! ttime=time! call STRING_LENGTH(ttime,length)% if (length.eq.5.or.length.eq.4) thenD if (length.eq.4) ttime(1:5)='0'//time(1:4) ! Stick on leading 0+ pos=INDEX(ttime,':') ! Find seperator if (pos.ne.0) then) read (ttime(1:2),10,err=9000) hour10 t format(i2.2) !+ read (ttime(4:5),10,err=9000) minuteR if (hour.ge.0.and.hour.le.23) then ! Only accept times from 00:00 to 23:590 if (minute.ge.0.and.minute.le.59) then return1 end if end if end if end if 9000 return end !ww>c************************************************************* c***** CLEAR2c*****+c***** Written by P.B.Wischow 26 July 1984c*****<c***** DESCRIPTION: This routine loadsu the passed array withc***** zeros.c*****2c***** PARAMETERS: array: The array to be zeroed.Cc***** (passed and returned,integer*2,variable length)c*****=c***** size: The size of the array to be zeroed.-c***** (passed,integer*4)c*****!c***** SUBROUTINES REQUIRED: nonec*****>c************************************************************* subroutine clear2(array,size) implicit integer*2(a-z) integer*4 size dimensivon array(size) do i=1,size array(i)=0 end do return endww Xَ>c*************************************************************c***** CLEAR2D2c*****+c***** Written by P.B.Wischow 26 July 1984c*****Bc***** DESCRIPTION: This routine loads the passed two dimensional c***** array with zeros.c*****2c***** PARAMETERS: array: The array to be zeroed.Cc***** (passed and returned,integer*2,variable length)c*****=c***** size: The siwze of the array to be zeroed.-c***** (passed,integer*2)c*****!c***** SUBROUTINES REQUIRED: nonec*****>c************************************************************* subroutine clear2d2(array,size) implicit integer*2(a-z) dimension array(2,size) do i=1,size array(1,i)=0 array(2,i)=0 end do return endww>c************************************************************* c***** CLEAR4c*****+c***** Written by P.B.Wischow 26 Juxly 1984c*****<c***** DESCRIPTION: This routine loads the passed array withc***** zeros.c*****2c***** PARAMETERS: array: The array to be zeroed.Cc***** (passed and returned,integer*4,variable length)c*****=c***** size: The size of the array to be zeroed.-c***** (passed,integer*4)c*****!c***** SUBROUTINES REQUIRED: nonec*****>c************************************************************* subroutine clear4(array,sizye) implicit integer*4(a-z) dimension array(size) do i=1,size array(i)=0 end do return endww <C **********************************************************<C **********************************************************<C *** CLEAR4_REST Written by Kurt R. Eleam june 1985 *****<C *** ***********<C *** DESCRITPTION: This subroutine will zero fill *********<C *** a specified array. ***********< zC *** ***********<C *** PARAMETERS: ***********<C *** ***********<C *** Array: The name of the array. ***********<C *** (passed,integer*4) ***********<C *** ***********<C *** Start: The location in the array to begin ***********<C *** the zero fill. ***********<C *** { (passed,integer*4) ***********<C *** ***********<C *** End: The size of the array and ending ***********<C *** point of zero filling. ***********<C *** (passed,integer*4) ***********<C *** ***********<C **********************************************************<C **********************************************************( subroutine CLEAR4_R!|EST(array,start,end) implicit integer(a-z) dimension array(1) if(start.le.end) then do I=start,end array(I)=0 end do end if return endwwKس .title comp_times& .psect comp_times_data,wrt,noexe,long $LIBCLIDEFdesc: .long 47 .address foreignforeign:.blkb 47forlen: .blkw 1arglist:.long 3 .address desc .long 0 .address forlen time_desc: .long 23 .address timetime: .blkb 23time1: .blkq 1time2: .blkq 1 result_desc: .}long 1 .address resultresult: .blkb 1symbol: .ascid /TIME_RESULT/!table: .long LIB$K_CLI_GLOBAL_SYM& .psect comp_times_code,nowrt,exe,long .entry comp_times,04 callg arglist, G^LIB$GET_FOREIGN ; Get times string7 locc #^a/,/, @#forlen, foreign ; Locate time delimiter- movzwl r1, r6 ; Save address of delimiter( movzwl r0, r7 ; Save # of bytes left6 subl3 r7, forlen, r8 ; Compute length of first time< movc5 r8, foreign, #^a/ /, #23, time; Get first time string pus~hal time1 pushal time_desc calls #2, SYS$BINTIM1 subl2 #1, r7 ; Subtract delimiter from string& addl2 #1, r6 ; Skip over delimiterA skpc #^a/ /, r7, (r6) ; Skip over leading blanks in second time/ movzwl r1, r6 ; Save address of second time( movzwl r0, r7 ; Save # of bytes left; movc5 r7, (r6), #^a/ /, #23, time ; Get second time string pushal time2 pushal time_desc calls #2, SYS$BINTIM: cmpl time1+4, time2+4 ; Compare second longword of times bgtr GREATER blss LESS =equal: cmpl time1, time2 ; Compare first longword of times bgtr GREATER blss LESS , movb #^a/=/, result ; Set result to equal brb RETURN:greater:movb #^a/>/, result ; Set result to greater than brb RETURN6less: movb #^a/"[4mDate/Time"/[m / ? .ASCII /[4mStatus//[m //[4mSubject/t! .ASCII /[m/GPROMPT: .ASCII / Enter the user name to check ( to stop) : / .ASCII /[K/dMNO_MSSG:.ASCII / ************ NO MESSAGES ************/u .AS CII MNO_USER:.ASCII / ************ No such user ************/i .ASCII MHEADER: .ASCII /[2J//[1;25H/"[7m VAX/VMS Mail Status Check " ! .ASCII /[m/f;n,OUTBUF: .ASCII / / ; The output buffer,DT: .BLKB 23 ; Spot for date/time of mssg: .ASCII / / ; Received or not picked up .ASCII / /l, .BLKB 23 ; The suubject of the mail mssg4BLANKS: .BYTE ^X20[80] ; 80 blanks (clear buffers)*PRMP ,)- if (.not.status) call LIB$STOP(%val(status)) return endww`OQ3 DOUBLE PRECISION FUNCTION DOUB(SD, LOW, IER )3C THIS IS THE REAL CONVERSION ROUTINE BUTCHERED BY *C STEVE LINGSCH TO HANDLE DOUBLE PRECISIONC<C VAX DOUBLE PRECISION NUMBER FROM UNIVAC DOUBLE PRECISION C-C NOTE: THIS ROUTINE AND THE CALLING ROUTINE +C MUST BE COMPILED WITH THE /G_FLOAT OPTIONC-C THE ARGUMENT SD MUST BE IN THE SAME FORM AS0C IN THE REAL FUNCTION (SEE RFRD). THE ARGUMENT0C LOW IS BITS 33-36 OF THE FIRST UNIVAC WORD AND1C THE REMAINING BITS ARE BITS 1-28 OF THE SECOND C UNIVAC WORD.C&C (1,1) (2,1)/C ***************************************/C * * */C SD * higher end of * lower end of */C * univac bits * univac bits */C * 1-18 * 19-32 */C ***************************************C/C ***************************************/C * * */C LOW * 33-36 * 1-28 */C * * */C ***************************************C  INTEGER SD(2),LOW,INT(2) REAL*8 DOUBL INTEGER HH, IV INTEGER * 2 Q(2), IV2(2)4 EQUIVALENCE ( HH, Q), ( IV2, IV), ( DOUBL,INT) LOGICAL LSC SET UP MASKS% PARAMETER ( M18 = 2 ** 18 - 1 )% PARAMETER ( M9 = 2 ** 6 - 1 ) +C EXPONENT FIELD, BITS 9 THRU 16 ON6 PARAMETER ( MEX = ( 2 ** 12 - 1) * ( 2 ** 6 ) )*C NORMALIZATION BIT, BIT 22 ON ON% PARAMETER ( MNORMB = 2 ** 23 ) C SIGN BIT, BIT 17 ON& PARAMETER ( MSIGNB = 2 ** 17 ) IER = 0 HH = SD(1) IV = SD(2)6 LS = ( HH .AND. MSIGNB) .NE. 0 ! NOTE SIGN BIT'C MAP NEGATIVES ON TO POSITIVES IF ( LS ) THEN% HH = ( .NOT. HH ) .AND. M18% IV = ( .NOT. IV ) .AND. M18 END IFDC LOAD ALL 24 BITS OF UNIVAC MANTISSA INTO ONE VAX LONG WORD- IV = JISHFT( HH .AND. M9, 18 ) .OR. IV/C CHECK FOR NON ZERO MANTISSA IF ( IV .NE. 0 ) THEN2C CHECK FOR PROPER NORMALIZATION/ IF ( (IV .AND. MNORMB) .NE. 0 ) THEN+ HH = JISHFT( HH .AND. MEX, 14 ) . .OR., . JISHFT(IV .XOR. MNORMB,-3)<C FLIP WORDS WHILE LOADING OUTPUT LONGWORD IV2(1) = Q(2) IV2(2) = Q(1)6 CALL MVBITS(LOW,31,1,IV,16) !MOVE IN LAGGING BIT INT(2)=JISHFT(LOW,1) INT(1)=IV& IF ( LS ) DOUBL = - DOUBL ELSE IER = 1 IV = 0 END IF END IF" CALL MTH$CVT_GA_DA(DOUBL,DOUBL,1) DOUB = DOUBL RETURN END wwۈP1 _INQUIRE P P P P Requests assignment of a given local or global DCL symbol to the P string entered in response to a specified prompt. The _INQUIRE P command is a functionally enhanced, upward-compatible version of P the standard VMS INQUIRE command. Note the underscore as the P first character of the command. This is to distinguish it from P the DCL INQUIRE command. P P Format: P P _INQUIRE symbol-name [prompt-string] P P The _INQUIRE command is intended primarily for use in interactive P command procedures run from terminals. In this case, _INQUIRE P prompts/responses are to/from SYS$COMMAND. When SYS$COMMAND is P not a terminal (e.g. batch mode), prompting is to SYS$OUTPUT and P responses are read from SYS$COMMAND. When used in this mode, P qualifiers noted as being specific to terminal function have no P effect. P P2 PARAMETERS P P PROMPT-STRING P P Specifies the prompt to be displayed at the terminal when the P INQUIRE command is executed. If the prompt string contains any P lowercase characters, blanks or tabs, or an at sign character (@), P enclose it in quotation marks ("). P P When the system displays the prompt string at the terminal, it P generally places a colon (:) and a space at the end of the string. P (See the /PUNCTUATION qualifier.) P P If you do not specify a prompt string, the symbol name is used as P the prompt. P P SYMBOL-NAME P P Specifies a 1- through 255-alphanumeric character symbol to be P given a value. This parameter is required. P P P2 /ECHO P P /NOECHO causes response characters not to be echoed at the P terminal. P P /ECHO is the default. P P P2 /EOF=label P P Specifies a DCL label that is the target of the next statement P executed if the response terminates with an end-of-file status. P This qualifier can be used in both batch and terminal modes. (For P terminals, control-Z (end-of-file) is treated as any other P terminator would be, but is also used to signal the end-of-file.) P P P2 /ERASE=erase-item P P Causes an erase operation on an ANSI-compatible CRT terminal as a P part of the prompting. There are four possible values for P erase-item. P P EOL The prompt is written and the remainder of the line P containing the cursor is cleared. P P EOS The prompt is written and the remainder of the screen P following the cursor is cleared. P P LINE The line containing the cursor is cleared before the P prompt is written, but after any specified cursor P positioning is performed. P P SCREEN The entire screen is erased before the prompt is written. P P P2 /ESCAPE P P /ESCAPE causes escape sequences to be recognized as terminating a P response. (This is independent of whether the terminal is set for P /ESCAPE or not.) Explicit specification of /ESCAPE implies P /TERMINATOR, which means that the escape sequence will be included P in the returned string. Note that escape sequences are never P echoed regardless of the state of the ECHO qualifier. P P /NOESCAPE is the default. P P P2 /ET P P /NOET prevents the response terminator from being echoed. It does P not, alas, rid the universe of excessively cute alien cash cows. P P Note that the terminator is not echoed if /NOECHO is specified, P regardless of this qualifer's setting. Also, escape sequence P terminators (see /ESCAPE) are never echoed. P P Note that with the combination of /NOET, /NOPUNCTUATION and P /NOECHO, the terminal display should be unaffected by the action P of the command. P P /ET is the default. P P P2 /GLOBAL P P Causes all symbol definitions made by the _INQUIRE command to be P in the global DCL symbol table. The complement is /LOCAL. P P /LOCAL is the default. P P P2 /HLPLIB=file P P Causes the indicated file to be accessed as an interactive help P library if the PF2 key (-O-Q sequence) is depressed on an P ANSI-compatible terminal. The actual help text presented to the P help library system will be the string formed by joining (in P order): the value of /HLPPFX, the user's text prior to the , P followed by the value of /HLPSFX. If any of these are not P specified, they are taken to be null. P P For example, the qualifiers /HLPLIB=HELPLIB/HLPPFX=AIRCRAFT with a P response of "orville" would cause "AIRCRAFTorville" to be P presented to the VMS help system using library HELPLIB.HLB in the P default directory. Note that no spaces are automatically inserted P between items. In the preceeding, /HLPPFX="AIRCRAFT " would P insert the (presumably) required space. P P Activation of help by the user will cause the scrolling region to P be reset and the screen to be erased on ANSI-compatible CRT P terminals. The help is activated with no default library P searching, and prompting and paging do not occur. P P Following the completion of the help sub-session, the prompt is P re-issued, including any positioning and screen erase operations P specified in the command, unless /NOREPROMPT is specified. P P Because the screen may contain remnants of help text when the P prompt is re-issued, it is recommended that if /POSITION and P /HELPLIB are specified together that /ERASE=EOS or /ERASE=SCREEN P also be specified. P P Use of /HELPLIB implies /ESCAPE so that the PF2 key escape P sequence can be received. /HELPLIB with /NOESCAPE is pointless. P P P2 /HLPPFX=text P P Specifies a string to be prefixed onto any help request text if P the user terminates the response with and /HELPLIB=... is P specified. If 'text' contains special characters, then it should P be enclosed in double quotes. Note that embedded and trailing P spaces or tabs in 'text' will be significant. P P P2 /HLPSFX=text P P Specifies a string to be suffixed onto any help request text if P the user terminates the response with and /HELPLIB=... is P specified. If 'text' contains special characters, then it should P be enclosed in double quotes. Note that embedded and leading P spaces or tabs in 'text' will be significant. P P P2 /LOCAL P P Causes all symbol definitions made by the _INQUIRE command to be P in the local DCL symbol table. The complement is /GLOBAL. P P /LOCAL is the default. P P P2 /LOWER P P /LOWER permits the pass-through of lower case letters (a..z) in P the defined string. If /NOLOWER is specified then all lower case P letters are translated to upper case when the result string is P defined. This can be useful to avoid having to map a response for P comparison purposes to upper case using DCL. P P Note that the /NOLOWER translation is done internally. If lower P case letters are entered, they will be echoed that way. P P P2 /POSITION=(row,col) P P Causes the terminal's cursor to be positioned to the indicated row P and column before the prompt is issued. This qualifier has effect P only for terminals with the ANSI characteristic set. P P P2 /PUNCTUATION P P /NOPUNCTUATION prevents a standard two character sequence ": " P from being appended to the prompt. P P /PUNCTUATION is the default. P P P2 /PURGE P P /PURGE causes the terminal 'type-ahead' buffer to be emptied P before reading the response. P P /NOPURGE is the default. P P P P2 /REPOSITION P P /REPOSITION causes the terminal cursor position prior to the P prompt to be saved, and subsequently restored to it's original P position following the response. This qualifier has effect only P for terminals with the DEC_CRT attribute set. P P /NOREPOSITION is the default. P P P2 /REPROMPT P P /REPROMPT permits reprompting after a help operation (see P /HELPLIB). P P If /NOREPROMPT is specified, after the help subsession is P completed, the entered text and the PF2 terminator (-O-Q) are P taken as the response and the _INQUIRE command exits. P P /REPROMPT is the default. P P P2 /SECONDS=n P P Specifies a timeout value in seconds for the user to complete the P response from the terminal. If the response is not completed in P that time, the command exits with the definition of the symbol set P to all characters entered to that point. Note that an optional P target DCL label can be specified for timeout with the /TIMEOUT P qualifier. P P The value must be a non-negative integer. A value of zero is P legal, and will read the characters in the terminal's type-ahead P buffer at that point as the symbol's definition. P P P2 /TERMINATOR[=symbol] P P /TERMINATOR with no value causes the character(s) that terminate P input to be returned as a part of the symbol definition. P P /TERMINATOR with a symbol value specification causes the response P terminator string to be placed in the given DCL symbol name. The P symbol table is determined as described under /GLOBAL and /LOCAL. P P When _INQUIRE is used non-interactively with /TERMINATOR=symbol, P the named symbol is always set to null. P P /NOTERMINATOR is the default unless /ESCAPE is specified. P P P2 /TIMEOUT=label P P Specifies a target DCL label for the next command if timeout P occurs (see /SECONDS qualifier). This qualifier has no effect P unless /SECONDS is also given. P P P2 Program Interface P P It is possible for an application program to call the INQUIRE P routines to perform the same sorts of processing that a DCL P _INQUIRE command can specify. There are two methods for doing P this. The command interface is called with a command string in a P format similar to that of the corresponding DCL command. While P very simple to use, it requires processing overhead to parse the P command string on each call. P P The direct call interface is not quite as simple, but is more P efficient, especially if many calls are to be made. P P All routines are available by linking with the object library P GRAVLIB$INQUIRE:INQUIRE.OLB. P P P2 Command Interface P P The command call statement has the form: P P Status.wlc.v = INQ$PROGRAM(cmdstr.rt.ds, result-str.wt.ds, P result-len.wl.r) P P Cmd-str is a string containing a command line as it would appear P for _INQUIRE, including all necessary qualifiers. The command P string should NOT contain the "_INQUIRE" prefix itself. P P The response string is returned right blank-padded or truncated if P necessary in result-str. The actual length of the response is P returned in result-len. P P Example: P P ISTAT=INQ$PROGRAM('SYS$COMMAND "Value"/SECONDS=4',RES,LEN) P P Note that certain qualifier forms are invalid when used in the P program interface. Their appearance causes a fatal status of P CLI$_INVQUAL to be returned as the status of the call. These P qualifiers are: P P /EOF=label P /GLOBAL P /LOCAL P /TERMINATOR=symbol P /TIMEOUT=label P P P2 Direct Call P P The INQUIRE direct call interface provides several entry points to P specify the options for the inquiry. The prompting is always to P SYS$COMMAND with this method. /NOTERMINATOR and /NOPUNCTUATION P are always in effect. However, note that the terminator string can P always be picked up with a call to a separate entry point. P P To use this method, first issue a call to INQ$CALL_INIT in the P form: P P Status.wlc.v = INQ$CALL_INIT() P P Then call one or more of the optional set-up routines if special P options are desired (see below). Then, issue one or more calls to P INQ$CALL_READPROMPT of the form: P P Status.wlc.v = INQ$CALL_READPROMPT(flags.wl.r,prompt-str.rt.ds, P response-str.wt.ds, response-len.wl.r, P P Each call to INQ$CALL_READPROMPT issues a inquiry to SYS$COMMAND. P P The flags argument specifies call-specific processing options (see P below). The prompt-str, response-str and response-len arguments P are all as described for the command interface method above. P P P3 Flags P P The flag bits given in a call to INQ$CALL_READPROMPT are defined P for FORTRAN users in GRAVLIB$INQUIRE:INQCALFOR.DEF as P follows: P P Name Value Description P P INQ$M_FLAG_NOECHO 1 Set for /NOECHO P INQ$M_FLAG_NOET 2 Set for /NOET P INQ$M_FLAG_PURGE 4 Set for /PURGE P INQ$M_FLAG_REPOSITION 8 Set for /REPOSITION P INQ$M_FLAG_NOREPROMPT 16 Set for /NOREPROMPT P INQ$M_FLAG_NOLOWER 32 Set for /NOLOWER P INQ$M_FLAG_NOESCAPE 64 Set for /NOESCAPE P P P3 INQ$CALL_ERASE P P Status.wlc.v = INQ$CALL_ERASE(code.rl.r) P P Call this routine before any call to INQ$CALL_READPROMPT to cause P the screen to be erased before the prompt as with P /ERASE=erase-item. The given code determines the type of erasing P performed. These codes are defined in P GRAVLIB$INQUIRE:INQCALFOR.DEF as follows: P P P Name Value Description P P INQ$C_ERASE_EOL 1 Erase to end of the line P INQ$C_ERASE_EOS 2 Erase to end of the screen P INQ$C_ERASE_LINE 3 Erase entire line P INQ$C_ERASE_SCREEN 4 Erase entire screen P P P The effect of this call persists until it is called again, or P until it is reset by calling INQ$CALL_INIT. P P P3 INQ$CALL_POSITION P P Status.wlc.v = INQ$CALL_POSITION(row.rl.r,column.rl.r) P P Call this routine before any call to INQ$CALL_READPROMPT to cause P the initial cursor position to be set as with P /POSITION=(row,column). P P The effect of this call persists until it is called again, or P until it is reset by calling INQ$CALL_INIT. P P P3 INQ$CALL_GETTERM P P Status.wl.v = INQ$CALL_GETTERM(term-str.wt.ds,term-len.wl.r) P P This routine returns the terminator and terminator length P associated with the last response returned with a call to P INQ$CALL_READPROMPT. The terminator string is returned right P blank-padded, truncated if necessary. Term-len contains the P actual length of the terminator string that was received in the P response. P P P3 INQ$CALL_TIMEOUT P P Status.wl.v = INQ$CALL_TIMEOUT(seconds.rl.r) P P Call this routine before any call to INQ$CALL_READPROMPT in order P to cause the read to have a integer timeout value of the given P number of seconds as with /TIMEOUT=seconds. P P The effect of this call persists until it is called again, or P until it is reset by calling INQ$CALL_INIT. P P P3 Sample Program P P There follows below an example program of the use of the INQUIRE P call interface, written in FORTRAN. P P PROGRAM INQUIRE_CALL_DEMO P P C This program demonstrates the use of the INQUIRE program P C call interface. It loops until the user hits a terminator P C key on the terminal (, control key, etc.) and then P C calls routine ACTION with the terminator key that was struck P P IMPLICIT NONE P P INCLUDE 'GRAVLIB$INQUIRE:INQCALFOR.DEF/NOLIST' P P C Functions P P INTEGER INQ$CALL_INIT, INQ$CALL_TIMEOUT, INQ$CALL_READPROMPT P P C Local store P P CHARACTER RESP, TERM P INTEGER NULL(2) /2*0/ !Fake-out null string descriptor P INTEGER MS100(2) /-1000000,0/ !100 millisecss in delta time P INTEGER ISTAT, TLEN, RLEN P P C Initialize the call interface P P ISTAT=INQ$CALL_INIT() P IF (.NOT. ISTAT) CALL EXIT(ISTAT) P P C Set the timeout for zero seconds P P ISTAT=INQ$CALL_TIMEOUT(0) P IF (.NOT. ISTAT) CALL EXIT(ISTAT) P P C Loop here until a terminator is hit on the terminal P TLEN=0 P ISTAT=1 P DO WHILE ((TLEN .EQ. 0) .AND. ISTAT) P ISTAT=INQ$CALL_READPROMPT(INQ$M_FLAG_NOECHO,NULL,RESP,RLEN) P CALL INQ$CALL_GETTERM(TERM,TLEN) P CALL SYS$SETIMR(,MS100,,) P CALL SYS$WAITFR() P ENDDO P IF (.NOT. ISTAT) CALL EXIT(ISTAT) P P C Call routine now that user has hit terminator key P CALL ACTION(TERM) P END wwEc********************************************************************Ec***** DUMPSPOOL written by P.B.WISCHOW JULY 1985 *****Ec******************************************************************** implicit integer*2(a-z) real psize character*50 filename dimension lgcmd(880) data pntr/1/ write(6,1) 01 format(' ENTER COMPLETE FILENAME TO DUMP: ',$) read(5,2) filename 2 format(a)) open(unit=10,file=filename,status='OLD') read(10,11) psize,units,pltnum11 format(f5.2,i1,i2) write(6,15)psize,units,pltnum715 format(' PSIZE= ',f5.2,' UNITS= ',i1,' PLTNUM= ',i2)"10 read(10,40,end=999) lgcmd(pntr)40 format(2o6) knt=knt+1 pntr=pntr+1 if (pntr.gt.880) then pntr=1 write(6,100) lgcmd#100 format(55(8(2(1x,o6),2x),/)) call CLEAR2(lgcmd,880) write(6,111)111 format('1') end if goto 10999 write(6,100) lgcmd write(6,1000) knt,1000 format(1x,i10,' commands encountered.') endww*0; ELTRAN = HIGH VOLUME I/O SUBROUTINE; PERFORMS2; BLOCK I/O TO TAPE,DISK OR OTHER DEVICE/; PROGRAMMER: Maria Kalcic, Code 022; functions are:; 1 - sequen T_LINE: ; ANSI ESC seq -> send the5 .ASCII /[3;1H/ ; cursor to line 3, column 1n<UNDLIN: .ASCII /[4m/ ; ANSI ESC seq -> underline mode:CLRATT: .ASCII /[m/ ; " " " -> turn off attr* .ASCII /[K/ ; Clear to end of line7CLR_END:.ASCII /[J/ ; Clear from current cursor d$ ; position to end of display8DEFSCR: .ASCII /[9;23r/ ; Define scrolling regionGCLEAR: .ASCII /[1;24r//[2J/ ; Reset scrolling region & cleartGFROM: .ASCII /From: //[4m/ ; "From: " (with underlining)mHTO: .ASCII /[K//To: //[4m/ ; "To: " (W/ under)YES: .ASCII /RECEIVED /NO: .ASCII /NOT PICKED UP /1%CRLF: .BYTE CR,LF ; comboa;i+DATE: ; Descriptor for ASCII date/timea .LONG 23 ; of mail message .ADDRESS DT4INBUFF: .BLKB 80 ; Input buffer for prompted info;d2SYSREC: .=.+1420 ; Buffer to hold SYSUAF record-MAILREC: ; Buffer to hold MAIL.MAI recordr .=.+200 r.PAGEb .SUBTITLE MAIN Routinei;tI;========================================================================. ;= =!;= M A I N R O U T I N E =r ;= =I;========================================================================-;. .ENTRY MAILRRR,^M<> ; Entry point of program) CLRL R10 ; Clear the YES messages flagr3 $ASSIGN_S - ; Assign the terminal an I/O channel1 DEVNAM=TTNAME, - CHAN=TTCHAN$/ BSBW SET_CTRLC ; Set the ^C interrupt handleri8 MOVAB DEFSCR,R0 ; Move addr of ANSI escape sequence to) MOVZBL #7,R1 ; set scrolling region3 BSBW PUT_OUT ; Send the sequence to the terminal$: MOVAB HEADER,R0 ; Move the HEADER addr to R0 for PUT_OUT4 MOVZBL #51,R1 ; Move the length to R1 for PUT_OUT" BSBW PUT_OUT ; Print the header;$;******* Get the name of the sender;t, $GETJPIW_S - ; Get the name of the sender ITMLST=JPI_LISTa8 LOCC #^A/ /,#12,USERNAME ; Find the end of the username2 BEQL LOOP ; Not found - name is 12 chars - contB SUBL3 #USERNAME,R1,UN_LEN ; Get the actual length of the username+ ; ...($GETJPI returns 12 - blanks pad);u*;***** Get the name of the MAIL recipient;_0LOOP: MOVC3 #16,BLANKS,TESTNAME ; Clear TESTNAME: $QIOW_S CHAN=TTCHAN, - ; Prompt the user for the name to3 FUNC=#IO$_READPROMPT, - ; of the user to checkb P1=INBUFF, - P2=#80, - P4=#0, - P5=#PROMPT, -a P6=#53- LOCC #^X1A,#80,INBUFF ; Did user enter a ^Z?t BEQL 1$ ; No -- continuee$ BRW BYE ; Yes -- exit t he program?1$: LOCC #CR,#80,INBUFF ; Find the indicating end of name8 SUBL3 #INBUFF,R1,R2 ; Was only character entered? BNEQ 5$ ; NO - continue# BRW BYE ; YES - exit the programe;5$: MOVL R2,TN_LEN ; Move the length of TESTNAME to TN_LEN 5 MOVC3 R2,INBUFF,TESTNAME ; Move the name to TESTNAMEp;f";*** Convert the name to uppercase;u9 MOVL TN_LEN,R0 ; Get the length of the username entered/ MOVAB TESTNAME,R1 ; Move the starting address*7$: CMPB #^X60,(R1) ; Is character >= "a"1 BGTR 9$ ; No - don't touch it. Yes - continuew= BICB2 #^B00100000,(R1) ; Convert each character to uppercasee ; (turn off bit 5)o-9$: INCL R1 ; Bump up pointer into TESTNAMEc. SOBGTR R0,7$ ; Finished? No - convert next; ( BSBW PUT_HEADINGS ; Print the headings;_E;**** Check to see if the recipient name entered is a valid usernamet; 9 CMPL #16,TN_LEN ; Is name entered longer than 16 chars?% BGEQ 10$ ; Yes -- no such username BRW NO_SUCH_USERq<10$: $OPEN FAB=SYSFAB ; Open SYSUAF to read TESTNAME record, BLBS R0,20$ ; Error opening? Go to ERROR BRW ERROR720$: $CONNECT RAB=SYSRAB ; Connect the RAB with SYSUAFn/ BLBS R0,30$ ; Error connecting? Go to ERRORm BRW ERROR;b030$: $GET RAB=SYSRAB ; Read the TESTNAME record' CMPL #RMS$_RNF,R0 ; Was record found?: BNEQ 35$, BRW NO_SUCH_USERm/35$: $CLOSE FAB=SYSFAB ; Close the SYSUAF files t; P;****** Get the recipient's default device and directory (home of the MAIL.MAI);;***** * and build the complete MAIL.MAI file specificationv;D LOCC #^A":",#32,SYSREC+117 ; Find ":" indicating end of device name= SUBL3 #SYSREC+117,R1,R6 ; Get the length of the def dev namer INCL R6 ; Bump to include ":"3 MOVL R6,R8 ; Save the number of chars in def dev < MOVC3 R6,SYSREC+117,FILESPEC ; Move the def dev to FILESPECD LOCC #^A"]",#40,SYSREC+149 ; Find "]" indicating end of default dir6 SUBL2 #SYSREC+149,R1 ; Get the length of the def dir INCL R1 ; Bump to include "]"6 A DDL2 R1,R8 ; Add to the number of chars in def devE MOVC3 R1,SYSREC+149,FILESPEC[R6] ; Move the def dir name to FILESPECoA MOVC3 #8,MAIL_FILE,FILESPEC[R8] ; Move MAIL.MAI to the filespeca6 ADDB2 #8,R8 ; Bump up R8 (total length of FILESPEC);w5 $FAB_STORE - ; Store FILESPEC (the receiver's maile4 FAB=MAILFAB, - ; filename) in the FAB for MAIL FNA=FILESPEC, - FNS=R8;N;******* Open the recipient's MAIL file (if there), read in each mail header,K;******* to see if the file was sent by the USERNAME, and, if so, put the 3/;******* message status into the output buffera;/ $OPEN FAB=MAILFAB ; Open the user's mail filek6 BLBS R0,40$ ; Error opening? No messages from user BRW NO_MESS640$: $CONNECT RAB=MAILRAB ; Connect RAB with MAIL.MAI# BLBS R0,HERE ; Error connecting?e& BRW NO_MESS ; No messages from userHERE:n. $GET RAB=MAILRAB ; Get the first mail header' CMPL #RMS$_RNF,R0 ; Was record found?p BNEQ 4$ ; Yes - continuel) BRW NO_MESS ; No -- goto error routineb/4$: CMPL #RMS$_EOF,R0 ; Was end of file found?f BNEQ 5$ ; Yes - continuei) BRW NO_MESS ; No -- goto error routineJ5$: MATCHC UN_LEN,USERNAME,UN_LEN,MAILREC+68 ; Is mail from running user?$ BNEQ HERE ; No -- get next record;m+;******* Here if message was from USERNAME,>; ; CMPC3 #7,NEWMAIL,MAILREC+9 ; Has file been read (NEWMAIL)? ' TSTL R0 ; Is this in NEWMAIL folder? , BNEQ 10$ ; Yes - move t he RECEIVED status8 MOVC3 #14,NO,OUTBUF+32 ; Move "NOT PICKED UP" to OUTBUF/ BRB 12$ ; Go find the subject of the messagew810$: MOVC3 #14,YES,OUTBUF+32 ; Move "RECEIVED" to OUTBUF ,; /12$: dXXX:= moval mailrec+68,r3 ; Get beginning addr of SENT FROM fieldc4 locc #^x01,#100,(r3) ; Find end of SENT FROM field bneq 13$ ? brw NO_SUCH_USER ; Not found --- get another user 113$: addl2 #2,r1 ; Incr to length of FROM fieldpE movw (r1)+,r2 ; Get length of FROM field...point to start of fieldb6 addl3 r2,r1,r3 ; R3 now points to one word past the ; end of FROM field1 addl2 #2,r3 ; Incr to get length of next fielde>; 3; locc #^x02,#100,(r3) ; Find end of SENT TO fielde/; BEQL 15$ ; Not found --- truncate subjecte1; addl2 #2,r1 ; Incr to length of SUBJECT fieldf4 movzwl (r3)+,r2 ; Get length of SUBJECT field and; point to start of field, cmpl r2,#23 ; Check for length > 23 chars' bleq 20$ ; Length is from 1 to 23...x915$: MOVL #23,R2 ; Here if truncate -- set length to 23rJ;** MATCHC TN_LEN,TESTNAME,#128,MAILREC+116 ; Look for beginning of SUBJ1;** ADDL2 #4,R3 ; Bump up to point to beginninga0;** LOCC #^X05,#23,(R3) ; Look for end of Subj:>20$: MOVC3 R2,(R3),OUTBUF+51 ; Move the Subj: string to OUTBUF;e2 $ASCTIM_S - ; Convert the date/time of the mail5 TIMBUF=DATE, - ; message to ASCII and put it in( TIMADR=MAILREC ; the output buffer3 MOVAB OUTBUF,R0 ; Move addr of OUTBUF for PUT_OUT * MOVZBL #74,R1 ; Move length for PUT_OUT) BSBW PUT_OUT ; Print the output buffero2 MOVAB CRLF,R0 ; Send a to the terminal MOVZBL #2,R1 ; .... BSBW PUT_OUT ; ....2 MOVC3 #74,BLANKS,OUTBUF ; Clear the output buffer& MOVB #1,R10 ; Set YES messages flag) BRW HERE ; Go get the next mail recordn;m5;******* Here if there are no messages from USERNAME;vNO_MESS:5 BLBS R10,STOP ; Is YES messages flag set? Yes, exit ! CLRL R10 ; Clear messages flagr/ MOVAB NO_MSSG,R0 ; Move mssg addr for PUT_OUTt/ MOVZBL #48,R1 ; Move mssg length for PUT_OUTf# BSBW PUT_OUT ; Print the messagec;tC;******* Here when all messages in the mail file have been checkeds; STOP:c. $CLOSE FAB=MAILFAB ; Close the MAIL.MAI file6 MOVC3 #30,BLANKS,TESTNAME ; Clear the TESTNAME buffer6 BSBW GOTO_PRMPT ; Send the cursor to the prompt line! CLRL R10 ; Clear messages flag4 BRW LOOP ; Go get next username (if there is one);_2;******* Here if TESTNAME was not found in SYSUAF;i NO_SUCH_USER:g+ $CLOSE FAB=SYSFAB ; Close the SYSUAF filet5 MOVAB NO_USER,R0 ; Move mssg addr to R0 for PUT_OUTr6 MOVZBL #48,R1 ; Move the message length for PUT_OUT# BSBW PUT_OUT ; Print the message6 BSBW GOTO_PRMPT ; Send the cursor to the prompt line" BRW LOOP ; Go get next username c;aD;******* Here if , ^Z, or ^C was entered at prompt for username;p8BYE: MOVAB CLEAR,R0 ; Move the ANSI escape sequence and3 MOVZBL #11,R1 ; length to reset the scrollingt0 BSBW PUT_OUT ; region and clear the screen $EXIT_S;t.;******* Here if there was an error somewhere;rERROR:* PUSHL R0 ; Push message code onto stack1 CALLS #1,G^LIB$SIGNAL ; Print the error message*4 MOVAB CLEAR,R0 ; Move the ANSI escape sequence and2 MOVZBL #7,R1 ; length to reset the scrolling BSBW PUT_OUT ; regionf $EXIT_S  ; Return to VMSo c.PAGE## .SUBTITLE PUT_HEADINGS subroutinebI;========================================================================g ;= =#;= Subroutine PUT_HEADINGS = ;= =!;= Functional description : =r ;= =8;= This routine prints the headings "From: ", "To: ", =;= "Date/Time", etc. = ;= =;= Parameters : =a ;= =;= None = ;= =;= Implicit inputs : =b ;= =7;= CRLF, OUTBUF, USERNAME, UN_LEN, TESTNAME, TN_LEN, =t;= BLANKS, CLR_END = ;= =;= Effects : = ;= =;= None = ;= =I;========================================================================a;n PUT_HEADINGS:g2 PUSHR #^M ; Save registers9 MOVAB CRLF,R0 ; Send a combination to the TT:p MOVZBL #2,R1 ; ..... BSBW PUT_OUT ; ..... BSBW PUT_OUT ; .....7 MOVAB OUTBUF,R6 ; Move addr of OUTBUF to R6 for FROM:p; MOVC3 #12,FROM,(R6) ; Move "From: " and underline ESC seq1( ADDB2 #12,R6 ; Bump up OUTBUF pointer9 MOVC3 UN_LEN,USERNAME,(R6) ; Move the username to OUTBUF* ADDB2 UN_LEN,R6 ; Bump up OUTBUF pointer9 MOVC3 #3,CLRATT,(R6) ; Move ESC exit underline sequence9 MOVC3 #14,TO,3(R6) ; Move "To: " and underline sequencen! ADDB2 #17,R6 ; Bump up pointerf5 MOVC3 TN_LEN,TESTNAME,(R6) ; Move testname to OUTBUF # ADDL2 TN_LEN,R6 ; Bump up pointerc9 MOVC3 #6,CLRATT,(R6) ; Move ESC exit underline sequenceh ADDB2 # 6,R6 ; Bump up pointer0 MOVAB OUTBUF,R0 ; Move OUTBUF addr for PUT_OUT/ SUBL3 #OUTBUF,R6,R1 ; Move length for PUT_OUTb BSBW PUT_OUT ; Print it2 MOVC3 #80,BLANKS,OUTBUF ; Clear the output buffer9 MOVAB CRLF,R0 ; Send a combination to the TT:l MOVZBL #2,R1 ; .....c BSBW PUT_OUT ; .....$ BSBW PUT_OUT ; .....,. MOVAB HEAD2,R0 ; Move HEAD2 addr for PUT_OUT) MOVZBL #83,R1 ; Move length to PUT_OUT* BSBW PUT_OUT ; Print it6 MOVAB CLR_END,R0 ; Move addr of ANSI erase to end of5 MOVZBL #3,R1 ; display and send to the terminaln BSBW PUT_OUTn4 POPR #^M ; Restore registers RSB ; Return to main a.PAGEn! .SUBTITLE GOTO_PRMPT subroutine;lI;======================================================================== ;= = ;= Subroutine GOTO_PRMPT = ;= =!;= Functional description : =r ;= =7;= Send the cursor to the prompt line -- the flow of =e2;= control falls through to subroutine PUT_OUT = ;= =I;========================================================================5;f GOTO_PRMPT:e# PUSHR #^M ; Save registers,= MOVAB PRMPT_LINE,R0 ; Move the ANSI escape sequence and its85 MOVZBL #6,R1 ; length that will send the cursor,5 BSBB PUT_OUT ; Send the cursor to the command line=% POPR #^M ; Restore registersn RSB ; to the prompt line .PAGE> .SUBTITLE PUT_OUT subroutine;nI;========================================================================, ;= =;= Subroutine PUT_OUT = ;= =!;= Functional description : =1 ;= =4;= Send the contents of a buffer to the terminal = ;= =;= Parameters : =i ;= =!;= Address of buffer in R0 = ;= Length of buffer in R1 = ;= =;= Effects : = ;= =;= None = ;= =I;========================================================================d;sPUT_OUT:1 PUSHR #^M ; Save the registers destroyed@ $QIOW_S CHAN=TTCHAN, - ; Send ASCII characters to the terminal+ FUNC=#IO$_WRITEVBLK, - ; ...Address in R0f P1=(R0), - ; ...Length in R1  P2=R1f% POPR #^M ; Restore registersf RSB .PAGEr .SUBTITLE SET_CTRLC subroutine;aI;========================================================================$ ;= =;= Subroutine SET_CTRLC =$ ;= =!;= Functional description : =a ;= =.;= This routine establishes a ^C handler. = ;= =;= Parameters : == ;= =;= None = ;= =;= Effects : = ;= =;= None = ;= =I;========================================================================.;r%SET_CTRLC: ; Enable the ^C handler 1 PUSHR #^M ; Save the registers destroyeds2 $QIOW_S CHAN=TTCHAN, - ; Enable a ^C AST handler$ FUNC=#IO$_SETMODE!IO$M_CTRLCAST, -# P1=C_AST ; The AST entry addresse% POPR #^M ; Restore registersb  RSB;eI;========================================================================n ;= =8;= CONTROL-C handling routine --- exit the program = ;= =I;======================================================================== ; -C_AST: .WORD 0 ; Entry mask -- save no regst% JMP BYE ; Jump to exit the program .END MAILRRR wwe not ready or not mounted/5dpe: .ascid /eltran error: device positioning error/3ext: .ascid /eltran error: acp file extend failed/Cdac: . J>C Mail_Message is designed to allow command procedures to findGC out how many unread VAXmail messages are left unread. It is designedr"C to be used as a foreign command.C:C M:=$SYS$VPWFILES:MAILMSGoCr@C The command format is M where is the>C User_name used for specifying the account file. For general9C use Mail_Message must either only be used by those withr;C SYSPRV or it must be installed so that it has read accesseC rights for SYSUAF.DA in rab - file not open/Eful: .ascid /eltran error: device full;cannot create or extend file/Ifac: .ascid /eltran error: operation not allowed; file may be read only/;nef: .ascid /eltran error: not positioned at end of file/fun_msg:.ascid / = function/#lun_msg:.ascid / = logical unit/ .end  wwp9wMc****************************************************************************0c***** DISABLING AND ENABLING CONTROL_Y ROUTINESMc****************************************************************************>C This subroutine disables control Y interrupts and enables a -c control Y attention AST for the terminal. c c WHERE: c>c ttchan: Channel number of terminal to disable control Y on.c (passed,integer*2)c2c routine: Routine to be executed upon CONTROL_Y.c (passed,integer*4).c MUST be EXTERNALed in the calling routine.c.c arg: An argument that is passed to ROUTINE.c (passed,integer*4)/c MUST be specified, but it does not have to "c be used by the AST routine.cc'c SUBROUTINES REQUIRED: SYSTEM SERVICEScc'c Written by: P.B.WISCHOW March 1986Mc****************************************************************************1 subroutine enable_ctrly_ast (ttchan,routine,arg) implicit integer*4(a-z) include '($IODEF)' include '($SYSSRVNAM)' include '($LIBCLIDEF)' integer*2 ttchan common /CTRL_MASK/ mask mask = LIB$M_CLI_CTRLY !7 status = LIB$DISABLE_CTRL(mask) ! Disable ^Y for CLI) set_ast = IO$_SETMODE .or. IO$M_CTRLYASTI status = SYS$QIOW (,%val(ttchan), %val(set_ast) ! Enable AST recognition& * ,,,,%ref(routine), arg,,,,) !1 if (.not. status) call LIB$STOP (%val(status)) ! return ! endMc****************************************************************************c***** CONTROL Y ENABLE Cc This routine is used to enable DCL CONTROL_Y's that were disabledc by ENABLE_CTRLY_AST.Mc************************************* *************************************** subroutine enable_ctrly  implicit integer*4(a-z) common /CTRL_MASK/ mask ! status = LIB$ENABLE_CTRL(mask)1 if (.not. status) call LIB$STOP (%val(status)) ! return endwwKc**************************************************************************4c FILESPECS Written by: P.B. Wischow August 1986c=c This routine parses a file specification into its component c parts.Kc*************************************** ***********************************< subroutine filespecs(*,filespec,node,device,root,dir,fname,' * type,vers,fullfilespec,flags) implicit integer*4(a-z) include '($RMSDEF)'4 include 'GRAVLIB$GENERAL:USER$FORSYSDEF($FSCNDEF)'< character*(*) filespec,node,device,root,dir,fname,type,vers character*1 fill character*31 specs(7) character*(*) fullfilespec& data zero/0/, fill/' '/, dest_len/31/ structure /ITEMLIST/ integer*2 length, code integer*4 address end s tructure record /ITEMLIST/ list(8)7 status = LIB$FIND_FILE(filespec,fullfilespec,zero,,,,) if (status.eq.RMS$_NORMAL) then list(1).code = FSCN$_NODE list(2).code = FSCN$_DEVICE list(3).code = FSCN$_ROOT" list(4).code = FSCN$_DIRECTORY list(5).code = FSCN$_NAME list(6).code = FSCN$_TYPE list(7).code = FSCN$_VERSION2 status = SYS$FILESCAN(fullfilespec,list,flags)0 if (.not.status) call LIB$STOP(%val(status)) do i=1,70 if (BTEST(flags,i-1 )) status = LIB$MOVC5( * %ref(list(i).length),! * %val(list(i).address), * %ref(fill), * %ref(dest_len), * %ref(specs(i)))3 if (.not.status) call LIB$STOP(%val(status)) end do else return1 ! File not found end if7 status = LIB$FIND_FILE_END(zero) ! Reset search node = specs(1) device = specs(2) root = specs(3) dir = specs(4) fname = specs(5) type = specs(6) vers = specs(7) return endww @t)\+ subroutine fill_string(string,char,length) integer*2 length character *(*) string character*1 char8 status = LIB$MOVC5 (0,0,%ref(char),length,%ref(string)) return endww>)D;******************************************************************* ;***** FLIP;*****:;***** AUTHOR and DATE: Maria Kalcic CODE 022 Fall 1984;*****?;***** DESCRIPTION: This routine flips characters within words:;***** for proper symbol plotting by Calcomp);***** on VAX-11 computers.;*****6;***** example call: call FLIP(in,nchars,out);*****;***** PARAMETERS:;*****-;***** in: Input array or character string.0;***** (passed,integer*2, or character string);*****6;***** nchars: Number of characters or bytes in "IN".;***** (passed,integer*2);*****.;***** out: Output array or character string.2;***** (returned,integer*2, or character string);*****D;******************************************************************* .title flip .psect dta,long,nowrt% .entry flip,^m movl 4(ap),r3 movl @8(ap),r2 movl 12(ap),r8 movl #1,r4 movl #0,r6labl: cmpl r4,r2 bgtr done movb (r3)[r6],r7 movb (r3)[r4],(r8)[r6] movb r7,(r8)[r4] addl2 #2,r6 addl2 #2,r4 brw labldone: ret .endww4Nc*****************************************************************************c***** GEOBATHc*****Kc***** This routine gives geoid height and bathymetry for a lat and lon.c*****7c***** Coordinates can be total minutes (360 or 180).+c***** Minutes can be absolute or signed.c*****Bc***** Assigns bath file DISK$USER:[SECRET.SHARED]geoid_bath.datc***** on unit 11.:c***** Returns real geoid height and integer bathymetry.c*****c*****<c***** To read a 5 deg x 5 deg array, put in calling prog:c*****c***** dimension barray(3712)c***** common/freda/barrayc*****Nc*****************************************************************************7 subroutine geobath(llatd,llatm,llond,llonm,geoid,bath) implicit integer*4 (a-z) integer*2 gee real geoid dimension barray(3712) character*50 fyl common/freda/barray data ones/'fff'x/6 data fyl/'DISK$SYSTEM:[SECRET.SHARED]GEOID_BATH.DAT'/ data stat/0/ if(stat.eq.0) then3 call ELTRAN(11,5,0,1,fyl,stat) !open bath file if(stat.ne.512) then: print*,'ELTRAN cannon open file: ',fyl, 'for BTY or UND' stop end if end if los=1 las=1# if(llatm.lt.0.or.llatd.lt.0)las=-1# if(llonm.lt.0.or.llond.lt.0)los=-12c change to 360 and round off lat,lon to nearest 57 llll=2.5+FLOAT((llond+(1-los)*180)*60+los*IABS(llonm)) lond=llll/60 lonm=llll-lond*60+ lala=2.5+FLOAT(IABS(llatd)*60+IABS(llatm))2 if(lala.gt.4797)then !check for beyond 79 55 geoid=0.0 bath =0 return end if latd=lala/60 latm=lala-latd*60 ld=lond-5*(lond/5) if(las.gt.0)then a=latd b=latd/5+M c=33409 !bypass 33408 neg-lat blocks d=latm/5 else a=80 b=(79-latd)/5 c=1 d=-latm/5-12*latd-1 end if2c 2088 blks/5 deg lat band, 29 blks/sq in lat band blkno=c+2088*b+29*(lond/5)7 base=a-5*b !=sq bottom(south) or deg incr (north)' ltline=12*base+d !lat line in sq addr=1+ltline*60+ld*12+lonm/5> if(blkno.ne.blknop)call ELTRAN(11,3,blkno,14848,barray,statr) gee=ibits(barray(addr),0,16) geoid=.01*FLOAT(gee)! bath = IBITS(barray(addr),16, 16) blknop=blkno return endww .title getdescr .psect dta,long,nowrt .entry getdescr,^m movab @4(ap),r3 movl #1,r2 movl (r3)[r2],r6 movl r6,@8(ap) ret  .endwwRr?c**************************************************************1c GETPID S. Lingsch 15 Aug 1984c c DESCRIPTION:c <c This routine utilizes VAX system services to obtain c the calling process's PID.c c PARAMETERS:=c pid: Current process's Process Identification Code. 0c (returned, integer*4)c .c SUBROUTINES REQUIRED: VAX System Services.c &c MODIFIED: P.B. Wischow 23 March 1987)c Replaced EQUIVALENCE with STRUCTURE's.c?c************************************************************** subroutine getpid(pid) implicit integer*4 (a-z) include '($SSDEF)' include '($JPIDEF)' structure /JPIDEF/ integer*2 buflen, itemcode integer*4 bufadr, retadr end structure record /JPIDEF/ list(2) list(1).buflen = 4 list(1).itemcode = JPI$_PID list(1).bufadr = %LOC(pid)! status = SYS$GETJPIW(,,,list,,,) if (status .eq. SS$_NOPRIV) G 1 print*,' %GETPID-W-NOPRIV No privilege for attempted operation' return endww ;8Mc****************************************************************************IC GET_CURSOR This routine uses a QIO to get the current cursor position.CBC call GET_CURSOR (row,column) Where row and column are integer*2.C#c Written by: Perry Bret Wischow c 2-Apr-1987cMc****************************************************************************# subroutine get_cursor (row,column) implicit integer*2 (a-z)E include '($SYSSRVNAM)' ! System service definitions include '($TT2DEF)' include '($TRMDEF)'* include '($IODEF)' ! I/O function codes character*4 ask character*8 ans data ask(1:1)/27/ data ask(2:4)/'[6n'/, integer*4 LIB$STOP, LIB$GET_SYMBOL, status,! 1 LIB$DO_COMMAND, readfunc$ common /TERMINAL/ ttchan, iterminal structure /QIOLIST/ integer*2 len, code integer*4 address,ret_addr end structure structure /IOSB/ integer*2 status,offset( byte terminator,dummy,termlen,curpos end structure+ record /QIOLIST/ func_list(3), /IOSB/ iosb$ . if (ttchan.eq.0) call GET_TERMTYPE(iterminal) if (iterminal .lt. 110) return+ if (pass.eq.0) then ! E xecute only once. pass = 1& func_list(1).code = TRM$_MODIFIERS2 func_list(1).address = TRM$M_TM_NORECALL .or. + 1 TRM$M_TM_ESCAPE .or. TRM$M_TM_PURGE func_list(1).len = 00 func_list(1).ret_addr = 0 9 func_list(2).code = TRM$_PROMPT ! Send communications1 func_list(2).address = %LOC(ask) ! inquiry func_list(2).len = LEN(ask) func_list(2).ret_addr = 0/ func_list(3).code = TRM$_TIMEOUT ! Timeout 4 func_list(3).address = 1 ! after 0-1 seconds func_list(3).len = 0 func_list(3).ret_addr = 0- read_func = IO$_READVBLK .or. IO$M_EXTEND listlen = 36* end if +10 status = SYS$QIOW (, ! Event flag* 1 %val(ttchan), ! Assigned channel, 2 %val(read_func), ! Function code(s)/ 3 iosb,,, ! I/O status, ast, astparam$ 4 %ref(ans), ! Data read* 5 %val(8), ! Data read buffer size 6 , ! Access mode 7 ,  ! Not used7 8 %ref(func_list), ! Address of item list buffer1 9 %val(listlen)) ! Item list buffer size@ if (status .eq. SS$_TIMEOUT) goto 10 ! If timed out try again- if (.not.status) call LIB$STOP(%val(status)) s = INDEX(ans,'[') + 1 e = INDEX(ans,';') - 1 read (ans(s:e),7000) row7000 format(i2) s = e + 2 e = INDEX(ans,'R') - 1 read (ans(s:e),7000) column return endwwD Jc*************************************************************************c* GET_ELEMENTc**c* Returns elements of a delimited string.c**c* Written by P.B.Wischow 16 July 1986c*Jc*************************************************************************; subroutine get_element(*,element,string,delimiter,context) implicit integer*2(a-z) character*(*) element, string character*1 delimiter+ if (context.eq.0) then ! First pass thru s = 1# call STRING_LENGTH(string,slen)+ delim = INDEX(string(1:slen),delimiter)  if (delim.eq.0) then ; e = slen ! Only one element else@ e = delim - 1 ! More than one element) end if  else. if (e.eq.slen) return1 ! No more elements( s = e + 2 ! Find start of element+ delim = INDEX(string(s:slen),delimiter)> if (delim.eq.0) then ! Find end of element e = slen else e = e + delim end if end if. context = context + 1 ! Total # of elements* element = string(s:e) ! Get the element return endww`؂ُ .title get_ownerL;***************************************************************************5; GET_OWNER written by: P.B. Wischow (9 March 1987);6; Returns the owner of the specified file as a string.;/; FORTRAN call: call GET_OWNER(filename,owner); ; Where: #; filename: Name of file to lookup.; (passed, character*(*)); owner: Owner of file.; (returned, character*12);L;***************************************************************************& .psect get_owner_data,wrt,noexe,long $RMSDEF desc: .blkq 1 addr: .blkl 1size: .blkl 1 uic: .blkl 1 owner_desc: .long 255 .address owner%owner: .blkb 255 olen: .blkb 1context:.blkl 1+ .align long ; Align on longword boundary:infab: $FAB xab=xabblk ; Get allocate, date, time infoxabblk: $XABPRO( .psect get_owner_code,exe,rd,nowrt,long  .entry GET_OWNER, ^M6 moval @8(ap), r8 ; Get address of desciptor of owner0 movq @4(ap), desc ; Get desciptor of filename, movzwl desc, size ; Get length of filename. movl desc+4, addr ; Get address of filename+ $FAB_STORE fab=infab, fna=@addr, fns=size $OPEN fab=infab blbc r0,return ; Error ??? moval xabblk,r5 + movl xab$l_uic(r5),uic ; Get the UIC. $IDTOASC_S id=uic, - ; Convert UIC to string namlen=olen, - nambuf=(r8) - contxt=contex!t $FINISH_RDB_S contxt=context $CLOSE fab=infab RETURN: ret .end ww`x$ subroutine get_speed(rspeed,tspeed) implicit integer*2(a-z) include '($SYSSRVNAM)' include '($TTDEF)' include '($IODEF)' common /TERMINAL/ ttchan byte iosb(8) integer*4 status, char(3) dimension speeds(2,16) data sensemode /IO$_SENSEMODE/% data speeds /TT$C_BAUD_50, 50, * TT$C_BAUD_75, 75, * TT$C_BAUD_110, 110, * TT$C_BAUD_134", 134, * TT$C_BAUD_150, 150, * TT$C_BAUD_300, 300, * TT$C_BAUD_600, 600, * TT$C_BAUD_1200, 1200, * TT$C_BAUD_1800, 1800, * TT$C_BAUD_2000, 2000, * TT$C_BAUD_2400, 2400, * TT$C_BAUD_3600, 3600, * TT$C_BAUD_4800, 4800, * TT$C_BAUD_7200, 7200, * TT$C_BAUD_9600, 9600,' * TT$C_BAUD_19200, 19200/ ; if (ttchan.eq.0) status = SYS$ASSIGN('SYS$INPUT',tt#chan,,)LC***** Find The Current Terminal Characteristics (Only care about IOSB)*****2 status = SYS$QIOW (,%val(ttchan), %val(sensemode)- * ,iosb,,,char,%val(12),,,,)> if (.not. status) call LIB$STOP (%val(status)) ! Die if fails do i=1,16? if (iosb(3).eq.speeds(1,i)) tspeed = speeds(2,i) ! Transmit? if (iosb(4).eq.speeds(1,i)) rspeed = speeds(2,i) ! Receive end do return endww:Mc*********************************************************$*******************JC GET_TERMTYPE Return the code showing the type of terminal currently=C in use for SYS$INPUT. If SYS$INPUT is part of a batch:C stream, a command procedure or not a terminal then Ic TERMTYPE equals -1. This also sets the terminal type1c in the TERMINAL common block.CC call GET_TERMTYPE (termtype)CC Where termtype is I*2.CC Written by: James G. DownwardC 12-Nov-19825c Modified by: Perry Bre%t Wischow Update for GRADS.c 28-JAN-1986c1c Perry Bret Wischow Include tests for VT240's.0c 20-JUN-1986 (if VT240, then termtype = 120)cMc****************************************************************************" subroutine get_termtype(termtype) implicit integer*4 (a-z) include '($SYSSRVNAM)'* include '($DCDEF)' ! device class codes* include '($DVIDEF)' ! device type codes* include '($IODEF)' ! I/O function codes integer*2 termtype* integer*4 length, type,& termclass, status integer*4 readfunc, iosb(2) character*1 esc character*4 ask character*10 ans data ask(1:1)/27/ data ask(2:4)/'[>c'/$ common /TERMINAL/ ttchan, iterminal structure /GETDVI_BLOCK/ integer*2 length, code integer*4 bufadr, ret_len end structure" record /GETDVI_BLOCK/ dvi_list(3)c if (ttchan.eq.0) then.c status = SYS$ASSIGN('SYS$INPUT',ttchan,,)1c if (.not.status) call LIB$STOP(%val(status))c end if, status = SYS$ASSIGN('SYS$INPUT',ttc'han,,)- if (.not.status) call LIB$STOP(%val(status)); dvi_list(1).code = DVI$_DEVCLASS .or. DVI$C_SECONDARY  dvi_list(1).length = 4% dvi_list(1).bufadr = %loc(termclass)! dvi_list(2).code = DVI$_DEVTYPE  dvi_list(2).length = 4 dvi_list(2).bufadr = %loc(type)1 status = SYS$GETDVI(,%val(ttchan),,dvi_list,,,,) termtype = type if (.not.status) then : type *,'%GET_TERMTYPE-F-GETDVIERR SYS$GETDVI failed' call EXIT end if if (termclass.ne.DC$_TERM) then5 term(type = -1 ! Input device is not a terminal! else if (termtype.ge.110) then9 readfunc = IO$_READPROMPT .or. IO$M_TIMED .or. 5 * IO$M_ESCAPE .or. IO$M_PURGE .or. IO$M_NOECHOP10 status = SYS$QIOW (, ! Event flag P 1 %val(ttchan), ! Assigned channel P 2 %val(readfunc), ! Function code(s) P 3 iosb,,, ! I/O status), ast, astparam P 4 %ref(ans), ! Data read P 5 %val(10), ! Data read buffer size H 6 %val(2), ! Timeout after 1 secondF 7 , ! Read terminator maskP 8 %ref(ask), ! Address of item list buffer P 9 %val(4)) ! Item list buffer size ( if (st*atus .eq. SS$_TIMEOUT) goto 100 if (.not.status) call LIB$STOP(%val(status))> if (ans(4:4).eq.'2') termtype = 120 ! VT240 !!! end if iterminal = termtype return endww໻塖Kc**************************************************************************DC GET_USERINFO Subroutine to return current process information.C'C FORTRAN call: call GET_USERINFOcC1C You MUST include the following common block:,c common /USERINFO/ user_name, +process_namec3c If you need the lengths of the data include the c following common block:c2c common /USERINFO_LENGTHS/ name_len, process_lenccc WHERE: C user_name: User name string.c (returned,character*12)c-c process_name: Name of the current process.c (returned,character*15)cc 4c All of the returned string lengths are INTEGER*2.ccKc************************************************************************** subroutine get_userinfo implici,t integer*2(a-z) include '($JPIDEF)' include '($SYSSRVNAM)' character*12 user_name character*15 process_name integer*4 status, STR$TRIM* common /USERINFO/ user_name, process_name0 common /USERINFO_LENGTHS/ name_len, process_len structure /GETJPI_BLOCK/$ integer*2 buflen/4/, itemcode/0/ integer*4 bufadr, retlen/0/ end structure; record /GETJPI_BLOCK/ list(3) ! length of itemlist is the ! number of items + 1 . list(1).itemcode = JPI$_USERNAME ! user name - list(1).buflen = LEN(user_name)! list(1).bufadr = %loc(user_name) list(1).retlen = %loc(name_len)/ list(2).itemcode = JPI$_PRCNAM ! process name# list(2).buflen = LEN(process_name)$ list(2).bufadr = %loc(process_name)# list(2).retlen = %loc(process_len) status = SYS$GETJPI(,,,list,,,)- if (.not.status) call LIB$STOP(%val(status))0 status = STR$TRIM(user_name,user_name,name_len) return endww ) Xp:C Get_USERNAME Subroutine to return the USERNAME of the .C current process.C'C CALL Get_USERNAME(Cuser_Name,Ilength)C Where:.C Cuser_Name Character*12 User name string,C Ilength I*4 Length of name stringCC Written by: James G. DownwardC KMS Fusion, Inc.C P.O. Box 1567C Ann Arbor, Mich 48104C (313)-769-8500CC C-C, SUBROUTINE Get_USERNAME(Cuser_Name,Ilength) implicit integer*2(a-z) CHARACTER*12 Cuser_name !? INTEGER*2 JPI_Code,JPI_Length,JPI_Header(2) ! For GETJPI setup INTEGER*4 LIST(3)/ !% INTEGER*4 Istatus,ilength,SYS$GETJPI' EQUIVALENCE (JPI_Header(1),JPI_Length)% EQUIVALENCE (JPI_Header(2),JPI_Code)$ EQUIVALENCE (JPI_Header(1),LIST(1))C2C -- Find out the User_Name of the current processC$ JPI_Code = '202'X ! Get USERNAME# JPI_Length = 12 ! 4 bytes long. LIST (2) = %LOC(Cuser_name) ! Set up GETJPI2 LIST (3) = %LOC(Ilength) ! Length of name strng# ISTATUS=SYS$GETJPI(,,,LIST,,,) !4 Ilength=INDEX(Cuser_Name,' ')-1 ! get end of name END0ww⦃Q" FUNCTION IFID( SD, IOVER ) IMPLICIT INTEGER ( A - Z )C+C VAX INTEGER FROM UNIVAC INTEGER DOUBLETC<C THE FUNCTION IFID CONVERTS A UNIVAC ONE'S COMPLIMENT4C INTEGER TO A VAX TWO'S COMPLIMENT INTEGER. 9C THE FUNCTION EXPECTS THE FIRST 18 BITS (LOWER END>C OF THE WORD) IN THE FIRST 18 BITS OF SH(2,1) AND:C THE HIGHER END OF THE WORD IN THE FIRST 18 BITS OFC SH(1,1)9C WHERE SH IS TYPED I*4 1AND DIMENSIONED (2,1)$C IN THE CALLING ROUTINE( DIMENSION SD(2) ! SPLIT DOUBLET=C REPRESENTING UNIVAC INTEGERS  LOGICAL ISBC DATA M18 /O00000777777/ ! MASK OF LOW ORDER 18 BITS ON! PARAMETER M18 = 2 ** 18 - 1BC DATA M12 /O00000017777/ ! MASK OF LOW ORDER 13 BITS ON"C PARAMETER M13 = 2 ** 13 - 1BC DATA IVMAX /O17777777777/ ! MAXIMUM VAX POSITIVE INTEGER- PARAMETER IVMAX = 2 * (2 ** 30 - 1) 2+ 1EC DATA MIOVER /O00000360000/ ! MASK FOR INTEGER OVERFLOW CHECK) PARAMETER MIOVER = 15 * ( 2 ** 13 )CC DATA MSIGNB /O00000400000/ ! MASK FOR SIGN BIT, BIT 17 ON  PARAMETER MSIGNB = 2**17  IOVER = 0  IFID = SD(2) HH = SD(1) IS = .FALSE. / IF ( (HH .AND. MSIGNB) .NE. 0 ) THEN * IS = .TRUE. ! NOTE SIGN BIT* IFID = (.NOT. IFID) .AND. M18 HH = .NOT. HH END I3F0 IF ( (HH .AND. MIOVER ) .EQ. 0) THEN, IFID = JISHFT( HH, 18) .OR. IFID ELSE IOVER = 1 IFID = IVMAX END IF! IF ( IS ) IFID = - IFID RETURN ENDww .title jbcshell .ident /v1/;++E; This module provides a shell to the $SNDJBC system service for with,; two entry points LIB_PRINT and LIB_SUBMIT.;; Author Eric Wentz 27-Nov-1985;%; Modified: P. B. Wischow 26-M4ar-1987!; Drop the "GE_" from the names.;;-- $SJCDEF ; $SNDJBC definitions;++P;=============================================================================== ; LIB_PRINT;; Calling sequence:;C; status = LIB_PRINT(file,queue [,notify] [,copies] [,delete_flag]);; Where:; status status of call-; file name of the file passed by descriptor+; notify .TRUE. if user should be notified; passed by reference/; queue name of the queue passed by descriptor:; co5pies number of copies passed by reference (default=1)5; delete_flag true (odd) if the file is to be deleted); passed by reference (default = false)P;===============================================================================;--;++; Define AP offsets;-- FILE = 4 QUEUE = 8 NOTIFY = 12$ COPIES = 16 ; Unique for LIB_PRINT DELETE = 20 ; " ";; AP offsets for LIB_SUBMIT.; Note that FILE and QUEUE are used from above; LOG_QUEUE= 16 KEEP = 20 AFTER = 264 LOG_FILE= 28 0 .PSECT LIB_PRINT_CODE RD,SHR,NOWRT,EXE,PIC,LONG .ENTRY LIB_PRINT ^M, CLRL -(SP) ; Set end of list on the stack;7; Create an item list entry with the file specification;- SUBL #12, SP ; Allocate an item list entry( CLRL 8(SP) ; Clear the return address/ MOVQ @FILE(AP),(SP) ; Load up file descriptor8 MOVW #SJC$_FILE_SPECIFICATION,2(SP) ; And the item type;/; Create an item list entry with the queue name;. SUBL #12, SP ; Grab a7nother item list entry( CLRL 8(SP) ; Clear the return address1 MOVQ @QUEUE(AP),(SP) ; Get the queue descriptor, MOVW #SJC$_QUEUE,2(SP) ; Load the item type; ; See if they specified "NOTIFY";" CMPW #2, (AP) ; Argument there ?* BGEQ 30$ ; Branch if only two arguments+ MOVL NOTIFY(AP), R0 ; Get address of flag BEQL 30$ ; Branch if null ptr& BLBC (R0), 30$ ; Branch if no notify" SUBL #12, SP ; Allocate an item( CLRL 8(SP) ; Clear the return address* CLRQ (SP) ; Clear t8he rest of the block* MOVW #SJC$_NOTIFY,2(SP) ; Set notify flag;,; If requested, specify the number of copies;)30$: CMPW #3, (AP) ; Copies specified ?, BGEQ 40$ ; Branch if only three arguments& MOVL COPIES(AP), R0 ; Null pointer ? BEQL 40$ ; Branch if null" SUBL #12, SP ; Get another item! CLRL 8(SP) ; Clear the address& MOVW #4, (SP) ; Length of a longword) MOVW #SJC$_FILE_COPIES, 2(SP); Item type- MOVL R0,4(SP) ; Address of number of copies;;; Finally, specify9 whether or not we should delete the file; after printing;+40$: CMPW #4, (AP) ; Delete flag specified& BGEQ 90$ ; Branch if only four args% MOVL DELETE(AP),R0 ; Null pointer ?$ BEQL 90$ ; Branch if null pointer& BLBC (R0), 90$ ; Branch if no delete;H; Here, we should specify that the file should be deleted after printing; SUBL #12, SP ; Item space$ CLRL 8(SP) ; Clear return address( CLRQ (SP) ; Clear the 1st 2 longwords3 MOVW #SJC$_DELETE_FILE,2(SP) ; Set the dele:te item;&; Ready to queue the file for printing;*90$: MOVL SP, R1 ; Get item list pointer& SUBL #8, SP ; Make room for an IOSB* MOVL SP, R2 ; R2 now points to the IOSB4 $SNDJBCW_S FUNC = QFILE,- ; Call the system service ITMLST = (R1),- ; IOSB = (R2) ;1 BLBC R0, 100$ ; Branch on system service errors$ MOVL (SP), R0 ; Return IOSB status+100$: RET ; Return with status to caller5QFILE: .LONG SJC$_ENTER_FILE ; $SNDJBC function code;++P;=========================;====================================================== ; LIB_SUBMIT;; Calling sequence:;;D; status = LIB_SUBMIT(file,queue [,notify] [,log_queue] [,keep_flag]; [,time_after] [,log_file]);; Where:#; status status returned from call-; file name of the file passed by descriptor/; queue name of the queue passed by descriptor/; notify .TRUE. if the user should be notified; passed by reference>; log_queue name of the queue to print the log file (if req'd); pass<ed by descriptor@; keep_flag .TRUE. if log file is to be kept passed by reference4; after_time time to start the job after 64 bit time; passed by reference0; log_file name of log file passed by descriptorP;===============================================================================;-- .ENTRY LIB_SUBMIT ^M, CLRL -(SP) ; Set end of list on the stack;7; Create an item list entry with the file specification;- SUBL #12, SP ; Allocate an item list entry( CLRL 8(SP) = ; Clear the return address/ MOVQ @FILE(AP),(SP) ; Load up file descriptor8 MOVW #SJC$_FILE_SPECIFICATION,2(SP) ; And the item type;/; Create an item list entry with the queue name;. SUBL #12, SP ; Grab another item list entry( CLRL 8(SP) ; Clear the return address1 MOVQ @QUEUE(AP),(SP) ; Get the queue descriptor, MOVW #SJC$_QUEUE,2(SP) ; Load the item type;'; See if they specified the NOTIFY flag; CMPW #2, (AP) ; Test arg count BGEQ 10$ ; Branch if only two+ MOV>L NOTIFY(AP), R0 ; Get address of flag BEQL 10$ ; Branch on null ptr& BLBC (R0), 10$ ; Branch on no notify SUBL #12, SP ; Allocate space$ CLRL 8(SP) ; Clear return address* CLRQ (SP) ; Clear the other 2 longwords. MOVW #SJC$_NOTIFY,2(SP) ; Set the notify flag;=; See if they have specified a queue to print the log file on;'10$: SUBL #12, SP ; Get an item entry( CLRL 8(SP) ; Clear the return address# CMPW #3, (AP) ; Three arguments ?# BGEQ 20$ ; Branch if no print?ing;; Set up to print the log file;0 MOVL LOG_QUEUE(AP), R0 ; Get descriptor pointer# BEQL 20$ ; Branch if no printing, MOVQ (R0), (SP) ; Get the queue descriptor0 MOVW #SJC$_LOG_QUEUE, 2(SP) ; Set the item type! BRB 30$ ; Skip the other stuff;; Set up for no printing;.20$: CLRQ (SP) ; Clear the first 2 longwords6 MOVW #SJC$_NO_LOG_SPOOL, 2(SP) ; Set the noprint flag;5; Ok, now let's see if they want to keep the log file;%30$: CMPW #4, (AP) ; Three arguments@+ BGEQ 40$ ; Branch if less than four args6 MOVL KEEP(AP), R0 ; Get the pointer to the keep flag$ BEQL 40$ ; Branch if null pointer( SUBL #12, SP ; Get an item list block( CLRL 8(SP) ; Clear the return address( CLRQ (SP) ; And the rest of the block7 BLBC (R0), 35$ ; Branch if they don't want to keep it. MOVW #SJC$_NO_LOG_DELETE,2(SP) ; Set the flag BRB 40$735$: MOVW #SJC$_LOG_DELETE, 2(SP) ; Set the delete flag;6; See if they specify the time to submit the job after;(A40$: CMPW #5, (AP) ; Test for five args+ BGEQ 50$ ; Branch if less than five args2 MOVL AFTER(AP), R0 ; Get the pointer to the time( BEQL 50$ ; Skip if its a null pointer! SUBL #12, SP ; Item list block# CLRL 8(SP) ; Clear return length& MOVW #8, (SP) ; Length of a quadword( MOVW #SJC$_AFTER_TIME,2(SP) ; Item type+ MOVL R0, 4(SP) ; Pointer to quadword time;?; Finally see if they explicitly specify the name of a log file;'50$: CMPW #6, (AP) ; Test for six args* BGEQ B90$ ; Branch if less than six args2 MOVL LOG_FILE(AP), R0 ; Get address of descriptor$ BEQL 90$ ; Branch if null pointer! SUBL #12, SP ; Get a list item( CLRL 8(SP) ; Clear the return address. MOVQ (R0), (SP) ; Get the log file name desc8 MOVW #SJC$_LOG_SPECIFICATION, 2(SP) ; Set the item type;9; Finally ready to submit the file to the batch processor;*90$: MOVL SP, R1 ; Get item list pointer& SUBL #8, SP ; Make room for an IOSB* MOVL SP, R2 ; R2 now points to the IOSB C4 $SNDJBCW_S FUNC = QFILE,- ; Call the system service ITMLST = (R1),- ; IOSB = (R2) ;1 BLBC R0, 100$ ; Branch on system service errors$ MOVL (SP), R0 ; Return IOSB status+100$: RET ; Return with status to caller .ENDwwٸa@c***************************************************************9c***** Subroutine JOBMODE operates basically the same way<c***** that subroutine JOBTYP does. The main differences<c***** are that JOBMODE utilizes the VAX Run Time L Dibrary=c***** routines as opposed to JOBTYP's usage of VAX System;c***** Services and that JOBMODE returns an 11-character>c***** string of BATCH, NETWORK, or INTERACTIVE rather thanc***** a logical value. 3c***** Written 6/24/85 by E. S. Gremillion.@c***************************************************************" subroutine jobmode(string)) integer*4 itmcd,status,lib$getjpi integer*2 ilength character*11 string include '($LEIBDEF)' include '($JPIDEF)'/ status = LIB$GETJPI(%ref(jpi$_mode),,,,9 1 %descr(string),%ref(ilength)) return endww`(a:c*********************************************************2c***** Subroutine JOBTYP is the VAX version of the3c***** UNIVAC subroutine with the same name. It4c***** utilizes the VAX System Service SYS$GETJPI5c***** and returns the logical value true or false4c***** depending on wheFther the job being run is c***** demand. 3c***** Written 6/24/85 by E. S. Gremillion.:c*********************************************************! subroutine jobtyp(demand)3 integer*4 itmlst(4),iproc,status,sys$getjpi integer*2 stuff(2) logical demand( equivalence (itmlst(1),stuff(1)) include '($JPIDEF)/list' stuff(1)=4 stuff(2)=JPI$_MODE itmlst(2)=%loc(iproc) itmlst(3)=%loc(ilength) itmlst(4)=0' G status=SYS$GETJPI(,,,itmlst,,,)' if (iproc.eq.3) demand=.true. return endww@+0PC*******************************************************************************+C**** SUBROUTINE JULMIN (ASCII):C*****AUTHOR--SAUNDRA S. PETTYJOHN--CODE 2211--AUGUST 1970C*****=C*****PURPOSE--THIS SUBROUTINE CONVERTS JULIAN DAY, HOURS AND=C*****MINUTES TO JULIAN MINUTES WHEN HOURS AND MINUTES ARE INC*****SEPARATE WORDS9C***** REWRITTEN AND UPDA HTED BY P.B.WISCHOW AUGUST 1982C*****C***** ARGUMENTS--+C***** DAY--JULIAN DAY TO BE CONVERTED (IN)%C***** HR--HOURS TO BE CONVERTED (IN)(C***** MIN--MINUTES TO BE CONVERTED (IN)!C***** JMIN--JULIAN MINUTES (OUT)C**** ENTRY POINTS--"C**** ENTRY JLMIN1(DAY,HRMIN,JMIN)CC**** PURPOSE--THIS ENTRY IS USED WHEN HOURS AND MUNUTES ARE IN THEC**** SAME WORD.3C***** HRMIN--HOURS AND MINUTES TO BE CONVERTED(IN)PC***************************************************************************I****( SUBROUTINE JULMIN(DAY,HR,MIN,JMIN) IMPLICIT INTEGER(A-Z) TEMP1=IABS(HR) TEMP2=IABS(MIN) GO TO 3" ENTRY JLMIN1(DAY,HRMIN,JMIN) TEMP1 = HRMIN/100 TEMP2 = MOD(HRMIN,100)@C*****CONVERTING JULIAN DAY, HOURS AND MINUTES TO JULIAN MINUTES3 DAY=IABS(DAY)( JMIN=(DAY-1)*1440+TEMP1*60+TEMP2+1 RETURN ENDwwΔ=c************************************************************ c***** JULSECc*****.c*****J Written by P.B.Wischow 20 June 1984c*****6c***** DESCRIPTION: This routine has two entry points. c***** :c***** JULSEC: converts day,hours,minutes,seconds to %c***** julian seconds.c*****@c***** SECJUL: converts julian seconds to day,hours,minutes#c***** and seconds.c*****c***** PARAMETERS:c*****c***** entry point JULSEC:c*****2c***** day: Julian day (passed,integer*4)7c***** hour: Two digit hour (passed,int Keger*4)=c***** minutes: Two digit minutes (passed,integer*4)=c***** seconds: Two digit seconds (passed,integer*4)9c***** time: Julian seconds (returned,integer*4)c*****c*****c***** entry point SECJUL:c*****7c***** time: Julian seconds (passed,integer*4)4c***** day: Julian day (returned,integer*4)9c***** hour: Two digit hour (returned,integer*4)?c***** minutes: Two digit minutes (returned,integer*4)?c***** L seconds: Two digit seconds (returned,integer*4)c*****!c***** SUBROUTINES REQUIRED: nonec*****=c************************************************************1 subroutine julsec(day,hours,mins,secs,time) implicit integer(a-z)0 time=(day-1)*86400+hours*3600+mins*60+secs return, entry secjul(time,day,hours,mins,secs) c***** 1440*60=86400 ***** day=time/86400 tday=day*86400 day=day+1 hours=(time-tday)/3600 thours=hours*3M600 mins=(time-tday-thours)/60# secs=time-tday-thours-mins*60 return endwwࡲ;C SUBROUTINE LANDMASK READS DATA FROM THE FILE,LANDMASK.DATEC AND RETURNS A VALUE OF 1 OR 0 DEPENDING ON WHETHER THE WHETHER THE .C DATA IN THE SPECIFIED AREA IS LAND OR WATER.C THE INPUT PARAMETERS ARE:$C DLATD = DEGREE LATITUDE REQUESTED$C DLATM = MINUTE LATITUDE REQUESTED%C DLOND = DEGREE LONGITUDE REQUESTED%C LONM = MINUTE LONGITUDE REQUESTEDC THE NOUTPUT PARAMETER IS:0C IMASK = AN INTEGER WITH THE VALUE OF 1 IF THE/C REQUESTED RECORD IS LAND OR 0 IF THE$C REQUESTED RECORD IS WATER4C SUBROUTINE LANDMASK WAS WRITTEN BY J. HAMMACK AND 4C E. GREMILLION, NAVOCEANO, CODE 8321. THE LANDMASK<C DATA FILE WAS BASED ON WORK DONE BY MIKE CARRON, CODE 022.1 SUBROUTINE LANDMASK(DLATD,DLATM,DLOND,LONM,MASK) IMPLICIT INTEGER (A-Z) DIMENSION OUT(5) LATD=DLATD LATM=DLATM LOND=DLOND IF (PQASS.EQ.0)THEN5 OPEN (UNIT=10,FILE='GRAVLIB$GENERAL:LANDMASK.DAT',/ 1 ACCESS='DIRECT',FORM='UNFORMATTED',RECL=5,( 2 MAXREC=52200,STATUS='OLD',READONLY) END IF PASS=1" IF (LATD.LE.0.AND.LATM.LT.0) THEN LATD = LATD - 1 LATM = ABS(LATM) END IF  " IF (DLOND.LT.0) LOND = DLOND +360$ RECORD = (LATD + 72)*360 + LOND + 1+ IF (RECORD.NE.OLDREC) READ (10'RECORD) OUT OLDREC=RECORD K = (LATM/5)*12 + (LONM/5) MASK = IBITS(OUT(1),K,1)P RETURN ENDwwXp( subroutine lshift_string(string,length) implicit integer*2(a-z) character *(*) string, integer*4 nonblank,status,LIB$SKPC,STR$TRIM : nonblank=LIB$SKPC(' ',string) ! find first non-blank char if (nonblank.ne.0) then length=LEN(string) pntr=1 do i=nonblank,length$ string(pntr:pntr)=string(i:i) pntr=pntr+1 end do do j=pntr,length string(j:j)=' ' end do) status=STR$TRIM(string,string,length) eQnd if return endww`>C Mail_Message is designed to allow command procedures to findGC out how many unread VAXmail messages are left unread. It is designed"C to be used as a foreign command.CC M:=$SYS$VPWFILES:MAILMSGC@C The command format is M where is the>C User_name used for specifying the account file. For general9C use Mail_Message must either only be used by those with;C SYSPRV or it must be installed so that it has read accR } .TITLE UOPEN_PRINTO .IDENT /A5.V01/; I;========================================================================R; UOPEN_PRINT.MARdI;========================================================================_;E; Copyright (C) 1983a;m*; EVANS & SUTHERLAND COMPUTER CORPORATION;i4; May not be reproduced in whole or in part without3; the prior written consent of Evans & Sutherland.);I; E&S PART 908076-061 NC;e2; VERSION DATE MODIFIED BY REASON FOR CHSANGE5; ------- --------- --------------- ----------------- 0; A1.V00 24-OCT-80 B. BRIMLEY INITIAL VERSION.;15; A3.V01 25-Feb-82 R.Best A3 Release.N;s,; A4.V01 29-Jun-83 S.Morgan A4 Release.;.,; A5.V01 19-Feb-85 S.Morgan A5 Release.;dD; GRADS 25-Jun-86 J.Hammack Changed to submit to print"; instead of batch. Entry is"; now UOPEN_PRINT instead of; uopen.I;=======================================================================T=t; 5; THIS FILE CONTAINS THE FOLLOWING PROGRAM SEGMENTS: ;.A; UOPEN_PRINT SUBROUTINE USED TO OPEN A FILE WITH THE SPOOL TOn; BATCH QUEUE OPTION SET. ;rL;==========================================================================\;sQ; THE SUBROUTINE UOPEN_PRINT IS USED TO OPEN A FILE WITH THE SPOOL TO PRINT QUEUE ; OPTION SET.L;T; FORTRAN CALLING SEQUENCE:i;d ; OPEN ( USEROPEN=UOPEN_PRINT );eM;---------------------------------------------------------------------------- e* $FABDEF ; DEFINE ALL FAB BITS & OFFSETS .ENTRY UOPEN_PRINT, ^M<>e# MOVL 4(AP),R0 ; GET ADDRESS OF FABA INSV #1,#FAB$V_SPL,#1,FAB$L_FOP(R0) ; SET SUBMIT TO PRINT OPTION28 INSV #1,#FAB$V_DLT,#1,FAB$L_FOP(R0) ; SET DELETE OPTION# $CREATE FAB = @4(AP) ; CREATE FILE  BLBC R0,10$ ; BRANCH IF ERRORm/ $CONNECT RAB = @8(AP) ; CONNECT STREAM TO FILEL7 10$: RET ; RETURN WITH R0 SET TO SUCCESS OR FAILURE.S .END ww.DAT', ! The Mail File/ - STATUS='OLD', ! is anV`Խ PROGRAM VAXUSERS   C FACILITY: VPWC,AC ABSTRACT: This module will give a Yes/No answer whenn;C querried as to if a user exist in the System UAF.P-C To make this querry, the command is C $VAXUSERS usernamek;C The answer is passed as exit status. 1=Yes, 3=No.<C If a user(s) is found, he/she/they will be listed.@C If unsure of the spelling of a user's name, a trailing<C wildcard is alloweWd and all users having the first4C letters (up to the '*') will be displayed.=C To see who all users are, enter '*' for "username". C C C ENVIRONMENT: VAX/VMS LCR(C AUTHOR: James G. DownwardC KMS Fusion, Inc.C P.O. Box 1567n C Ann Arbor, Mich. 48106CL"C CREATION DATE: 24-Jan-1985CsC(*C C H A N G E L O GC+C Date ! Name ! DescriptionsOC_______________!___________X__!________________________________________________gFC 28-Jan-1985 J. Downward Use UAFDEF.FOR for V4.0 and henceforthDc 09-May-1986 P.B.Wischow Use DISPLAY_USERS and CHECK_UAF from"c GRADS version of REMINDER. CHARACTER*1 Cbell /7/ CHARACTER*80 Cbuf LOGICAL*1 Is_Found INTEGER*4 Ier,Ilength,IerrorE" CALL LIB$GET_FOREIGN(Cbuf,,Nchar). IF(Nchar.EQ.0) GOTO 9999! Exit if no input IF(Cbuf(1:1).EQ.'*') THEN= CALL Display_Users(*600)= ELSE= IF (Nchar.GT.12) NchaYr=120 CALL Check_UAF(*500,*600,Cbuf(1:Nchar),Nchar) END IF 9999 CALL EXIT (1) ! 500 WRITE(*,210) Cbuf(1:Nchar) !@210 FORMAT(' VAXUSERS -- ',A,' is not registered as a VAX user') goto 8888 !600 WRITE(*,200)Cbell A200 FORMAT(' VAXUSERS -- Fatal, SYSUAF.DAT can not be opened.',A)A8888 CALL EXIT (3) ! ENDLC***************************************************************************9C CHECK_UAF Check the User Authorization File to see if=5C the specified user has an account Zon this system.=C='C call CHECK_UAF(*10,*20,Cname,Ilength)=C=C Where:#C Cname Character*(*) User namem C Ilength I*2 length of name(c normal return: Name found in SYSUAF.&c return1: Name not found in SYSUAF.$c return2: Error openning SYSUAF.Ci#C Modified: 14-Jul-1983 J. Downwarda$C JGD1 Force exact match on names4c 13-FEB-1986 P.B.Wischow (for general GRADS use),c 7-MAY-1986 P.B.Wischow (DECUS updates)C-( subroutine check_uaf(*,*,cname,ilength) implicit [integer*2(a-z)5 include 'GRAVLIB$GENERAL:USER$FORSYSDEF.TLB(UAFDEF)'g? include 'GRAVLIB$GENERAL:USER$FORSYSDEF.TLB(UAF_EQUIVALENCES)' # character*12 cname ! User namem' character*256 cstring ! Data buffere) equivalence (UAF_RECORD(0),cstring(1:1)) 5 open(unit=1,name='SYS$SYSTEM:SYSUAF.DAT', ! The UAFp/ - status='OLD', ! is an OLD file , - readonly, ! with read only) - shared, ! shared accessp: - organization='INDEXED', ! Inde \xed and will7 - recordtype='VARIABLE', ! search via thed, - access='KEYED', ! first key7 - key=(5:36:character), ! the user's name . - err=9900) ! Exit on error is_found = 1i3 call STR$UPCASE(cname(1:ilength),cname(1:ilength))s if (ilength.lt.12) then. if (cname(ilength:ilength).ne.'*') then ! 7 cname(ilength+1:12) = ' ' ! Blank rest of names ilength = ilength + 1C else ] r- ilength = ilength - 1 ! Drop off "*"o end if end if 8 read(unit=1,keyge=cname(1:Ilength), ! Unformatted read* - keyid=0, ! on key 0@ - err =9020) cstring ! Error -> key not fndT IF(Cname(1:Ilength).NE.UAF_T_Username(1:Ilength)) GOTO 9020 ! Force exact matchJGD1 write(*,5)(5 format(' Username Full Name',/,/ - ' -------- ---------') I2 write(*,11)UAF_T_Username(1:12),UAF_T_Owner(2:32)11 f^ormat(' 'a,4x,a)10 read(unit=1,end=30) CstringQ IF(Cname(1:Ilength).NE.UAF_T_Username(1:Ilength)) GOTO 30! Force exact matchJGD1=3 write(*,11) UAF_T_Username(1:12),UAF_T_Owner(2:32)d goto 10'30 CLOSE(UNIT=1) ! Close SYSUAF.DAT= return ! DoneY)9020 close(unit=1) ! Close SYSUAF.DATN return1 ! Done 9900 return2 end !=C+Kc************************************************************************** C DISPLAY_USERSC=<C Subroutine to display all current users in _ the VAX account<C file. No check is made as to whether or not the users can=C receive mail (ie they have adequate disk quota) or that theU@C 'user' is not a phantom account present to let accounting workAC more smoothly. If the account file can not be opened, RETURN1.=C Otherwise, NORMAL RETURN.=C=C CALL Display_Users(*)Kc**************************************************************************=C- subroutine display_users(*) implicit integer*2(a-z)5 include 'GRAVLIB$GENERAL:USER`$FORSYSDEF.TLB(UAFDEF)' ? include 'GRAVLIB$GENERAL:USER$FORSYSDEF.TLB(UAF_EQUIVALENCES)'=! character*12 cname ! User nameF% character*80 outline ! Output line=& character*256 cstring ! Data buffer) equivalence (UAF_RECORD(0),cstring(1:1))=C=C .. Implied FORM='UNFORMATTED'DC* open(unit=1, ! Open the System Account0 - name='SYS$SYSTEM:SYSUAF.DAT',! file* - status='OLD', ! It must exit. - readonly, ! we can only read it+ - shared, ! a as a shared filel9 - organization='INDEXED', ! It is indexed with> - recordtype='VARIABLE', ! variable length records2 - access='KEYED', ! access it by keys; - key=(5:36:character), ! First key is user name-5 - err=9900) ! In case we can't open fileT Idx=1 !' Outline=' ' ! Fill line with blanks910 read(unit=1,end=9020) cstring ! Read till end of filei: Ipos=INDEX(UAF_T_USERNAME(1:12),'NETPRIV') ! Skip DECNET& IF (Ipos.GT.b0) goto 10 ! " ": Ipos=INDEX(UAF_T_USERNAME(1:12),'NETNONPRIV') ! " "% IF (Ipos.GT.0) goto 10 ! " " 6c if (UAF_W_GRP.le.10) goto 10 ! No display if system Iptr=1+(Idx-1)*15 !& Outline(Iptr:Iptr+12)=CString(1:12) ! IF (Idx.EQ.5) then !a WRITE(*,30)OUTLINE !30 FORMAT(' 'A) !m Outline=' ' ! Idx=0 ! END IF !0 Idx=Idx+1 !  goto 10 !'9020 IF(Idx.GT.1) WRITE(*,30)Outline !r% close(unit=1) ! Always close fileP returns.9900 return1 ! Fatal, can't open acnt file end !wwDDRESS USERNAME .LONG UN_LEN .LONG 0;+USERNAME: ; Buffer to hold the username .BLKB 12 ; of the sender+TESTNAME: ; Buffer to hold the username0 .ASCII / / ; of the receiver .=.+202UN_LEN: .LONG 0 ; The length of the sender name0TN_LEN: .LONG 0 ; The length of receiver name;TTNAME: .ASCID /SYS$COMMAND/ ; The output name (terminal)0TTCHAN: .LONG 0 ; I/O channel assigned to2OR-X WISCHOW UOPEN_PRINTVAXUSERS/` WISCHOW CONVERT_MACRO_DEFS.FORB [ WISCHOW CONVERT_MACRO_DEFSCONVERT_MACRO_DEFS.FOR/^f WISCHOW CONVERT_MACRO_DEFS.FOR'@^8 WISCHOW BORDERTEST.FOR&=> WISCHOW CHBNDTEST.FOR-P WISCHOW CHBNDTEST BORDERTESTn WISCHOW WAIT READ(5,*,ERR=100) SCALE,RLONW,RLONE,RLATS,RLATN,LATSTP,LONSTP9 PRINT *,' TYPE IN VALUES FOR TICS,CLASS,COAST,LABEL,HEAD5% *, TYPING IN ONE VALUE PER LINE'  READ(5,10,ERR=100) tics 10 FORMAT(A) READ(5,10,ERR=100) class! READ(5,10,ERR=100) coaste READ(5,10,ERR=100) label g READ(5,10,ERR=100) head$ PRINT *,tics,class,coast,label,head CALL PLOTS (0,0,0),8 CALL BORDER(SCALE,RLONW,RLONE,RLATS,RLATN,LATSTP,LONSTP# *,HEAD,tics,class,coast,label)  CALL PLOT (0,0,999) STOP ' '*! 100 PRINT *,'ERROR DURING READ' ENDww ',a,' Definitions.',/,sA * 'c Created by CONVERT_MACRO_DEFS version 1.2',/,[( * 'c Date created: ',a,/,A * 'c***************************************************') end ifI1 write(20,101) ph[= implicit integer*4(a-z) real alat,alon,blat,blon, character*9 chartnumber 1 write(6,10)0$10 format(' ENTER CHART NUMBER: ',$) read(5,20) chartnumbert 20 format(a)5 call CHBND(chartnumber,alat,alon,blat,blon,ps_scale)/5 write(6,30) chartnumber,alat,alon,blat,blon,ps_scale@30 format(//,' chartnumber=',a9,/,' alat=',f8.2,/,' alon=',f8.2,= * /,' blat=',f8.2,/,' blon=',f8.2,/,' ps_scale=',i6,//)= goto 1= endww;= =!;= M A I N R O U T I N E = i;= =I;========================================================================;. .ENTRY MAILRRR,^M<> ; Entry point of program) CLRL R10 ; Clear the YES messages flag3 $ASSIGN_S - ; Assign the terminal an I/O channel DEVNAM=TTNAME, - CHAN=TTCHAN/ BSBW SET_CTRLC ; Set the ^C interrupt handler8 MOVAB DEFSCR,R0 ; Move addr of ANSI escape sequence to) MOVZBL #7,R1 ; set scrolling region3 BSBW PUT_OUT ; Send the sequence to the terminal: MOVAB HEADER,R0 ; Movej the HEADER addr to R0 for PUT_OUT4 MOVZBL #51,R1 ; Move the length to R1 for PUT_OUT" BSBW PUT_OUT ; Print the header;$;******* Get the name of the sender;, $GETJPIW_S - ; Get the name of the sender ITMLST=JPI_LIST8 LOCC #^A/ /,#12,USERNAME ; Find the end of the username2 BEQL LOOP ; Not found - name is 12 chars - contB SUBL3 #USERNAME,R1,UN_LEN ; Get the actual length of the username+ ; ...($GETJPI returns 12 - blanks pad);*;***** Get the name of the MAIL recipieknt;0LOOP: MOVC3 #16,BLANKS,TESTNAME ; Clear TESTNAME: $QIOW_S CHAN=TTCHAN, - ; Prompt the user for the name to3 FUNC=#IO$_READPROMPT, - ; of the user to check P1=INBUFF, - P2=#80, - P4=#0, - P5=#PROMPT, - P6=#53- LOCC #^X1A,#80,INBUFF ; Did user enter a ^Z? BEQL 1$ ; No -- continue$ BRW BYE ; Yes -- exit the program?1$: LOCC #CR,#80,INBUFF ; Find the indicating end of name8 SUBL3 #INBUFF,R1,R2 ; Was only character entered? BNEQ 5$ ; NO - continlue# BRW BYE ; YES - exit the program;5$: MOVL R2,TN_LEN ; Move the length of TESTNAME to TN_LEN5 MOVC3 R2,INBUFF,TESTNAME ; Move the name to TESTNAME;";*** Convert the name to uppercase;9 MOVL TN_LEN,R0 ; Get the length of the username entered/ MOVAB TESTNAME,R1 ; Move the starting address*7$: CMPB #^X60,(R1) ; Is character >= "a"1 BGTR 9$ ; No - don't touch it. Yes - continue= BICB2 #^B00100000,(R1) ; Convert each character to uppercase ; (turn off bit 5)-9$: mINCL R1 ; Bump up pointer into TESTNAME. SOBGTR R0,7$ ; Finished? No - convert next;( BSBW PUT_HEADINGS ; Print the headings;E;**** Check to see if the recipient name entered is a valid username;9 CMPL #16,TN_LEN ; Is name entered longer than 16 chars?% BGEQ 10$ ; Yes -- no such username BRW NO_SUCH_USER<10$: $OPEN FAB=SYSFAB ; Open SYSUAF to read TESTNAME record, BLBS R0,20$ ; Error opening? Go to ERROR BRW ERROR720$: $CONNECT RAB=SYSRAB ; Connect the RAB withn SYSUAF/ BLBS R0,30$ ; Error connecting? Go to ERROR BRW ERROR;030$: $GET RAB=SYSRAB ; Read the TESTNAME record' CMPL #RMS$_RNF,R0 ; Was record found? BNEQ 35$ BRW NO_SUCH_USER/35$: $CLOSE FAB=SYSFAB ; Close the SYSUAF file ;P;****** Get the recipient's default device and directory (home of the MAIL.MAI);;****** and build the complete MAIL.MAI file specification;D LOCC #^A":",#32,SYSREC+117 ; Find ":" indicating end of device name= SUBL3 #SYSREC+117,R1,R6 ; Geto the length of the def dev name INCL R6 ; Bump to include ":"3 MOVL R6,R8 ; Save the number of chars in def dev< MOVC3 R6,SYSREC+117,FILESPEC ; Move the def dev to FILESPECD LOCC #^A"]",#40,SYSREC+149 ; Find "]" indicating end of default dir6 SUBL2 #SYSREC+149,R1 ; Get the length of the def dir INCL R1 ; Bump to include "]"6 ADDL2 R1,R8 ; Add to the number of chars in def devE MOVC3 R1,SYSREC+149,FILESPEC[R6] ; Move the def dir name to FILESPECA MOVC3 #8,MAIL_FILE,FILESPEC[R8] p; Move MAIL.MAI to the filespec6 ADDB2 #8,R8 ; Bump up R8 (total length of FILESPEC);5 $FAB_STORE - ; Store FILESPEC (the receiver's mail4 FAB=MAILFAB, - ; filename) in the FAB for MAIL FNA=FILESPEC, - FNS=R8;N;******* Open the recipient's MAIL file (if there), read in each mail header,K;******* to see if the file was sent by the USERNAME, and, if so, put the /;******* message status into the output buffer;/ $OPEN FAB=MAILFAB ; Open the user's mail file6 BLBS qR0,40$ ; Error opening? No messages from user BRW NO_MESS640$: $CONNECT RAB=MAILRAB ; Connect RAB with MAIL.MAI# BLBS R0,HERE ; Error connecting?& BRW NO_MESS ; No messages from userHERE:. $GET RAB=MAILRAB ; Get the first mail header' CMPL #RMS$_RNF,R0 ; Was record found? BNEQ 4$ ; Yes - continue) BRW NO_MESS ; No -- goto error routine/4$: CMPL #RMS$_EOF,R0 ; Was end of file found? BNEQ 5$ ; Yes - continue) BRW NO_MESS ; No -- goto error routineJ5$: MATCHC UrN_LEN,USERNAME,UN_LEN,MAILREC+68 ; Is mail from running user?$ BNEQ HERE ; No -- get next record;+;******* Here if message was from USERNAME>; ; CMPC3 #7,NEWMAIL,MAILREC+9 ; Has file been read (NEWMAIL)?' TSTL R0 ; Is this in NEWMAIL folder?, BNEQ 10$ ; Yes - move the RECEIVED status8 MOVC3 #14,NO,OUTBUF+32 ; Move "NOT PICKED UP" to OUTBUF/ BRB 12$ ; Go find the subject of the message810$: MOVC3 #14,YES,OUTBUF+32 ; Msove "RECEIVED" to OUTBUF ,; /12$: XXX:= moval mailrec+68,r3 ; Get beginning addr of SENT FROM field4 locc #^x01,#100,(r3) ; Find end of SENT FROM field bneq 13$ ? brw NO_SUCH_USER ; Not found --- get another user113$: addl2 #2,r1 ; Incr to length of FROM fieldE movw (r1)+,r2 ; Get length of FROM field...point to start of field6 addl3 r2,r1,r3 ; R3 now points to one word past thte ; end of FROM field1 addl2 #2,r3 ; Incr to get length of next field>; 3; locc #^x02,#100,(r3) ; Find end of SENT TO field/; BEQL 15$ ; Not found --- truncate subject1; addl2 #2,r1 ; Incr to length of SUBJECT field4 movzwl (r3)+,r2 ; Get length of SUBJECT field and; point to start of field, cmpl r2,#23 ; Check for length > 23 chars' bleq 20$ ; Length is from 1 to 23...915$: MOVL #23,R2 ; Here ifu truncate -- set length to 23J;** MATCHC TN_LEN,TESTNAME,#128,MAILREC+116 ; Look for beginning of SUBJ1;** ADDL2 #4,R3 ; Bump up to point to beginning0;** LOCC #^X05,#23,(R3) ; Look for end of Subj:>20$: MOVC3 R2,(R3),OUTBUF+51 ; Move the Subj: string to OUTBUF;2 $ASCTIM_S - ; Convert the date/time of the mail5 TIMBUF=DATE, - ; message to ASCII and put it in( TIMADR=MAILREC ; the output buffer3 MOVAB OUTBUF,R0 ; Move addr of OUTBUF for PUT_OUT* MOVZBL #74,R1 ; Move vlength for PUT_OUT) BSBW PUT_OUT ; Print the output buffer2 MOVAB CRLF,R0 ; Send a to the terminal MOVZBL #2,R1 ; .... BSBW PUT_OUT ; ....2 MOVC3 #74,BLANKS,OUTBUF ; Clear the output buffer& MOVB #1,R10 ; Set YES messages flag) BRW HERE ; Go get the next mail record;5;******* Here if there are no messages from USERNAME;NO_MESS:5 BLBS R10,STOP ; Is YES messages flag set? Yes, exit! CLRL R10 ; Clear messages flag/ MOVAB NO_MSSG,R0 ; Move mssg addr for wPUT_OUT/ MOVZBL #48,R1 ; Move mssg length for PUT_OUT# BSBW PUT_OUT ; Print the message;C;******* Here when all messages in the mail file have been checked;STOP:. $CLOSE FAB=MAILFAB ; Close the MAIL.MAI file6 MOVC3 #30,BLANKS,TESTNAME ; Clear the TESTNAME buffer6 BSBW GOTO_PRMPT ; Send the cursor to the prompt line! CLRL R10 ; Clear messages flag4 BRW LOOP ; Go get next username (if there is one);2;******* Here if TESTNAME was not found in SYSUAF; NO_SUCH_USERx:+ $CLOSE FAB=SYSFAB ; Close the SYSUAF file5 MOVAB NO_USER,R0 ; Move mssg addr to R0 for PUT_OUT6 MOVZBL #48,R1 ; Move the message length for PUT_OUT# BSBW PUT_OUT ; Print the message6 BSBW GOTO_PRMPT ; Send the cursor to the prompt line" BRW LOOP ; Go get next username ;D;******* Here if , ^Z, or ^C was entered at prompt for username;8BYE: MOVAB CLEAR,R0 ; Move the ANSI escape sequence and3 MOVZBL #11,R1 ; length to reset the scrolling0 BSBW PUT_OUT ; y region and clear the screen $EXIT_S;.;******* Here if there was an error somewhere;ERROR:* PUSHL R0 ; Push message code onto stack1 CALLS #1,G^LIB$SIGNAL ; Print the error message4 MOVAB CLEAR,R0 ; Move the ANSI escape sequence and2 MOVZBL #7,R1 ; length to reset the scrolling BSBW PUT_OUT ; region $EXIT_S ; Return to VMS .PAGE# .SUBTITLE PUT_HEADINGS subroutineI;======================================================================== ;= =#z;= Subroutine PUT_HEADINGS = ;= =!;= Functional description : = ;= =8;= This routine prints the headings "From: ", "To: ", =;= "Date/Time", etc. = ;= =;= Parameters : = ;= =;= None = ;= =;= Implicit inputs : = ;= =7;= CRLF, OUTBUF, USERNAME, UN_LEN, TESTNAME, TN_LEN, =;= BLANKS, CLR_END = ;= =;= Effects : = ;= =;= None = ;= =I;================={=======================================================; PUT_HEADINGS:2 PUSHR #^M ; Save registers9 MOVAB CRLF,R0 ; Send a combination to the TT: MOVZBL #2,R1 ; ..... BSBW PUT_OUT ; ..... BSBW PUT_OUT ; .....7 MOVAB OUTBUF,R6 ; Move addr of OUTBUF to R6 for FROM:; MOVC3 #12,FROM,(R6) ; Move "From: " and underline ESC seq( ADDB2 #12,R6 ; Bump up OUTBUF pointer9 MOVC3 UN_LEN,USERNAME,(R6) ; Move the username to OUTBUF* ADDB2 UN_LEN,R6| ; Bump up OUTBUF pointer9 MOVC3 #3,CLRATT,(R6) ; Move ESC exit underline sequence9 MOVC3 #14,TO,3(R6) ; Move "To: " and underline sequence! ADDB2 #17,R6 ; Bump up pointer5 MOVC3 TN_LEN,TESTNAME,(R6) ; Move testname to OUTBUF# ADDL2 TN_LEN,R6 ; Bump up pointer9 MOVC3 #6,CLRATT,(R6) ; Move ESC exit underline sequence ADDB2 #6,R6 ; Bump up pointer0 MOVAB OUTBUF,R0 ; Move OUTBUF addr for PUT_OUT/ SUBL3 #OUTBUF,R6,R1 ; Move length for PUT_OUT BSBW PUT_OUT ; Print it2 MOVC3} #80,BLANKS,OUTBUF ; Clear the output buffer9 MOVAB CRLF,R0 ; Send a combination to the TT: MOVZBL #2,R1 ; ..... BSBW PUT_OUT ; ..... BSBW PUT_OUT ; ...... MOVAB HEAD2,R0 ; Move HEAD2 addr for PUT_OUT) MOVZBL #83,R1 ; Move length to PUT_OUT BSBW PUT_OUT ; Print it6 MOVAB CLR_END,R0 ; Move addr of ANSI erase to end of5 MOVZBL #3,R1 ; display and send to the terminal BSBW PUT_OUT4 POPR #^M ; Restore registers RSB ; Return to ~main .PAGE! .SUBTITLE GOTO_PRMPT subroutine;I;======================================================================== ;= = ;= Subroutine GOTO_PRMPT = ;= =!;= Functional description : = ;= =7;= Send the cursor to the prompt line -- the flow of =2;= control falls through to subroutine PUT_OUT = ;= =I;========================================================================; GOTO_PRMPT:# PUSHR #^M ; Save registers= MOVAB PRMPT_LINE,R0 ; Move the ANSI escape sequence and its5 MOVZBL #6,R1 ; length that will send the cursor5 BSBB PUT_OUT ; Send the cursor to the command line% POPR #^M ; Restore registers RSB ; to the prompt line .PAGE .SUBTITLE PUT_OUT subroutine;I;======================================================================== ;= =;= Subroutine PUT_OUT = ;= =!;= Functional description : = ;= =4;= Send the contents of a buffer to the terminal = ;= =;= Parameters : = ;= =!;= Address of buffer in R0 = ;= Length of buffer in R1 = ;= =;= Effects : = ;= =;= None = ;= =I;========================================================================;PUT_OUT:1 PUSHR #^M ; Save the registers destroyed@ $QIOW_S CHAN=TTCHAN, - ; Send ASCII characters to the terminal+ FUNC=#IO$_WRITEVBLK, - ; ...Address in R0 P1=(R0), - ; ...Length in R1 P2=R1% POPR #^M ; Restore registers RSB .PAGE .SUBTITLE SET_CTRLC subroutine;I;======================================================================== ;= =;= Subroutine SET_CTRLC = ;= =!;= Functional description : = ;= =.;= This routine establishes a ^C handler. = ;= =;= Parameters : = ;= =;= None = ;= =;= Effects : = ;= =;= None = ;=  =I;========================================================================;%SET_CTRLC: ; Enable the ^C handler1 PUSHR #^M ; Save the registers destroyed2 $QIOW_S CHAN=TTCHAN, - ; Enable a ^C AST handler$ FUNC=#IO$_SETMODE!IO$M_CTRLCAST, -# P1=C_AST ; The AST entry address% POPR #^M ; Restore registers RSB;I;======================================================================== ;= =8;= CONTROL-C handling routine --- exit the program = ;= =I;========================================================================;-C_AST: .WORD 0 ; Entry mask -- save no regs% JMP BYE ; Jump to exit the program .END MAILRRRww )!RJDc*******************************************************************3C***** CONVERTED TO ASCII BY S. LINGSCH MAY 1983Hc******************************************************************* * subroutine mapdex (plat,plon,iew,ns,jsss)& implicit double precision (a-h,o-x,z) d imension j(4); dimension nband(91),jpp2(128),bcmn(21),difmn(21),jpp1(128)< data nband/01,01,01,02,02,02,02,02,02,02,03,03,03,03,03,03,C * 03,04,04,04,04,04,04,05,05,05,05,05,05,06,06,06,06,06,06,07,C * 07,07,07,07,08,08,08,08,08,09,09,09,09,10,10,10,10,11,11,11,C * 12,12,12,13,13,13,14,14,15,15,15,15,15,15,16,16,16,16,17,17,4 * 17,18,18,18,18,19,19,19,20,20,20,21,21,21,21/? data bcmn/-180.0d0,180.0d0,600.0d0,1020.0d0,1380.0d0,1740.0d0,F * 2100.0d0,2400.0d0,2700.0d0,29 40.0d0,3180.0d0,3360.0d0,3540.0d0,G * 3720.0d0,3840.0d0,4200.0d0,4440.0d0,4620.0d0,4860.0d0,5040.0d0, * 5220.0d0/< data difmn/360.0d0,420.0d0,420.0d0,360.0d0,360.0d0,360.0d0,? * 300.0d0,300.0d0,240.0d0,240.0d0,180.0d0,180.0d0,180.0d0,7 * 120.0d0,360.0d0,240.0d0,180.0d0,240.0d0,180.0d0, * 180.0d0,180.0d0/= data jpp1/3333,3332,3323,3322,3233,3232,3223,3222,2333,2332,C * 2323,2322,2233,2232,2223,2222,3334,3331,3324,3321,3234,3231,C * 3224,3221,2334,2331,2324,2321,2234,2231,2224,2221,3343,3342,C * 3313,3312,3243,3242,3213,3212,2343,2342,2313,2312,2243,2242,C * 2213,2212,3344,3341,3314,3311,3244,3241,3214,3211,2344,2341,C * 2314,2311,2244,2241,2214,2211,3433,3432,3423,3422,3133,3132,C * 3123,3122,2433,2432,2423,2422,2133,2132,2123,2122,3434,3431,D * 3424,3421,3134,3131,3124,3121,2434,2431,2424,2421,2134,2131,C * 2124,2121,3443,3442,3413,3412,3143,3142,3113,3112,2443,2442,C * 2413,2412,2143,2142,2113,2112,3444,3441,3 414,3411,3144,3141,9 * 3114,3111,2444,2441,2414,2411,2144,2141,2114,2111/= data jpp2/4333,4332,4323,4322,4233,4232,4223,4222,1333,1332,C * 1323,1322,1233,1232,1223,1222,4334,4331,4324,4321,4234,4231,C * 4224,4221,1334,1331,1324,1321,1234,1231,1224,1221,4343,4342,C * 4313,4312,4243,4242,4213,4212,1343,1342,1313,1312,1243,1242,C * 1213,1212,4344,4341,4314,4311,4244,4241,4214,4211,1344,1341,C * 1314,1311,1244,1241,1214,1211,4433,4432,4423,4422,4133,4132,C * 412 3,4122,1433,1432,1423,1422,1133,1132,1123,1122,4434,4431,C * 4424,4421,4134,4131,4124,4121,1434,1431,1424,1421,1134,1131,C * 1124,1121,4443,4442,4413,4412,4143,4142,4113,4112,1443,1442,C * 1413,1412,1143,1142,1113,1112,4444,4441,4414,4411,4144,4141,9 * 4114,4111,1444,1441,1414,1411,1144,1141,1114,1111/ is = SIGN(1,JIDINT(plat)) plat = ABS(plat)7 if (ABS(plat).ge.90.00d0) plat = 89.9999999999999999d0 plon = -plon if (plon.ge.0) then iquad = 1 else iquad = 2 end if lat = IFIX(SNGL(plat)) lon = IFIX(SNGL(plon)) alt = FLOAT(lat) along = FLOAT(lon)$ altmn = (ABS(plat)-ABS(alt))*60.000& amnlg = (ABS(plon)-ABS(along))*60.000 if (iquad.eq.1) then ultmn = alt*60.+altmn umnlg = along*60.+amnlg else ultmn = alt*60.+altmn umnlg = along*60.-amnlg end if ns = nband(lat+1)) nspps = ((ultmn-bcmn(ns))/difmn(ns))*16. if (iquad.eq.1) then if (lat.lt.64) then iew = lon /10+1! bcllg = (iew-1)*600. iwpps = ((umnlg-bcllg)/600.)*16.( ipps = (16-iwpps)+nspps*16 go to 1520 end if, if (lat.ge.64.and.lat.lt.84) then iew = lon/15 +1! bcllg = (iew-1)*900. iwpps = ((umnlg-bcllg)/900.)*16.( ipps = (16-iwpps)+nspps*16 go to 1520 end if% if (lat.ge.84.and.lat.lt.87) then iew = lon/20 +1 bcllg = (iew-1)*1200- iwpps = ((umnlg-bcllg)/1200)*16( ipps = (16-iwpps)+nspps*16 go to 1520 end if if (lat.ge.87) then iew = lon/40 + 1" bcllg = (iew-1)*2400- iwpps = ((umnlg-bcllg)/2400)*16( ipps = (16-iwpps)+nspps*16 go to 1520 end if else if (lat.lt.64) then iew = 36+lon /10" bcllg = (iew-36)*6003 iwpps = ((umnlg-bcllg)/600.)*(-16.)+1#  ipps = nspps*16+iwpps go to 1520 end if % if (lat.ge.64.and.lat.lt.84) then iew = 24+lon/15 bcllg = (iew-24)*900+ iwpps = ((umnlg-bcllg)/900.)*(-16)+1 ipps = nspps*16+iwpps go to 1520 end if, if (lat.ge.84.and.lat.lt.87) then iew = 12+lon/20 bcllg = (iew-12)*12003 iwpps = ((umnlg-bcllg)/1200.)*(-16)+1# ipps = nspps*16+iwpps iew = iew+6  go to 1520 end if if (lat.ge.87) then iew = lon/40 bcllg = iew*24002 iwpps = ((umnlg-bcllg)/2400)*(-16)+1# ipps = nspps*16+iwpps iew = iew+9 end if end if1520 if (ipps.gt.128) then ipps = ipps - 128 jsss = jpp2(ipps) else jsss = jpp1(ipps) end if if (is.lt.0) then ydiv = 10000. ybl = jsss do i = 1,4 ydiv = ydiv/10.  y = ybl/ydiv j(i) = y + 0.1! ybl = (y-j(i))*ydiv end do do i = 1,4. if (j(i).eq.2.or.j(i).eq.4) then- if ((plat-3.0d0).lt.0.) then# j(i) = j(i) - 1 else# j(i) = j(i) + 4 end if else- if ((plat-3.0d0).lt.0.) then# j(i) = j(i) + 1 else# j(i) = j(i) + 6  end if end if end do0 jsss = j(1)*1000 + j(2)*100 + j(3)*10 + j(4) end if if (is.lt.0) then plat = -plat else plon = -plon end if return endww@5C SUBROUTINE MASK IS THE LANDMASK PLOTTING SUBROUTINE# SUBROUTINE MASK(SCALE,RLONW,RLATS) IMPLICIT INTEGER(A-Z)( REAL Y,X,YMP,LAT,SCALE,RLONW,RLATS,SLAT $ IF (RLONW.LT.0) RLONW = RLONW + 360 SLAT=YMP(RLATS*60.) DO I=1,2  IF (I.EQ.1) THEN  START=-47 STOP=0 BEGIN=-55 END=0 ELSE START=0 STOP=5 BEGIN=0 END=55 END IF DO LATD=START,STOP,1 DO LATM=BEGIN,END,5 LAT=LATD*60 + LATM! Y = ((YMP(LAT)-SLAT)/60.* SCALE) CALL PLOT(0.,Y,3) FLAG=1 OLD=1 DO LOND=90,180 DO LONM=0,55,5) CALL LANDMASK(LATD,LATM,LOND,LONM,IMASK) IF (IMASK.NE.OLD) THEN FLAG = -FLAG LAT=LATD*60 + LATM$ Y = ((YMP(LAT)-SLAT)/60. * SCALE)* X = ((LOND + LONM/60.) - RLONW) * SCALE# IF (FLAG.EQ.-1) CALL PLOT(X,Y,2)# IF (FLAG.EQ.1) CALL PLOT(X,Y,3) END IF OLD=IMASK END DO END DO IF (OLD.EQ.1) CALL PLOT(X,Y,2) END DO END DO END DO RETURN ENDww@?x+0PC********************************************************************************C**** SUBROUTINE MINJUL (ASCII)C**** ORIGINALLY WRITTEN BY...<C**** SAUNDRA S. PETTYJOHN--CODE 0831--OCTOBER 1970<C********* REWRITTEN AND UPDATED BY P.B.WISCHOW AUGUST 1982 C****>C**** PURPOSE--THIS SUBROUTINE CONVERTS MINUTES TO JULIAN DAY,C**** HOURS AND MINUTES.C**** USES--MOD,IABSC****C**** ARGUMENTS--*C**** JMIN--MINUTES TO BE CONVERTED(IN)=C**** DAY--EQUIVALENT JULIAN DAY OF CONVERTED MINUTES(OUT)6C**** HR--EQUIVALENT HOUR OF CONVERTED MINUTES(OUT);C**** MINS--EQUIVALENT MINUTES OF CONVERTED MINUTES(OUT)C**** ENTRY POINTS--"C**** ENTRY MINJL1(JMIN,DAY,HRMIN)EC**** PURPOSE--USED WHEN THE INPUT FOR HOURS AND MINUTES ARE COMBINED:C**** HRMIN--EQUIVALENT HOURS AND MUNUTES COMBINED(OUT)PC******************************************************************************** SUBROUTINE MINJUL(JMINS,DAY,HR,MINS) IMPLICIT INTEGER(A-Z) FLAG = 1# ENTRY MINJL1(JMINS,DAY,HRMIN) JMIN = IABS(JMINS) JMIN = JMIN - 1 DAY=JMIN/1440 + 1 TIME=MOD(JMIN,1440) TEMP1=TIME/60 TEMP2=IABS(TIME-TEMP1*60) IF(FLAG.EQ.0) THEN HRMIN=TEMP1*100+TEMP2 ELSE  HR=TEMP1 MINS=TEMP2 END IF FLAG=0 RETURN ENDww͑,1C THIS ROUTINE SIMULATES THE UNIVAC NTRAN ROUTINE,C THE ROUTINE WAS ORIGINALLY WRITTEN BY DMAC0C AND MODFIED JAN 84 BY STEVE LINGSCH TO INCLUDE/C THE FOLLOWING FUNCTIONS: WRITE, WRITE AN EOF,C REWIND, REWIND AND DISMOUNTC$C THE ROUTINE IS CALLED AS FOLLOWS:&C CALL NTRAN(UNIT,OPER,NUW,ARRAY,L);C UNIT: THE LOGICAL UNIT NUMBER WHCIH CAN BE ASSIGNED  'C $MOUNT MSA0: LABEL 10,C _____ _____ __,C | | | 0C DEVICE LABEL LOGICAL.C UNITC OR C $ASSIGN MSA0: 103C VALID UNIT NUMBERS RANGE FROM 01 TO 30'C OPER: OPERATION TO BE PERFORMED C 1-WRITEC 2-READ&C 7-POSITION TAPE BY BLOCK%C 8-POSITION TAPE BY FILEC 9-WRITE AN EOFC 10-REWIND)C 17-REWIND AND DISMOUNT TAPE C 22-WAIT AN UNSTACK2C NUW: NUMBER OF WORDS TO BE WRITTEN OR READ4C MIN=3, MAX=16383 WARNING:AN ERROR WILL -C NOT OCCUR IF THE MAX IS EXCEEDED 1C ON AN POSITION TAPE BY BLOCK OR FILE1C NUW IS THE NUMBER OF BLOCKS OR FILES<C TO BE MOVED. A POSITIVE NUMBER WILL POSITION 4C THE TAPE FOWARD, AND NEGATIVE BACKWARD.:C ARRAY: ARRAY TO BE WRITTEN OUT OR TO RECIEVE DATA:C L: STATUS UNDER NORMAL COMPLETION L WILL EQUAL THE&C NUMBER OF WORDS TRANSFERED.C -1 ERROR CONDITIONC -2 END OF FILE:C L: STATUS UNDER NORMAL COMPLETION L WILL EQUAL THE&C NUMBER OF WORDS TRANSFERED.C -1 ERROR CONDITIONC -2 END OF FILE( SUBROUTINE NTRAN(IU,IOP,NUW,IBL,L)CCC IMPLICIT INTEGER ( A - H )C4 INTEGER*4 SYS$ASSIGN, SYS$QIOW, RETCOD,NBYTES CHARACTER*2 CHAN,TABLE(30)! DIMENSION IBL(1), LABEL(20) INTEGER*2 IOSTAT(4),CHC INCLUDE '($IODEF)' INCLUDE '($SSDEF)'C: DATA TABLE /'01','02','03','04','05','06','07','08',8 1'09','10','11','12','13','14','15','16','17','18',= 2'19','20','21','22','23','24','25','26','27','28','29', 3'30'/ DATA IONCE /0/,I8/8/ IF ( IONCE .EQ. 0 ) THEN IONCE = 1 CHAN=TABLE(IU), RETCOD = SYS$ASSIGN ( CHAN, CH,, ) # IF ( RETCOD .NE. 1 ) THEN PRINT 990, RETCOD@ 990 FORMAT ( ' UTRAN I/O ASSIGN FAILURE, STATUS = ',Z8 )) CALL LIB$STOP ( %VAL(RETCOD)) END IF END IF L = 0CC SIMULATE NTRAN READ IF(IOP .EQ.2) THEN NBYTES = NUW*4: RETCOD = SYS$QIOW(,%VAL(CH),%VAL(33),IOSTAT,,,IBL/ 1  ,%VAL(NBYTES),,,,); IF (RETCOD .NE. 1) CALL LIB$STOP ( %VAL(RETCOD) )C, IF ( IOSTAT(1) .EQ. SS$_NORMAL .OR.9 1 IOSTAT(1) .EQ. SS$_DATAOVERUN ) THEN % LUWIR = (IOSTAT(2)*I8)/36" L = MIN ( NUW,LUWIR ).C ELSE IF(IOSTAT(1) .EQ. '870'X) THEN5 ELSE IF(IOSTAT(1) .EQ. SS$_ENDOFFILE) THEN L=-21 WRITE(6,*)' UTRAN EOF WHILE READING,'CD . ' NUMBER OF BYTES ACQUIRED= ', IOSTAT(2)<D WRITE(16,111)(IBL(K),K=1,(IOSTAT(2) + 3)/4,4 ) " 111 FORMAT((1X,12(1X,Z8))) ELSEF PRINT 911, ' STATUS AFTER READ ', IOP, NUW, RETCOD, IOSTAT L = -1 END IFC SIMULATE NTRAN WRITE ELSE IF(IOP .EQ. 1) THEN  NBYTES=NUW*4- RETCOD=SYS$QIOW(,%VAL(CH),%VAL(32),IOSTAT,! 1 ,,IBL,%VAL(NBYTES),,,,)/ IF(RETCOD .NE. 1)CALL LIB$STOP(%VAL(RETCOD)). IF(IOSTAT(1) .EQ. SS$_NORMAL .OR. IOSTAT(1) 1 .EQ. SS$DATAOVERUN)THEN LUWIR=(IOSTAT(2)*I8)/36 L=MIN(NUW,LUWIR) ELSE3 PRINT 911,'STATUS AFTER WRITE',IOP,NUW,RETCOD, 1 IOSTAT L=-1 END IFCC WRITE END OF FILE ELSE IF (IOP .EQ. 9) THEN, RETCOD=SYS$QIOW(,%VAL(CH),%VAL(40), 1 IOSTAT,,,,,,,,)5 IF(RETCOD .NE. 1)CALL LIB$STOP(%VAL(RETCOD))/ IF(IOSTAT(1) .NE. SS$_NORMAL)GO TO 900#C TAPE REWIND AND DISMOUNT ELSE IF(IOP .EQ. 17)THEN+ RETCOD=SYS$QIOW(,%VAL(CH),%VAL(34), 1 ,,,,,,,,)4 IF(RETCOD .NE. 1)CALL LIB$STOP(%VAL(RETCOD)) C SIMULATE NTRAN REWIND ELSE IF(IOP .EQ. 10) THEN= RETCOD = SYS$QIOW(,%VAL(CH),%VAL(36),IOSTAT,,,,,,,,); IF (RETCOD .NE. 1) CALL LIB$STOP ( %VAL(RETCOD) )= RETCOD = SYS$QIOW(,%VAL(CH),%VAL(33),IOSTAT,,,LABEL, 1 %VAL(80),,,,); IF (RETCOD .NE. 1) CALL LIB$STOP ( %VAL(RETCOD) )& IF(LABEL(1) .EQ. 'VOL1') THEN:  RETCOD = SYS$QIOW(,%VAL(CH),%VAL(37),IOSTAT,,, 1 %VAL(1),,,,,)> IF (RETCOD .NE. 1) CALL LIB$STOP ( %VAL(RETCOD) ) ELSEH RETCOD = SYS$QIOW(,%VAL(CH),%VAL(IO_$REWIND),IOSTAT,,,,,,,,)> IF (RETCOD .NE. 1) CALL LIB$STOP ( %VAL(RETCOD) )= IF(IOSTAT(1) .NE. 1 ) CALL LIB$STOP(%VAL(RETCOD)) END IF L = NUWC*C SIMULATE NTRAN WAIT AND UNSTACK ELSE IF(IOP .EQ. 22) THENC RETURNC/C SIMULATE NTRAN POSITION TAPE BY FILE ELSE IF(IOP .EQ.8) THEN/ PRINT *, ' POSITION TAPE BY FILE ',NUW7 RETCOD = SYS$QIOW(,%VAL(CH),%VAL(37),IOSTAT,,,1 1 %VAL(NUW),,,,,); IF (RETCOD .NE. 1) CALL LIB$STOP ( %VAL(RETCOD) )A PRINT 911, ' SKIPPING STATUS ', IOP, NUW, RETCOD, IOSTAT3 IF ( IOSTAT(1) .NE. SS$_NORMAL ) GO TO 900 L = IOSTAT(2)C0C SIMULATE NTRAN POSITION TAPE BY BLOCK" ELSE IF ( IOP .EQ. 7 ) THEN7 RETCOD = SYS$QIOW(,%VAL(CH),%VAL(38),IOSTAT,,,1 1 %VAL(NUW),,,,,); IF (RETCOD .NE. 1) CALL LIB$STOP ( %VAL(RETCOD) )@ PRINT 911, ' POSITIONING STATUS ',IOP,NUW,RETCOD,IOSTAT+ IF ( IOSTAT(1) .NE. 1 ) GO TO 900 L = IOSTAT(2)C/C DISPOSE OF INVALID OPERATION REQUEST ELSE PRINT 410, IOP6 410 FORMAT (' INVALID OPTRAN ON UTRAN CALL ',I10)  CALL LIB$STOPC END IF RETURNC:C DISPOSE OF END OF FILE CONDITION AND I/O ERRORS 900 CONTINUEC(C TEST FOR END OF FILE CONDITION0 IF ( IOSTAT(1) .EQ. SS$_ENDOFFILE0 . .OR. IOSTAT(1) .EQ. SS$_ENDOFTAPE: . .OR. IOSTAT(1) .EQ. SS$_ENDOFVOLUME ) THENE WRITE( 6,911) 'UTRAN END OF FILE',IOP, NUW, RETCOD, IOSTAT. 911 FORMAT (1X, A, 3(1X,I10), 4(1X,Z8) ) L = -2 RETURN END IF C&C DISPOSE OF ERROR CONDITIONS< WRITE(6,911) ' UTRAN ERROR', IOP, NUW, RETCOD, IOSTAT L = -1) CALL LIB$STOP( %VAL( IOSTAT(1) ) )C END wwWԕ8C PAGE Erase the screen of a video terminal or move to#C a new page on a hardcopy device.C C CALL PAGEC?C This subroutine recognizes the following classes of terminals3C VT100 terminals in ANSI mode Erases screen-C Tek 4014 terminals (/FT1) Erases screen-C NBI terminals (/FT2) Erases Screen)C VK100 Video Board Erases Screen(C LA120 Printer Form FeedC all others 7 line feedsCC Written by: James G. DownwardC KMS Fusion, Inc.C P.O. Box 1567C Ann Arbor, Mich 48104C (313)-769-8500C 12-Nov-1982C C-C SUBROUTINE PAGE IMPLICIT INTEGER*2 (A-Z), CHARACTER*1 Cescape,Cform_Feed,Cline_Feed ! CHARACTER*50 Cpage? INTEGER*2 DVI_Code,DVI_Length,DVI_Header(2) ! For GETDVI setup= INTEGER*4 LIST(3), LENGTH, SYS$GETDVI, ilength, idevice_type integer*4 istatus' EQUIVALENCE (DVI_Header(1),DVI_Length)% EQUIVALENCE (DVI_Header(2),DVI_Code)$ EQUIVALENCE (DVI_Header(1),LIST(1)) DATA Cescape /27/ DATA Cform_feed /12/ DATA Cline_feed /10/ include '($TTDEF)'# DVI_Code =6 ! Get from $DVIDEF" DVI_Length = 4 ! 4 bytes long0 LIST (2) = %LOC(Idevice_Type) ! Set up GETDVI LIST (3) = %LOC(Ilength) ! . ISTATUS=SYS$GETDVI(,,'SYS$OUTPUT',LIST,,,,) !1 IF(Idev ice_Type.GE.TT$_VT100) THEN ! If a VT100+ Cpage=Cescape//'[1;H'//Cescape//'[2J' ! Length=9 !3 ELSE IF(Idevice_Type.EQ.TT$_FT1) THEN ! If a 4014! Cpage=Cescape//Cform_Feed ! Length=2 !9 ELSE IF(Idevice_Type.EQ.TT$_FT2 .OR. ! If a NBI beastie5 - Idevice_Type.EQ.TT$_LA120 .OR. ! or a LA120? - Idevice_Type.EQ.TT$_VK100) THEN ! or VK100 vid board' Cpage=Cform_Feed ! then use a FF Length=1 !" ELSE ! Else use 7 linefeeds' DO I=1,50 ! to simulate a page Cpage(I:I)=Cline_Feed ! END DO ! Length=50 ! END IF !, IF(Idevice_Type.LT.TT$_VT100) TYPE *, ' ' !4 WRITE(*,20) Cpage(1:Length) ! Output control char20 FORMAT('+',A,$) ! RETURN ! ENDww@jڏPc*******************************************************************************(c RADDEG (Originally subroutine CONDMS)c:c This subroutine converts radians to degrees and minutes.c c PARAMETERS: 0c code: 0--convert radians to floating degrees.<c 1--convert radians to fixed degrees and floating minutes..c rads: Latitude or longitude in radians(in).4c degs,idegs: Degrees of latitude or longitude(out)./c mins: Minutes of latitude or longitude(out).c9c Author: Saundra S. Pettyjohn--code 0831--september 1970=c Rewritten and updated in ASCII by P.B. Wischow March 1983Pc*******************************************************************************- subroutine raddeg(code,rads,degs,idegs,mins) implicit integer*4(a-z)" real second,degs,mins,rads,tdegs 8 second = rads/.48481368e-05 ! Change radians to seconds> tdegs = second/3600.0 ! Convert seconds to floating degrees  if (code .eq. 0) then degs = tdegs else idegs = tdegsG mins = (ABS(second - FLOAT(idegs) * 3600.0))/60. ! Convert radians ! to fixed degrees $ ! and floating minutes 0 if (idegs.eq.0 .and. rads.lt.0) mins = -mins end if return endww4c***************************************************4c***** Must be compiled with /CHECK=NOOVERFLOW *****4c***************************************************$ integer*4 function random(low,high) implicit integer*4(a-z) real*4 rand- if (pass .eq. 0) then ! INITIALIZE FUNCTION pass = 1? iseconds = INT (SECNDS(0.0) * SECNDS(0.0)) ! Beginning seed scale = MAX (10, high) if (scale .eq. high) then scale = MAX (100, high)" else if (scale .eq. high ) then scale = MAX (1000, high) endif endif10 rand = RAN (iseconds)) random = INT (rand * FLOAT(scale) - 0.5) if (random .gt. high .or.& 1 random .lt. low) goto 10 return end ww O-9c********************************************************.c***** P.B.WISCHOW AND SKIP DERRY 13MAR1984c*****3c***** This routine reads a univac formatted ntranBc***** tape. Reshuffles the bytes to a VAX-11 readable format. c***** ?c***** UNIT: logical device name (integer longword) (passed)Fc***** UNIVAC: reshuffled array (2016 integer longwords) (returned)Kc***** ISTAT: returned status of operation (integer longword) (returned)c***** 9c********************************************************( subroutine readtape (unit,univac,istat) implicit integer*4 (a-z)' integer aray(2016),univac(2016)(20 call ntran(unit,2,2016,aray,istat,22) if(istat.ge.0)then do i=1,20164 call mvbits(aray(i),0,8,univac(i),24)4 call mvbits(aray(i),8,8,univac(i),16)4 call mvbits(aray(i),16,8,univac(i),8)4 call mvbits(aray(i),24,8,univac(i),0) end do end if500 return endwwzYw*c Program reads Harris tape from Magnetics"c and writes it to specified file. implicit integer*4 (a-z) character*81 buffer,filename, print *, ' Tape should be logical unit 11 '4 open (unit=11,access='sequential',form='formatted', 1 recl=81,status='old') rewind 11 print *, ' Output filename?' read (*,5) filename 5 format (a)4 open (unit=12,access='sequential',form='formatted',0 1 carriagecontrol='list',recl=80,name=filename, 2 status='new')10 read (11,5,end=99), buffer write (12,5), buffer(1:80)8 if (mod(lines,100) .eq. 0) print *, lines,' lines read' lines = lines + 1 go to 10 99 close (11) close (12)' print *, lines,' lines read from tape' print *, ' Program co mplete' endwwV7OC****************************************************************************** c READ_LINEc2c call READ_LINE(text,text_length,return_status)cBC This is an input routine that checks for escape sequences from aDc VT type keyboard. The keys listed below are the ones currentlyBc checked for. This routine assigns a channel to SYS$INPUT forBc the I/O. If the terminal is a VT type the I/O is done using Cc $QIOW, else if SYS$INPUT is an unknown terminal or a batch job)c the I/O is done using FORTRAN I/O. cc WHERE:Cc text: Character string that is returned. Blank if return_statusc is not equal to zero.c (character*(*),returned)cCc text_length: Length of TEXT. Zero if return_status is not equal c to zero.c (integer*2,returned)c9c return_status: Status code defining which key was hit.c (integer*2,returned)c c WHERE:cc -2: undefined key was hit'c -1: carriage return only 13: keypad 3+c 0: keyboard characters only 14: keypad 4c 1: ctrl Z 15: keypad 5c 2: up arrow 16: keypad 6c 3: down arrow 17: keypad 7c 4: left arrow 18: keypad 8 c 5: right arrow 19: keypad 9"c 6: PF1 20: keypad period (.)c 7: PF2 21: keypad ENTER"c 8: PF3 22: keypad comma (,)c 9: PF4 23: keypad minusc 10: keypad 0c 11: keypad 1c 12: keypad 2ccAc If you wish to use the terminal type in another module, include c the following common block:cCc common /TERMINAL/ ttchan, iterminal, save_modes(2), new_modes(3)cc WHERE:c ttchan: I/O channel number.c (integer*2,common)c=c iterminal: Terminal type (see $TTDEF for equivalent names)c (integer*2,common)c4c save_modes(2): Previous terminal characteristics.c (integer*4,common)c2c new_modes(3): Current terminal characteristics.c (integer*4,common)c@c SAVE_MODES and NEW_MODES are not required. They are here for Gc convenience (to be used in other user modules to maintain terminalc characteristics).cc-c READ_LINE assigns a channel via SYS$ASSIGN.cOC******************************************************************************5 subroutine read_line(text,text_length,return_status) implicit integer*2(a-z) include '($IODEF)' include '($TT2DEF)' include '($TRMDEF)' character*(*) text character*1 cr character*255 temptext5 integer*4 SYS$QIOW, LIB$STOP, LIB$GET_SYMBOL, status integer*4 LIB$DO_COMMAND byte app_keypads(7)( data app_keypads/27,61,27,91,63,49,104/ data cr /13/# common /TERMINAL/ ttchan,iterminal structure /QIOLIST/ integer*2 len, code integer*4 address,ret_addr end structure structure /IOSB/ integer*2 status,offset( byte terminator,dummy,termlen,curpos end structure+ record /QIOLIST/ func_list(1), /IOSB/ iosb return_status = 0 text_length = 0+ if (pass.eq.0) then ! Execute only once. pass=11 if (ttchan.eq.0) call GET_TE RMTYPE(iterminal)3 if (iterminal.gt.0) then ! Setup VT type I/O io_func = IO$_WRITEVBLK< status = SYS$QIOW (,%val(ttchan), ! SET KEYPAD MODES * %val(io_func),,,,( * %ref(app_keypads),%val(7),,,,)5 if (.not. status) call LIB$STOP (%val(status))) func_list(1).code = TRM$_MODIFIERSD func_list(1).address = TRM$M_TM_NORECALL .or. TRM$M_TM_ESCAPE * .or. TRM$M_TM_NOEDIT func_list(1).len = 0 func_list(1).ret_addr = 0. io_func = IO$_READVBLK .or. IO$M_EXTEND end if end if2 if (iterminal.le.0) then ! Alternate input path. read(*,1010,end=1500) text_length,temptext1010 format(q,a) @ call LSHIFT_STRING(temptext,text_length) ! Left justify text: if (temptext(1:1).ne.cr) text_length = text_length + 1 else < status = SYS$QIOW (, %val(ttchan),%val(io_func),iosb,,,2 * %ref(temptext),%val(LEN(temptext)),,,$ * %ref(func_list), %val(12))2 if (.not. status) call LIB$STOP (%val(status)), text_length = iosb.offset + iosb.termlen end if4 call CHECK_READ(temptext,text_length,return_status) if (text_length.gt.0) 9 * status = STR$UPCASE(text,temptext(1:text_length)) return+1500 return_status = 1 ! Treat as a CTRL_Z return endww`RDJc*************************************************************************c***** RESET_TERMINALc*****Cc***** This routine tries to return the users terminal to its Bc***** original state. If the terminal characteristics were savedDc***** (using SENSE_MODE & SET_MODE in a QIO) then this will restoreFc***** those characteristics. There are some characteristics that mayGc***** have been changed using escape sequences (reverse video, jump orDc***** smooth scroll, etc). These can be changed by creating a fileCc***** (USER$GPWFILES:RESET_TERMINAL.COM) and including the desiredFc***** escapes sequences (in DCL format). This routine checks to see Ec***** if the USER reset command file exists. If it does then it is :c***** used; else, it defaults to the system command file )c***** (SYS$GPWFILES:RESET_TERMINAL.COM).Hc***** If any terminal characteristics are altered using QIO's thenEc***** the following common block MUST be used to ensure proper reset c***** of those characteristics.Ic***** common /TERMINAL/ ttchan, terminal,save_modes(2), new_modes(2)Jc*************************************************************************;c***** Restore terminal characteristics (if modified) ***** subroutine reset_terminal implicit integer*2(a-z) include '($SYSSRVNAM)' include '($IODEF)' include '($RMSDEF)'1 integer*4 save_modes, new_modes, status, zero/0/5 integer*4 LIB$STOP, LIB$FIND_FILE, LIB$FIND_FILE_END character*80 dummyA common /TERMINAL/ ttchan, iterminal, save_modes(2), new_modes(2) if (iterminal.gt.0) thenB if (save_modes(2).ne.0) then ! Reset only if modes were savedI status = SYS$QIOW (,%val( ttchan), IO$_SETMODE ! Reset any changed B * ,,,,save_modes, %val(8),,,,) ! term charact.5 if (.not. status) call LIB$STOP (%val(status)) end if> status = LIB$FIND_FILE('USER$GPWFILES:RESET_TERMINAL.COM', * dummy,zero) if (status.eq.RMS$_FNF) then write(6,10)610 format(' *** TERMINAL RESET FAILED ***',/,0 * ' *** USING SYSTEM TERMINAL RESET ***')= status = LIB$SPAWN('@SYS$GPWFILES:RESET_TERMINAL.COM') else>  status = LIB$SPAWN('@USER$GPWFILES:RESET_TERMINAL.COM') end if end if! status = LIB$FIND_FILE_END(zero) return endwwGQ" REAL FUNCTION RFRD(SD, IER )C+C VAX REAL NUMBER FROM UNIVAC REAL DOUBLETC1C SD IS ASSUMED TO BE A TWO DIMENSIONAL I*4 ARRAY1C DIMENSIONED (2,1). THE HIGER END OF THE UNIVAC/C REAL IS STORED IN SD(1,1), AND THE LOWER END +C (LEAST SIGNIFICANT) IS STORED IN SD(2,1).C#C EX: SET UP IN THE CALLING ROUTINE)C CALL MVBITS(UNIVAC,18,14,SH(1,1),0)(C CALL MVBITS(UNIVAC,0,14,SH(2,1),4)C3C IN THIS EXAMPLE THE TAPE IS WRITTEN QUARTER WORD /C SENSITIVE ON THE UNIVAC THEREFOR ONLY 32 BITS,C OF THE UNIVAC REAL ARE TRANSFERED. 5C IF ALL 36 BITS WERE TRANSFERED THE TWO WORDS /C WOULD BE SET UP SO THAT SD(2,1) WOULD CONTAIN*C ALL 18 BITS IN THE LOWER END OF THE WORD INTEGER SD(2) REAL RV INTEGER HH, IV INTEGER * 2 Q(2), IV2(2)1 EQUIVALENCE ( HH, Q), ( IV2, IV), ( IV, RV) LOGICAL LSC SET UP MASKS% PARAMETER ( M18 = 2 ** 18 - 1 )% PARAMETER ( M9 = 2 ** 9 - 1 ) +C EXPONENT FIELD, BITS 9 THRU 16 ON5 PARAMETER ( MEX = ( 2 ** 8 - 1) * ( 2 ** 9 ) )*C NORMALIZATION BIT, BIT 22 ON ON% PARAMETER ( MNORMB = 2 ** 26 ) C SIGN BIT, BIT 17 ON& PARAMETER ( MSIGNB = 2 ** 17 ) IER = 0 HH = SD(1) IV = SD(2)6 LS = ( HH .AND. MSIGNB) .NE. 0 ! NOTE SIGN BIT'C MAP NEGATIVES ON TO POSITIVES IF ( LS ) THEN% HH = ( .NOT. HH ) .AND. M18% IV = ( .NOT. IV ) .AND. M18 END IFDC LOAD ALL 27 BITS OF UNIVAC MANTISSA INTO ONE VAX LONG WORD- IV = JISHFT( HH .AND. M9, 18 ) .OR. IV/C CHECK FOR NON ZERO MANTISSA IF ( IV .NE. 0 ) THEN2C CHECK FOR PROPER NORMALIZATION/ IF ( (IV .AND. MNORMB) .NE. 0 ) THEN+ HH = JISHFT( HH .AND. MEX, 14 ) . .OR., . JISHFT( IV .XOR. MNORMB,-3)<C FLIP WORDS WHILE LOADING OUTPUT LONGWORD IV2(1) = Q(2) IV2(2) = Q(1) IF ( LS ) RV = - RV ELSE IER = 1 IV = 0 END IF END IF RFRD = RV RETURN END ww?MC****************************************************************************#C COPYRIGHT (C) 1983 GLENN EVERHART@C PERMISSION IS GIVEN TO ANYONE TO USE, DISTRIBUTE, OR COPY THIS1C PROGRAM FREELY BUT NOT TO SELL IT COMMERICALLY.C:C VT100 VIDEO DISPLAY COMMAND PROGRAM. CALLING SEQUENCE IS=C CALL UVT100(CMD,N1,N2), WHERE CMD IS ONE OF THE COMMANDS INAC THE PARAMETER LIST BELOW, AND N1 AND N2 ARE OPTIONAL PARAMETERSDC DEPENDING UPON CMD. SEE THE UVT100 USER'S MANUAL FOR MORE DETAILS.CC AUTHOR: GLEN HOFFINGC DATE: 24-FEB-81*C MODIFIED FOR PORTACALC BY GLENN EVERHARTC7c Modified by P.B. Wischow (12 FEBUARY 1986) for GRADS.CMC****************************************************************************% subroutine screen (cmd,n1,n2,string): implicit integer*2(a-z)  dimension modes(12); character outbuf*132, string*(*), tempbuf*132, cr*1, esc*1 character*2 sgr(8)2 data sgr/' 1',' 4',' 5',' 7','22','24','25','27'/ data cr/13/, esc/27/& data modes/1,2,3,4,5,6,7,8,25,2,4,20/$ common /TERMINAL/ ttchan, iterminal if (passit.eq.0) then passit = 11 if (ttchan.eq.0) call GET_TERMTYPE(iterminal) if (iterminal.ge.96) thenC open (99,file='TT:',carriagecontrol='NONE',status='UNKNOWN') end if end if if (iterminal.lt.96) then% call STRING_LENGTH(string,strlen)# write(*,99998) string(1:strlen)99998 format(1x,a) return end if tempbuf(1:132)=' ' tempbuf(1:1)=esc tempbuf(2:2) = '['? goto (100,200,300,400,500,600,700,800,900,1000,1100,1200,1300,* * 1400,1500,1600,1700,1800,1900) cmd4100 call POSITIONS(tempbuf,n1,n2) ! CURSOR POSITION tempbuf(9:9)='H' goto 888888200 call ENCODE_VALUE(tempbuf(3:4),n1) ! MOVE CURSOR UP tempbuf(5:5)='A' goto 88888:300 call ENCODE_VALUE(tempbuf(3:4),n1) ! MOVE CURSOR DOWN tempbuf(5:5)='B' goto 88888;400 call ENCODE_VALUE(tempbuf(3:5),n1) ! MOVE CURSOR RIGHT tempbuf(6:6)='C' goto 88888:500 call ENCODE_VALUE(tempbuf(3:5),n1) ! MOVE CURSOR LEFT tempbuf(6:6)='D' goto 888886600 call POSITIONS(tempbuf,n1,n2) ! DOUBLE WIDTH LINE tempbuf(9:9)='H' tempbuf(10:10)=tempbuf(1:1) tempbuf(11:11)='#'  tempbuf(12:12)='6' goto 888887700 call POSITIONS(tempbuf,n1,n2) ! DOUBLE HEIGHT LINE tempbuf(9:9)='H' tempbuf(10:10)=tempbuf(1:1) tempbuf(11:11)='#'710 if (pass.eq.0) then! tempbuf(12:12)='3' ! top half pass = 1 else tempnum=n1+1+ call ENCODE_VALUE(tempbuf(3:4),tempnum)$ tempbuf(12:12)='4' ! bottom half pass = 0 end if goto 88888'800 tempbuf(2:2)='8' ! RESTORE CURSOR goto 88888$900 tempbuf(2:2)='7' ! SAVE CURSOR goto 88888+1000 tempbuf(2:2)='#' ! SINGLE WIDTH LINE tempbuf(3:3)='5' goto 88888 1100 if (n1.eq.0) then ! ERASE. tempbuf(3:3)='0' ! erase from cursor down else if (n1.eq.1) then: tempbuf(3:3)='1' ! erase from beginning to cursor else) tempbuf(3:3)='2' ! erase entire display end if tempbuf(4:4)='J' goto 88888(1200 if (n1.eq.0) then  ! ERASE IN LINE8 tempbuf(3:3)='0' ! erase from cursor to end of line else if (n1.eq.1) then6 tempbuf(3:3)='1' ! erase beginning of line to cursor else& tempbuf(3:3)='2' ! erase entire line end if tempbuf(4:4)='K' goto 88888! ! SET SCREEN GRAPHICS RENDITION1300 if (n1.eq.0) then3 tempbuf(3:3)='0' ! All attributes off (reset) else inc = 3 do while (i.lt.8) if (BTEST(n1,i)) then= tempbuf(inc:inc+1) = sgr(i+1) ! Set specific attributes tempbuf(inc+2:inc+2) = ';' inc = inc + 3 end if i = i + 1 end do end if call STRING_LENGTH(tempbuf,len) tempbuf(len:len)='m' goto 8888851400 tempbuf(2:2)='E' ! 8 BIT CONTROL CHARACTER FOR goto 88888*1500 if (n1.eq.0) then ! DESIGNATE HARD  ! CHARACTER SETS tempbuf(2:2)='(' ! as G0 else tempbuf(2:2)=')' ! as G1 end if if (n2.eq.0) then+ tempbuf(3:3)='A' ! British chars else if (n2.eq.1) then-  tempbuf(3:3)='B' ! ASCII chars else+ tempbuf(3:3)='0' ! special graphics end if goto 88888#1600 tempbuf(3:3)='?' ! SET MODES* call ENCODE_VALUE(tempbuf(4:5),modes(n1)) tempbuf(6:6)='h' goto 88888%1700 tempbuf(3:3)='?' ! RESET MODES* call ENCODE_VALUE(tempbuf(4:5),modes(n1)) tempbuf(6:6)='l' goto 88888:1800 tempbuf(2:2)='<' ! DEC SUPPLEMENTAL HARD CHARACTER ) goto 88888 ! SET (VT200 mode only)=1900 call POSITIONS(tempbuf,n1,n2) ! DEFINE SCROLLING REGION tempbuf(9:9) = 'r'88888 outbuf = tempbuf" call DELETE_BLANKS(outbuf,buflen) if (string.ne.' ') then% call STRING_LENGTH(string,strlen)* if (string(strlen:strlen).eq.':') then5 outbuf=outbuf(1:buflen)//string(1:strlen)//' ' buflen=buflen+strlen+1 else0 outbuf=outbuf(1:buflen)//string(1:strlen) buflen=buflen+strlen end if end if! write(99,99999) outbuf(1:buflen)99999 format(a)< if (cmd.eq.7.and.pass.eq.1) goto 710 ! for double wide line return end# subroutine POSITIONS(buffer,n1,n2) implicit integer*2(a-z) character*(*) buffer # call ENCODE_VALUE (buffer(3:4),n1) buffer(5:5)=';'# call ENCODE_VALUE (buffer(6:8),n2) return end$ subroutine ENCODE_VALUE(buffer,num) implicit integer*2(a-z) character*(*) buffer length = LEN(buffer) if (length.eq.3) then$ if(num.gt.0.and.num.lt.133) then% ENCODE(3,101,buffer) num101 format(i3) else buffer=' 1' end if else# if(num.gt.0.and.num.lt.25) then% ENCODE(2,102,buffer) num102 format(i2) else buffer=' 1' end if end if return endww`0[pOc******************************************************************************6c This subroutine will set the VT100 scroll reqion for8c the VAX Professional Workstation tasks. Input is the 7c terminal type, the the top and bot line defining the 8c scrollT.Ce PROGRAM Mail_Message C IDENT /1/i2 CHARACTER*6 Cmessage ! Where we write the answer* CHARACTER*80 Cbuf ! Command line buffer INTEGER*2 Nmessage ! INTEGER*4 Ilength !7 CALL LIB$GET_FOREIGN(Cbuf,,Nchar) ! Get a command line*. IF(Nchar.EQ.0) GOTO 9999 ! Exit if no input/ IF (Nchar.GT.31) Nchar=31 ! Force name lengtha. CALL Check_Mail(Cbuf(1:Nchar),Nchar,Nmessage)2 IF(Nmessage.LT.0) THEN ! Compute width of string Iwdth=2 ! to output6 ELSE IF(Nmessage.GT.-1 .AND. Nmessage.LT.10) THEN Iwdth=16 ELSE IF(Nmessage.GE.10 .AND. Nmessage.LT.100) THEN Iwdth=26 ELSE IF(Nmessage.GE.100 .AND. Nmessage.LT.1000) THEN Iwdth=3 6 ELSE IF(Nmessage.GE.1000.AND. Nmessage.LT.10000) THEN Iwdth=4 ELSEg Iwdth=5  END IF 8 WRITE(Cmessage(1:Iwdth),10)Nmessage ! Encode the number10 FORMAT(I) > Istatus=LIB$SET_SYMBOL('MAIL_MSG_NUMBER',Cmessage(1:Iwdth),1)9999 ENDC+@C Check_Mail Check the User Authorization File to see how many1C unread mail messages the user has. The valueeC is returned in NmessageiC/)C CALL Check_Mail(Cname,Ilength,Nmessage)C C Where:"C Cname Character*12 User name C Ilength I*4 length of name.C Nmessage I*2 0 -> Number of mail messages(C -1 User Not Found in VMSMAIL.DAT(C -2 VMSMAIL.DAT can not be openedC*0C Modified: J. Downward 28-Jan-1985 V4.0 UpdateCSC VMSMAIL.DAT Isam Formats&C |Username....|.Fut. Exp....| 0 |Cnt|-C 1 12 31 33 36*C-. SUBROUTINE CHECK_Mail(Cname,Ilength,Imessage) CHARACTER*1 CBUFp CHARACTER*80 CBUF2r" CHARACTER*31 Cname ! User name( CHARACTER*256 CSTRING ! Data buffer$ INTEGER*2 Nmessage,Imessage ! LOGICAL*1 Lmessage(2) !w( EQUIVALENCE (Lmessage(1),Nmessage) !C CALL ERRSET(67,,.FALSE.,.TRUE.,.FALSE.) ! Is OK if rec too short u; OPEN(UNIT=1,NAME='SYS$SYSTEM:VMSMAIL.DAT', ! The Mail File/ - STATUS='OLD', ! is an OLD filem, - REA DONLY, ! with read only) - SHARED, ! shared accessa: - ORGANIZATION='INDEXED', ! Indexed and will * iostat=istat,7 - RECORDTYPE='VARIABLE', ! search via then, - ACCESS='KEYED', ! first key7 - KEY=(1:31:CHARACTER), ! the user's name) - ERR=9900) ! Exit on error ( Imessage=-1 ! assume user not found3 call STR$UPCASE(Cname(1:Ilength),Cname(1:Ilength)) A IF(Ilength.LT.31)Cname(Ilength+1:31)=' ' ! Pad with spaces JGD1i4 READ(UNIT=1,KEYEQ=cname(1:31), ! Unformatted read* - KEYID=0, ! on key 0) - ERR =10)CSTRING ! n+10 CALL ERRSNS(Ier,irms1,Irms2,Iunit,Icond)o IF(Ier .NE. 67) GOTO 9020)C write(*,5)Cstring(1:12),Cstring(33:34) nC5 format(' 'a,4x,a)$15 Lmessage(1)=Ichar(Cstring(34:34))" Lmessage(2)=Ichar(Cstring(33:33))C write(*,16)Nmessagel3C16 format(' you have ',I6,' unread mail messages')sC10 read(unit=1,end=30)CstringKc IF(Cname(1:Ile ngth).NE.Cstring(1:Ilength)) GOTO 30! Force exact matchJGD1: c GOTO 10c Imessage=Nmessage*9020 CLOSE(Unit=1) ! Close VMSMAIL.DAT RETURN ! user not in file+9900 Imessage=-2 ! Error opening SYSUAFu4C TYPE *, 'SYS$SYSTEM:VMSMAIL.DAT can not be opened' RETURN ! for read END !swwere5020 format(q,a)" call STRING_LENGTH(where,size) goto 4020 where = blanks size = 0 end if40 call STR$UPCASE(where,where) if (size.eq.0) then where = 'SYS$LOGIN' size = 93 set = .TRUE.  end if offset = INDEX(where,'PRE') if (offset.ne.0) then6 if ((where(offset+3:offset+3).ne.blank).and.4 * (where(offset+3:offset+3).ne.null)) goto 60C call TRAN_LOGNAME(*3,'PREV_DIR',where,size,'LNM$PROCESS_TABLE') set = .TRUE.3 if (size.eq.0) then where = 'SYS$LOGIN' size = 9 end if end if 60 offset = INDEX(where,':') - 1 if (offset.eq.-1) offset = size6 call TRAN_LOGNAME(*80,where(1:offset),dir,dirlen,' ') set = .TRUE. if (offset.ne.size) then savesize = size - offset - 1* save(:savesize) = where(offset+2:size) size = dirlen + savesize= where(1:size) = dir(:dirlen-1)//'.'//save(:savesize)//']'* where(size+1:255) = blanks(size+1:255) else where = dir size = dirlen end if 80 continue" if (where(size:size).ne.':') then* if (INDEX(where(:size),'[').eq.0) then do idx = size,1,-1-  if (where(idx:idx).eq.':') goto 100 end do idx = 0100 idx = idx + 1/ where(idx:size+1) = '['//where(idx:size) size = size + 1 end if+ if (INDEX(where(:size),']').eq. 0) then size = size + 1 where(size:size) = ']' end if end if do i=1,size+ if (where(i:i).eq.'\') where(i:i) = '-' end do  if (set) goto 120. offset = INDEX(where,'::') ! Check for node if (offset.eq.0) then if (curnode.ne.node) then! save(:size) = where(:size) slen = size size = slen + cnlen2 where(:size) = curnode(:cnlen)//save(:slen) offset = cnlen end if else0 if (where(:offset+1).eq.node(:nodelen)) then nsize = size - offset - 1+ where(:nsize) = where(offset+2:size) size = nsize offset = 0 else offset = offset + 1 end if end if= offset1 = INDEX(where(offset+1:size),':') ! Check for device if (offset1.eq.0) then slen = size - offset& save(:size) = where(offset+1:size)! size = offset + slen + cddlen5 where(offset+1:size) = cdev(:cddlen)//save(:slen) offset1 = offset + cddlen end if2 if (offset1.ge.size) then ! Check for directory size = offset +cdlen* where(offset1+1:size) = curdir(:cdlen) end if# offset1 = INDEX(where(1:size),'[')+ if (where(offset1+1:offset+1).eq.'.') then oldsize = size size = size + cdlen - 2/ where(offset+1:size) = curdir(2:cdlen-1)//! * where(offset1+1:oldsize)0 else if (where(offset1+1:offset+1).eq.'-') then oldsize = size size = size + cdlen - 14 where(offset+1:size) = curdir(2:cdlen-1)//'.'//! * where(offset1+1:oldsize)- else if (INDEX(where(1:size),']').eq.0) then oldsize = size size = size + cdlen , where(oldsize+1:size) = curdir(1:curlen) end if 120 idx = 04 status = LIB$FIND_FILE(where(:size),dir,idx,'*.*',)1 if ((.not.status).and.(status.ne.RMS$_FNF)) then6 j = SYS$GETMSG(%val(status),length,error,%val(3),)- write(out_unit,5030) bell,error(2:length)+5030 format(' ',a1,'%IN-I-',a)* write(out_unit,5050) curnode(:cnlen)//' * cdev(:cddlen)//curdir(:cdlen) goto 140 end if dirlen = INDEX(dir,']')> idx = INDEX(dir(:dirlen),'[') - 1 ! Separate device/directory/ status = LIB$SET_LOGICAL('SYS$DISK',dir(:idx))- if (.not.status) call LIB$STOP(%val(status))> status = SYS$SETDDIR(dir(idx+1:dirlen),,) ! Set the directory- if (.not.status) call LIB$STOP(%val(status))6 status = LIB$SET_LOGICAL('PREV_DIR',curdev(:cdvlen)// * curdir(:cdlen))  if (INDEX(dir,'::').eq.0) then5 write(out_unit,5050) node(:nodelen)//dir(:dirlen) else offset = 1( do while (dir(offset:offset).eq.'_') offset = offset + 1 end do+ write(out_unit,5050) dir(offset:dirlen),5050 format(' New default directory: ',a) end if140 endww~Fc********************************************************************* c* SET_MODE%c* c* AVAILABLE MODES: 0 = resetc* 1 = no broadcastc* 2 = no echoc* 4 = no wrap aroundFc********************************************************************* subroutine set_mode(mode) implicit integer*2(a-z) include '($SYSSRVNAM)' include '($TTDEF)' include '($IODEF)'+ integer*4 status, old_char(2), new_char(2)$ common /TERMINAL/ ttchan, iterminal6 data setm ode /IO$_SETMODE/, sensemode /IO$_SENSEMODE/ if (mode.ne.0) then> if (ttchan.eq.0) status = SYS$ASSIGN('SYS$INPUT',ttchan,,)6C***** FIND THE CURRENT TERMINAL CHARACTERISTICS *****5 status = SYS$QIOW (,%val(ttchan), %val(sensemode)- * ,,,,old_char, %val(8),,,,)A if (.not. status) call LIB$STOP (%val(status)) ! Die if fails: new_char(1) = old_char(1) ! Transfer characteristics: new_char(2) = old_char(2) ! Transfer characteristicsE if (BTEST(mode,0 )) new_char(2) = IBSET(new_char(2),TT$V_NOBRDCST)C if (BTEST(mode,1)) new_char(2) = IBSET(new_char(2),TT$V_NOECHO)A if (BTEST(mode,2)) new_char(2) = IBCLR(new_char(2),TT$V_WRAP)1C***** SET THE NEW TERMINAL CHARACTERISTICS *****3 status = SYS$QIOW (,%val(ttchan), %val(setmode)- * ,,,,new_char, %val(8),,,,)2 if (.not. status) call LIB$STOP (%val(status)) else;C***** RESTORE TERMINAL CHARACTERISTICS (IF MODIFIED) *****3 status = SYS$QIOW (,%val(ttchan), %val(setmode)1 * ,,,,old_char, %val(8),,,,) 2 if (.not. status) call LIB$STOP (%val(status)) end if return endww" subroutine set_processname(pname) implicit integer*4(a-z) include '($SYSSRVNAM)' character*(*) pname status = SYS$SETPRN(pname)- if (.not.status) call LIB$STOP(%val(status)) return endww YJ;*************************************************************************: .TITLE SNDOPR - send message to central operators console;1; Written by P.B. Wischow 25 November 1986;&; FORTRAN call: call SNDOPR(message)C; The message is a string up to 255 characters long. Any carriage @; control (linefeeds and CR's must be included by the calling ; routine.J;************************************************************************* $OPCDEF ; Macro definitions% .PSECT SNDOPR_DATA,noexe,rd,wrt,long8buff: .blkb 263 ; 255 characters + 8 for control words desc: .blkl 1 .address buff .PSECT SNDOPR,exe,rd,nowrt,long .entry SNDOPR, ^M5 movq @4(ap), r6 ; Address of user string descriptor, movb #OPC$_RQ_RQST,buff ; Request code type9 movl #OPC$M_NM_CENTRL,buff+1 ; Send to CENTRAL operator & movl #666,buff+4 ; User message code$ movzwl r6, r8 ; Length of message7 addl3 r8, #8, desc ; Compute length of message buffer6 movc5 r8,(r7),#^A/ /,r8,buff+8 ; Load message to send( $SNDOPR_S msgbuf=desc ; Send message  ret .endww` Kc**************************************************************************c***** STRING_LENGTH c*****Fc***** This routine counts the number of characters in a string after 5c***** the trailing blanks and tabs are truncated.c***** c***** P.B.Wischow August 1985Kc**************************************************************************( subroutine string_length(string,length) implicit integer*2(a-z) character *(*) string character*255 save integer*4 STR$TRIM,status save=string" status=STR$TRIM(save,save,length) return endww]?;************************************************************** ;***** STRIPD;*****;;***** AUTHOR AND DATE: MARIA KALCIC CODE 022 1 JUNE 1984;*****;;***** DESCRIPTION: This routine strips the descriptor off );***** the character string.;*****5;***** FORTRAN CALL: call STRIPD(in,nchars,out);*****;***** PARAMETERS: ;***** /;***** in: Input array or character string.1;***** (integer*2, or character string)9;***** nchars: Number of characters or bytes in "IN".;*****1;***** out: Output array or character string.2;***** (integer*2, or character string);*****#;***** SUBROUTINES REQUIRED: none;*****2;***** This routine is used by the Calcomp SYMBOL.;*****?;************************************************************** .title stripd .psect dta,long,nowrt! .entry stripd,^m moval @4(ap),r3 movl @8(ap),r2 moval @12(ap),r7 movl #0,r6 movl #1,r4 movl (r3)[r4],r5labl: cmpl r2,r6 beql done movb (r5)[r6],(r7)[r6] incl r6 brw labldone: ret .endww  Hc***********************************************************************:c This routine will display the title for Vax Professional=c workstation tasks. Input is the title (passed as a literal;c string). The terminal type must be previously defined by$c the global symbol "TERMINAL_TYPE".Hc*********************************************************************** program title implicit integer*2(a-z)3 integer*4 status, LIB$GET_FOREIGN, LIB$GET_SYMBOL character*30 ititle character*10 ident character*1 cesc, cnull, cbell character*3 dblu,dbll character*4 rvid, cbold, cnorm character*7 type character*80 spaces, command! character*100 titleu,titlel,msg2 character*100 blank_lineu,blank_linel,blank_line" data cesc/27/, cnull/0/, cbell/7/@ status = LIB$GET_SYMBOL(%descr('TERMINAL_TYPE'),%descr(type),,) if (.not.status) goto 99999 spaces = ' '' status = LIB$GET_FOREIGN(command,,len). if (len.eq.0) goto 99999 ! No parameters!!! comma = INDEX(command,',')- if (comma.eq.0) then ! No identity phrase ititle = command(1:len) ititle_length = len ident_length = 0 else ititle = command(1:comma-1) ititle_length = comma - 1 ident = command(comma+1:len) ident_length = len - comma  end if9 if (type.ne.'UNKNOWN') then ! If a VT100 type terminal cbold=cesc//'[1m' cnorm=cesc//'[0m' save_length=ititle_length! ititle_length=ititle_length+4: pre_length=(40-Ititle_Length)/2 ! # of prefill spaces2 dblU=cesc//'#3' ! Convert to dbl ht top line2 dblL=cesc//'#4' ! Convert to dbl ht bot line& rvid=cesc//'[7m' ! Reverse video: blank_linel=dbll//rvid//spaces(1:ititle_length)//cnorm itemp=ident_length/2 !' fill_length=ititle_length - itemp ! if (ident_length.eq.0) then blank_line = blank_linel elseS blank_line=rvid//spaces(1:fill_length)//ident(1:ident_length) ! Insert Ident3 call STRING_LENGTH(blank_line,length) E if (2*itemp.lt.ident_length) then ! Compensate for odd length+ blank_line=blank_line(1:length)//: * spaces(1:fill_length-1)//cnorm ! Ident strings else+ blank_line=blank_line(1:length)//& * spaces(1:fill_length)//cnorm end if ! end if != titleU=DblU//Rvid//' '//cnorm//' '//Ititle(1:save_length)+ * //' '//cnorm//Rvid//' '//cnorm= titleL=DblL//Rvid//' '//cnorm//' '//Ititle(1:save_length)( * //' '//cnorm//Rvid//' '//cnorm* call STRING_LENGTH(blank_linel,length)< write(*,1001) spaces(1:pre_length),Blank_Linel(1:length)1001 format('+',a,a,a)% call STRING_LENGTH(titleu,length)7 write(*,1000) spaces(1:pre_length),TitleU(1:length)% call STRING_LENGTH(titlel,length)7 write(*,1000) spaces(1:pre_length),TitleL(1:length)1000 format(1x,a,a,a)) call STRING_LENGTH(blank_line,length) if (ident_length.eq.0) then> write(*,1000) spaces(1:pre_length),blank_line(1:length) else? write(*,1000) spaces(1:pre_length),spaces(1:pre_length), * Blank_line(1:length) end if else , call STRING_LENGTH(ititle,ititle_length)7 length=(80-Ititle_Length)/2 ! # of prefill spacesK call FILL_STRING(titlel,'*',ititle_length+4) ! Fill top line with stars8 titlel = spaces(1:length)//titlel(1:ititle_length+4)6 write(*,1100) titlel(1:length+ititle_length+4)1100 format(1x,a)% titleu = spaces(1:length)//'* '//' * ititle(1:ititle_length)//' *'2 write(*,1100) titleu(1:length+ititle_length+4)6 write(*,1100) titlel(1:length+ititle_length+4)5 length=(80-ident_Length)/2 ! # of prefill spaces* write(*,1200) spaces(1:length+2),ident1200 format(/,1 x,a,a) end if 99999 end wwX)a3Nc*****************************************************************************;c***** TRAN_LOGNAME P.B.Wischow 19 FEB 1985c*****?c***** This routine translates a logical name until it finallyFc***** locates the base equivalent name. By default the following Hc***** logical name tables are searched in this order: LNM$PROCESS, +c***** LNM$JOB, LNM$GROUP, LNM$SYSTEM. c*****Rc***** FORTRAN call: call TRAN_LOGNAME(*100,logname,equivname,equivlen,table)c*****c***** Where:4c***** return1: No logical name translation found.c*****0c***** logname: Logical name to be translated. c***** (passed,character*(*))c*****-c***** equivname: Logical name equivalence."c***** (returned,character*(*))c*****-c***** equivlen: Length of equivalent name.c***** (returned,integer*2)c*****1c***** table: Table to search for logical name. c***** (passed,character*(*))2c***** If blank then the tables are searched in6c***** the default order...else, only the specifiedc***** table is searched.c*****;c***** SUBROUTINES REQUIRED: STRING_LENGTH, System Servicesc*****Nc*****************************************************************************9 subroutine tran_logname(*,temp,equivname,equivlen,table) implicit integer*4(a-z) include '($SSDEF)' include '($LNMDEF)' integer*2 equivlen% character*(*) temp, equivname, table character*12 logname_table character*255 logname logical found structure /TRNLNM/ integer*2 buflen, itemcode% integer*4 bufadr, retadr, endlist end structure record /TRNLNM/ list# data logname_table/'LNM$FILE_DEV'/ list.itemcode = LNM$_STRING list.buflen = LEN(equivname) list.bufadr = %loc(equivname) list.retadr = %loc(equivlen)$ call STRING_LENGTH(temp,lognamelen) logname = temp(1:lognamelen) found = .FALSE.6 mask = LNM$M_CASE_BLIND ! Ingore upper & lower case equivname = ' ' if (table(1:1).eq.' ') then-10 status = SYS$TRNLNM(mask,logname_table,% * logname(1:lognamelen),,list) if (status) then& logname = equivname(1:equivlen) lognamelen = equivlen) found = .TRUE. ! Have found one 2 goto 10 ! Go look for another level down end if else? status = SYS$TRNLNM(mask,table,logname(1:lognamelen),,list) end if! if (status.eq.SS$_NOLOGNAM) then if (found) then( equivname = equivname(1:equivlen) r eturn else equivname = ' ' equivlen = 0 return1 end if end if- if (.not.status) call LIB$STOP(%val(status)) end wwvJC+ C Type_PageC>C Type_Page is a foreign command which will type out a section<C of an ASCII sequential file. The format of the command isC (C TYPE_PAGE /Start=xxx/End=zzzC?C Starting with line 'xxx' in the file, the file contents up to-C and including line 'zzz' will be displayed.C C Writen by:C James G. DownwardC KMS Fusion, Inc.C P.O. Box 1567C Ann Arbor, Mich. 48106C (313)-769-8500C November 6, 1984C- PROGRAM Type_PageCC IDENT /V1.0/C  CHARACTER*15 Cswitch1 CHARACTER*15 Cswitch2" CHARACTER*80 Cfile ! File name3 CHARACTER*132 Command_Line ! Command Line buffer/ CHARACTER*180 Cbuffer ! Input/output buffer: LOGICAL*1 Lswtch1 /.FALSE./ ! Do not have switch 1: LOGICAL*1 Lswtch2 /.FALSE./ ! Do not have switch 2( INTEGER*4 Istart_Line ! Starting Line. INTEGER*4 Ilast_Line ! Last line to display INTEGER*4 Istatus !% INTEGER*4 Ipos,Ilength,Name_length !E Istatus=LIB$GET_FOREIGN(Command_Line,'_Command: ',! Get command line - Ilength,) !5 IF(Ilength.EQ.0) CALL EXIT ! Give up if no command10 format(' 'A)= Ipos=INDEX(Command_Line(1:Ilength),'/') ! Find first switch4 IF(Ipos .EQ.0) GOTO 8000! If missing, exit/ Cfile=Command_Line(1:Ipos-1) ! Get file name Name_Length=Ipos-1 !3 Command_Line=Command_Line(Ipos+1:Ilength) ! Repack% Ilength=Ilength-Ipos ! New length1 Ipos=INDEX(Command_Line,'/') ! Get next switch4 IF(Ipos .EQ.0) GOTO 8000! If missing, exit5 Cswitch1=Command_Line(1:Ipos-1) ! Get first switch: IF(Cswitch1(1:1) .NE. 'S' .AND. ! Check for valid swtchG - Cswitch1(1:1) .NE. 'E') GOTO 8020! and die if missing Ilen1=Ipos-1 !6 Cswitch2=Command_Line(Ipos+1:) ! Isolate 2nd switch Ilen2=(Ilength-Ipos) !: IF(Cswitch2(1:1) .NE. 'S' .AND. ! Check for valid swtchG - Cswitch2(1:1) .NE. 'E') GOTO 8020! and die if missing, IF(Cswitch1(1:1) .EQ. 'S') Lswtch1=.TRUE. !, IF(Cswitch1(1:1) .EQ. 'E') Lswtch2=.TRUE. !, IF(Cswitch2(1:1) .EQ. 'S') Lswtch1=.TRUE. !, IF(Cswitch2(1:1) .EQ. 'E') Lswtch2=.TRUE. ! A IF(.NOT. Lswtch1 .OR. .NOT. Lswtch2) GOTO 8000! If one missingH CALL Get_Value(Cswitch1(1:Ilen1),Iline,Istatus) ! Get the numeric value: IF(Istatus .NE. 1)  GOTO 8040! Was any value there" IF(Cswitch1(1:1) .EQ.'S') THEN ! Istart_line=Iline ! ELSE ! Ilast_Line=Iline ! END IF !H CALL Get_Value(Cswitch2(1:Ilen2),Iline,Istatus) ! Get the numeric value: IF(Istatus .NE. 1) GOTO 8040! Was any value there" IF(Cswitch2(1:1) .EQ.'S') THEN ! Istart_line=Iline ! ELSE ! Ilast_Line=Iline ! END IF !> IF(Ilast_Line .LT.Istart_Line) GOTO 8060 ! Sanity check$c WRITE(*,20)Istart_Line, Ilast_Linec20 Format(' '2I10)" OPEN( Unit =1, ! Open the file, - Name =Cfile(1:Name_Length), ! - Type ='Old', ! - Readonly, ! - Shared, ! - ERR =8100) ! Iline=0 ! Line counter1100 READ(1,110,END=300)N,Cbuffer ! Read in file110 FORMAT(Q,A) !" Iline=Iline+1 ! Count lines< IF(Iline .GE. Istart_Line .AND. ! Only write out if line? - Iline .LE. Ilast_Line) THEN ! read in is between3 WRITE(*,120)Cbuffer(1:n) ! start/end lines120 FORMAT(' ',A) ! END IF !9 IF(Iline+1.GT.ILast_Line) GOTO 200! Stop if too large GOTO 100 ! Loop till done200 CLOSE(Unit=1) !) CALL EXIT (1) ! Exit, show more left300 CLOSE(UNIT=1) !% CALL EXIT(13) ! Show end of file8000 WRITE(*,8010)D8010 FORMAT(' Type_Page -- Fatal. /START or /END switch is missing') GOTO 99998020 WRITE(*,8030)-8030 FORMAT(' Type_Page -- Unknown switch. ',4 - 'Only switches /START and /END are allowed') GOTO 99998040 WRITE(*,8050)<8050 FORMAT(' Type_Page -- Starting or ending line number '," - 'not specified correctly') GOTO 99998060 WRITE(*,8070)D8070 FORMAT(' Type_Page -- Fatal. Last line preceeds starting line') GOTO 9999&8100 WRITE(*,8110)Cfile(1:Name_Length)D8110 FORMAT(' Type_Page -- ',A,' can not be opened for read access') GOTO 99999999 CALL EXIT(3) END, SUBROUTINE Get_Value(Cswitch,Iline,Istatus), CHARACTER*(*) Cswitch ! Switch to decode# INTEGER*4 Iline ! Value to read) INTEGER*4 Istatus ! Success indicator Istatus=-1 ! Assume failure- Ipos=INDEX(Cswitch,'=') ! Get deliminator3 IF(Ipos .EQ.0) RETURN ! give up if missing8 IF(Ipos .EQ. LEN(Cswitch)) RETURN ! Value missing ; READ(Cswitch(Ipos+1:),10,ERR=100)Iline ! So get the value!10 FORMAT(I5) ! Get the value Istatus=1 ! Show success100 RETURN ! ENDwwfPy .TITLE UOPEN_PRINT .IDENT /A5.V01/;I;========================================================================; UOPEN_PRINT.MARI;========================================================================;; Copyright (C) 1983;*; EVANS & SUTHERLAND COMPUTER CORPORATION;4; May not be reproduced in whole or in part without3; the prior written consent of Evans & Sutherland.;; E&S PART 908076-061 NC;2; VERSION DATE MODIFIED BY REASON FOR CHANGE5; ------- --------- --------------- -----------------0; A1.V00 24-OCT-80 B. BRIMLEY INITIAL VERSION.;5; A3.V01 25-Feb-82 R.Best A3 Release.;,; A4.V01 29-Jun-83 S.Morgan A4 Release.;,; A5.V01 19-Feb-85 S.Morgan A5 Release.;D; GRADS 25-Jun-86 J.Hammack Changed to submit to print"; instead of batch. Entry is"; now UOPEN_PRINT instead of; uopen.I;========================================================================;5; THIS FILE CONTAINS THE FOLLOWING PROGRAM SEGMENTS:;A; UOPEN_PRINT SUBROUTINE USED TO OPEN A FILE WITH THE SPOOL TO; BATCH QUEUE OPTION SET.;L;==========================================================================\;Q; THE SUBROUTINE UOPEN_PRINT IS USED TO OPEN A FILE WITH THE SPOOL TO PRINT QUEUE ; OPTION SET.;; FORTRAN CALLING SEQUENCE:; ; OPEN ( USEROPEN=UOPEN_PRINT );M;----------------------------------------------------------------------------* $FABDEF ; DEFINE ALL FAB BITS & OFFSETS .ENTRY UOPEN_PRINT, ^M<># MOVL 4(AP),R0 ; GET ADDRESS OF FABA INSV #1,#FAB$V_SPL,#1,FAB$L_FOP(R0) ; SET SUBMIT TO PRINT OPTION8 INSV #1,#FAB$V_DLT,#1,FAB$L_FOP(R0) ; SET DELETE OPTION# $CREATE FAB = @4(AP) ; CREATE FILE BLBC R0,10$ ; BRANCH IF ERROR/ $CONNECT RAB = @8(AP) ; CONNECT STREAM TO FILE7 10$: RET ; RETURN WITH R0 SET TO SUCCESS OR FAILURE. .END ww`م PROGRAM VPWDIRECTC<C Provide a program which will provide a formatted directory:C listing of names only. VPWDIRECT is designed to be used:C as a foreign commmand. The command line passes both the=C directory wild card search string, and the title to displayC if any files are found.C5C VPWDIRECT Search_String[|"Title...Title....Title"]C __ _8C Note that the _" and the trailing " in the title line<C are required if a title is present. The title is optional.CC The display is set to CC Title...Title...TitleC C File1 File2 File3 File4C File5 File6 File7 File8C File9 File10 file11 File12CC Written by: Version 1.0C April 8,1983C James G. DownwardC KMS Fusion, Inc.C P.O. Box 1567C Ann Arbor, Mich. 48106C (#13)-769-8500CC-6 logical*1 ltitle_flag /.False./ ! Assume not printed7 logical*1 lfound_one /.False./ ! Assume no files found$ character*1 cnull /0/ ! null byte) character*80 cfile ! File name string- character*80 csearch ! File search string* chara cter*80 ctitle ! Title to display. character*80 outline ! Output display line% character*132 command_line ! Input integer*2 ilength ! integer*4 istatus,icontext !: istatus=LIB$GET_FOREIGN(command_Line,'Command: ',ilength)3 if (ilength.eq.0) goto 9999 ! Exit if no command ctitle=cnull ! Set to null@ ipos=INDEX(command_line(1:ilength),'|"') ! Find delim sep title+ if (ipos.eq.0) then ! If none then just1 ipos=LEN(csearch)+1 ! use search string else  ! Else= ctitle=command_line(ipos+2:ilength-1) ! set title line end if !# csearch=command_line(1:ipos-1) ! outline=' ' ! Blank fill" icntr=0 ! start counter at 0E50 istatus=LIB$FIND_FILE(csearch,cfile,icontext) ! Get next file spec2 if (.not.istatus) goto 200 ! If done, finish up- lfound_one=.TRUE. ! Show found at least 1* icntr=icntr+1 ! Point to dsp position2 ipos1=INDEX(cfile,']') ! find end of [] string7 ipos2=INDEX(cfile(ipos1:80),'.') ! fin d start of type ipos2=ipos1+ipos2-1 !+ iloc=icntr*20-15 ! find output location5 outline(iloc:)=cfile(ipos1+1:ipos2-1) ! Set in name0 if (icntr.lt. 4) then ! Only dsply 4 columns( goto 50 ! If not there get next else ! If there9 if (.not.ltitle_flag .and. ! Write title one time> * ctitle(1:1).ne.cnull) then ! If title not null9 call STRING_LENGTH (ctitle,ilength) ! Find total length3 write(*,80)ctitle(1:ilength) ! only, if present80  format(' ',a,/) !1 ltitle_Flag=.TRUE. ! Show we wrote it end if !, call STRING_LENGTH (outline,ilength) !8 write(*,100) outline(1:ilength) ! output the names100 format(' 'a) !* outline=' ' ! Reset to all blanks icntr=0 ! Reset counter goto 50 ! Back for more end if !6200 if (.NOT. ltitle_flag .and. ! Last time through0 * lfound_one .and. ! write title if not( * ctitle(1:1).ne.cnull) then  !< call STRING_LENGTH (ctitle,ilength) ! Find total length4 write(*,80)ctitle(1:ilength) ! written before end if !( call STRING_LENGTH (outline,ilength) !F if (icntr.gt.0) write(*,100)outline(1:ilength) ! write outline if nec9999 end ! all donewwǠ PROGRAM VAXUSERS  C FACILITY: VPWCAC ABSTRACT: This module will give a Yes/No answer when;C querried as to if a user exist in the System UAF.-C To make this querry, the command isC $VAXUSERS username;C The answer is passed as exit status. 1=Yes, 3=No.<C If a user(s) is found, he/she/they will be listed.@C If unsure of the spelling of a user's name, a trailing<C wildcard is allowed and all users having the first4C letters (up to the '*') will be displayed.=C To see who all users are, enter '*' for "username". C CC ENVIRONMENT: VAX/VMS C(C AUTHOR: James G. DownwardC KMS Fusion, Inc.C P.O. Box 1567 C Ann Arbor, Mich. 48106C"C CREATION DATE: 24-Jan-1985CC*C C H A N G E L O GC+C Date ! Name ! DescriptionOC_______________!_____________!________________________________________________FC 28-Jan-1985 J. Downward Use UAFDEF.FOR for V4.0 and henceforthDc 09-May-1986 P.B.Wischow Use DISPLAY_USERS and CHECK_UAF from"c GRADS version of REMINDER. CHARACTER*1 Cbell /7/ CHARACTER*80 Cbuf LOGICAL*1 Is_Found INTEGER*4 Ier,Ilength,Ierror" CALL LIB$GET_FOREIGN(Cbuf,,Nchar). IF(Nchar.EQ.0) GOTO 9999! Exit if no input IF(Cbuf(1:1).EQ.'*') THEN CALL Display_Users(*600) ELSE IF (Nchar.GT.12) Nchar=120 CALL Check_UAF(*500,*600,Cbuf(1:Nchar),Nchar) END IF9999 CALL EXIT (1) ! 500 WRITE(*,210) Cbuf(1:Nchar) !@210 FORMAT(' VAXUSERS -- ',A,' is not registered as a VAX user') goto 8888 !600 WRITE(*,20 0)CbellA200 FORMAT(' VAXUSERS -- Fatal, SYSUAF.DAT can not be opened.',A)8888 CALL EXIT (3) ! ENDLC***************************************************************************9C CHECK_UAF Check the User Authorization File to see if5C the specified user has an account on this system.C'C call CHECK_UAF(*10,*20,Cname,Ilength)CC Where:#C Cname Character*(*) User name C Ilength I*2 length of name(c normal return: Name found in SYSUAF.&c return1: Name not found in SYSUAF.$c return2: Error openning SYSUAF.C#C Modified: 14-Jul-1983 J. Downward$C JGD1 Force exact match on names4c 13-FEB-1986 P.B.Wischow (for general GRADS use),c 7-MAY-1986 P.B.Wischow (DECUS updates)C-( subroutine check_uaf(*,*,cname,ilength) implicit integer*2(a-z)5 include 'GRAVLIB$GENERAL:USER$FORSYSDEF.TLB(UAFDEF)'? include 'GRAVLIB$GENERAL:USER$FORSYSDEF.TLB(UAF_EQUIVALENCES)'# character*12 cname ! User name' character*256 cstring ! Data buffer) e quivalence (UAF_RECORD(0),cstring(1:1))5 open(unit=1,name='SYS$SYSTEM:SYSUAF.DAT', ! The UAF/ - status='OLD', ! is an OLD file, - readonly, ! with read only) - shared, ! shared access: - organization='INDEXED', ! Indexed and will7 - recordtype='VARIABLE', ! search via the, - access='KEYED', ! first key7 - key=(5:36:character), ! the user's name. - err=9900) ! Exit on err or is_found = 13 call STR$UPCASE(cname(1:ilength),cname(1:ilength)) if (ilength.lt.12) then. if (cname(ilength:ilength).ne.'*') then ! 7 cname(ilength+1:12) = ' ' ! Blank rest of name ilength = ilength + 1C else - ilength = ilength - 1 ! Drop off "*" end if end if8 read(unit=1,keyge=cname(1:Ilength), ! Unformatted read* - keyid=0, ! on key 0@ - err =90 20) cstring ! Error -> key not fndT IF(Cname(1:Ilength).NE.UAF_T_Username(1:Ilength)) GOTO 9020 ! Force exact matchJGD1 write(*,5)(5 format(' Username Full Name',/,/ - ' -------- ---------') 2 write(*,11)UAF_T_Username(1:12),UAF_T_Owner(2:32)11 format(' 'a,4x,a)10 read(unit=1,end=30) CstringQ IF(Cname(1:Ilength).NE.UAF_T_Username(1:Ilength)) GOTO 30! Force exact matchJGD13 write(*,11) UAF_T_Username(1:12),UAF_T_Owner(2:32) goto 10'30 CLOSE(UNIT=1) ! Close SYSUAF.DAT return ! Done)9020 close(unit=1) ! Close SYSUAF.DAT return1 ! Done 9900 return2 end !C+Kc**************************************************************************C DISPLAY_USERSC<C Subroutine to display all current users in the VAX account<C file. No check is made as to whether or not the users can=C receive mail (ie they have adequate disk quota) or that the@C 'user' is not a phantom account present to let accounting workAC more smoothly. If the account file can not be opened, RETURN1.C Otherwise, NORMAL RETURN.CC CALL Display_Users(*)Kc**************************************************************************C- subroutine display_users(*) implicit integer*2(a-z)5 include 'GRAVLIB$GENERAL:USER$FORSYSDEF.TLB(UAFDEF)'? include 'GRAVLIB$GENERAL:USER$FORSYSDEF.TLB(UAF_EQUIVALENCES)'! character*12 cname ! User name% character*80 outline ! Output line& character*256 cstring ! Data buffer) equivalence (UAF_RECORD(0),cstring(1:1))CC .. Implied FORM='UNFORMATTED'C* open(unit=1, ! Open the System Account0 - name='SYS$SYSTEM:SYSUAF.DAT',! file* - status='OLD', ! It must exit. - readonly, ! we can only read it+ - shared, ! as a shared file9 - organization='INDEXED', ! It is indexed with> - recordtype='VARIABLE', ! variable length records2 - access='KEYED', ! access it by keys; - key=(5:36:character), ! First key is user name5 - err=9900) ! In case we can't open file Idx=1 !' Outline=' ' ! Fill line with blanks910 read(unit=1,end=9020) cstring ! Read till end of file: Ipos=INDEX(UAF_T_USERNAME(1:12),'NETPRIV') ! Skip DECNET& IF (Ipos.GT.0) goto 10 ! " ": Ipos=INDEX(UAF_T_USERNAME(1:12),'NETNONPRIV') ! " "% IF (Ipos.GT.0) goto 10 ! " "6c if (UAF_W_GRP.le.10) goto 10 ! No display if system Iptr=1+(Idx-1)*15 !& Outline(Iptr:Iptr+12)=CString(1:12) ! IF (Idx.EQ.5) then ! WRITE(*,30)OUTLINE !30 FORMAT(' 'A) ! Outline=' ' ! Idx=0 ! END IF ! Idx=Idx+1 ! goto 10 !'9020 IF(Idx.GT.1) WRITE(*,30)Outline !% close(unit=1) ! Always close file return.9900 return1 ! Fatal, can't open acnt file end !ww쏣ȎHc***********************************************************************=c This subroutine will display the title for Vax Professiona l=c workstation tasks. Input is the title (passed as a literal1c string) and the terminal type found from GETDVIHc***********************************************************************! subroutine vt_title(title,ident) implicit integer*2(a-z) character *(*) title,ident character*1 cesc, cnull, cbell character*3 dblu,dbll character*4 rvid, cbold, cnorm character*80 spacesC character*100 titleu,titlel,msg,blank_lineu,blank_linel,blank_line% common /TERMINAL/ ttchan, iterminal" data cesc/27/, cnull/0/, cbell/7/ call FILL_STRING(spaces,' ',80); if (iterminal .ge. 96 ) then ! If a VT100 type terminal if (pass.eq.0) then cbold=cesc//'[1m' cnorm=cesc//'[0m' pass=1 end if, call STRING_LENGTH(ident,Ident_Length) !, call STRING_LENGTH(title,Title_Length) ! save_length=title_length title_length=title_length+49 pre_length=(40-Title_Length)/2 ! # of prefill spaces2 dblU=cesc//'#3' ! Convert to dbl ht top line2 dblL=cesc//'#4' ! Convert to dbl ht bot line& rvid=cesc//'[7m' ! Reverse video9 blank_LineL=DblL//Rvid//SPACEs(1:title_length)//cnorm itemp=ident_length/2 !& fill_length=title_length - itemp !P Blank_Line=Rvid//spaces(1:fill_length)//Ident(1:ident_length) ! Insert Ident) call STRING_LENGTH(blank_line,length) !B if (2*Itemp.lt.Ident_Length) THEN ! Compensate for odd lengthV Blank_Line=Blank_Line(1:length)//SPACEs(1:fill_length-1)//cnorm ! ident strings else !D Blank_Line=Blank_Line(1:length)//SPACEs(1:fill_length)//cnorm end if ! !< titleU=DblU//Rvid//' '//cnorm//' '//Title(1:save_length)+ * //' '//cnorm//Rvid//' '//cnorm< titleL=DblL//Rvid//' '//cnorm//' '//Title(1:save_length)( * //' '//cnorm//Rvid//' '//cnorm* call STRING_LENGTH(blank_linel,length)< write(6,1000) spaces(1:pre_length),Blank_Linel(1:length)1000 format(1x,a,a,a)% call STRING_LENGTH(titleu,length)7 write(6,1000) spaces(1:pre_length),TitleU(1:length)% call STRING_LENGTH(titlel,length)7 write(6,1000) spaces(1:pre_length),TitleL(1:length)) call STRING_LENGTH(blank_line,length)< write(6,1000) spaces(1:pre_length),spaces(1:pre_length), * Blank_line(1:length) !- esc_char=8 ! 8 extra char for cbold ^Y else ! if (pass.eq.0) then' cbold=cnull//cnull//cnull//cnull cnorm=cbold pass=1 end if* call STRING_LENGTH(t itle,title_length)5 length=(80-Title_Length)/2 ! # of prefill spaces( write(6,1100) spaces(1:length),Title1100 format(/,1x,a,a) esc_char=0 ! end if ! return end ww*@c*************************************************************** c***** WAITc*****+c***** AUTHOR: Jim Hammack 26 June 1984c*****>c***** DESCRIPTION: This routine will cause a process to wait-c***** a specified number of seconds.c*****c***** PARAMETERS: c***** @c***** seconds: The number of seconds that the routine willBc***** wait before returning to the calling program.-c***** (passed,integer*4)c*****2c***** SUBROUTINES REQUIRED: VAX System Services.c*****@c*************************************************************** subroutine wait(seconds) implicit integer*4(a-z) character*24 time" character*2 ahours,aminutes,asecs dimension quad(4) hours=seconds/3600 minutes=(seconds-hours*3600)/60# secs=seconds-hours*3600-minutes*600 status=OTS$CVT_L_TI(%ref(hours),%descr(ahours))4 status=OTS$CVT_L_TI(%ref(minutes),%descr(aminutes)). status=OTS$CVT_L_TI(%ref(secs),%descr(asecs))/ time='0 '//ahours//':'//aminutes//':' // asecs) call SYS$BINTIM(%descr(time),%ref(quad))# status = SYS$SCHDWK(,,%ref(quad),)- if (.not.status) call LIB$STOP(%val(status)) status = SYS$HIBER()- if (.not.status) call LIB$STOP(%val(status)) return endwwF7Kc************************************************************************** c YES_OR_NO 8c This routine check to see if the ANSwer is Y or N.c return1: Yesc return2: Noc return3: NeitherKc************************************************************************** subroutine yes_or_no(*,*,*,ans) implicit integer*2(a-z) character *(*) ans call STR$UPCASE(ans,ans) if (ans(1:1).eq.'Y') then return1 else if (ans(1:1).eq.'N') then return2 else return3 end if endww BCC FUNCTION USED IN EASCIAC function ymp (Z) data ap /0.7853981634/ y = abs(z) * .29088209e-03 t = tan (ap+y*0.5)/ ym = 7915.7045*alog10(t)-23.268932*sin(y) ymp = ym*sign(1.0,z) return endww@6 .TITLE ARGCNT .IDENT /1/;+;A; A fortran callable subroutine to return the number of argumentsA; passed to the previously called subroutine. The call to ARGCNTK; must immediately follow the subroutine statement or as soon as possible).; Normal usage is as follows.;"; SUBROUTINE FOO(N1,N2,N3,.....NN) ; . . . . .6; CALL ARGCNT(NARG) ! NARG IS THE NUMBER OF ARGUMENTS; ! ACTUALLY PASSED TO FOO; ; Written by:; James G. Downward; KMS Fusion, Inc .; P.O. Box 1567; Ann Arbor, Mich. 48106; 01-Apr-1982;- .ENTRY ARGCNT,02 MOVL @8(FP),@4(AP) ; BUMP PREVIOUS CALLS COUNTER RET ; INTO NARG AND RETURN .ENDww0#@7 WISCHOW ARGCNT.MAR3P WISCHOW ARGCNT% 1wh WISCHOW BIGCHARS.MAR#8 WISCHOW BINDEC.FOR! " WISCHOW BOXPAGE. @ WISCHOW BOXPAGE#s WISCHOW BSET_Q.MAR$ WISCHOW BTEST_Q.MAR#@A WISCHOW DECBIN.FOR#O WISCHOW ELTRAN.MAR%QX WISCHOW GETDESCR.MAR# 0u WISCHOW SETDEF.FOR#V} WISCHOW SNDOPR.MAR @Mg) .TITLE BIGCHARS - GENERATE LARGE LETTERS .SBTTL DECLARATIONS $SSDEF $DSCDEF;4; THIS ROUTINE WILL FORMAT A WIDE LINE OF CHARACTERS; ! .psect BIGCHARS_DATA, long,noexeRET_LEN:.blkw 1 ROWS: .blkl 1POINTR: .blkl 1DESCR: .blkq 1SPACING:.blkw 1WIDTH: .blkw 1 SPACEOUT:  .blkw 1 OUTBUF_DESCR: .blkq 1;OUTBUF: .blkb 132 ; .word 132; .byte DSC$K_DTYPE_T; .byte DSC$K_CLASS_S; .address outbuf;" .PSECT BIGCHARS,exe,rd,nowrt,!long; ; MACROS:;2; MACRO TO GENERATE A TABLE FOR CHARACTER DECODING; .MACRO DECTAB HI,LO,TABLE .ASCII \HI'LO\ .WORD TABLE-. .ENDM ;; EQUATED SYMBOLS:;4; DEFINE THE OFFSET TO INPUT ARGUMENTS AS THE APPEAR#; AFTER BEING PUSHED INTO THE STACK;; COUNT = 0 ;BYTE COUNT; ADR = 4 ;BUFFER ADDRESS'; SPACOUT = 8 ;PRECEEDING SPACE COUNT'; HEIGTH = 9 ;NUMBER OF LINES PER ROW/; WIDTH = 10 ;NUMBER OF CHARACTERS PER COLUMN); SPACING = 11 ;INTER CHARACTER "SPACING; ;:; THE FOLLOWING TABLES ARE USED TO GENERATE THE CHARACTERS8; EACH ENTRY IS 35 BITS LONG, 1 BIT FOR EACH POSITION IN; A 5X7 MATRIX.;;ALPHA:< .WORD ^O143056,^O061770,^O030574,^O014276,^O007637,^O102041< .WORD ^O057740,^O030614,^O173706,^O074103,^O176041,^O141037< .WORD ^O020413,^O010370,^O107502,^O143056,^O061770,^O107214< .WORD ^O041020,^O101610,^O141020,^O056430,^O164614,^O014244< .WORD ^O004103,^O102041,^O073437,^O030615,^O014306,^O146547< .WORD ^O135061,^O061430,^#O167214,^O174305,^O004102,^O143056< .WORD ^O111530,^O030575,^O111276,^O007642,^O040701,^O037370< .WORD ^O102041,^O011020,^O106143,^O177061,^O061430,^O105214< .WORD ^O014304,^O156543,^O043061,^O052105,^O030614,^O041052% .WORD ^O174410,^O010420,^O037021,^O0 ; ; BIT MASK TABLE FOR NUMBERS 0-9; NUMERIC:3 .WORD ^O163056,^O121472,^O103043,^O041020,^O105634E .WORD ^O010420,^O056761,^O004204,^O113506,^O175122,^O120410,^O007037E .WORD ^O150602,^O010271,^O106136,^O040756,^O104210,^O0270%$10,^O013506! .WORD ^O071643,^O075061,^O016410 ;$; BIT MASK FOR UNDER SCORE CHARACTER; UNDERSCORE: .WORD ^O0,^O140000,^O7 ;; THE DOLLAR SIGN; DOLLARS: .WORD ^O013704,^O017507,^O1 ;; BIT MASK TABLE FOR '.'; DOT: .WORD ^O0,^O14000,^O3 ;; BIT MASK FOR ':;'; 4COLONS: .WORD ^O30600,^O14300,^O006140,^O103060,^O10 ;; BIT MASK TABLE FOR ' '; BLANK: .WORD ^O0,^O0,^O0 @; THE FOLLOWING TABLE IS USED TO DECODE WHICH BIT TA%BLE CONTAINS*; THE INFORMATION ABOUT A GIVEN CHARACTER.;DECODE: ! DECTAB Z,A,ALPHA ;DECODE ALPHAS! DECTAB 9,0,NUMERIC ;AND NUMBERS# DECTAB <;>,<:>,COLONS ;THE COLONS4 DECTAB <_>,<_>,UNDERSCORE ;THE UNDERSCORE CHARACTER- DECTAB <$>,<$>,DOLLARS ;THE OLD BUCK MARKER DECTAB <.>,<.>,DOT ;THE PERIOD .BYTE 255,0 ;CATCH ALL .WORD BLANK-. ;PRINT A SPACE .PAGE .SBTTL GENERATE THE CHARACTERS ;++; FUNCTIONAL DESCRIPTION:;3; THIS ROUTINE USES A 5X7 ARRAY OF BITS TO GEN&ERATE=; CHARACTERS ON THE PRINTER. THE ROUTINE IS USED TO GENERATE; THE FLAG PAGE.;; FORTRAN CALLING SEQUENCE:<; 3; call BIGCHARS_INIT(string,spacing,width,spaceout); call BIGCHARS(*999,buffer);; INPUT PARAMETERS:;; string: String to be outputA; spacing: The number of blank characters between big characters.A; width: Is the number of times to repeat a character on a row.8; spacout: Is the number of leading sp'aces on each line.;; OUTPUT PARAMETERS:;; THE WIDE LINE IS PRINTED;; IMPLICIT OUTPUTS:;; NONE;; COMPLETION CODES:;; NONE;; SIDE EFFECTS:;9; NONE J;*************************************************************************  .entry BIGCHARS_INIT,^M<>start:- movq @4(ap),DESCR ; Input string descriptor movw @8(ap),spacing movw @12(ap),width movw @16(ap),spaceout" clrl rows ; Zero row counter( pushaw RET_LEN pushaq DESCR pushaq DESCR3 calls #3,G^STR$TRIM ; Trim blanks & tabs from end pushaq DESCR pushaq DESCR7 calls #2,G^STR$UPCASE ; Translate string to uppercase ret- .entry BIGCHARS, ^Mstart1:10$: cmpl #7,rows ; Done??? bneq 15$ ; NO!!!' brw 100$ ; Yes...branch to return1?15$: movq @4(ap),outbuf_descr ; Output buffer string descriptor6 movzwl outbuf_descr,r9 ; Get length of output buffer7 movl outbuf_descr+4 ),R0 ; Base address of output buffer7 movc5 #0,(r0),#^a/ /,r9,(r0) ; Blank out output buffer* clrl r9 ; Reset length of output buffer7 movl outbuf_descr+4,R0 ; Base address of output buffer, movl descr+4,r7 ; Get input string address. movzwl ret_len,r6 ; Get input string length: movzbl spaceout,r2 ; Count of leading spaces on the line, beql 30$ ; Br if no leading spaces wanted$20$: movzbl #^A/ /,r1 ; Get a space. bsbw 200$ ; Output space characters to line30$:* movzbl (r7),r3 * ; Get character to print- moval decode-3,r4 ; Address of decode table40$:+ addl #3,r4 ; Advance to next table entry* cmpb r3,(r4)+ ; Check against high limit! bgtru 40$ ; Br if out of limit% cmpb r3,(r4) ; Now check low limit' blssu 40$ ; Br if in range of table# subb (r4)+,r3 ; Remove table bias* cvtwl (r4),r1 ; Get offset to bit table* addl r1,r4 ; Find real address of table5 mull #35,r3 ; Find index to first bit in character. mull3 #5,rows,r1 ; Find index fo +r proper row3 addl r1,r3 ; Find first bit to test for this row/ movl #5,r5 ; Set number of columns to output70$:% movzbl (r7),r1 ; Get the character, bbs r3,(r4),80$ ; Br if no space this time! movzbl #^A/ /,r1 ; Print spaces80$:E movzbl width,r2 ; Get number of characters per column, bsbw 200$ ; Output characters to the line# incl r3 ; Adjust bit number up 18 sobgtr r5,70$ ; Repeat for 5 times-number columns perF movzbl spacing,r2 ; Get n,umber of blanks for separation& incl r7 ; Advance character pointer7 sobgtr r6,20$ ; Loop around if more characters to do85$:& movl r0,pointr ; Save buffer pointer= movw r9,outbuf_descr ; Save current length of output buffer/; movq outbuf_descr,@4(ap) ; Restore descriptor90$: incl rows ; Inc row count * clrl r0 ; Set for normal FORTRAN return brb 110$100$:) movl S^#1,r0 ; Set for FORTRAN return1110$: ret ;;; LOCAL SUBROUTINE TO OUTPUT CHARACTERS TO THE P RINT BUFFER;; R0 IS BUFFER ADDRESS; R1 IS CHARACTER ; R2 IS COUNT;200$: incl r9 ; OUTBUF length% movb r1,(r0)+ ; Store the character' sobgtr r2,200$ ; Repeat if necessary rsb .endww .ةHc***********************************************************************Hc***** BINARY TO DECIMAL CONVERTER *****Hc***** *****Hc***** Written by P.B.WISCHOW AUGUST 1985 *****Hc*********************************************************************** implicit integer*2(a-z) integer*4 status character*16 binary, temp logical*1 neg1 binary='0000000000000000/' incre=1 total=0 write(6,10) 510 format(' ENTER BINARY NUMBER (16 digits max): ',$) read(5,20) binary 20 format(a)! status=STR$TRIM(temp,binary,len)) if (len.eq.16.and.temp(1:1).eq.'1') then do i=1,160 if (temp(i:i).eq.'0') then ! flip "bits" temp(i:i)='1' else temp(i:i)='0' end if end do neg=.TRUE. else" do i=1,16 ! find blank char: if (temp(i:i).eq.' ') then ! end of input string. start=16-i+2 ! set start of string goto 100 end if end do end if start=1100 do i=start,168 if (temp(17-i:17-i).eq.'1') total=total+2**(incre-1) incre=incre+1 end do if (neg) total=-(total+1) write(6,300) binary, total-300 format(' BINARY: ',a,2x,'DECIMAL: ',i6,/) goto 1 endww1xQJc************************************************************************* c BOXPAGEHc This routine outputs to logical name FOR006 (Fortran unit 6)Cc three lines of large text. Each line may be up to ten charactersc in length. c0c FORTRAN call: call BOXPAGE(line1,line2,line3)c>c Where: line1, line2, line3 are the three lines of text to bec output in large letters.c (passed,character*10)c$c The text is centered on each line.c+c Written by2: P.B. Wischow 12 AUGUST 1986Jc*************************************************************************& subroutine boxpage(line1,line2,line3) implicit integer*2(a-z)" character*10 line1, line2, line3 character*132 outline write(6,10) 10 format(/)' call CENTER_STRING(line1,2,2,spaceout)' call BIGCHARS_INIT(line1,2,2,spaceout) do i=1,7 call BIGCHARS(*1000,outline) write(6,20) outline, outline20 format(1x,a,/,1x,a) end do1000 write(6,30)30 format(3(/))'3 call CENTER_STRING(line2,2,2,spaceout)' call BIGCHARS_INIT(line2,2,2,spaceout) do i=1,14 call BIGCHARS(*2000,outline) write(6,20) outline, outline end do2000 write(6,30)( call CENTER_STRING(line3,2,2,spaceout)' call BIGCHARS_INIT(line3,2,2,spaceout) do i=1,14 call BIGCHARS(*3000,outline) write(6,20) outline, outline end do3000 write(6,10) return end8 subroutine CENTER_STRING(string,spacing,width,spaceout) implicit integer*2(a-z) character*(*) s=tring data letter_size/5/ call STRING_LENGTH(string,len)- letter_space = letter_size * width + spacing) spaceout = (132 - len * letter_space)/2  return endww5dJc************************************************************************* c BOXPAGEHc This routine outputs to logical name FOR006 (Fortran unit 6)Cc three lines of large text. Each line may be up to ten charactersc in length. c0c FORTRAN call: call BOXPAGE(line1,line2,line3)c>c Where: line1, line2, line3 are the three lines of text to bec output in large letters.c (passed,character*10)c$c The text is centered on each line.c+c Written by6: P.B. Wischow 12 AUGUST 1986Jc*************************************************************************& subroutine boxpage(line1,line2,line3) implicit integer*2(a-z)" character*10 line1, line2, line3 character*132 outline write(6,10) 10 format(/)' call CENTER_STRING(line1,2,2,spaceout)' call BIGCHARS_INIT(line1,2,2,spaceout) do i=1,7 call BIGCHARS(*1000,outline) write(6,20) outline, outline20 format(1x,a,/,1x,a) end do1000 write(6,30)30 format(3(/))'7 call CENTER_STRING(line2,2,2,spaceout)' call BIGCHARS_INIT(line2,2,2,spaceout) do i=1,14 call BIGCHARS(*2000,outline) write(6,20) outline, outline end do2000 write(6,30)( call CENTER_STRING(line3,2,2,spaceout)' call BIGCHARS_INIT(line3,2,2,spaceout) do i=1,14 call BIGCHARS(*3000,outline) write(6,20) outline, outline end do3000 write(6,10) return end8 subroutine CENTER_STRING(string,spacing,width,spaceout) implicit integer*2(a-z) character*(*) s tring data letter_size/5/ call STRING_LENGTH(string,len)- letter_space = letter_size * width + spacing) spaceout = (132 - len * letter_space)/2  return endwwrrect location8 bisl2 r8, 4(r5) ; Set specified bit in second longword(RETURN: mnegl #1, r0 ; ... return TRUE ret .endww : ΈJ;*************************************************************************+ .TITLE BTEST_Q - Test bits of a quad word ;C; This routine will test the specified bit (0-63) for SET or CLEAR.; J;*************************************************************************! .PSECT BTEST_Q,exe,rd,nowrt,long! .entry BTEST_Q, ^Mstart:0 movaq @4(ap), r5 ; Address of quadword to test) movl @8(ap), r7 ; Bit to test (0 -> 64)1 cmpb r7, #31 ; Which longword to test (1 or 2)M bgtr SECOND ; If bit to test is greater than 31 then look at 2nd longwordA bbs r7, (r5), SET ; Test for bit set...if so , return TRUE brb CLEAR ASECOND: subb2 #32, r7 ; Decrement bit count for second longword: bbs r7, 4(r5), SET ; Test for bit set in second longword! ; ...if so , return TRUE/CLEAR: clrl r0 ; Bit NOT set ... return FALSE ret-SET: mnegl #1, r0 ; Bit set ... return TRUE ret .endww <~AHc***********************************************************************Hc***** DECIMAL TO BINARY CONVERTER *****Hc***** *****Hc***** Written by P.B.WISCHOW AUGUST 1985 *****Hc*********************************************************************** implicit integer*4(a-z) character*16 binary10 binary='0000000000000000' write(6,100) 6100 format(' ENTER DEC IMAL NUMBER (5 digits max): ',$) read(5,*) decimal do i=0,15. if(BTEST(decimal,i)) binary(16-i:16-i)='1' end do write(6,200) decimal, binary-200 format(' DECIMAL: ',i6,2x,'BINARY: ',a,/) goto 10 endww>`EN0; ELTRAN = HIGH VOLUME I/O SUBROUTINE; PERFORMS2; BLOCK I/O TO TAPE,DISK OR OTHER DEVICE/; PROGRAMMER: Maria Kalcic, Code 022; functions are:; 1 - sequential read; 2 - sequential write; 3 - random read; 4 - random write; 5 - open and assign; 6 - close and deassign; 7 - skip record; 8 - skip file; 9 - write end of file; 10 - rewind; 11 - create file; 12 - seq.record read; 13 - seq.record wr?ite; 14 - random record read; 15 - random record write .title eltran .psect dta,long,nowrt+ .entry eltran,^m;3; get arguments from fortran call with displacement; of argument pointer (ap);! movl @4(ap),lu ;get logical unit movl @8(ap),r2 ;get funcition movl @8(ap),ifun ;! movl @12(ap),irnn ;get block no.! movl @16(ap),nbtm ;get no. bytes) movab @20(ap),ib ;get base address of ib6 movl @24(ap),alqw ;get allocati@on size for file, moval @24(ap),l ;get address of status word8 movl lu,r8 ;store address get lu index for fab address* movl fabadr[r8],elfab ;store addr. of fab* movl rabadr[r8],elrab ;store addr. of rab;4; use case instruction to branch to function (reg 2); casel r2,#1,#141$: .word seqread-1$ .word seqwrit-1$ .word ranread-1$ .word ranwrit-1$ .word open-1$ .word close-1$ .word skrec-1$ .word skfile-1$ .word weof-1$ .word rewind-1$ .word alloc-1$ .word seqArecrd-1$ .word seqrecwr-1$ .word ranrecrd-1$ .word ranrecwr-1$ brw exit;; function 1: sequential read;seqread:! $rab_store rab=@elrab,usz=nbtm,- bkt=#0,ubf=@ib movl #0,@lsread: $read rab=@elrabnread: movl elrab,r4 addl2 #rab$w_rsz,r4 movw (r4),@l blbc r0,check brw exitcheck: ) cmpl r0,#rms$_eof ;check for end of file beql eof. cmpl r0,#rms$_rer ;check for small block size beql rer ;if so, return 0 in l brw errorrer: movl #0,@l; pushal rerB_err; calls #1,g^lib$put_output brw exit+eof: movl elfab,r4 ;eof, now check for tape addl2 #fab$l_ctx,r4 movl (r4),ctx cmpl #0,ctx beql flag+ $close fab=@elfab ;eof on tape must reopen $open fab=@elfab+ $connect rab=@elrab ;position at next file flag: movl #-3,@l ;set eof flag brw exit;; function 2: sequential write;seqwrit:' $rab_store rab=@elrab,bkt=#0,rbf=@ib,- rsz=nbtm $fab_store fab=@elfab,bls=nbtm $write rab=@elrab blbs r0,sw_ok brw error0swC_ok: movl nbtm,@l ;return number bytes written brw exit;; function 3: random read;ranread: $rab_store rab=@elrab,usz=nbtm- bkt=irnn,ubf=@ib $read rab=@elrab movl elrab,r4 addl2 #rab$w_rsz,r4 movw (r4),@l blbs r0,rr_ok brw checkrr_ok: brw exit;; function 4: random write; ranwrit: ) $rab_store rab=@elrab,bkt=irnn,rbf=@ib,- rsz=nbtm $write rab=@elrab blbs r0,rw_ok brw error0rw_ok: movl nbtm,@l ;return number bytes written brw exit;&D; function 5: open files and devices;&; logical unit numbers assigned also%; logical unit numbers are store in-; file access blocks (fabs) at assembly timeopen: movw @ib,leng movl #1,r4 movl ib,r2 movl (r2)[r4],fnam moval nxo,return brw bld_fldnxo: movl r4,valu. $fab_store fab=@elfab,ctx=#0 ;clear tape flag;; check for block or record i/o; 0 is for block i/o cmpl #0,irnn beql op2; open for record i/o'; check for read only privelege on open$ $fab_Estore fab=@elfab,fac= cmpl #0,nbtm bneq continu0 $fab_store fab=@elfab,fac= brw continu%op2: ; block io check for read only cmpl #1,nbtm beql continu/; give write privelege - set put option in fab movl elfab,r6 bisb2 #fab$m_put,fab$b_fac(r6)continu:" movl #512,@l ; store sector size+ moval tap_ch,return ; check for tape drive brw devicetap_ch: cmpl tape,test+ bneq nxchk ; if tape drive, sector size=0 movl #1,@l ; file isF tape brw seflgnxchk: cmpl tapec,test bneq nxtd movl #1,@l2seflg: $fab_store fab=@elfab,ctx=#1 ;set tape flagnxtd: movl lu,valu moval set,return brw convrtset: pushal @ib pushal val_desc3 calls #2,g^lib$set_logical ;assign lu file -device blbc r0,er_assignopn: $open fab=@elfab cmpl r0,#rms$_ifi bneq opn2 brw exit.opn2: blbc r0,ermsg ; branch to ermsg if error" $connect rab=@elrab ; connect rab blbc r0,ermsg brw exit er_assign: pushal era brw put_msg G; error checking*ermsg: cmpl r0,#rms$_fnf ; file not found?, beql fnferr ; if not found, return -1 in l& brw error ; otherwise, error in openfnferr: brw rtn;); function 6: close file and deassign lu;close:  $close fab=@elfab blbs r0,cl_ok, cmpl r0,#rms$_ifi ; was file already closed" beql cl_ok ; if so just deassign brw error ; otherwise, error#cl_ok: $fab_store fab=@elfab,ctx=#0 movl lu,valu moval dasgn,return brw convrtdasgn: pushal val_desc2 calls #1,g^liHb$delete_logical ;deassign log.unit. brw exit;; function 7: skip record;skrec: $rab_store rab=@elrab,bkt=irnn $space rab=@elrab blbs r0,skr_ok brw errorskr_ok: brw exit;; function 8: skip file;skfile: movl irnn,r3& cmpl #0,r3 ;check for forward or back bgeq back $rab_store rab=@elrab,bkt=#100 brw skip"back: mnegl r3,r3 ; skip backwards $rab_store rab=@elrab,bkt=#-1002skip: $space rab=@elrab ;skip until eof is reached cmpl r0,#rms$_eof bneq skipI decl r3 bneq skip brw exit;4; function 9: write end-of-file (close and reopen);2weof: $close fab=@elfab ;close function writes eof2 $open fab=@elfab ;reopen since close not required $connect rab=@elrab blbs r0,we_ok brw errorwe_ok: brw exit;; function 10: rewind;rewind: $rewind rab=@elrab blbs r0,re_ok brw errorre_ok: brw exit;'; function 11: allocate file (create);alloc: movw @ib,leng movl #1,r4 movl ib,r2 movl (r2)[r4],fnam J cmpl #0,alqw bneq gohed movl #64,alqwgohed: cmpl #1,irnn beql fixrec cmpl #2,irnn bneq varec brw recfix9;create file for block i/o access with var.length recordsvarec:! $fab_store fab=@elfab,alq=alqw,-! mrs=#48000,org=seq,rfm=var,- deq=#1000,rat=cr,fop=cbt,- fna=@fnam,fns=leng brw create9;create file for block i/o access with fixed length recs.(fixrec: $fab_store fab=@elfab,alq=alqw,-& mrs=nbtm,org=seq,rfm=fix,- deq=#1000,rat=cr,Kfop=cbt,- fna=@fnam,fns=leng brw create6;create file record i/o access with fixed length recs.(recfix: $fab_store fab=@elfab,alq=alqw,- mrs=nbtm,org=seq,rfm=fix,- deq=#64,rat=cr,fop=cbt,- fac=,- fna=@fnam,fns=lengcreate: $create fab=@elfab blbs r0,cnct brw error&cnct: $connect rab=@elrab ;connect rab blbs r0,cr1 brw error/cr1: movl #512,@l ;return disk sector size in l movl lu,valu moval nextep,return brw convrtLnextep: pushal @ib pushal val_desc. calls #2,g^lib$set_logical ;assign lu to file blbs r0,cr2 brw er_assign cr2: brw exit;seqrecrd: $fab_store fab=@elfab! $rab_store rab=@elrab,usz=nbtm,- ubf=@ib $get rab=@elrab movl elrab,r4 addl2 #rab$w_rsz,r4 movw (r4),@l blbs r0,sqrd brw checksqrd: brw exit;;seqrecwr: $fab_store fab=@elfab! $rab_store rab=@elrab,rbf=@ib,- rsz=nbtm $put rab=@elrab blbs r0,swr_ok brw errorswr_ok: movl nbtm,@l brwM exit;;ranrecrd: $fab_store fab=@elfab $rab_store rab=@elrab,- rac=key,kbf=irnn,- ubf=@ib,usz=nbtm $get rab=@elrab movl elrab,r4 addl2 #rab$w_rsz,r4 movw (r4),@l blbs r0,rnr_ok brw checkrnr_ok: brw exit;;ranrecwr: $fab_store fab=@elfab $rab_store rab=@elrab,- rbf=@ib,rsz=nbtm,- rac=key,kbf=irnn,- rop= $put rab=@elrab blbs r0,rnwr_ok brw errorrnwr_ok: movl nbtm,@l brw exit;;;!; exit for normal status retNurn; exit: ret 2;*************************************************;3; convrt: routine to convert 1 or 2 digit logical&; unit or function number to ascii'; descriptor for error output&; valu= integer value to be converted ; return = address to return to;$convrt: movl #1,r10 ;set for 1 digit" cmpl #10,valu ;is value 2 digits? bgtr store ;yes, go store the 1 incl r10 ;no, set for 2 digits4store: movw r10,val_desc ;store length in descriptor& pushal val_deOsc ;push parms. on stack pushal valu calls #2,g^ots$cvt_l_ti jmp @return3;**************************************************;8; bld_fld: routine to build file descriptor, file_desc'; ib = buffer containing file name0; return = address to which to return;bld_fld: movl #0,r4 movl #-1,r6 movl fnam,r3&contr: incl r6 ;get length of filename cmpb #58,(r3)[r6] beql nexta addl2 #1,r4 cmpl #20,r4 beql nexta brb contr3nexta: movl r4,file_desc ;build fiPlename descriptor movl fnam,file_desc+4 jmp @return3;**************************************************;3; device: routine to construct device name as dd:,; controller and unit specifications are5; suppressed, device name is placed in test; valu = filename length-; return = address to return to;$device: movl valu,r4 ;length of name" movl fnam,r3 ;get address of name$ movw @fnam,test ;get first 2 chars.$ movb (r3)[r4],test+2 ;pick up colon jmpQ @return2;*************************************************;2; error handling: compare contents of register 03; to error codes and put address-; of error message on stackerror: cmpl r0,#rms$_act bneq err1 pushal act brw put_msgerr1: cmpl r0,#rms$_dnr bneq err2 pushal dnr brw put_msgerr2: cmpl r0,#rms$_dpe bneq err3 pushal dpe brw put_msgerr3: cmpl r0,#rms$_ext bneq err4 pushal ext brw put_msgerr4: cmpl r0,#rms$_daRc bneq err5 pushal dac brw put_msgerr5: cmpl r0,#rms$_cre bneq err6 pushal cre brw put_msgerr6: cmpl r0,#rms$_dnf bneq err7 pushal dnf brw put_msgerr7: cmpl r0,#rms$_flk bneq err8 pushal flk brw put_msgerr8: cmpl r0,#rms$_wlk bneq err9 pushal acc brw put_msgerr9: cmpl r0,#rms$_acc bneq err10 pushal acc brw put_msgerr10: cmpl r0,#rms$_fnf bneq err11 pushal fnf brw put_msgerr11: cmpl r0,#rms$_ifi bneq err12 pushal ifi brw putS_msgerr12: cmpl r0,#rms$_isi bneq err13 pushal isi brw put_msgerr13: cmpl r0,#rms$_ful bneq err14 pushal ful brw put_msgerr14: cmpl r0,#rms$_fac bneq err15 pushal fac brw put_msgerr15: cmpl r0,#rms$_nef bneq err16 pushal nef brw put_msg0err16: movl r0,status ;general error,dump status pushal stat_desc pushal status calls #2,g^ots$cvt_l_tz pushal elerr calls #1,g^lib$put_output pushal stat_descput_msg: calls #1,g^lib$put_output* movl ifun,valTu ;convert function to ascii moval put_fun,return brw convrtput_fun:6 movb val,fun_msg+8 ;move ascii function to descriptor cmpl #10,valu bgtr fun1 movb val+1,fun_msg+92fun1: pushal fun_msg ;output ascii function number calls #1,g^lib$put_output# movl lu,valu ;convert lun to ascii moval put_lun,return brw convrtput_lun:1 movb val,lun_msg+8 ;move ascii lun to descriptor cmpl #10,valu bgtr lun1 movb val+1,lun_msg+9/lun1: pushal lun_msg ;output ascii logical unitU calls #1,g^lib$put_outputrtn: movl #-1,@l ret8;*******************************************************8;*******************************************************; data section; .psect dat2,wrt,noexe,long lu: .long 0 ifun: .long 0 irnn: .long 0nbtm: .long 0 ib: .long 0 l: .long 0 ctx: .long 0status: .long 0return: .long 0 valu: .long 0 fnam: .long 0 leng: .long 0 alqw: .long 0tape: .ascii /ms: /tapec: .ascii /MS: /test: .ascii / /( .alVign long ;fab and rab blocks must be7; aligned on longword boundarieselfab: .address fab1elrab: .address rab1fab1: $fab fac=,- fnm=<1>fab2: $fab fac=,- fnm=<2>fab3: $fab fac=,- fnm=<3>fab4: $fab fac=,- fnm=<4>fab5: $fab fac=,- fnm=<5>fab6: $fab fac=,- fnm=<6>fab7: $fab fac=,- fnm=<7>fab8: $fab fac=,- fnm=<8>fab9: $fab fac=,- fnm=<9>fab10:W $fab fac=,- fnm=<10>fab11: $fab fac=,- fnm=<11>fab12: $fab fac=,- fnm=<12>fab13: $fab fac=,- fnm=<13>fab14: $fab fac=,- fnm=<14>fab15: $fab fac=,- fnm=<15>fab16: $fab fac=,- fnm=<16>fab17: $fab fac=,- fnm=<17>fab18: $fab fac=,- fnm=<18>fab19: $fab fac=,- fnm=<19>fab20: $fab fac=,- fnm=<20>fabadr: .long 0 .address fab1 .address fab2X .address fab3 .address fab4 .address fab5 .address fab6 .address fab7 .address fab8 .address fab9 .address fab10 .address fab11 .address fab12 .address fab13 .address fab14 .address fab15 .address fab16 .address fab17 .address fab18 .address fab19 .address fab20rab1: $rab fab=fab1rab2: $rab fab=fab2rab3: $rab fab=fab3rab4: $rab fab=fab4rab5: $rab fab=fab5rab6: $rab fab=fab6rab7: $rab fab=fab7rab8: $rab fab=fab8rab9: $rab fab=fab9Yrab10: $rab fab=fab10rab11: $rab fab=fab11rab12: $rab fab=fab12rab13: $rab fab=fab13rab14: $rab fab=fab14rab15: $rab fab=fab15rab16: $rab fab=fab16rab17: $rab fab=fab17rab18: $rab fab=fab18rab19: $rab fab=fab19rab20: $rab fab=fab20rabadr: .long 0 .address rab1 .address rab2 .address rab3 .address rab4 .address rab5 .address rab6 .address rab7 .address rab8 .address rab9 .address rab10 .address rab11 .address rab12 .address rab13 .addrZess rab14 .address rab15 .address rab16 .address rab17 .address rab18 .address rab19 .address rab20 stat: .blkb 8 stat_desc:  .word 8 .byte 14 .byte 1 .long stat val: .blkb 2 val_desc: .word 1 .byte 14 .byte 2 .long valfile_desc: .long 0file_name: .long 0<rer_err: .ascid /file read warning,less bytes than in rec/3era: .ascid /eltran error: error in lu assignment/.elerr: .ascid /eltran error: not diagnosed/>act: .ascid /eltran error: file act[ivity precludes operation/<dnr: .ascid /eltran error: device not ready or not mounted/5dpe: .ascid /eltran error: device positioning error/3ext: .ascid /eltran error: acp file extend failed/Cdac: .ascid /eltran error: acp file deaccess failed during $close/5cre: .ascid /eltran error: acp file creation failed/0dnf: .ascid /eltran error: directory not found/Bflk: .ascid /eltran error: file currently locked by another user/:wlk: .ascid /eltran error: device currently write locked/4ac\c: .ascid /eltran error: acp file access failed/,fnf: .ascid /eltran error: file not found/Cifi: .ascid /eltran error: invalid id in fab - file not open/>isi: .ascid /eltran error: invalid id in rab - file not open/Eful: .ascid /eltran error: device full;cannot create or extend file/Ifac: .ascid /eltran error: operation not allowed; file may be read only/;nef: .ascid /eltran error: not positioned at end of file/fun_msg:.ascid / = function/#lun_msg:.ascid / = logical unit/ .end  ww X .title getdescr .psect dta,long,nowrt .entry getdescr,^m movab @4(ap),r3 movl #1,r2 movl (r3)[r2],r6 movl r6,@8(ap) ret  .endww _gtLc***************************************************************************Gc* SETDEF from the MAY 1986 issue of THE DEC PROFESSIONAL, page 64. (c* (by M.E. Nieland and W.J. Haas, Jr.Lc*************************************************************************** program set_default_directory implicit integer*4(a-z) include '($SSDEF)' include '($RMSDEF)' include '($LNMDEF)' character*(*) null, bell, blank" character*255 where, save, blanks character*256 error `' character*255 dev, node, cdev, curnode" character*255 dir, curdir, curdev character*1 blnks(255) integer*2 name_len, name_code+ integer*4 name_addr, ret_addr, end_list/0/A common /LIST/ name_len, name_code, name_addr, ret_addr, end_list# equivalence (blnks(1),blanks(1:1)) logical set7 parameter (bell=CHAR(7), blank=CHAR(32), null=CHAR(0))- data blnks/255*' '/, in_unit/3/, out_unit/4/5 open(unit=in_unit,file='SYS$INPUT',status='UNKNOWN')7 open(unit=out_unit,file='SYS$OUTPUT',astatus='UNKNOWN')= status = SYS$SETDDIR(,cdlen,curdir) ! Get default directoryC call TRAN_LOGNAME(*1,'SYS$DISK',curdev,cdvlen,'LNM$PROCESS_TABLE')B1 call TRAN_LOGNAME(*2,'SYS$NODE',node,nodelen,'LNM$SYSTEM_TABLE') if (nodelen.gt.0) then? do while (node(1:1).eq.'_') ! Remove leading underscores* node(1:nodelen-1) = node(2:nodelen) nodelen = nodelen - 1 end do  end if offset = INDEX(curdev,'::') !  if (offset.eq.0) then2 curnode = node cnlen = bnodelen cdev = curdev cddlen = cdvlen else curnode = curdev(:offset+1)% call STRING_LENGTH(curnode,cnlen)" cdev = curdev(offset+2:cdvlen)# call STRING_LENGTH(cdev,cddlen) end if do while (curnode(1:1).eq.'_') ) curnode(1:cnlen-1) = curnode(2:cnlen) cnlen = cnlen - 1 end do set = .FALSE.# call LIB$GET_FOREIGN(where,,size,) if (size.eq.0) then write(out_unit,5000)(5000 format(' Default Directory? ',$)0 read(in_unit,5020,err=20c,end=20) size, where5020 format(q,a)" call STRING_LENGTH(where,size) goto 4020 where = blanks size = 0 end if40 call STR$UPCASE(where,where) if (size.eq.0) then where = 'SYS$LOGIN' size = 93 set = .TRUE.  end if offset = INDEX(where,'PRE') if (offset.ne.0) then6 if ((where(offset+3:offset+3).ne.blank).and.4 * (where(offset+3:offset+3).ne.null)) goto 60C call TRAN_LOGNAME(*3,'PREV_DIR',wherde,size,'LNM$PROCESS_TABLE') set = .TRUE.3 if (size.eq.0) then where = 'SYS$LOGIN' size = 9 end if end if 60 offset = INDEX(where,':') - 1 if (offset.eq.-1) offset = size6 call TRAN_LOGNAME(*80,where(1:offset),dir,dirlen,' ') set = .TRUE. if (offset.ne.size) then savesize = size - offset - 1* save(:savesize) = where(offset+2:size) size = dirlen + savesize= where(1:size) = dir(:dirlen-1)//'.'//save(:savesize)//']'* where(size+1:255e) = blanks(size+1:255) else where = dir size = dirlen end if 80 continue" if (where(size:size).ne.':') then* if (INDEX(where(:size),'[').eq.0) then do idx = size,1,-1- if (where(idx:idx).eq.':') goto 100 end do idx = 0100 idx = idx + 1/ where(idx:size+1) = '['//where(idx:size) size = size + 1 end if+ if (INDEX(where(:size),']').eq. 0) then size = size + 1 where(size:size) = ']' end fif end if do i=1,size+ if (where(i:i).eq.'\') where(i:i) = '-' end do  if (set) goto 120. offset = INDEX(where,'::') ! Check for node if (offset.eq.0) then if (curnode.ne.node) then! save(:size) = where(:size) slen = size size = slen + cnlen2 where(:size) = curnode(:cnlen)//save(:slen) offset = cnlen end if else0 if (where(:offset+1).eq.node(:nodelen)) then nsize = size - offset - 1+ where(:nsize) = whereg(offset+2:size) size = nsize offset = 0 else offset = offset + 1 end if end if= offset1 = INDEX(where(offset+1:size),':') ! Check for device if (offset1.eq.0) then slen = size - offset& save(:size) = where(offset+1:size)! size = offset + slen + cddlen5 where(offset+1:size) = cdev(:cddlen)//save(:slen) offset1 = offset + cddlen end if2 if (offset1.ge.size) then ! Check for directory size = offset +cdlen* where(offseth1+1:size) = curdir(:cdlen) end if# offset1 = INDEX(where(1:size),'[')+ if (where(offset1+1:offset+1).eq.'.') then oldsize = size size = size + cdlen - 2/ where(offset+1:size) = curdir(2:cdlen-1)//! * where(offset1+1:oldsize)0 else if (where(offset1+1:offset+1).eq.'-') then oldsize = size size = size + cdlen - 14 where(offset+1:size) = curdir(2:cdlen-1)//'.'//! * where(offset1+1:oldsize)- else if (INDEX(where(1:size),']').eq.0) then oldsiize = size size = size + cdlen , where(oldsize+1:size) = curdir(1:curlen) end if 120 idx = 04 status = LIB$FIND_FILE(where(:size),dir,idx,'*.*',)1 if ((.not.status).and.(status.ne.RMS$_FNF)) then6 j = SYS$GETMSG(%val(status),length,error,%val(3),)- write(out_unit,5030) bell,error(2:length)+5030 format(' ',a1,'%IN-I-',a)* write(out_unit,5050) curnode(:cnlen)//' * cdev(:cddlen)//curdir(:cdlen) goto 140 end if dirlen = INDEX(dir,']')> ijdx = INDEX(dir(:dirlen),'[') - 1 ! Separate device/directory/ status = LIB$SET_LOGICAL('SYS$DISK',dir(:idx))- if (.not.status) call LIB$STOP(%val(status))> status = SYS$SETDDIR(dir(idx+1:dirlen),,) ! Set the directory- if (.not.status) call LIB$STOP(%val(status))6 status = LIB$SET_LOGICAL('PREV_DIR',curdev(:cdvlen)// * curdir(:cdlen))  if (INDEX(dir,'::').eq.0) then5 write(out_unit,5050) node(:nodelen)//dir(:dirlen) else offset = 1( do while (dir(offset:offset).eq.'_') offset = offset + 1 end do+ write(out_unit,5050) dir(offset:dirlen),5050 format(' New default directory: ',a) end if140 endww l}J;*************************************************************************: .TITLE SNDOPR - send message to central operators console;1; Written by P.B. Wischow 25 November 1986;&; FORTRAN call: call SNDOPR(message)C; The message is a string up to 255 characters long. Any carriage @; control (linefeeds and CR's must be included by the calling ; routine.J;************************************************************************* $OPCDEF ; Macro defimnitions% .PSECT SNDOPR_DATA,noexe,rd,wrt,long8buff: .blkb 263 ; 255 characters + 8 for control words desc: .blkl 1 .address buff .PSECT SNDOPR,exe,rd,nowrt,long .entry SNDOPR, ^M5 movq @4(ap), r6 ; Address of user string descriptor, movb #OPC$_RQ_RQST,buff ; Request code type9 movl #OPC$M_NM_CENTRL,buff+1 ; Send to CENTRAL operator & movl #666,buff+4 ; User message code$ movzwl r6, r8 ; Length of message7 addl3 r8, #8, desc ; Compute length of message buffer6 movc5 r8,(r7),#^A/ /,r8,buff+8 ; Load message to send( $SNDOPR_S msgbuf=desc ; Send message  ret .endwwo^΃?;************************************************************** ;***** STRIPD;*****;;***** AUTHOR AND DATE: MARIA KALCIC CODE 022 1 JUNE 1984;*****;;***** DESCRIPTION: This routine strips the descriptor off );***** the character string.;*****5;***** FORTRAN CALL: call STRIPD(in,nchars,out);*****;***** PARAMETERS: ;***** /;***** in: Input array or character string.1;***** (integer*2, or character string)9;***** p nchars: Number of characters or bytes in "IN".;*****1;***** out: Output array or character string.2;***** (integer*2, or character string);*****#;***** SUBROUTINES REQUIRED: none;*****2;***** This routine is used by the Calcomp SYMBOL.;*****?;************************************************************** .title stripd .psect dta,long,nowrt! .entry stripd,^m moval @4(ap),r3 movl @8(ap),r2 moval @12(ap),r7 movl #0,r6 movl #1,r4 mov l (r3)[r4],r5labl: cmpl r2,r6 beql done movb (r5)[r6],(r7)[r6] incl r6 brw labldone: ret .endwwc#r+ WISCHOW STRIPD.MAR\ ?  WISCHOW BIGCHARSBSET_QBTEST_QELTRANGETDESCRSCROLLSETDEFSNDOPRSTRIPD/6 WISCHOW BINDECBOXPAGE.DECBIN% O WISCHOW DISUSER_FLAG" WISCHOW TITLE.FOR  WISCHOW TITLE$`8 WISCHOW MAILRRR.MAR$J WISCHOW MAILMSG.FOR(9_ WISCHOW MAILRRRMAILMSG(?~ WISCHOW UOPEN_PRINT.MAR%1 WISCHOW VAXUSERS.F