	PROGRAM EXPORT

**
*
*	Alan L. Zirkle     K53     16 June 1986
*
*

	IMPLICIT NONE

	INTEGER SJC$_FILE_SPECIFICATION,SJC$_QUEUE,
	1	SJC$_JOB_STATUS_OUTPUT,SJC$_ENTER_FILE,
	2	SJC$_ENTRY_NUMBER_OUTPUT,SJC$_SYNCHRONIZE_JOB,
	3	SJC$_ENTRY_NUMBER,SJC$_DELETE_FILE,SJC$_LOG_DELETE,
	4	SJC$_LOG_QUEUE,SJC$_LOG_SPECIFICATION,SJC$_NO_LOG_SPOOL,
	5	SJC$_PARAMETER_1,SJC$_PARAMETER_2,SJC$_PARAMETER_3,
	6	SJC$_PARAMETER_4,SJC$_PARAMETER_5,SJC$_PARAMETER_6,
	7	SJC$_PARAMETER_7,SJC$_PARAMETER_8,SJC$_USERNAME,
	8	SJC$_JOB_NAME,SJC$_NO_LOG_SPECIFICATION,SJC$_LOG_SPOOL,
	9	SJC$_NO_LOG_DELETE

	PARAMETER ( SJC$_ENTER_FILE = '13'X )
	PARAMETER ( SJC$_SYNCHRONIZE_JOB = '1D'X )

	PARAMETER ( SJC$_FILE_SPECIFICATION = '2A'X )
	PARAMETER ( SJC$_QUEUE = '86'X )
	PARAMETER ( SJC$_JOB_STATUS_OUTPUT = '58'X )
	PARAMETER ( SJC$_ENTRY_NUMBER = '1E'X )
	PARAMETER ( SJC$_ENTRY_NUMBER_OUTPUT = '1F'X )
	PARAMETER ( SJC$_DELETE_FILE = '18'X )
	PARAMETER ( SJC$_LOG_DELETE = '5F'X )
	PARAMETER ( SJC$_NO_LOG_DELETE = '60'X )
	PARAMETER ( SJC$_LOG_QUEUE = '61'X )
	PARAMETER ( SJC$_LOG_SPECIFICATION = '62'X )
	PARAMETER ( SJC$_NO_LOG_SPECIFICATION = '63'X )
	PARAMETER ( SJC$_LOG_SPOOL = '64'X )
	PARAMETER ( SJC$_NO_LOG_SPOOL = '65'X )
	PARAMETER ( SJC$_PARAMETER_1 = '77'X )
	PARAMETER ( SJC$_PARAMETER_2 = '78'X )
	PARAMETER ( SJC$_PARAMETER_3 = '79'X )
	PARAMETER ( SJC$_PARAMETER_4 = '7A'X )
	PARAMETER ( SJC$_PARAMETER_5 = '7B'X )
	PARAMETER ( SJC$_PARAMETER_6 = '7C'X )
	PARAMETER ( SJC$_PARAMETER_7 = '7D'X )
	PARAMETER ( SJC$_PARAMETER_8 = '7E'X )
	PARAMETER ( SJC$_USERNAME = '9F'X )
	PARAMETER ( SJC$_JOB_NAME = '4F'X )

	EXTERNAL CLI$_COMMA,CLI$_NEGATED,CLI$_ABSENT
	EXTERNAL AST

	INTEGER*4 ITMLST(100),ITMLST2(7),IOSB(2)

	INTEGER*4 I,IL,ILBASE,STATUS,FSLEN,LSLEN,JSLEN,ENTRY_NUMBER,WLEN,
	1	  PLEN(8),UNLEN,JNLEN,LQLEN,TOTAL_JOBS,JOBS_TO_DO,
	2	  COMPLETED_JOB,WORST_STATUS

	CHARACTER*256 FILE_SPEC,LOG_SPEC,JOB_STATUS,PARAM(8),WORK
	CHARACTER*39 JOBNAME
	CHARACTER*32 LOGQUEUE
	CHARACTER*12 USERNAME

	LOGICAL BUILT,MORE_PARAMS,MAKELOG,KEEPLOG,CLUSTER_WIDE,SAVESTAT,
	1	COPIES

	LOGICAL CLI$PRESENT
	INTEGER CLI$GET_VALUE,SYS$SNDJBCW,STR_LEN,LIB$SET_SYMBOL,
	1	LIB$DELETE_FILE,SYS$SNDJBC

	COMMON /ITMLST_/ IL,ITMLST

	STRUCTURE /JOBLIST/
	    CHARACTER*32 QUEUE
	    INTEGER*4 QLEN
	    CHARACTER*32 STATUS_SYMBOL
	    INTEGER*4 SLEN
	    INTEGER*4 IOSB2(2)
	    INTEGER*4 ENTRY_NUMBER
	END STRUCTURE !/JOBLIST/

	RECORD /JOBLIST/ JOBS(16)

	COMMON /JOBLIST_/ JOBS_TO_DO,COMPLETED_JOB,JOBS

	VOLATILE JOBS_TO_DO,COMPLETED_JOB,ENTRY_NUMBER,JOB_STATUS,JSLEN

	DATA IL,JOBS_TO_DO,TOTAL_JOBS,WORST_STATUS / 1,1,0,1 /
	DATA SAVESTAT,CLUSTER_WIDE,COPIES,BUILT,KEEPLOG,MAKELOG
	1					    / 5*.FALSE.,.TRUE. /

