PROGRAM MAILBOX_A
	IMPLICIT NONE
C******************************************************************************
C***
C***	This program is an example of using mailboxes to comunicate between
C***	two process. This program MAILBOX_A, creates two mailboxs. One for
C***	read and one for write then spawns a subprocess MAILBOX_B, which opens 
C***	the two mailboxs. MAILBOX_A then writes two unformatted integers describing
C***	the two dimensions of a real array to transfer. If either of the two integers
C***	is zero, then MAILBOX_B closes the two mailboxes and exits. Then MAILBOX_B
C***	closes and deletes the mailboxes and exits itself. However if the two
C***	integers are non-zero, then the two-dimensional real array is transferred to
C***	MAILBOX_B which then negates all elements and sends it back to MAILBOX_A.
C***
C***	Author :	Jeff Cameron
C***			jcam90502@jcameron.com
C***			http://www.jcameron.com/vms/
C***
C***	Modification history :
C***
C***	Programmer	Date		Description
C*** ----------------------------------------------------------------------
C***	Jeff Cameron	25-JAN-1989	Initially written
C*** ----------------------------------------------------------------------
C***
C******************************************************************************
C
C***	Constants
	INCLUDE		'($SSDEF)'
	INCLUDE		'($LIBDEF)'
	INTEGER*1	TEMPORARY
	PARAMETER	(TEMPORARY = 0)
	INTEGER*4	NOWAIT
	PARAMETER	(NOWAIT = 1)
C
C***	Common blocks
C
C***	Local declarations
	REAL*4		IN_ARRAY (100,100)
	REAL*4		OUT_ARRAY (100,100)
	INTEGER*4	ROWS,COLS
	INTEGER*4	I,J
	INTEGER*4	ERRORS
C
	INTEGER*4	STATUS
	INTEGER*4	ATOB_CHAN, BTOA_CHAN
	INTEGER*4	A2B /11/, B2A /12/	! Fortran LUNS for mailboxes
	INTEGER*4	PID, COMPLETION_STATUS, COUNT
C
C***	Externals
	INCLUDE		'($SYSSRVNAM)'
	INTEGER*4	LIB$SPAWN
	EXTERNAL	LIB$SPAWN
C
C***	Formats
 1	FORMAT (A)
C------------------------------------------------------------------------------
C
C***	Begining of executable code.
C***	First create the mailbox for transfer from A to B
	WRITE (6,1) ' >> Creating A to B mailbox.'
	STATUS = SYS$CREMBX (%VAL(TEMPORARY),ATOB_CHAN,,,,,'A_TO_B',)
	IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))
C
C***	Open the file for unformatted writes
	WRITE (6,1) ' >> Opening A to B mailbox.'
	OPEN (UNIT=A2B,FILE='A_TO_B',STATUS='NEW',FORM='UNFORMATTED',IOSTAT=STATUS)
	IF (STATUS .NE. 0) STOP 'OPEN ATOB'
C
C***	NOW CREATE the mailbox for transfer back from B to A
	WRITE (6,1) ' >> Creating B to A mailbox.'
	STATUS = SYS$CREMBX (%VAL(TEMPORARY),BTOA_CHAN,,,,,'B_TO_A',)
	IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))
C
C***	Now open file for unformatted reads
	WRITE (6,1) ' >> Opening B to A mailbox.'
	OPEN (UNIT=B2A,FILE='B_TO_A',STATUS='NEW',FORM='UNFORMATTED',IOSTAT=STATUS)
	IF (STATUS .NE. 0) STOP 'OPEN BTOA'
C
C***	Create the subprocess
	WRITE (6,1) ' >> Creating MAILBOX_B subprocess.'
	STATUS = LIB$SPAWN ('RUN MAILBOX_B.EXE',,,NOWAIT,'MBX B',PID,%VAL(%LOC(COMPLETION_STATUS)),,,,,,)
	IF (.NOT. STATUS) CALL LIB$STOP (%VAL(STATUS))
	COMPLETION_STATUS = -1
C
C***	GENERATE AND WRITE THE FIRST ARRAY
	ROWS = 50
	COLS = 80
	ERRORS = 0
C
	WRITE (6,1) ' >> Writing ROWS,COLS for pass 1.'
	WRITE (A2B) ROWS,COLS
C
	WRITE (6,1) ' >> Sending pass 1 array.'
	DO J = 1,ROWS
	    DO I = 1,COLS
		IN_ARRAY (I,J) = FLOAT (I - J)
	    END DO
	    WRITE (A2B) (IN_ARRAY(I,J),I=1,COLS)
	END DO
