[mod.computers.vax] SET DEFAULT program in FORTRAN

welch@UMass.BITNET (11/17/86)

This is in response to the person who asked for a change directory
routine in fortran.  The code here sets default to SYS$LOGIN, allows
other processing to be performed, then sets default back to where you
were to start with.  It should be straight forward enough to modify it
to do other things.

------------------cut here----------------------
	INCLUDE '($JPIDEF)'
	INCLUDE '($LNMDEF)'

	STRUCTURE /Itm/
	  INTEGER*2 BufLen
	  INTEGER*2 Code
	  INTEGER*4 Addr
	  INTEGER*4 RetLen
	END STRUCTURE

	RECORD /Itm/ Itemlist(2)

	COMMON /Disk_Stuff/ Orig_Disk, Orig_Dir,
     >                      Orig_Disk_Len, Orig_Dir_Len

	CHARACTER*80 Orig_Disk, Orig_Dir, New_Disk, New_Dir
	INTEGER*4 Orig_Disk_Len, Orig_Dir_Len, New_Disk_Len, New_Dir_Len

	CHARACTER*255 Buffer
	INTEGER*4 Retlen

	INTEGER*4 LIB$GETJPI
	INTEGER*4 LIB$SET_LOGICAL
	INTEGER*4 SYS$SETDDIR
	INTEGER*4 SYS$TRNLNM

	INTEGER*4 Colon
	INTEGER*4 Sts

	Itemlist(1).Buflen = 255
	Itemlist(1).Code = LNM$_STRING
	Itemlist(1).Addr = %LOC(Buffer)
	Itemlist(1).Retlen = %LOC(Retlen)

	Itemlist(2).Buflen = 0
	Itemlist(2).Code = 0

	Sts = SYS$TRNLNM(,'LNM$PROCESS_TABLE','SYS$DISK',,Itemlist)
	IF(.NOT. Sts .AND. Sts .NE. 0)THEN
	  CALL Write_Error('Error from SYS$TRNLNM=',Sts)
	END IF

	Orig_Disk = Buffer(:Retlen)
	Orig_Disk_Len = Retlen

	Sts = SYS$TRNLNM(,'LNM$JOB',
     >                   'SYS$LOGIN',,Itemlist)
	IF(.NOT. Sts .AND. Sts .NE. 0)THEN
	  CALL Write_Error('Error from SYS$TRNLNM=',Sts)
	END IF

	Colon = INDEX(Buffer,':')
	New_Disk = Buffer(:Colon)
	New_Disk_Len = Colon
	New_Dir = Buffer(Colon+1:Retlen)
	New_Dir_Len = Retlen - Colon+1

	Sts = LIB$SET_LOGICAL('SYS$DISK',New_Disk(:New_Disk_Len),,,)
	IF(.NOT. Sts .AND. Sts .NE. 0)THEN
	  CALL Write_Error('Error from LIB$SET_LOGICAL=',Sts)
	END IF

	Sts = SYS$SETDDIR(New_Dir(:New_Dir_Len),Orig_Dir_Len,Orig_Dir)
	IF(.NOT. Sts .AND. Sts .NE. 0)THEN
	  CALL Write_Error('Error from SYS$SETDDIR=',Sts)
	END IF

	call lib$spawn('sh def')
c	. other
c	. processing
c	. goes
c	. here

	CALL Reset_DDir

	END

	SUBROUTINE Reset_DDir

	COMMON /Disk_Stuff/ Orig_Disk, Orig_Dir,
     >                      Orig_Disk_Len, Orig_Dir_Len

	CHARACTER*80 Orig_Disk, Orig_Dir
	INTEGER*4 Orig_Disk_Len, Orig_Dir_Len

	INTEGER*4 Sts

	INTEGER*4 SYS$SETDDIR

	INTEGER*4 LIB$SET_LOGICAL

	Sts = SYS$SETDDIR(Orig_Dir(:Orig_Dir_Len),,)
	IF(.NOT. Sts .AND. Sts .NE. 0)THEN
	  CALL Write_Error('Error from SYS$SETDDIR=',Sts)
	END IF

	Sts = LIB$SET_LOGICAL('SYS$DISK',Orig_Disk(:Orig_Disk_Len),,,)
	IF(.NOT. Sts .AND. Sts .NE. 0)THEN
	  CALL Write_Error('Error from LIB$SET_LOGICAL=',Sts)
	END IF

	RETURN
	END

	SUBROUTINE Write_Error(Message, Value)

	CHARACTER*(*) Message

	INTEGER*4 Value

	WRITE(6,*)Message,Value

	RETURN
	END