C*****  Get the /STATUS qualifier value, if any  ***********************

	IF (CLI$PRESENT('STATUS')) THEN

	    CALL CLI$GET_VALUE('STATUS',JOBS(1).STATUS_SYMBOL,
	1						   JOBS(1).SLEN)
	    SAVESTAT = .TRUE.

	ENDIF

C*****  The QUEUE  *****************************************************

	IF (CLI$PRESENT('QUEUE')) THEN

	    CALL CLI$GET_VALUE('QUEUE',JOBS(1).QUEUE,JOBS(1).QLEN)

	ELSE IF (CLI$PRESENT('CLUSTER')) THEN
	
	    CLUSTER_WIDE = .TRUE.

	    CALL GET_CLUSTER_NODES

	ELSE

	    CALL FPRINT(' %EXPORT-F-MISSING, /QUEUE or /CLUSTER'//
	1					  ' qualifier required')
	    CALL EXIT('10000004'X)

	ENDIF

C*****  The COPY count  ************************************************

	IF (CLI$PRESENT('COPIES')) THEN

	    CALL CLI$GET_VALUE('COPIES',WORK,WLEN)

	    CALL OTS$CVT_TI_L(WORK(1:WLEN),JOBS_TO_DO)

	    IF (JOBS_TO_DO.LT.1 .OR. JOBS_TO_DO.GT.16) THEN
	        CALL FPRINT(' %EXPORT-F-COPIES, /COPIES value must'//
	1					 ' be between 1 and 16')
	        CALL EXIT('10000004'X)
	    ENDIF

	    DO I=JOBS_TO_DO,1,-1

		CALL SYS$FAO('!UL',WLEN,WORK,%VAL(I))

		JOBS(I).QUEUE = JOBS(1).QUEUE
		JOBS(I).QLEN  = JOBS(1).QLEN
		JOBS(I).STATUS_SYMBOL =
	1	     JOBS(1).STATUS_SYMBOL(1:JOBS(1).SLEN) // '_'
	2					 	 // WORK(1:WLEN)
		JOBS(I).SLEN = JOBS(1).SLEN + WLEN + 1

	    ENDDO

	    COPIES = .TRUE.

	ENDIF