C
	ERRORS = 0
C
C***	READ and check THE RESPONSE
	WRITE (6,1) ' >> reading back pass 1 array.'
	DO J = 1,ROWS
	    READ (B2A) (OUT_ARRAY(I,J),I=1,COLS)
	    DO I = 1,COLS
		IF (OUT_ARRAY(I,J) .NE. (-1.0*IN_ARRAY(I,J))) ERRORS = ERRORS + 1
	    END DO
	END DO
C
	WRITE (6,*) ' >> TOTAL ERRORS PASS 1 = ',ERRORS
C
	CALL SUSPEND (0,0,5,0)
C***	DO IT AGAIN
	ROWS = 100
	COLS = 100
	ERRORS = 0
C
	WRITE (6,1) ' >> Writing ROWS,COLS for pass 2.'
	WRITE (A2B) ROWS,COLS
C
	WRITE (6,1) ' >> Sending pass 2 array.'
	DO J = 1,ROWS
	    DO I = 1,COLS
		IN_ARRAY (I,J) = FLOAT (2*I - 2*J) 
	    END DO
	    WRITE (A2B) (IN_ARRAY(I,J),I=1,COLS)
	END DO
C
	ERRORS = 0
C
C***	READ and check THE RESPONSE
	WRITE (6,1) ' >> reading back pass 2 array.'
	DO J = 1,ROWS
	    READ (B2A) (OUT_ARRAY(I,J),I=1,COLS)
	    DO I = 1,COLS
		IF (OUT_ARRAY(I,J) .NE. (-1.0*IN_ARRAY(I,J))) ERRORS = ERRORS + 1
	    END DO
	END DO
C
	WRITE (6,*) ' TOTAL ERRORS PASS 2 = ',ERRORS
C
	CALL SUSPEND (0,0,5,0)
C***	TELL THE SUBPROCESS TO QUIT
	ROWS = 0
	COLS = 0
	WRITE (6,1) ' >> Telling MAILBOX_B subprocess to quit.'
	WRITE (A2B) ROWS,COLS
C
C***	WAIT UNTIL COMPLETION STATUS IS WRITTEN
	COUNT = 0
	WRITE (6,1) ' >> Waiting for MAILBOX_B subprocess to quit.'
	DO WHILE (COMPLETION_STATUS .EQ. -1)
	    CALL SUSPEND (0,0,1,0)
	    COUNT = COUNT + 1
	    WRITE (6,1) ' >> Still Waiting.'
	    IF (COUNT .GT. 10) STOP 'SUBPSTOP'
	END DO
C
C***	CLOSE THE FORTRAN MAILBOX FILES
	WRITE (6,1) ' >> Closing FORTRAN Mailbox files.'
	CLOSE (UNIT=A2B)
	CLOSE (UNIT=B2A)
C
C***	DELETE THE MAILBOXES
	WRITE (6,1) ' >> Deleting Mailboxs.'
	STATUS = SYS$DELMBX (ATOB_CHAN)
	STATUS = SYS$DELMBX (BTOA_CHAN)
C
C***	All done
	WRITE (6,1) ' >> ALL DONE!'
	CALL EXIT
	END
	SUBROUTINE SUSPEND (HOURS,MINUTES,SECONDS,TENTHS)
	INTEGER*4 HOURS, MINUTES, SECONDS, TENTHS
C*********************************************************************
C***
C***	THIS ROUTINE WILL SUSPEND THE PROGRAM FOR THE SPECIFIED TIME
C***
C***	HOURS IS LIMITED FROM 0 TO 23
C***	MINUTES IS LIMITED FROM 0 TO 59
C***	SECONDS IS LIMITED FROM 0 TO 59
C***	TENTHS IS LIMITED FROM 0 TO 9
C***
C***	IF ALL PARAMETERS ARE 0, THEN THE ROUTINE WILL RETURN
C***	IMMEDIATELY
C***
C***	PARAMETERS :
C***
C***		HOURS	(I*4)	NUMBER OF HOURS TO WAIT
C***
C***		MINUTES	(I*4)	NUMBER OF MINUTES TO WAIT
C***
C***		SECONDS	(I*4)	NUMBER OF SECONDS TO WAIT
C***
C***		TENTHS	(I*4)	NUMBER OF TENTHS OF SECONDS TO WAIT
C***
C********************************************************************
C*MCT
	INTEGER*4 H, M, S, T
	CHARACTER*16 ASCII_TIME
	INTEGER*4 BINARY_TIME(2)
