!File: LABIOCON.FOR ! Version 'V04-000' ! !**************************************************************************** !* * !* COPYRIGHT (c) 1978, 1980, 1982, 1984 BY * !* DIGITAL EQUIPMENT CORPORATION, MAYNARD, MASSACHUSETTS. * !* ALL RIGHTS RESERVED. * !* * !* THIS SOFTWARE IS FURNISHED UNDER A LICENSE AND MAY BE USED AND COPIED * !* ONLY IN ACCORDANCE WITH THE TERMS OF SUCH LICENSE AND WITH THE * !* INCLUSION OF THE ABOVE COPYRIGHT NOTICE. THIS SOFTWARE OR ANY OTHER * !* COPIES THEREOF MAY NOT BE PROVIDED OR OTHERWISE MADE AVAILABLE TO ANY * !* OTHER PERSON. NO TITLE TO AND OWNERSHIP OF THE SOFTWARE IS HEREBY * !* TRANSFERRED. * !* * !* THE INFORMATION IN THIS SOFTWARE IS SUBJECT TO CHANGE WITHOUT NOTICE * !* AND SHOULD NOT BE CONSTRUED AS A COMMITMENT BY DIGITAL EQUIPMENT * !* CORPORATION. * !* * !* DIGITAL ASSUMES NO RESPONSIBILITY FOR THE USE OR RELIABILITY OF ITS * !* SOFTWARE ON EQUIPMENT WHICH IS NOT SUPPLIED BY DIGITAL. * !* * !* * !**************************************************************************** ! Program LABIO_CONNECT ! Define Labio data structures Include 'LABCHNDEF.FOR' ! Mailbox Definitions Include 'LABMBXDEF.FOR' !Defines Mailbox Data Structures ! System Service Definitions Logical*4 SYS$CREMBX,SYS$ASSIGN Logical*4 SUCCESS External SS$_ENDOFFILE ! Subroutine Definitions Integer CONNECT,DISCONNECT,ABORT,ALLOCATE,DEALLOCATE Integer READ_MAILBOX,WRITE_MAILBOX,LABIO_LOG,ACKNOWLEDGE Integer CHECK_PID,RETURN_CODE ! Command Data Structures Parameter MAX_COMMAND = 5 Character*15 COMMAND,COMMAND_TABLE(MAX_COMMAND) Data COMMAND_TABLE /'CONNECT', 1 'DISCONNECT', 1 'ABORT', 1 'ALLOCATE', 1 'DEALLOCATE'/ ! ! Map to the Global Data Section 'LABIO_COMMON' ! And Define the Commom Event Flag CLusters ! Request write access to the data base. ! Call LABIO_INIT ( 1 ) ! ! See if mailbox LABIO_CONNECT exists by attempting to assign it, if ! it does not exist, create it. This mailbox is used to communicate with ! other LABIO processes. Restrict it to processes within this group. ! SUCCESS = SYS$ASSIGN('LABIO_CONNECT',MBX_CHANNEL,,) If (.not. SUCCESS ) Then SUCCESS = SYS$CREMBX(,MBX_CHANNEL,,,%Val('FD00'x),,'LABIO_CONNECT') If (.not. SUCCESS) 1 Call FATAL_ERROR( SUCCESS, 'Creating mailbox') End If ! ! Tell other processes that we're ready to go. ! Call SYS$SETEF( %val( EF_CONNECT ) ) ! Get a command from a requesting processes ! 10 Call READ_MAILBOX !Get a message Call CONNECT_CHECK !Check the database to clear !any deleted processes. ! ! If I/O status is EOF then process has terminated, ABORT it. ! If ( MBX_IO_STATUS .eq. %Loc(SS$_ENDOFFILE) ) Go To 23 ! ! Decode characters as a command ! If ( MBX_MESSAGE_L .eq. 0 ) Go To 10 Decode (MBX_MESSAGE_L,100,MBX_MESSAGE,ERR=10) COMMAND ! ! Search Command Table for Command ! Do 11 COMMAND_INDEX = 1,MAX_COMMAND If( COMMAND .eq. COMMAND_TABLE(COMMAND_INDEX) ) Go To 12 11 Continue Go To 13 !Illegal command ! ! Dispatch to correct routine ! 12 Go To (21,22,23,24,25) COMMAND_INDEX ! ! If we get here, it's an unknown command 13 Call LABIO_LOG(-1) ! ! CONNECT command ! 21 RETURN_CODE = CONNECT (MBX_PID) Call ACKNOWLEDGE( RETURN_CODE ) !Acknowledge the request Call LABIO_LOG ( RETURN_CODE ) !Log the acknowledgement ! ! Disconnect if was bad connect ! If (RETURN_CODE .ne. 0 ) Call DISCONNECT(-1) Go To 10 ! ! DISCONNECT Command ! 22 RETURN_CODE = DISCONNECT (MBX_PID) Call LABIO_LOG ( RETURN_CODE ) !Log the acknowledgement Go To 10 ! ! ABORT command ! 23 RETURN_CODE = ABORT (MBX_PID) Go To 40 ! ! ALLOCATE command ! 24 RETURN_CODE = ALLOCATE (MBX_PID) Go To 40 ! ! DEALLOCATE command ! 25 RETURN_CODE = DEALLOCATE (MBX_PID) Go To 40 ! ! Return status in first character position ! 40 Call ACKNOWLEDGE( RETURN_CODE ) !Acknowledge the request Call LABIO_LOG( RETURN_CODE ) !Log the acknowledgement Go To 10 ! ! Formats ! 100 Format (A) End Subroutine CONNECT_CHECK ! This routine checks to make sure all processes ! connected (in CONNECT_BLOCK) actually exist. ! If a process has been deleted, this routine ! removes it from the database by calling ABORT Include 'LABCHNDEF.FOR' Logical*4 SYS$GETJPI Do 10 I = 1, MAX_PID PID = CONNECT_BLOCK(I,1) If ( PID .ne. 0 ) Then If( .not. SYS$GETJPI(%Val(2),PID,,0,,,) ) Call ABORT( PID ) End If 10 Continue Return End Logical*4 Function READ_MAILBOX ! ! This routine reads the LABOI_CONNECT mailbox ! Returns when a message is ready ! External IO$_READVBLK Include 'LABMBXDEF.FOR' Logical*4 SYS$QIOW,SUCCESS ! ! Read for a message from another process ! MBX_READ=%LOC(IO$_READVBLK) MBX_MESSAGE(1) = ' ' READ_MAILBOX = SYS$QIOW(,%Val(MBX_CHANNEL),%Val(MBX_READ), 1 MBX_IO_STATUS,,,MBX_MESSAGE, 1 %Val(MAX_MESSAGE),,,,) Return End Logical*4 Function WRITE_MAILBOX(MBX_CHAN,MESSAGE,MESSAGE_LENGTH) ! This routine writes a message to a mailbox ! Input are the MBX channel, the message, and message length ! External IO$_WRITEVBLK,IO$M_NOW Logical SYS$QIO ! ! Write response buffer of MBX ! MBX_WRITE =%Loc(IO$_WRITEVBLK)+%Loc(IO$M_NOW) WRITE_MAILBOX = SYS$QIO(,%Val(MBX_CHAN),%Val(MBX_WRITE),,,, 1 MESSAGE,%Val(MESSAGE_LENGTH),,,,) 99 Return End Logical*4 Function OPEN_MAILBOX(MAILBOX_CHAN,MAILBOX_NAME) ! This routine opens mailbox indicated by MAILBOX_NAME. It returns ! the VMS channel number assignde to it. The mailbox name can be ! padded on the right with blanks. Character*(*) MAILBOX_NAME Integer MAILBOX_CHAN Logical*4 SYS$ASSIGN,SUCCESS ! ! Determine length of mailbox name string ! MAILBOX_NAME_L=Index(MAILBOX_NAME,' ')-1 If (MAILBOX_NAME_L .lt. 0 ) MAILBOX_NAME_L=Len(MAILBOX_NAME) ! ! Assign a channel to mailbox ! Return status to caller ! OPEN_MAILBOX =SYS$ASSIGN(MAILBOX_NAME(:MAILBOX_NAME_L),MAILBOX_CHAN,,) Return End Subroutine ACKNOWLEDGE (ACK_CODE) ! ! This routine acknowlegdes a request of process, by return the ! command string the process sent us. The string is preceded ! an acknowledge code (ACK_CODE). The acknowledgement is sent ! via the mailbox the the sending processes had created. ! If that process has not connected to us, we do nothing. Include 'LABCHNDEF.FOR' Logical*4 WRITE_MAILBOX Include 'LABMBXDEF.FOR' Integer CONNECT_INDEX,CHECK_PID,ACK_CODE ! ! If process is not in CONNECT_BLOCK, do not respond. ! CONNECT_INDEX = CHECK_PID(MBX_PID) If (CONNECT_INDEX .ne. 0 ) Then Encode( MBX_RESPONSE_L,100,MBX_RESPONSE) ACK_CODE MAILBOX = CONNECT_BLOCK(CONNECT_INDEX,2) Call WRITE_MAILBOX( MAILBOX, MBX_RESPONSE, 1 MBX_MESSAGE_L + MBX_RESPONSE_L ) End If Return 100 Format ( I2 ) End Subroutine LABIO_LOG( CODE ) ! ! This routine logs a message that has been processed. The message ! is written to the log file, along with the time, process ID, IO status ! word and the message length. This routine opens the log file ! if it hasn't been opened. Include 'LABMBXDEF.FOR' Character*24 TIME Logical LOG_OPEN Integer CODE Data LOG_OPEN/.false./ Call SYS$ASCTIM(,TIME,,) !Get the date and time ! ! Open Log file if this is the first time thru ! If ( .not. LOG_OPEN ) Then Open (Unit = 1, Name='LABIO_LOG', Type='Unknown', Access = 'Append') LOG_OPEN = .True. Write(1,100) TIME,' Labio Log Opened' End If 10 Write(1,200) TIME,MBX_PID,MBX_IO_STATUS,MBX_MESSAGE_L, 1 CODE,(MBX_MESSAGE(I),I=1,MBX_MESSAGE_L) Return 100 Format( 2A ) 200 Format( A,Z10,Z10,I10/I3,128A1 ) End Integer Function CONNECT(REQ_PID) Include 'LABCHNDEF.FOR' Include 'LABMBXDEF.FOR' Character*63 MAILBOX_NAME Integer*4 REQ_PID,CHECK_PID Logical*4 OPEN_MAILBOX CONNECT = 1 ! ! Find an empty CONNECT_BLOCK slot ! Do 10 I = 1, MAX_PID If ( CONNECT_BLOCK(I,1) .eq. 0 ) Go To 20 10 Continue ! We should never get here, since the last slot of ! the CONNECT_BLOCK is a spare for sending message ! disallowing a connect! Go To 99 ! ! Open user specified MAILBOX ! 20 Decode (MBX_MESSAGE_L,100,MBX_MESSAGE) MAILBOX_NAME If( .not. OPEN_MAILBOX( MAILBOX_CHAN,MAILBOX_NAME) ) Go To 99 ! ! Allocate the connect block. if it is not a duplicate ! PID, store the PID and mailbox channel in CONNECT_BLOCK ! If it is a duplicate, store the PID as -1. If( CHECK_PID(REQ_PID) .eq. 0 ) Then CONNECT_BLOCK(I,1) = REQ_PID CONNECT = 0 Else CONNECT_BLOCK(I,1) = -1 !Duplicate PID! We will Disconnect !After Acknowledging request End If CONNECT_BLOCK(I,2) = MAILBOX_CHAN If ( I .ge. MAX_PID ) CONNECT = 1 !No room for process! 99 Return 100 Format(15X,A) End Integer Function DISCONNECT(REQ_PID) ! This routine disconnects a process from the LABIO system. ! If it is a valid process, all channels still allocated are ! deallocated, the request is acknowledged, the channel assigned ! to the mailbox is deassigned, and the CONNECT_BLOCK entry is removed. Include 'LABCHNDEF.FOR' Integer*4 REQ_PID,CHECK_PID DISCONNECT = 1 ! ! Find index into connect block ! CONNECT_INDEX = CHECK_PID(REQ_PID) If (CONNECT_INDEX .eq. 0 ) Go To 99 !Not connected ! ! Deallocate all A/D channels ! Call DEALLOCATE_ALL(REQ_PID) ! ! Acknowledge DISCONNECT request ! Call ACKNOWLEDGE(0) ! ! Close the mailbox, and zero CONNECT_BLOCK ! Call SYS$DASSGN( %Val(CONNECT_BLOCK(CONNECT_INDEX,2)) ) CONNECT_BLOCK(CONNECT_INDEX,1) = 0 CONNECT_BLOCK(CONNECT_INDEX,2) = 0 DISCONNECT =0 99 Return End Integer Function ABORT(REQ_PID) Call DISCONNECT( REQ_PID ) Return End Integer Function ALLOCATE(REQ_PID) ! This routines allocates an A/D channel to a specific process. ! The process request a channels by number (1-16), specifing ! the asample rate in tics/sample, the buffer size in words, and ! the number of buffers to acquire ( 0 = infinity ). The user can ! default the rate to 1 tic/sample. Default the buffer size to ! the maximum, and the buffer count to 0. If the user reallocates ! the channel, the defaults are the previous values allocated. ! The channel must been INACTIVE if it is reallocated. Include 'LABCHNDEF.FOR' Include 'LABMBXDEF.FOR' Integer*4 REQ_PID !PID of requesting process Integer*4 PARM(4) !4 input parameters Integer*2 CONNECT_INDEX,CHECK_PID Integer*4 REQ_AD_CHAN,REQ_TICS,REQ_BUF_SIZE,REQ_BUF_COUNT Logical CHECK_PARM ! ! Get index into CONNECT_BLOCK for REQ_PID ! If index is not > 0 , ignore request ! ALLOCATE = 1 !Checking first field CONNECT_INDEX = CHECK_PID(REQ_PID) If ( CONNECT_INDEX .le. 0 ) Go To 99 !Req. Proc not connected! ! ! Decode message into four fields ! Decode ( MBX_MESSAGE_L,100,MBX_MESSAGE) PARM REQ_AD_CHAN = PARM(1) !Requested A/D channel is first parm REQ_TICS = PARM(2) !Tics/sample is 2nd REQ_BUF_SIZE= PARM(3) !Buffer size is 3rd REQ_BUF_COUNT=PARM(4) !Number of buffers is 4th ALLOCATE = 2 !Check next parameter (channel number) ! Valid channel numbers are 1-16 If (REQ_AD_CHAN .lt. 1 .or. REQ_AD_CHAN .gt. 16) Go To 99 ! Requested channel must not allocated, or ! allocated to the requesting process If ( AD_BLOCK(2,REQ_AD_CHAN) .ne. 0 .and. 1 AD_BLOCK(2,REQ_AD_CHAN) .ne. REQ_PID ) Go To 99 ! The channel must not be active If (AD_BLOCK(1,REQ_AD_CHAN) .gt. INACTIVE ) Go To 99 ALLOCATE = 3 !Checking next parm (Tics/sample) ! Tics/sample must be between 1 and 2^31-1 If( .not. CHECK_PARM(REQ_TICS,AD_BLOCK(3,REQ_AD_CHAN), 1 1,'7FFFFFFF'X,1) ) Go To 99 ALLOCATE = 4 !Checking parmeter (Buffer size) ! ! Buffer size between 1 and MAX_BUF_SIZE ! If( .not. CHECK_PARM(REQ_BUF_SIZE,AD_BLOCK(4,REQ_AD_CHAN), 1 1,MAX_BUF_SIZE,MAX_BUF_SIZE) ) Go To 99 ALLOCATE = 5 ! Checking next parameter (number of buffers) ! Number of buffers to acquire must be between 1 and 2^31-1, or ! zero to indicate no limit If ( .not. CHECK_PARM(REQ_BUF_COUNT,AD_BLOCK(5,REQ_AD_CHAN),1, 1 '7FFFFFFF'x,0) ) Go To 99 ALLOCATE = 0 !Everything is acceptable ! ! Enter info into AD_BLOCK ! AD_BLOCK(1,REQ_AD_CHAN) = 0 !Lock the data base ! ! Clear associated event flags ! Call SYS$CLREF(%Val( EF_NOTIFY_OFF + REQ_AD_CHAN ) ) Call SYS$CLREF(%Val( EF_ACTIVITY_OFF + REQ_AD_CHAN) ) Call SYS$CLREF(%Val( EF_STATUS_OFF + REQ_AD_CHAN ) ) AD_BLOCK(2,REQ_AD_CHAN) = REQ_PID !Requesting PID AD_BLOCK(3,REQ_AD_CHAN) = REQ_TICS !Tics/sample AD_BLOCK(4,REQ_AD_CHAN) = REQ_BUF_SIZE !Requested buffer size AD_BLOCK(5,REQ_AD_CHAN) = REQ_BUF_COUNT !Number of buffers to acquire AD_BLOCK(6,REQ_AD_CHAN) = 0 !No buffers acquired AD_BLOCK(7,REQ_AD_CHAN) = 0 !No data buffer available AD_BLOCK(8,REQ_AD_CHAN) = 0 !Number elements in last buf AD_BLOCK(9,REQ_AD_CHAN) = 1 !Current buffer index AD_BLOCK(10,REQ_AD_CHAN) = 0 !Current buffer count AD_BLOCK(11,REQ_AD_CHAN) = 1 !Tics remaining AD_BLOCK(12,REQ_AD_CHAN) = 0 !Offset to next data point AD_BLOCK(1,REQ_AD_CHAN) = INACTIVE !Channel is inactive Return ! ! Error return ! 99 Return !Return to caller 100 Format(15X,4I) End Integer Function DEALLOCATE(REQ_PID) ! This routine deallocates a channel previously allocated by ! a process. The channel must be INACTIVE when deallocated. Include 'LABCHNDEF.FOR' Include 'LABMBXDEF.FOR' Integer*4 REQ_PID !PID of requesting process Integer*2 CONNECT_INDEX,CHECK_PID Integer*4 REQ_AD_CHAN ! Get index into CONNECT_BLOCK for REQ_PID ! If index is not > 0 , ignore request DEALLOCATE = 1 !Checking first field CONNECT_INDEX = CHECK_PID(PID) If ( CONNECT_INDEX .le. 0 ) Go To 99 DEALLOCATE = 2 Decode (MBX_MESSAGE_L,100,MBX_MESSAGE) REQ_AD_CHAN ! Valid channel numbers are 1-16 If (REQ_AD_CHAN .lt. 1 .or. REQ_AD_CHAN .gt. 16) Go To 99 ! Does requesting process own the channel? DEALLOCATE = 21 If (AD_BLOCK(2,REQ_AD_CHAN) .ne. REQ_PID ) Go To 99 ! Is the channel inactive, clear the channel parameters DEALLOCATE = 22 If ( AD_BLOCK(1,REQ_AD_CHAN) .ne. INACTIVE ) Go to 99 Call AD_CANCEL(REQ_AD_CHAN) DEALLOCATE = 0 !Everything OK Return ! ! ERROR return ! 99 Return ! ! This entry point is used to deallocate all channels ! allocated to a specific process. Entry DEALLOCATE_ALL(REQ_PID) DEALLOCATE = 1 ! Valid PID? CONNECT_INDEX = CHECK_PID(PID) If ( CONNECT_INDEX .ne. 0 ) Then ! Look for all A/D channels allocated to process ! and cancel all I/O unconditionally. Do 10 AD_CHAN = 1 , MAX_AD_CHANNEL If ( AD_BLOCK(2,AD_CHAN) .eq. REQ_PID ) Call AD_CANCEL(AD_CHAN) 10 Continue DEALLOCATE_ALL = 0 End If Return 100 Format(15X,I15) End Integer*4 Function AD_CANCEL( CHANNEL ) ! Clears the parameter table associated with A/D channel Include 'LABCHNDEF.FOR' Integer CHANNEL AD_CANCEL = 1 !Assume error ! ! Legal channel numbers are 1-16 ! If ( CHANNEL .ge. 1 .and. CHANNEL .le. 16 ) Then ! ! Zero the AD_BLOCK for this channel ! Do 10 J = 1 , 16 !Clear everthing 10 AD_BLOCK(J, CHANNEL ) = 0 AD_CANCEL = 0 !Everything ok End IF ! ! Clear associated event flags ! Call SYS$CLREF(%Val( EF_NOTIFY_OFF + CHANNEL ) ) Call SYS$CLREF(%Val( EF_ACTIVITY_OFF + CHANNEL ) ) Call SYS$CLREF(%Val( EF_STATUS_OFF + CHANNEL ) ) 99 Return End Logical Function CHECK_PARM(IVAL,OVAL,MIN,MAX,DEFAULT) ! This routine validates and defaults an input parameter (IVAL) ! If IVAL is not 0, it compares it to MIN and MAX, returning TRUE or FALSE. ! If IVAL is 0, and OVAL is not zero, IVAL = OVAL ! If IVAL is 0, and OVAL is zero, IVAL = DEFAULT Integer*4 IVAL,OVAL,MIN,MAX,DEFAULT CHECK_PARM = .false. !assume the worst If (IVAL .ne. 0 ) Then If( IVAL .lt. MIN .or. IVAL .gt. MAX) Go To 99 Else If (OVAL .ne. 0 ) Then IVAL = OVAL Else IVAL = DEFAULT End If End IF CHECK_PARM = .true. 99 Return END Integer Function CHECK_PID(PID) ! This routine checks to see if a PID is in CONNECT_BLOCK ! If it is, the INDEX into CONNECT_BLOCK is returned. If ! it isn't, 0 is returned Include 'LABCHNDEF.FOR' Integer*4 PID ! Assume PID is not in database CHECK_PID = 0 ! If PID is found, return index. Do 10 I = 1 , MAX_PID If( CONNECT_BLOCK(I,1) .eq. PID ) CHECK_PID = I 10 Continue Return End