C*****  The FILE-SPEC  *************************************************

	IF (CLI$PRESENT('P1')) THEN

	    CALL CLI$GET_VALUE('P1',FILE_SPEC,FSLEN)

	    INQUIRE (FILE=FILE_SPEC(1:FSLEN),DEFAULTFILE='.COM',
	1						 NAME=FILE_SPEC)
	    FSLEN = STR_LEN(FILE_SPEC)

	ELSE

	    OPEN (1,FILE='EXPORT.TMP',STATUS='NEW',
	1					 CARRIAGECONTROL='LIST')

	    INQUIRE (1,NAME=FILE_SPEC)

	    FSLEN = STR_LEN(FILE_SPEC)

	    CALL BUILD_COMMAND_FILE

	    BUILT = .TRUE.

	ENDIF

	CALL ITEM_LIST(ITMLST(IL),SJC$_FILE_SPECIFICATION,
	1					    FILE_SPEC(1:FSLEN),)
	IL = IL + 3

C*****  Delete the input file after completion?  ***********************

	IF (CLI$PRESENT('DELETE')) THEN

	    CALL ITEM_LIST(ITMLST(IL),SJC$_DELETE_FILE,)
	    IL = IL + 3

	ENDIF

C*****  Job parameters  ************************************************

	I = 0

	MORE_PARAMS = CLI$PRESENT('PARAMETERS')

	DO WHILE (MORE_PARAMS)

	    I = I + 1

	    IF (I.GT.8) THEN
		CALL FPRINT(' %EXPORT-F-PARAM, too many '//
	1					    '/PARAMETER values')
		CALL EXIT('10000004'X)
	    ENDIF

	    STATUS = CLI$GET_VALUE('PARAMETERS',PARAM(I),PLEN(I))

	    CALL ITEM_LIST(ITMLST(IL),SJC$_PARAMETER_1-1+I,
	1					   PARAM(I)(1:PLEN(I)),)
	    IL = IL + 3

	    MORE_PARAMS = STATUS .EQ. %LOC(CLI$_COMMA)

	ENDDO

C*****  Existance of the log file  *************************************

	STATUS = CLI$PRESENT('LOG_FILE')

	IF (STATUS.EQ.%LOC(CLI$_NEGATED)) THEN

	    CALL ITEM_LIST(ITMLST(IL),SJC$_NO_LOG_SPECIFICATION,)
	    IL = IL + 3

	    MAKELOG = .FALSE.

	ELSE IF (STATUS) THEN

	    CALL CLI$GET_VALUE('LOG_FILE',LOG_SPEC,LSLEN)

	    IF (LSLEN.GT.0) THEN

		CALL ITEM_LIST(ITMLST(IL),SJC$_LOG_SPECIFICATION,
	1					     LOG_SPEC(1:LSLEN),)
		IL = IL + 3

	    ENDIF

	ENDIF

C*****  Handling of the log file  **************************************

	IF (MAKELOG) THEN

	    STATUS = CLI$PRESENT('PRINTER')

	    IF (STATUS.EQ.%LOC(CLI$_NEGATED)) THEN

		CALL ITEM_LIST(ITMLST(IL),SJC$_NO_LOG_SPOOL,)
		IL = IL + 3

		KEEPLOG = .TRUE.

	    ELSE IF (STATUS) THEN

		CALL CLI$GET_VALUE('PRINTER',LOGQUEUE,LQLEN)

		CALL ITEM_LIST(ITMLST(IL),SJC$_LOG_SPOOL,
	1					     LOGQUEUE(1:LQLEN),)
		IL = IL + 3

	    ENDIF

	ENDIF

	STATUS = CLI$PRESENT('KEEP')

	IF (STATUS.NE.%LOC(CLI$_ABSENT)) KEEPLOG = STATUS

	I = SJC$_LOG_DELETE

	IF (KEEPLOG) I = SJC$_NO_LOG_DELETE	

	CALL ITEM_LIST(ITMLST(IL),I,)
	IL = IL + 3

C*****  User on whose behalf we are submitting the job  ****************

	IF (CLI$PRESENT('USER')) THEN

	    CALL CLI$GET_VALUE('USER',USERNAME,UNLEN)

	    CALL ITEM_LIST(ITMLST(IL),SJC$_USERNAME,USERNAME(1:UNLEN),)
	    IL = IL + 3

	ENDIF

