S U B R O U T I N E    D A L U P F (LOCK,FOUND)
C	===============================================
C
C
C  COMPONENT:	DALUPF -- UPDATE USER PROFILE FILE
C  ---------
C
C  DATE:	07-FEB-80
C  ----
C
C  AUTHOR:	GR JOHNSON
C  ------	BATTELLE NORTHWEST
C		P O BOX 999
C		RICHLAND WA 99352
C
C  SOURCE:	FORTRAN IV-PLUS
C  ------
C
C
C
C  DESCRIPTION:
C  -----------
C
C	ROUTINE "DALUPF" UPDATES USERNAME PRIVILEGES STORED IN THE USER
C  PROFILE FILE (UPF).  THE UPF ENTRY(S) TO BE UPDATED IS SPECIFIED BY
C  INITIALIZING VARIABLE "VAFUIC" IN THE COMMON BLOCK "VAFILE".
C
C

C	 G L O B A L   P A R A M E T E R S   A N D   V A R I A B L E S
C	 =============================================================
C
C
C
	INCLUDE 'VAFILE.COM/NOLIST'
	INCLUDE 'PDSUPF.COM/NOLIST'
	INCLUDE 'PDSUPX.COM/NOLIST'
	INCLUDE 'USNPAR.COM/NOLIST'
C
C
C	 L O C A L   P A R A M E T E R S   A N D   V A R I A B L E S
C	 ===========================================================
C
C
C
	PARAMETER UPFLUN = 3		! PDSUPF LUN
	PARAMETER UPXLUN = 4		! PDSUPX LUN
	PARAMETER TTYLUN = 5		! TTY I/O LUN
C
	PARAMETER EOS = 0		! END-OF-STRING
C
	LOGICAL	  LOCK			! LOCK/UNLOCK MODE FLAG
	LOGICAL	  FOUND			! USERNAME FOUND FLAG
C
	LOGICAL	  CHGABL		! USERNAME CHARGEABLE
C
C

C	U P D A T E   U S E R   P R O F I L E   F I L E
C	===============================================
C
C
C
C  OPEN USER PROFILE FILE -- FETCH DEFAULT PROFILE RECORD
C
 10	CALL NOLOCK(UPFLUN)
C
 1002	OPEN(	UNIT=UPFLUN,
	2	NAME=UPFFNM,
	3	TYPE='OLD',
	4	ACCESS='DIRECT',RECORDSIZE=16,
	5	SHARED,
	6	ERR=1004)