C
	INTEGER*4 SYS$BINTIM,	SYS$SETIMR,	SYS$WAITFR
	INTEGER*4 LIB$GET_EF
	INTEGER*4 FLAG
C
C***	LIMIT VALUES
	H = LIMIT (HOURS,0,23)
	M = LIMIT (MINUTES,0,59)
	S = LIMIT (SECONDS,0,59)
	T = LIMIT (TENTHS,0,9)
C
	I = H + M + S + T
	IF (I .EQ. 0) RETURN
C
C***	ENCODE THE ASCII TIME
	ENCODE (16,10,ASCII_TIME) H, M, S, T
 10	FORMAT ('0000 ',I2.2,':',I2.2,':',I2.2,'.',I1,'0')
C
C***	CONVERT TO SYSTEM BINARY TIME
	ISTAT = SYS$BINTIM (ASCII_TIME,BINARY_TIME)
	IF (.NOT. ISTAT) CALL SYS_SIGNAL (ISTAT)
C
C***	FIND OURSELF AN EVENT FLAG WE CAN USE
	CALL LIB$GET_EF (FLAG)
	IF (FLAG .EQ. -1) THEN
C
C***	   NO EVENT FLAGS AVAILABLE, RETURN WITH NO DELAY
	   RETURN
	ELSE
	ENDIF
C
C***	NOW SET THE TIMER
	ISTAT = SYS$SETIMR (%VAL(FLAG),BINARY_TIME,,)
	IF (.NOT. ISTAT) CALL SYS_SIGNAL (ISTAT)
C
C***	NOW SUSPEND OURSELF, AND WAIT FOR EVENT FLAG TO RAISE
	ISTAT = SYS$WAITFR (%VAL(FLAG))
	IF (.NOT. ISTAT) CALL SYS_SIGNAL (ISTAT)
C
C***	FREE THE EVENT FLAG
	CALL LIB$FREE_EF (FLAG)
C
	RETURN
	END
	SUBROUTINE SYS_SIGNAL (STATUS)
	INTEGER*4 STATUS
C*********************************************************************
C***
C***	This routine will take the status longword returned by a VMS
C***	system service, or runtime library routine and report to the
C***	SYS$OUTPUT device the error status. Since LIB$SIGNAL will
C***	stop the image if the severity is fatal, this routine will
C***    mask off the severity bit (bit 2) changing the error to a 
C***	warning.
C***
C***	PARAMETER :
C***		STATUS	(I*4) VMS STATUS LONGWORD
C***
C*********************************************************************
C*MCT
	INTEGER*4 LOCAL_STATUS
C
C***	ONLY PROCESS IF THERE IS AN ERROR
	IF (.NOT. STATUS) THEN
	    LOCAL_STATUS = STATUS
	    IF (BJTEST(LOCAL_STATUS,2)) LOCAL_STATUS = LOCAL_STATUS - 4
	    CALL LIB$SIGNAL (%VAL(LOCAL_STATUS))
	ELSE
	ENDIF
C
	RETURN
	END
	INTEGER*4 FUNCTION LIMIT (VALUE,MINIMUM,MAXIMUM) !	SUBROUTINE LIMIT
C	SUBROUTINE LIMIT
	INTEGER*4 VALUE		! INPUT VALUE TO BE LIMITED
	INTEGER*4 MINIMUM	! LOWER LIMIT VALUE
	INTEGER*4 MAXIMUM	! UPPER LIMIT VALUE
C************************************************************************
C***
C***	THIS FUNCTION WILL CLIP VALUE BETWEEN THE MINIMUM LIMIT AND
C***	THE MAXIMUM LIMIT.
C***
C***	PARAMETERS :
C***
C***		VALUE	(I*4)	INPUT VALUE TO BE LIMITED
C***
C***		MINIMUM	(I*4)	LOWWER LIMIT VALUE
C***
C***		MAXIMUM	(I*4)	UPPER LIMIT VALUE
C***
C************************************************************************
C*MCT
	IF (VALUE .GT. MAXIMUM) THEN
	   LIMIT = MAXIMUM
C
	ELSE IF (VALUE .LT. MINIMUM) THEN
	   LIMIT = MINIMUM
C
	ELSE
	   LIMIT = VALUE
	ENDIF
	RETURN
	END