C*****  Name of the job  ***********************************************

	IF (CLI$PRESENT('NAME')) THEN

	    CALL CLI$GET_VALUE('NAME',JOBNAME,JNLEN)

	    CALL ITEM_LIST(ITMLST(IL),SJC$_JOB_NAME,JOBNAME(1:JNLEN),)
	    IL = IL + 3

	ENDIF

C*****  Areas for information to be returned  **************************

	CALL ITEM_LIST(ITMLST(IL),SJC$_JOB_STATUS_OUTPUT,JOB_STATUS,
	1							  JSLEN)
	IL = IL + 3

	CALL ITEM_LIST(ITMLST(IL),SJC$_ENTRY_NUMBER_OUTPUT,ENTRY_NUMBER)
	IL = IL + 3

C*****  Submit the job(s)  *********************************************

	CALL SYS$SETAST()

	ILBASE = IL

	CALL FPRINT(' ')

10	TOTAL_JOBS = TOTAL_JOBS + 1

	IL = ILBASE

	CALL ITEM_LIST(ITMLST(IL),SJC$_QUEUE,
	1	       JOBS(TOTAL_JOBS).QUEUE(1:JOBS(TOTAL_JOBS).QLEN),)
	IL = IL + 3

	IF (COPIES) THEN

	    CALL SYS$FAO('!UL',WLEN,WORK,%VAL(TOTAL_JOBS))

	    CALL ITEM_LIST(ITMLST(IL),SJC$_PARAMETER_8,WORK(1:WLEN),)
	    IL = IL + 3

	ENDIF

	STATUS = SYS$SNDJBCW(,%VAL(SJC$_ENTER_FILE),,ITMLST,IOSB,,)

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (.NOT.IOSB(1)) CALL LIB$STOP(%VAL(IOSB(1)))

	IF (JOBS_TO_DO.GT.1) THEN
	    CALL FPRINT('   !UL. !AS',TOTAL_JOBS,JOB_STATUS(1:JSLEN))
	ELSE
	    CALL FPRINT('   !AS',JOB_STATUS(1:JSLEN))
	ENDIF

	JOBS(TOTAL_JOBS).ENTRY_NUMBER = ENTRY_NUMBER

C*****  Set up for notification when each job completes  ***************

	CALL ITEM_LIST(ITMLST2,
	1  SJC$_QUEUE,JOBS(TOTAL_JOBS).QUEUE(1:JOBS(TOTAL_JOBS).QLEN),,
	1		SJC$_ENTRY_NUMBER,JOBS(TOTAL_JOBS).ENTRY_NUMBER)

	STATUS = SYS$SNDJBC(,%VAL(SJC$_SYNCHRONIZE_JOB),,ITMLST2,
	1		    JOBS(TOTAL_JOBS).IOSB2,AST,%VAL(TOTAL_JOBS))

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	IF (TOTAL_JOBS.LT.JOBS_TO_DO) GO TO 10

C*****  Wait until the job(s) complete  ********************************

	IF (TOTAL_JOBS.EQ.1) THEN

	    CALL FPRINT('0  Waiting for the job to complete . . .')

	ELSE

	    CALL FPRINT('0  Waiting for the !UL jobs to complete . . .',
	1						     TOTAL_JOBS)
	ENDIF

20	CALL SYS$SETAST(%VAL(1))

	CALL GO_HIBERNATE