C
	READ(UPFLUN'1,ERR=90100) UPFDEF
	GO TO 1006
C
 1004	CALL ERRSNS(ISW,IFCS)
	IF(ISW.NE.30) GO TO 90000
	IF(IFCS.NE.-27.AND.IFCS.NE.-29) GO TO 90000
	CALL WAIT(1,2,ISW)
	GO TO 1002
C
 1006	CONTINUE
C
C
C
C  OPEN USER PROFILE EXTENSION FILE -- (IF UPX IS "TRUE")
C
 	IF(.NOT.UPX) GO TO 1012
C
	CALL NOLOCK(UPXLUN)
C
 1008	OPEN(	UNIT=UPXLUN,
	2	NAME=UPXFNM,
	3	TYPE='OLD',
	4	ACCESS='DIRECT',RECORDSIZE=8,
	5	SHARED,
	6	ERR=1010)
C
	GO TO 1012
C
 1010	CALL ERRSNS(ISW,IFCS)
	IF(ISW.NE.30) GO TO 90300
	IF(IFCS.NE.-27.AND.IFCS.NE.-29) GO TO 90300
	CALL WAIT(1,2,ISW)
	GO TO 1008
C
1012	CONTINUE
C
C
C
C  SCAN USER PROFILE FILE
C
 	FOUND=.FALSE.
C
	DO 1036 UPFPNT=UPFFRP,UPFLRP
C
	READ(UPFLUN'UPFPNT,ERR=90100) UPFREC
C
	IF(UPFUSN(1).EQ.0) GO TO 1036
C
C
C
C  TEST USER-ID
C
	IF(UPFUIC.NE.VAFUIC) GO TO 1036
C
	IF(FOUND) GO TO 1020
C
	FOUND=.TRUE.
C
	USRUSN(1)=UPFUSN(1)
	USRUSN(2)=UPFUSN(2)
	USRUSN(3)=UPFUSN(3)
	USRUSN(4)=UPFUSN(4)
C
C
C
C  CONVERT USERNAME TO ASCII
C
	CALL R50ASC(12,USRUSN,USRNAM)
C
	DO 1014 IPNT=1,12
	IF(USRNAM(IPNT).EQ.' ') USRNAM(IPNT)=EOS
 1014	CONTINUE
C
C
C
C  VALIDATE USERNAME -- (CLEAR SUFFIX IF "CHARGEABLE")
C
	CHGABL=.FALSE.
C
	DO 1016 IPNT=1,4
	IF(USRNAM(IPNT).LT.'A') GO TO 1020
	IF(USRNAM(IPNT).GT.'Z') GO TO 1020
 1016	CONTINUE
C
	IF(USRNAM(IPNT).EQ.EOS) GO TO 1020
C
	DO 1018 IPNT=6,9
	IF(USRNAM(IPNT).LT.'0') GO TO 1020
	IF(USRNAM(IPNT).GT.'9') GO TO 1020
 1018	CONTINUE
C
	CHGABL=.TRUE.
C
	USRNAM(10)=EOS
	USRNAM(11)=EOS
	USRNAM(12)=EOS
C
	USRUSN(4)=0
C
C
C
C  TEST USERNAME SUFFIX --  (IF "CHARGEABLE")
C
 1020	JSUF=0
C
	IF(.NOT.CHGABL) GO TO 1024
C
	DO 1022 JSUF=0,NSUF
	IF(UPFSUF.EQ.USNSUF(JSUF)) GO TO 1024
 1022	CONTINUE
	GO TO 90600
C
C
C
C  FETCH DEFAULT PRIVILEGES FROM USER PROFILE EXTENSION -- (IF UPX IS "TRUE")
C
 1024	IF(.NOT.UPX) GO TO 1025
C
	READ(UPXLUN'(UPFPNT-UPFFRP+UPXFRP),ERR=90400) UPXREC
C
	DEFPRI=UPXPRI
	DEFBPR=UPXBPR
C
C
C
C  MODIFY USERNAME AUTHORIZATION FLAG AND USERNAME PRIVILEGES
C
 1025	IF(.NOT.LOCK) GO TO 1028
C
C
C >>> LOCK USERNAME
C
 1026	UPXUNA=UPXUNA.OR.UNADAL			! SET DAL BIT
C
	UPFPRI=0
	UPFBPR=0
	GO TO 1034
C
C
C >>> UNLOCK USERNAME 
C
 1028	UPXUNA=UPXUNA.AND.(.NOT.UNADAL)		! CLEAR DAL BIT
C
	IF(UPXUNA.EQ.0)      GO TO 1030
	IF(UPXUNA.EQ.UNANTU) GO TO 1032
	                     GO TO 1034
C
C
C >>> PRIME-TIME PROCESSING
C
 1030	UPFPRI=DEFPRI.AND.USNPRI(JSUF).AND.USNDPR(JSUF)
	UPFBPR=DEFBPR.AND.USNBPR(JSUF).AND.USNDPR(JSUF)
	GO TO 1034
C
C
C >>> OFF-HOUR PROCESSING
C
 1032	UPFPRI=DEFPRI.AND.USNPRI(JSUF).AND.USNNPR(JSUF)
	UPFBPR=DEFBPR.AND.USNBPR(JSUF).AND.USNNPR(JSUF)
C
C
C
C  UPDATE UPF/UPX AND CONTINUE SCAN
C
 1034	        WRITE(UPFLUN'UPFPNT,ERR=90200) UPFREC
	IF(UPX) WRITE(UPXLUN'(UPFPNT-UPFFRP+UPXFRP),ERR=90500) UPXREC
C
 1036	CONTINUE
C
C
C
C  CLOSE FILES AND RETURN TO CALLER
C
	        CLOSE(UNIT=UPFLUN)
	IF(UPX) CLOSE(UNIT=UPXLUN)
C
C
	RETURN
C
C

C	P R O C E S S   F A T A L   E R R O R S
C	=======================================
C
C
C
90000	WRITE(TTYLUN,90001)
90001	FORMAT(' DAL -- UPF open error'/)
	CALL EXIT
C
90100	WRITE(TTYLUN,90101)
90101	FORMAT(' DAL -- UPF read error'/)
	CALL EXIT
C
90200	WRITE(TTYLUN,90201)
90201	FORMAT(' DAL -- UPF write error'/)
	CALL EXIT
C
90300	WRITE(TTYLUN,90301)
90301	FORMAT(' DAL -- UPX open error'/)
	CALL EXIT
C
90400	WRITE(TTYLUN,90401)
90401	FORMAT(' DAL -- UPX read error'/)
	CALL EXIT
C
90500	WRITE(TTYLUN,90501)
90501	FORMAT(' DAL -- UPX write error'/)
		
C
90600	WRITE(TTYLUN,90601)
90601	FORMAT(' DAL -- Unknown USN suffix encountered'/)
	CALL EXIT
C
C
	END