C*****  A job has completed  *******************************************

	I = JOBS(COMPLETED_JOB).IOSB2(1)

	IF (SAVESTAT) THEN

	    CALL SYS$FAO('%X!XL',WLEN,WORK,%VAL(I))

	    STATUS = LIB$SET_SYMBOL(JOBS(COMPLETED_JOB).
	1	 STATUS_SYMBOL(1:JOBS(COMPLETED_JOB).SLEN),WORK(1:WLEN))

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	ENDIF

	IF (I) THEN

	    CALL FPRINT('     Job !UL completed successfully',
	1			       JOBS(COMPLETED_JOB).ENTRY_NUMBER)

	ELSE

	    IF (IAND(I,7).GT.IAND(WORST_STATUS,7))
	1					WORST_STATUS = IAND(I,7)

	    CALL ERROR('     PROBLEM -- Final status of job !UL was:',
	1			      JOBS(COMPLETED_JOB).ENTRY_NUMBER,)

	    CALL SYS$GETMSG(%VAL(I),JSLEN,JOB_STATUS,,)

	    CALL ERROR('   !AD',JSLEN,%REF(JOB_STATUS))

	ENDIF

	IF (JOBS_TO_DO.GT.0) THEN
	    CALL FPRINT('   Waiting for !UL more job!%S . . .',JOBS_TO_DO)
	    GO TO 20
	ENDIF

C*****	All finished; delete the batch command file if EXPORT built it.

	IF (BUILT) THEN

	    STATUS = LIB$DELETE_FILE(FILE_SPEC(1:FSLEN))

	    IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	ENDIF

C*****	Create the DCL symbol EXPORT_STATUS.

	CALL SYS$FAO('!UL',WLEN,WORK,%VAL(WORST_STATUS))

	STATUS = LIB$SET_SYMBOL('EXPORT_STATUS',WORK(1:WLEN))

	IF (.NOT.STATUS) CALL LIB$STOP(%VAL(STATUS))

	END
	SUBROUTINE BUILD_COMMAND_FILE

*	Builds a batch command file from the following lines in
*	SYS$INPUT.  If column 1 contains an underscore, it is
*	removed.  If column 1 contains a tilde, it is removed and
*	the line is checked for DCL symbol replacement.

	IMPLICIT NONE

	CHARACTER*128 LINE

	INTEGER*4 LLEN,START

	LOGICAL INTIN,INTERACTIVE_INPUT
	INTIN = INTERACTIVE_INPUT()

10	IF (INTIN) PRINT 1000

	READ (*,1001,END=100) LLEN,LINE

	IF (LINE(1:1).EQ.'_') THEN

	    START = 2

	ELSE IF (LINE(1:1).EQ.'~') THEN

	    START = 2

	    LINE(LLEN+1:) = ' '

	    CALL SYMBOL_SUBSTITUTE(LINE,LLEN)

	ELSE

	    START = 1

	ENDIF

	WRITE (1,1002) LINE(START:LLEN)

	GO TO 10

100	CLOSE (1)

1000	FORMAT ('$EXPORT> ')
1001	FORMAT (Q,A)
1002	FORMAT (A)

	END
	SUBROUTINE GET_CLUSTER_NODES

*	Creates one batch job for each node on a cluster, except
*	for the node running EXPORT.  We get the node names and
*	each node's batch queue names from information in the
*	EXPORT.CLD file; specifically, the default values of the
*	qualifiers /Z1, /Z2, etc. .

*	JOBS(1).STATUS_SYMBOL and JOBS(1).SLEN must contain the
*	value of the /STATUS qualifier on the EXPORT command.

	IMPLICIT NONE

	CHARACTER*32 THISNODE
	CHARACTER*128 WORK
	CHARACTER*2 NODENUM / 'Zn' /

	INTEGER*4 IL,ITMLST(100)
	INTEGER*4 JOBS_TO_DO,COMPLETED_JOB
	INTEGER*4 COL,TNLEN,SLEN_SAVE,WLEN,TOTAL_NODES

	COMMON /ITMLST_/ IL,ITMLST

	STRUCTURE /JOBLIST/
	    CHARACTER*32 QUEUE
	    INTEGER*4 QLEN
	    CHARACTER*32 STATUS_SYMBOL
	    INTEGER*4 SLEN
	    INTEGER*4 IOSB2(2)
	    INTEGER*4 ENTRY_NUMBER
	END STRUCTURE !/JOBLIST/

	RECORD /JOBLIST/ JOBS(16)

	COMMON /JOBLIST_/ JOBS_TO_DO,COMPLETED_JOB,JOBS

	LOGICAL CLI$PRESENT,CLUSTER_MEMBER
	LOGICAL FIRST_CALL / .TRUE. /

	CALL CLUSTER_NODE(THISNODE,TNLEN)

	TOTAL_NODES = 0
	JOBS_TO_DO = 0
	SLEN_SAVE = JOBS(1).SLEN
	TOTAL_NODES = 0

10	TOTAL_NODES = TOTAL_NODES + 1

	CALL OTS$CVT_L_TZ(TOTAL_NODES,NODENUM(2:2))

	IF (CLI$PRESENT(NODENUM)) THEN		! /Z1, /Z2, ...

	    CALL CLI$GET_VALUE(NODENUM,WORK,WLEN)

	    COL = INDEX(WORK(1:WLEN),' ')

	    IF (WORK(1:COL-1).EQ.THISNODE(1:TNLEN)) GO TO 10

	    IF (.NOT.CLUSTER_MEMBER(WORK(1:COL-1))) THEN

		CALL ERROR('0WARNING -- Node !AD is unavailable--'//
	1				 'no job sent',COL-1,%REF(WORK))
		GO TO 10

	    ENDIF

	    JOBS_TO_DO = JOBS_TO_DO + 1

	    JOBS(JOBS_TO_DO).STATUS_SYMBOL =
	1     JOBS(1).STATUS_SYMBOL(1:SLEN_SAVE) // '_' // WORK(1:COL-1)

	    JOBS(JOBS_TO_DO).SLEN = SLEN_SAVE + COL

	    JOBS(JOBS_TO_DO).QUEUE = WORK(COL+1:WLEN)

	    JOBS(JOBS_TO_DO).QLEN = WLEN - COL

	    GO TO 10

	ENDIF

	END
	SUBROUTINE AST(ASTPARM)

*	This routine gets called each time a batch job completes.
*	The address of the argument ASTPARM is the ordinal number
*	(1,2,...) of the completing job (not the entry number).
*	We get the ordinal number and wake up the main program.
*	We disable ASTs so we can process one batch job fully 
*	before we get interrupted by another one completing.

	IMPLICIT NONE

	INTEGER*4 ASTPARM,JOBS_TO_DO,COMPLETED_JOB

	COMMON /JOBLIST_/ JOBS_TO_DO,COMPLETED_JOB

	VOLATILE JOBS_TO_DO,COMPLETED_JOB

	JOBS_TO_DO = JOBS_TO_DO - 1

	COMPLETED_JOB = %LOC(ASTPARM)	! This will be a job entry number

	CALL SYS$SETAST()

	CALL GO_WAKE_UP

	END
	SUBROUTINE ERROR(FMT_STRING,VAL1,VAL2)

	IMPLICIT NONE

	CHARACTER*(*) FMT_STRING
	CHARACTER*128 WORK

	CHARACTER*1 BEL /  7 /
	CHARACTER*1 ESC / 27 /

	INTEGER*4 VAL1,VAL2,WLEN

	LOGICAL FIRST_CALL,IOUT
	LOGICAL INTERACTIVE_OUTPUT

	DATA FIRST_CALL / .TRUE. /

	IF (FIRST_CALL) THEN
	    FIRST_CALL = .FALSE.
	    IOUT = INTERACTIVE_OUTPUT()
	ENDIF

	CALL SYS$FAO(FMT_STRING,WLEN,WORK,%VAL(VAL1),VAL2)

	IF (IOUT) THEN

	    WORK = WORK(1:1) // BEL // BEL // BEL // BEL //
	1				  ESC // '[1;7m' // WORK(2:WLEN)
	    WLEN = MAX(WLEN+10,91)

	    WORK(WLEN+1:WLEN+3) = ESC // '[m'

	    CALL FPRINT(WORK(1:WLEN+3))

	ELSE

	    CALL FPRINT(WORK(1:WLEN))

	ENDIF

	END
