Trailing-Edge
-
PDP-10 Archives
-
tops10and20_integ_tools_v9_3-aug-86
-
tools/mvusrs/mvusrs.for
There are 3 other files named mvusrs.for in the archive. Click here to see a list.
program MVUSRS
C
C MVUSRS :
C This utility takes user data from the TOPS-10/20
C operating systems, as well as input from the operator
C and generates a VMS .COM file which will install those
C users on a VAX system.
C
C Copyright 1985 by the Regents of the University of California.
C
C Version 1.0, September, 1985.
C
C Requisite software :
C MVUSRS, version 1.0, is known to work with TOPS-10 Version 7.01
C or earlier, TOPS-20 Version 5.1 or earlier, and VMS Version 4.0
C or later. Other versions may work, but have not been tested.
C In particular, it is unlikely that MVUSRS, Version 1.0, will
C work with versions of VMS prior to 4.0, since much use has been
C made of the enhanced account information available in Version 4.0.
C
C Written by Tom Brengle, Lawrence Livermore National Laboratory
C Mailing address : P. O. Box 5511, L-630, Livermore, CA 94550
C Telephone : (415) 422-1543 or FTS 532-1543
C Net mail address : ARPAnet BRENGLE%LLL@LLL-MFE
C MFEnet BRENGLE@LLL
C
implicit integer (a-z)
C
C
C Subroutines used :
C
C Name Function
C ------ -----------------------------------------------
C ANFIX Fix-up an alphanumeric string
C CHROCT Convert an octal string to an integer
C CKDEC Check for valid decimal value
C CKOCT Check for valid octal value
C LJUST Left-justify a string
C NXNBLK Find the next non-blank character in a string
C OCTCHR Convert an integer to an octal string
C OCTRNG Range check an octal value
C SLEN Find the length of a string
C UPCASE Shift a string to all upper case
C
C
C Variables used :
C
C Name Function
C ------ -----------------------------------------------
C ACCT Holds the current VMS account name
C DEFGN Holds the default VMS group number
C DEFOVR Holds the VMS default overdraft disk quota
C DEFPRM Holds the VMS default permanent disk quota
C DFACCT Holds the VMS default account name
C DFLGCM Holds the VMS file specification for the default
C login command file
C DSPLAY Flag to control display of generated output
C ("YES" or "NO")
C DUMMY Temporary storage for character strings
C FULNAM Holds the current VMS full name
C GETUIC Flag to control generation of VMS user number
C when current system is TOPS-20
C ("USER GROUP" or "DIRECTORY NUMBER")
C GRP Holds the current VMS group number
C INFILE Holds the name of the current input file
C LGNCOM Holds the VMS file specification for the current
C login command file
C LOGDEV Holds the name of the VMS default login device
C OPSYS Holds the name of the current operating system
C ("TOPS-10" or "TOPS-20")
C OUTFIL Holds the name of the current output file
C OVRQTA Holds the current VMS overdraft disk quota
C PRIVS Flag to control allocation of VMS privileges
C ("MINIMUM" or "ALL")
C PRMQTA Holds the current VMS permanent disk quota
C PSWRD Holds the current VMS user password
C TAB Holds the ASCII tab character
C TEMP Temporary storage for character strings
C TEST Temporary storage for character strings
C UIC Holds the current VMS user number and/or UIC
C USRDEV Holds the name of the current VMS login device
C USRDIR Holds the name of the current VMS login directory
C USRNAM Holds the current VMS user name
C VERIFY Flag to control verification of generated output
C ("YES" or "NO")
C VMSVFY Flag to control display of DCL command lines as
C they are executed on the target VMS system
C
character ckdec*3, ckoct*3, octrng*10, test*10, dummy*80
character temp*80, tab*1
character opsys*7, infile*80, outfil*80
character verify*3, dsplay*3, vmsvfy*3
character defgn*5
character logdev*80, defprm*10, defovr*10, dfacct*80, dflgcm*80
character usrnam*20, fulnam*20, acct*20, getuic*20
character usrdev*80, usrdir*20, grp*20, uic*20, privs*80
character pswrd*80, prmqta*10, ovrqta*10, lgncom*80
data outfil/'MVUSRS.COM'/
data verify/'YES'/, dsplay/'YES'/, vmsvfy/'YES'/
data defgn/'100'/, getuic/'DIRECTORY NUMBER'/
data logdev/'SYS$USER:'/, defprm/'1000'/,defovr/'100'/
data dfacct/'VMS'/
data dflgcm/'SYS$MANAGER:LGISAMPL.COM'/
data count/1/
C
C The following single character constant is initialized by
C direct assignment to make the code somewhat more readable.
tab = char(9)
C
C
C Print out welcome message.
C
write(5,fmt='/x,''MVUSRS :''
1 /3x,''This utility takes user data from the TOPS-10/20'',
2 /3x,''operating systems, as well as input from the operator'',
3 /3x,''and generates a VMS .COM file which will install those'',
4 /3x,''users on a VAX system.''')
C
C
C Show the current values for the default data, then ask the
C operator for any changes.
C
101 write(5,fmt='/')
C
C Find out which operating system the operator is running from.
C
102 write(5,fmt='x,''Which operating system?'',
1 /,3x,''(TOPS-10,TOPS-20) ['',a,''] : '',$') opsys
read(5,fmt='a') temp
C If nothing entered, use default.
if (slen(temp) .eq. 0) temp = opsys(1:slen(opsys))
C
C If there isn't a "1" or "2" in the response, try again.
if (index(temp,'1') .ne. 0 .or. index(temp,'2') .ne. 0) go to 103
write(5,fmt='x,''Sorry, TOPS-10 or TOPS-20 must be specified.'',
1 2x,''Please try again.''')
go to 102
C
C There is a "1" or "2" in the response. Decode the response.
C
C If a "1" but no "2", must be trying to say TOPS-10.
103 if (index(temp,'1') .ne. 0 .and. index(temp,'2') .eq. 0)
1 then
opsys = 'TOPS-10'
C
C If a "2" but no "1", must be trying to say TOPS-20.
else if (index(temp,'1') .eq. 0 .and. index(temp,'2') .ne. 0)
1 then
opsys = 'TOPS-20'
C
C If there is a "1" and a "2", but "1" comes first, then TOPS-10.
else if (index(temp,'1') .lt. index(temp,'2'))
1 then
opsys = 'TOPS-10'
C
C Otherwise, TOPS-20.
else
opsys = 'TOPS-20'
end if
C
C Get input file name.
C
104 write(5,fmt='x,a,'' input file name?''
1 /,3x,''['',a,''] : '',$')
1 opsys,infile(1:slen(infile))
read(5,fmt='a') temp
C if nothing was entered, use the default.
if (slen(temp) .eq. 0) temp = infile(1:slen(infile))
C Shift the response to all upper case.
call upcase(temp)
C Left-justify response.
call ljust(temp)
C
C Try to open the requested file.
C
open(unit=20,access='seqin',dialog=temp,err=105)
go to 106
C
C Here if an error occured while trying to open file.
C
105 write(5,fmt='x,''Sorry, there was an error trying to open'',
1 x,''that file. Please try again.''')
go to 104
C
C Save the properly validated input.
106 infile = temp(1:slen(temp))
C
C Get output file name.
C
107 write(5,fmt='x,''Output file name?'',
1 /,3x,''['',a,''] : '',$')
1 outfil(1:slen(outfil))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = outfil(1:slen(outfil))
C Shift the response to all upper case.
call upcase(temp)
C Left-justify response.
call ljust(temp)
C Install default .COM extension if none is supplied.
if(index(temp,'.') .eq. 0) temp = temp(1:slen(temp)) // '.COM'
C
C Try to open the requested file.
C
open(unit=21,access='seqout',dialog=temp,err=108)
go to 109
C
C Here if an error occured while trying to open file.
C
108 write(5,fmt='x,''Sorry, there was an error trying to open'',
1 x,''that file. Please try again.''')
go to 107
C
C Save the properly validated response.
109 outfil = temp(1:slen(temp))
C
C Find out if generated output should be verified before writing
C into output file.
C
write(5,fmt='x,''Allow verification of output commands before'',
1 x,''writing to '',a,''?'',
2 /,3x,''(YES,NO) ['',a,''] : '',$')
3 outfil(1:slen(outfil)),verify(1:slen(verify))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = verify(1:slen(verify))
C Shift the response to all upper case.
call upcase(temp)
C If the input string contains "N", set switch to NO.
if (index(temp,'N') .ne. 0)
1 then
verify = 'NO'
else
verify = 'YES'
end if
C
C Find out if generated output should be displayed before writing into
C output file. (Automatically set if verification is selected.)
C
if (verify .eq. 'YES')
1 then
C VERIFY set to YES implies DSPLAY set to YES.
dsplay = 'YES'
else
C If VERIFY is NO, ask if output commands should be displayed.
write(5,fmt='x,''Display output commands before writing'',
1 x,''to '',a,''?''
2 /,3x,''(YES,NO) ['',a,''] : '',$')
3 outfil(1:slen(outfil)),dsplay(1:slen(dsplay))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = dsplay(1:slen(dsplay))
C Shift response to all upper case.
call upcase(temp)
C If the input string contains "N", set switch to NO.
if (index(temp,'N') .ne. 0)
1 then
dsplay = 'NO'
else
dsplay = 'YES'
end if
end if
C
C Find out if the commands and their output should be displayed when
C the output file is executed under VMS.
C
write(5,fmt='x,''Have VMS display commands and their output'',
1 x,''as they are executed?'',
2 /,3x,''(YES,NO) ['',a,''] : '',$')
3 vmsvfy(1:slen(vmsvfy))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = vmsvfy(1:slen(vmsvfy))
C Shift response to all upper case.
call upcase(temp)
C If the input string contains "N", set switch to NO.
if (index(temp,'N') .ne. 0)
1 then
vmsvfy = 'NO'
else
vmsvfy = 'YES'
end if
C
C If TOPS-20, find out what the default group number should be.
C
110 if (opsys .eq. 'TOPS-20')
1 then
write(5,fmt='x,''What will be the default VMS group'',
1 x,''number?'',
2 /,3x,''(1-37776(octal)) ['',a,''] : '',$')
3 defgn(1:slen(defgn))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = defgn(1:slen(defgn))
C Left-justify response.
call ljust(temp)
if (ckoct(temp) .ne. 'OK')
1 then
write(5,fmt='x,''Sorry, that does not look like an'',
1 x,''octal number. Please try again.''')
go to 110
end if
test = octrng(temp,"1,"37776,dummy)
if (test .ne. 'OK')
1 then
if (test .eq. 'TOO HIGH')
1 then
write(5,fmt='x,''Sorry, that number is too high.'',
1 2x,''Please try again.''')
go to 110
else
write(5,fmt='x,''Sorry, that number is too low.'',
1 2x,''Please try again.''')
go to 110
end if
end if
C
C Save the new value.
defgn = temp(1:slen(temp))
end if
C
C If TOPS-20, find out how the VMS user number should be determined.
C
111 if (opsys .eq. 'TOPS-20')
1 then
write(5,fmt='x,''From what should the VMS user number'',
1 x,''be determined?'',
2 /,3x,''(DIRECTORY NUMBER,USER GROUP) ['',a,''] : '',$')
3 getuic(1:slen(getuic))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = getuic(1:slen(getuic))
C Shift the response to all upper case.
call upcase(temp)
C Left-justify the response.
call ljust(temp)
C If the response begins with "US", set GETUIC to "USER GROUP",
C otherwise, set it to "DIRECTORY NUMBER".
if (temp(1:2) .eq. 'US')
1 then
getuic = 'USER GROUP'
else
getuic = 'DIRECTORY NUMBER'
end if
end if
C
C Find out what the default login device on VMS is to be.
C
write(5,fmt='x,''What will be the default login device on'',
1 x,''VMS?'',
2 /,3x,''['',a,''] : '',$')
3 logdev(1:slen(logdev))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = logdev(1:slen(logdev))
C Shift the response to all upper case.
call upcase(temp)
C Left-justify response.
call ljust(temp)
C If not already present, append a ":" to make it look like
C a device name.
if (index(temp,':') .eq. 0) temp = temp(1:slen(temp)) // ':'
C Save the new string.
logdev = temp(1:slen(temp))
C
C Find out what the default permanent quota should be.
C
112 write(5,fmt='x,''What will be the default permanent disk'',
1 x,''quota on VMS?'',
2 /,3x,''['',a,'' blocks] : '',$')
3 defprm(1:slen(defprm))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = defprm(1:slen(defprm))
C Left-justify response.
call ljust(temp)
if (ckdec(temp) .eq. 'OK') go to 113
write(5,fmt='x,''Sorry, that does not look like a decimal'',
1 x,''number. Please try again.''')
go to 112
C
C Save the new value.
113 defprm = temp(1:slen(temp))
C
C Find out what the default overdraft quota should be.
C
114 write(5,fmt='x,''What will be the default overdraft disk'',
1 x,''quota on VMS?'',
2 /,3x,''['',a,'' blocks] : '',$')
3 defovr(1:slen(defovr))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = defovr(1:slen(defovr))
C Left-justify response.
call ljust(temp)
if (ckdec(temp) .eq. 'OK') go to 115
write(5,fmt='x,''Sorry, that does not look like a decimal'',
1 x,''number. Please try again.''')
go to 114
C
C Save the new value.
115 defovr = temp(1:slen(temp))
C
C Find out what the default account should be.
C
write(5,fmt='x,''What will be the default account?'',
1 /,3x,''['',a,''] : '',$')
2 dfacct(1:slen(dfacct))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = dfacct(1:slen(dfacct))
C Shift the response to all upper case.
call upcase(temp)
C Left-justify response.
call ljust(temp)
C Save the new file specification.
dfacct = temp(1:slen(temp))
C
C Find out what the default LOGIN.COM should be.
C
write(5,fmt='x,''What will be the default LOGIN.COM?'',
1 /,3x,''['',a,''] : '',$')
2 dflgcm(1:slen(dflgcm))
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = dflgcm(1:slen(dflgcm))
C Shift the response to all upper case.
call upcase(temp)
C Left-justify response.
call ljust(temp)
C Save the new file specification.
dflgcm = temp(1:slen(temp))
C
C Display the current default data.
C
write(5,fmt=
1 '/x,'' Operating system : '',a')
2 opsys
write(5,fmt=
1 ' x,'' Input file : '',a')
2 infile(1:slen(infile))
write(5,fmt=
1 ' x,'' Output file (VMS .COM file) : '',a')
2 outfil(1:slen(outfil))
write(5,fmt=
1 ' x,'' Display output before writing to file : '',a')
2 dsplay(1:slen(dsplay))
write(5,fmt=
1 ' x,'' Verify output before writing to file : '',a')
2 verify(1:slen(verify))
write(5,fmt=
1 ' x,''Have VMS display commands while executing : '',a')
2 vmsvfy(1:slen(vmsvfy))
if (opsys .eq. 'TOPS-20')
1 then
write(5,fmt=
1 ' x,'' Default VMS group number : '',a')
2 defgn(1:slen(defgn))
end if
if (opsys .eq. 'TOPS-20')
1 then
write(5,fmt=
1 ' x,'' VMS user number will be determined from : '',a')
2 getuic(1:slen(getuic))
end if
write(5,fmt=
1 ' x,'' Default VMS login device : '',a')
2 logdev(1:slen(logdev))
write(5,fmt=
1 ' x,'' Default VMS permanent disk quota : '',a')
2 defprm(1:slen(defprm))
write(5,fmt=
1 ' x,'' Default VMS overdraft disk quota : '',a')
2 defovr(1:slen(defovr))
write(5,fmt=
1 ' x,'' Default account : '',a')
2 dfacct(1:slen(dfacct))
write(5,fmt=
1 ' x,'' Default LOGIN.COM will be a copy of : '',a')
2 dflgcm(1:slen(dflgcm))
C
C Offer the operator a chance to change the default data before
C continuing.
C
write(5,fmt='/x,''Is this correct? (YES,NO) [YES] : '',$')
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = 'YES'
C Shift response to all upper case.
call upcase(temp)
C If the input string contains "N", go back and get new input.
if (index(temp,'N') .ne. 0) go to 101
C
C
C Write out some initial DCL commands to the output file to handle
C control-Y interrupts, warning errors, and to save the initial
C process environment. Also to check to make sure the operator
C has the proper privileges enabled.
C
write(21,fmt='''$!'',
1 /,''$! Set up to handle control-y and warning messages.'',
2 /,''$! (Allows graceful exit)'',
3 /,''$!'',
4 /,''$ ON CONTROLY THEN GOTO CLEANUP'',
5 /,''$ ON WARNING THEN GOTO CLEANUP'',
6 /,''$!'',
7 /,''$! Save current environment.'',
8 /,''$!'',
9 /,''$ OLDDIR = F$ENVIRONMENT("DEFAULT")'',
1 /,''$ PREVPRIV = F$SETPRV("SYSPRV")'',
2 /,''$ PROC_VER = F$ENVIRONMENT("VERIFY_PROCEDURE")'',
3 /,''$ IMAGE_VER = F$ENVIRONMENT("VERIFY_IMAGE")'',
4 /,''$!'',
5 /,''$! Check to see if this user has enough privileges'',
6 x,''to add users.'',
7 /,''$!'',
8 /,''$ IF .NOT. F$PRIVILEGE("SYSPRV") THEN GOTO NOPRIV''')
C
C Write out SET VERIFY command if VMSVFY is set.
C
if (vmsvfy .eq. 'YES')
1 write(21,fmt='''$!'',
2 /,''$! Set Verify to echo command lines and responses.'',
3 /,''$!'',
4 /,''$ SET VERIFY''')
C
C Write out the SET DEFAULT command.
C
write(21,fmt='''$!'',
1 /,''$! Set the default directory to run this from'',
2 /,''$!'',
3 /,''$ SET DEFAULT SYS$SYSTEM''')
C
C
C Begin processing user records from the input file.
C
200 continue
C
C Process the next record. Go to 500 on end of file.
C
if (opsys .eq. 'TOPS-10')
1 then
C
C Process a TOPS-10 user record.
C
C The TOPS-10 record is expected to be in the following format:
C
C Proj Prog Name Priv Password Times
C Core IPCF Profile CUSP Chg
C Expires Scd Type ENQ-DEQ
C
C Example :
C
C 30 3057 BRENGLE TOM 777777777777 GPHFRN 777777777777
C 511,,511 2,,5 017400001763 SETUP
C 8 Sep 768 0 511
C
C Set up initial condition to allow following loop to execute.
C Skip the first line of the input file.
read(20,fmt='a',end=500) temp
temp = temp(1:slen(temp)) // tab
C
C Search input file for beginning of next TOPS-10 user record.
C Find the next line that begins with a legal decimal number.
do while (ckdec(temp(nxnblk(temp,1):(index(temp,tab) - 1)))
1 .eq. 'NO')
read(20,fmt='a',end=500) temp
end do
C
C The line in TEMP now contains user data in the following format:
C Proj Prog Name Priv Password Times
C
C Extract the TOPS-10 project number to generate the VMS group
C group number.
left = nxnblk(temp(1:slen(temp)),1)
right = index(temp(left:slen(temp)),tab) - 1
grp = temp(left:right)
C
C Extract the TOPS-10 programmer number and build the UIC.
left = nxnblk(temp,right + 1)
right = left + index(temp(left:slen(temp)),tab) - 2
uic = temp(left:right)
C
C Combine the UIC group into the UIC.
uic = '[' // grp(1:slen(grp)) // ',' //
1 uic(1:slen(uic)) // ']'
C
C Extract the TOPS-10 user name and build the VMS full name
C and user name.
C
C Locate the beginning of the next field in the record by
C finding the next non-blank character.
left = nxnblk(temp,right + 1)
C Locate the end of the next field by finding the next blank
C (tab) character.
right = left + index(temp(left:slen(temp)),tab) - 2
C Use the entire field for the VMS full name.
fulnam = temp(left:right)
C Use the full name as the user name.
usrnam = fulnam(1:slen(fulnam))
C
C Extract the TOPS-10 privilege bits and build the VMS
C privilege string.
left = nxnblk(temp,right + 1)
right = left + index(temp(left:slen(temp)),tab) - 2
privs = temp(left:right)
if (privs .ne. '000000000000')
1 then
privs = 'ALL'
else
privs = 'MINIMUM'
end if
C
C Extract the TOP-10 password and make the VMS password.
left = nxnblk(temp,right + 1)
right = left + index(temp(left:slen(temp)),tab) - 2
pswrd = temp(left:right)
C
C The remaining two line of the user record,
C Core IPCF Profile CUSP Chg
C Expires Scd Type ENQ-DEQ
C are not used.
C
C Build the VMS default directory name from the TOPS-10 user name.
usrdir = usrnam(1:min0((index(usrnam,' ') - 1),30))
C
C Set up the default account.
acct = dfacct(1:slen(dfacct))
C
C End processing TOPS-10 user record.
C
else
C
C Process a TOPS-20 user record.
C
C The TOPS-20 record is expected to be in the following format:
C
C &STR:<DIRECTORY-NAME>
C PASSWORD
C LOGGED IN QUOTA
C CAPABILITIES
C FILES ONLY, ALPHA ACCTS, REPEAT LMSG
C LOGGED OUT QUOTA
C DIRECTORY NUMBER
C DEFAULT FILE PROTECTION
C DIRECTORY PROTECTION
C DEFAULT RETENTION SPECIFICATION
C LAST LOGIN
C USER GROUPS
C DIRECTORY GROUPS
C MAXIMUM SUBDIRECTORIES
C CREATABLE USER GROUPS
C DEFAULT DIRECTORY ACCOUNT
C
C Example :
C
C &BLUE:<BRENGLE>
C A003543432547354571515734
C 377777000000
C 200000
C 200000000400
C 377777000000
C 25
C 500000777752
C 500000777740
C 1
C 132163456541
C 3057,0
C 0
C 12
C 0
C M.T-C.USC.COMP
C
C Set up initial condition to allow following loop to execute.
read(20,fmt='a',end=500) temp
temp = temp // tab
C
C Process next TOPS-20 user record.
C Find start of next user record.
do while (temp(1:1) .ne. '&')
C Find line containing "&STR:<DIRECTORY-NAME>"
read(20,fmt='a',end=500) temp
end do
C
C The line in TEMP now contains user data in the following format:
C &STR:<DIRECTORY-NAME>
C
C Extract the TOPS-20 user name and build the VMS full name
C and user name.
left = index(temp,'<') + 1
right = index(temp,'>') - 1
C Use the entire field for the VMS full name.
fulnam = temp(left:right)
C Use the full name as the user name.
usrnam = fulnam(1:slen(fulnam))
C
C Read and discard line containing encrypted password.
read(20,fmt='a',end=500) temp
C Read and discard line containing logged in quota.
read(20,fmt='a',end=500) temp
C Read and discard line containing capabilities.
read(20,fmt='a',end=500) temp
C
C Extract the TOPS-20 privilege bits and set up the VMS
C privilege string.
left = nxnblk(temp(1:slen(temp)),1)
right = slen(temp)
privs = temp(left:right)
dummy = octrng(privs,"0,"777777,temp)
val = chroct(temp)
if (val .gt. "1000)
1 then
privs = 'ALL'
else
privs = 'MINIMUM'
end if
C
C Read and discard line containing "FILES ONLY",
C "ALPHA ACCTS", "REPEAT LMSG".
read(20,fmt='a',end=500) temp
C Read and discard line containing logged out quota.
read(20,fmt='a',end=500) temp
C Read line containing directory number.
read(20,fmt='a',end=500) temp
C
C If GETUIC is set to "DIRECTORY NUMBER", generate the VMS user
C number from the TOPS-20 directory number for this user's record.
if (getuic .eq. 'DIRECTORY NUMBER')
1 then
left = nxnblk(temp,1)
right = slen(temp)
uic = temp(left:right)
end if
C
C Read and discard line containing default file protection.
read(20,fmt='a',end=500) temp
C Read and discard line containing directory protection.
read(20,fmt='a',end=500) temp
C Read and discard line containing default retention specification.
read(20,fmt='a',end=500) temp
C Read and discard line containing last login.
read(20,fmt='a',end=500) temp
C Read line containing user groups.
read(20,fmt='a',end=500) temp
C
C If GETUIC is set to "USER GROUP", generate the VMS user number
C from the first item in the TOPS-20 USER-GROUPS list for this
C user's record.
if (getuic .eq. 'USER GROUP')
1 then
left = nxnblk(temp,1)
if (index(temp,',') .ne. 0)
1 then
right = index(temp,',') - 1
else
right = slen(temp)
end if
uic = temp(left:right)
end if
C
C Set up the default UIC group.
grp = defgn(1:slen(defgn))
C
C Combine the UIC group into the UIC.
uic = '[' // grp(1:slen(grp)) // ',' //
1 uic(1:slen(uic)) // ']'
C
C Generate a password for VMS from the VMS user name.
pswrd = usrnam(1:slen(usrnam))
C
C Build the VMS default directory name from the TOPS-20 user name.
usrdir = usrnam(1:min0((index(usrnam,' ') - 1),30))
C
C Set up the default account.
acct = dfacct(1:slen(dfacct))
C
C End processing TOPS-20 user record.
C
end if
C
C Set up remaining VMS defaults.
C
C Build the VMS default login device.
usrdev = logdev(1:slen(logdev))
C
C Set up the default disk quotas.
prmqta = defprm(1:slen(defprm))
ovrqta = defovr(1:slen(defovr))
C
C Set up the default login command file.
lgncom = dflgcm(1:slen(dflgcm))
C
C
C Make sure that the current data are legal as input to the VMS commands.
C This code should be current for VMS 4.1.
C
300 continue
C
C Legalize the user name.
C Left-justify the string.
call ljust(usrnam)
C Shift it to all upper case.
call upcase(usrnam)
C Replace any non-alphanumeric characters with underscores.
call anfix(usrnam,'NONE','_')
C Trim to 12 characters or less in length.
usrnam = usrnam(1:min0(slen(usrnam),12))
C
C Legalize the full name.
C Left-justify the string.
call ljust(fulnam)
C Trim to 31 characters or less in length.
fulnam = fulnam(1:min0(slen(fulnam),31))
C
C Legalize the account.
C Left-justify the string.
call ljust(acct)
C Shift it to all upper case.
call upcase(acct)
C Remove any non-alphanumeric characters.
call anfix(acct,'NONE','NONE')
C Trim to 8 characters or less in length.
acct = acct(1:min0(slen(acct),8))
C
C Legalize the default login device.
C Left-justify the string.
call ljust(usrdev)
C Shift it to all upper case.
call upcase(usrdev)
C Remove any non-alphanumeric (except "$" and ":") characters.
call anfix(usrdev,'$','NONE')
C Trim to 15 characters or less in length.
usrdev = usrdev(1:min0(slen(usrdev),15))
C Append a ":".
loc = min0((slen(usrdev) + 1),15)
usrdev(loc:loc) = ':'
C
C Legalize the default login directory.
C Left-justify the string.
call ljust(usrdir)
C Shift it to all upper case.
call upcase(usrdir)
C Remove any non-alphanumeric characters.
call anfix(usrdir,'NONE','NONE')
C Insert leading open square bracket.
temp = '[' // usrdir(1:slen(usrdir))
C Trim to 63 characters or less in length and append close square
C bracket.
usrdir = temp(1:min0(slen(temp),62)) // ']'
C
C Legalize the UIC.
C First, locate and extract the group number.
C Locate of the left bracket in the string.
left = index(uic(1:slen(uic)),'[') + 1
C Locate the comma to the right of the left bracket.
comma = index(uic(left:slen(uic)),',') + left - 1
if (comma .gt. left)
1 then
C If the comma is to the right of the left bracket, then the
C last character of the group number should be to the left
C of the comma.
right = comma - 1
else
C Otherwise just use whatever character is pointed to by the
C "LEFT" pointer.
right = left
end if
grp = uic(left:right)
C Now locate and extract the user number.
C Start looking for the user number to the right of the comma.
if (comma .gt. left) left = comma + 1
C Locate the right bracket.
right = index(uic(left:slen(uic)),']') + left - 1
if (right .gt. left)
1 then
C If the right bracket is found, the user number must end to
C the left of it.
right = right - 1
else
C Otherwise, the user number must end before the end of the string.
right = slen(uic)
end if
uic = uic(left:right)
C Force the group number to be within the allowed range.
dummy = octrng(grp,"1,"37776,temp)
grp = temp(1:min0(slen(temp),10))
C Force the user number to be within the allowed range.
dummy = octrng(uic,"0,"1777776,temp)
uic = temp(1:min0(slen(temp),10))
C Rebuild the UIC string and enclose it in square brackets.
uic = '[' // grp(1:slen(grp)) // ',' // uic(1:slen(uic)) // ']'
C
C Legalize the privileges code.
C Set the privileges code to 'MINIMUM' unless it has been set to 'ALL'.
if (privs .eq. 'ALL' .or. privs .eq. 'all')
1 then
privs = 'ALL'
else
privs = 'MINIMUM'
end if
C
C Legalize the password.
C Left justify the string.
call ljust(pswrd)
C Shift it to all upper case.
call upcase(pswrd)
C Replace any non-alphanumeric (or dollar signs or underscores)
C with underscores.
call anfix(pswrd,'$_','_')
C Trim to 31 characters or less in length.
pswrd = pswrd(1:min0(slen(pswrd),31))
C
C
C If DSPLAY is set to 'YES', display the constructed VMS user data.
C
if (dsplay .eq. 'YES')
1 then
write(5,fmt='//')
write(5,fmt='x,'' User Name : '',a')
1 usrnam(1:slen(usrnam))
write(5,fmt='x,'' Full Name : '',a')
1 fulnam(1:slen(fulnam))
write(5,fmt='x,'' Account : '',a')
1 acct(1:slen(acct))
write(5,fmt='x,'' Default Login Device : '',a')
1 usrdev(1:slen(usrdev))
write(5,fmt='x,''Default Login Directory : '',a,')
1 usrdir(1:slen(usrdir))
write(5,fmt='x,'' UIC : '',a')
1 uic(1:slen(uic))
write(5,fmt='x,'' Privileges : '',a')
1 privs(1:slen(privs))
write(5,fmt='x,'' Password : '',a')
1 pswrd(1:slen(pswrd))
write(5,fmt='x,'' Permanent Disk Quota : '',a')
1 prmqta(1:slen(prmqta))
write(5,fmt='x,'' Overdraft Disk Quota : '',a')
1 ovrqta(1:slen(ovrqta))
write(5,fmt='/x,a,a,''LOGIN.COM will be copied'',
1 x,''from : '',a')
2 usrdev(1:slen(usrdev)), usrdir(1:slen(usrdir)),
3 lgncom(1:slen(lgncom))
end if
C
C
C If enabled, allow operator to modify the data for the current user.
C
if (verify .eq. 'NO') go to 400
C
C Check to see if user wants to modify the data, or if he wants to
C skip the record altogether.
C
write(5,fmt='/x,''Are these values correct? (YES,NO,SKIP)'',
1 2x,''[YES] : '',$')
read(5,fmt='a') temp
C If nothing was typed in, use the default.
if (slen(temp) .eq. 0) temp = 'YES'
C Shift response to all upper case.
call upcase(temp)
C If the input string contains "N", go request new data.
if (index(temp,'N') .ne. 0) go to 350
C If the input string contains "S" but not "Y",
C skip to next input record.
if (index(temp,'S') .ne. 0 .and. index(temp,'Y') .eq. 0)
1 then
write(5,fmt='x,''Record skipped.''')
go to 200
end if
C If neither is specified, go write the output record.
go to 400
C
C If the operator wants to modify the current user's data, show him
C the data, one item at a time, and prompt him for new data.
C
350 write(5,fmt='//')
write(5,fmt='x,'' User Name : '',a')
1 usrnam(1:slen(usrnam))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) usrnam = temp(1:slen(temp))
C
write(5,fmt='x,'' Full Name : '',a')
1 fulnam(1:slen(fulnam))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) fulnam = temp(1:slen(temp))
C
write(5,fmt='x,'' Account : '',a')
1 acct(1:slen(acct))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) acct = temp(1:slen(temp))
C
write(5,fmt='x,'' Default Login Device : '',a')
1 usrdev(1:slen(usrdev))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) usrdev = temp(1:slen(temp))
C
write(5,fmt='x,'' Default Login Directory : '',a,')
1 usrdir(1:slen(usrdir))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) usrdir = temp(1:slen(temp))
C
write(5,fmt='x,'' UIC : '',a')
1 uic(1:slen(uic))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) uic = temp(1:slen(temp))
C
write(5,fmt='x,'' Privileges : '',a')
1 privs(1:slen(privs))
write(5,fmt='x,'' Correction (MINIMUM,ALL) : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) privs = temp(1:slen(temp))
C
write(5,fmt='x,'' Password : '',a')
1 pswrd(1:slen(pswrd))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) pswrd = temp(1:slen(temp))
C
write(5,fmt='x,'' Permanent Disk Quota : '',a')
1 prmqta(1:slen(prmqta))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) prmqta = temp(1:slen(temp))
C
write(5,fmt='x,'' Overdraft Disk Quota : '',a')
1 ovrqta(1:slen(ovrqta))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) ovrqta = temp(1:slen(temp))
C
write(5,fmt='/x,a,a,''LOGIN.COM will be copied'',
1 x,''from : '',a')
2 usrdev(1:slen(usrdev)), usrdir(1:slen(usrdir)),
3 lgncom(1:slen(lgncom))
write(5,fmt='x,'' Correction : '',$')
read(5,fmt='a') temp
C Save the corrected information. If nothing was typed in, use
C the default.
if (slen(temp) .ne. 0) lgncom = temp(1:slen(temp))
C
C Take the modified data back and legalize it.
go to 300
C
C
C Write the DCL commands with the validated user data to the output file.
C
400 write(21,fmt='''$!'',
1 /,''$!'',
2 /,''$! Check to see if quota management is being done'',
3 /,''$!'',
4 /,''$ IF F$SEARCH("'',a,''[0,0]QUOTA.SYS")'',
5 x,''.EQS. "" THEN GOTO NQ'',i3.3')
6 usrdev(1:slen(usrdev)), count
write(21,fmt='''$!'',
1 /,''$! If so, add disk quota entries'',
2 /,''$!''')
write(21,fmt='''$ RUN SYS$SYSTEM:DISKQUOTA''')
write(21,fmt=''' USE '',a') usrdev(1:slen(usrdev))
write(21,fmt=''' ADD '',a,'' /PERMQUOTA='',a,
1 '' /OVERDRAFT='',a')
2 uic(1:slen(uic)), prmqta(1:slen(prmqta)),
3 ovrqta(1:slen(ovrqta))
write(21,fmt=''' EXIT''')
write(21,fmt='''$ NQ'',i3.3,'':''') count
C
write(21,fmt='''$!'',
1 /,''$! Create a first-level directory for the account'',
2 /,''$!''')
write(21,fmt='''$ CREATE/DIRECTORY /OWNER_UIC='',a,
1 x,''/PROTECTION=(S=RWE,O=RWE,G=RE,W) -''')
2 uic(1:slen(uic))
write(21,fmt=''' '',a,a,'' /LOG''')
1 usrdev(1:slen(usrdev)), usrdir(1:slen(usrdir))
C
write(21,fmt='''$!'',
1 /,''$! If present, copy LOGIN.COM template to the account'',
2 /,''$!''')
write(21,fmt='''$ IF F$SEARCH("'',a,''") .EQS. "" THEN'',
1 x,'' GOTO NF'',i3.3')
2 lgncom(1:slen(lgncom)), count
write(21,fmt='''$ COPY '',a,'' -''')
1 lgncom(1:slen(lgncom))
write(21,fmt=''' '',a,a,''LOGIN.COM''')
1 usrdev(1:slen(usrdev)), usrdir(1:slen(usrdir))
write(21,fmt='''$ SET FILE/OWNER_UIC='',a,x,a,a,''LOGIN.COM''')
1 uic(1:slen(uic)), usrdev(1:slen(usrdev)),
2 usrdir(1:slen(usrdir))
write(21,fmt='''$ NF'',i3.3,'':''') count
C
write(21,fmt='''$!'',
1 /,''$! Add the account record to the UAF'',
2 /,''$!''')
write(21,fmt='''$ RUN SYS$SYSTEM:AUTHORIZE''')
write(21,fmt=''' ADD '',a,'' -''')
1 usrnam(1:slen(usrnam))
write(21,fmt=''' /OWNER="'',a,''" -''')
1 fulnam(1:slen(fulnam))
write(21,fmt=''' /ACCOUNT='',a,'' -''')
1 acct(1:slen(acct))
write(21,fmt=''' /DEVICE='',a,'' -''')
1 usrdev(1:slen(usrdev))
write(21,fmt=''' /DIRECTORY='',a,'' -''')
1 usrdir(1:slen(usrdir))
write(21,fmt=''' /UIC='',a,'' -''')
1 uic(1:slen(uic))
if (privs .eq. 'ALL')
1 then
write(21,fmt=''' /PRIV=ALL -''')
else
write(21,fmt=''' /PRIV=(TMPMBX,NETMBX) -''')
end if
write(21,fmt=''' /PASSWORD='',a,'' -''')
1 pswrd(1:slen(pswrd))
write(21,fmt=''' /LGICMD='',a,a,''LOGIN.COM''')
1 usrdev(1:slen(usrdev)), usrdir(1:slen(usrdir))
write(21,fmt=''' EXIT''')
C
C Increment the record counter.
count = count +1
C
C Go back to get next user record.
go to 200
C
C
C Write out final DCL commands to restore the VMS process environment.
C
500 write(21,fmt='''$!'',
1 /,''$! Restore previous working environment.'',
2 /,''$!'',
3 /,''$ CLEANUP:'',
4 /,''$ SET TERMINAL/ECHO'',
5 /,''$ PROC_VER = F$VERIFY(PROC_VER,IMAGE_VER)'',
6 /,''$ PREVPRIV = F$SETPRV(PREVPRIV)''')
C The kluge on the next line is to allow sending out of a single quote.
write(21,1000)
1000 format('$ SET DEFAULT ''OLDDIR''')
write(21,fmt='''$ EXIT'',
9 /,''$!'',
1 /,''$! Come here in case proper privileges are not set.'',
2 /,''$!'',
3 /,''$ NOPRIV:'',
4 /,''$ WRITE SYS$OUTPUT "You need SETPRV or SYSPRV'',
5 x,''to run this procedure"'',
6 /,''$ GOTO CLEANUP''')
C
C
C Clean up and exit after processing last user record.
C
count = count - 1
write(5,fmt='x,i4,'' user records processed.''') count
C
C Close the input and output files.
close(unit=20)
close(unit=21)
call exit
end
C
C ANFIX : This routine replaces any non-alphanumeric characters
C in the string in the first argument, except for those
C listed in the string in the second argument, with the
C character supplied in the third argument. If the third
C argument is 'NONE', the non-matching characters are
C removed and the string is shifted to fill the empty space.
C
C Args: CVAR ; Arbitrary character variable.
C MCHLST ; Character variable.
C REPL ; Single character or 'NONE'.
C Returns : CVAR ; Character.
C
subroutine anfix(cvar,mchlst,repl)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar, mchlst
character repl*4
C
C Check the length of the string.
if (slen(cvar) .gt. 0)
1 then
C
C Set up dummy MCHLST if no match characters have been specified.
C Putting an alphanumeric character in MCHLST allows the logic
C to work correctly.
if (mchlst .eq. 'NONE') mchlst = '0'
C
C Initialize an output pointer in to the string.
optr = 1
C
C Loop over the length of the string in CVAR.
do 1 i = 1,slen(cvar)
C
C Check to see if it is a non-alphanumeric character and
C not in the match character list.
if ((llt(cvar(i:i),'0') .or.
1 (lgt(cvar(i:i),'9') .and. llt(cvar(i:i),'A')) .or.
2 (lgt(cvar(i:i),'Z') .and. llt(cvar(i:i),'a')) .or.
3 lgt(cvar(i:i),'z')) .and.
4 (index(mchlst(1:slen(mchlst)),cvar(i:i)) .eq. 0))
1 then
C If non-alphanumeric, replace with character in REPL
C or remove and shift to fill space.
if (repl .ne. 'NONE')
1 then
C Replace with the character in REPL.
cvar(optr:optr) = repl(1:1)
C Increment the output pointer.
optr = optr + 1
else
C Remove the character and fill the space. (This will
C happen automatically at this point because the
C output pointer will not get incremented.)
end if
else
C If alphanumeric, just copy it from the input location
C to the output location.
cvar(optr:optr) = cvar(i:i)
C Increment the output pointer.
optr = optr + 1
end if
1 continue
C
C Fill remainder of string from optr to slen(cvar) with blanks.
do 2 i = optr, slen(cvar)
cvar(i:i) = ' '
2 continue
end if
C
C Return with the modified string in CVAR.
return
end
C
C CHROCT : This routine converts the string stored in CVAR to an
C integer value after forcing it to be a legal octal number.
C
C Args: CVAR ; Arbitrary character variable.
C Returns : CHROCT ; Integer.
C
integer function chroct(cvar)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar
character digit*1
C
C Initialize the return value.
chroct = 0
C
C Loop over the number of characters in the input string.
do 1 i = 1, slen(cvar)
C
C Get the digit.
digit = cvar(i:i)
C
C If it is a legal octal digit, accumulate a new total.
if (digit .ge. '0' .and. digit .le. '7')
1 chroct = 8 * chroct + (ichar(digit) - 48)
1 continue
C
C Return the accumulated value in CHROCT.
return
end
C
C CKDEC : This routine checks a character variable to see
C if it contains a valid decimal value.
C
C Args: CVAR ; Arbitrary character variable.
C Returns : CKDEC ; Character (OK,NO).
C
character*3 function ckdec(cvar,val)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar
C
C Check the length of the string.
if (slen(cvar) .gt. 0)
1 then
C
C If the length greater than zero, start the check for a number.
ckdec = 'OK'
C
C Loop over the length of the string in CVAR.
do 1 i = 1,slen(cvar)
C
C Check to see if it is a legal decimal digit.
if (llt(cvar(i:i),'0') .or. lgt(cvar(i:i),'9'))
1 then
ckdec = 'NO'
return
end if
1 continue
else
C
C If the length is less than or equal to zero,
C return CKDEC set to NO.
ckdec = 'NO'
end if
C
C Return with the proper response in CKDEC.
return
end
C
C CKOCT : This routine checks a character variable to see
C if it contains a valid octal value.
C
C Args: CVAR ; Arbitrary character variable.
C Returns : CKOCT ; Character (OK,NO).
C
character*3 function ckoct(cvar,val)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar
C
C Check the length of the string.
if (slen(cvar) .gt. 0)
1 then
C
C If the length greater than zero, start the check for a number.
ckoct = 'OK'
C
C Loop over the length of the string in CVAR.
do 1 i = 1,slen(cvar)
C
C Check to see if it is a legal octal digit.
if (llt(cvar(i:i),'0') .or. lgt(cvar(i:i),'7'))
1 then
ckoct = 'NO'
return
end if
1 continue
else
C
C If the length is less than or equal to zero,
C return CKOCT set to NO.
ckoct = 'NO'
end if
C
C Return with the proper response in CKOCT.
return
end
C
C LJUST : This routine left-adjusts the string stored in CVAR.
C
C Args: CVAR ; Arbitrary character variable.
C Returns : CVAR ; Character variable.
C
subroutine ljust(cvar)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar
C
C Don't do anything if the string length is zero.
if (slen(cvar) .eq. 0) return
C
C Determine the number of leading spaces.
i = 1
do 1 while (cvar(i:i) .eq. ' ' .and. i .le. slen(cvar))
i = i + 1
1 continue
cvar = cvar(i:slen(cvar))
C Return with shifted string in CVAR.
return
end
C
C NXNBLK : This routine searches the string stored in CVAR
C beginning at ISTART for the first non-blank and
C non-tab character. The function returns the value
C of the index for that character in NXNBLK.
C
C Args: CVAR ; Arbitrary character variable.
C ISTART ; Integer.
C Returns : NXNBLK ; Integer.
C
integer function nxnblk(cvar,istart)
implicit integer (a-z)
C Declare variable length character argument.
character *(*) cvar
character tab*1
tab = char(9)
C
C Start search at ISTART.
nxnblk = istart
C
C Search through string.
do while (nxnblk .le. slen(cvar))
C
C Check for a blank or tab.
if (cvar(nxnblk:nxnblk) .eq. ' ' .or.
1 cvar(nxnblk:nxnblk) .eq. tab)
1 then
C
C If so, increment count and check next character.
nxnblk = nxnblk + 1
else
C
C If not, search is finished; return.
return
end if
end do
C
C If index goes off end of string, return NXNBLK set to zero.
nxnblk = 0
return
end
C
C OCTCHR : This routine converts an integer value to a character
C string value in octal notation. This routine will work
C with octal values up to ten octal digits.
C
C Args: NUM ; Integer.
C Returns : OCTCHR ; Character.
C
character*10 function octchr(num)
implicit integer (a-z)
character lzeros*3
C
C Initialize a pointer into the output string.
optr = 1
C
C Check to see if the input argument is greater than zero.
if (num .gt. 0)
1 then
C
C If so, then convert in to a character string.
C
C Initialize a flag to be used to eliminate leading zeroes
C in the output string.
lzeros = 'YES'
C
C Set up the divisor for the largest digit of the largest value
C allowed for conversion.
divsor = 8 ** 9
C
C Loop over the possible digits.
do 1 i = 1, 10
C
C Divide the current remainder by the current divisor.
digit = num / divsor
C
C Generate the next divisor.
divsor = divsor / 8
C
C If the new digit would be a leading zero, do the next one.
if (digit .eq. 0 .and. lzeros .eq. 'YES') go to 1
C
C Clear the leading zeroes flag when the first non-zero
C digit is found.
lzeros = 'NO'
C
C Subtract off the amount due to this divisor.
num = num - (digit * divsor)
C
C Convert digit to character and insert in output string.
octchr(optr:optr) = char(digit + 48)
C
C Increment output pointer.
optr = optr + 1
1 continue
else
C
C If the input value is not greater than zero, return zero
C as the character value.
octchr(optr:optr) = '0'
C
C Increment the output pointer.
optr = optr + 1
end if
C
C Pad the remainder of the output string with blanks.
do 2 i = optr, 10
octchr(i:i) = ' '
2 continue
end
C
C OCTRNG : This routine processes a character variable to see
C if it contains an octal value within a given range.
C It also returns a character value forced to be octal
C and within the range.
C
C Args: CVAR ; Arbitrary character variable.
C LOWLIM ; Integer.
C HILIM ; Integer.
C Returns : OCTRNG ; Character (OK,TOO LOW,TOO HIGH).
C FRCVAL ; Character.
C
character*10 function octrng(cvar,lowlim,hilim,frcval)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar
character frcval*10, digit*1, octchr*10, lzeros*3
C
C Check the length of the string.
len = slen(cvar)
if (len .gt. 0)
1 then
C
C Initialize a test result accumulation variable.
test = 0
C
C Initialize an output pointer into the output string.
optr = 1
C
C Initialize a flag to be used to eliminate leading zeroes
C in the output string.
lzeros = 'YES'
C
C Loop over the length of the string in CVAR.
do 1 i = 1, len
C
C Get the next octal digit from the input string.
digit = cvar(i:i)
C
C Test to see if it is a valid octal digit.
if (digit .ge. '0' .and. digit .le. '7')
1 then
C
C Accumulate a test result using the new octal digit.
test = 8 * test + (ichar(digit) - 48)
C
C Check to see if the accumulated value is still less than
C or equal to the high limit.
if (test .le. hilim)
1 then
C
C If so, try to add the new digit to the forced-in-range
C output string.
if (optr .le. 10)
1 then
if (digit .eq. '0' .and. lzeros .eq. 'YES')
1 then
C Throw away leading zero.
else
lzeros = 'NO'
frcval(optr:optr) = digit
optr = optr + 1
end if
else
C
C Otherwise, return that the value is too high.
octrng = 'TOO HIGH'
return
end if
C
else
C
C If not still in range, fill the remainder of the
C forced-in-range output value with blanks. Then
C return that the value is too high.
do 2 j = optr, 10
frcval(j:j) = ' '
2 continue
octrng = 'TOO HIGH'
return
end if
end if
1 continue
C
C If the loop terminates normally, the accumulated value must be less
C then the high limit. Fill the remainder of the forced-in-range
C value with blanks.
do 3 i = optr, 10
frcval(i:i) = ' '
3 continue
C
C Test to see if the accumulated value is greater than or equal
C to the lower limit.
if (test .ge. lowlim)
1 then
C
C If so, then return that it is OK.
octrng = 'OK'
return
end if
end if
C
C If the string length is zero, or if the accumulated value is less
C than the lower limit, set the forced-in-range return value to
C be the lower limit and return that it is too low.
octrng = 'TOO LOW'
frcval = octchr(lowlim)
return
end
C
C SLEN : This function returns the length of the string in CVAR
C up to the first trailing space.
C
C Args: CVAR ; Arbitrary character variable.
C Returns : SLEN ; Integer.
C
integer function slen (cvar)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar
C
C Set up to search character expression backwards from end
C for first non-blank character.
slen = len(cvar)
C Do the search. Stop on first non-blank character.
do while (cvar(slen:slen) .eq. ' ' .and. slen .gt. 0)
slen = slen - 1
end do
C Return with string length in SLEN.
return
end
C
C UPCASE : This routine shifts the alphabetic characters of the
C string stored in CVAR to upper case.
C
C Args: CVAR ; Arbitrary character variable.
C Returns : CVAR ; Character variable.
C
subroutine upcase(cvar)
implicit integer (a-z)
C
C Declare variable length character argument.
character *(*) cvar
C
C Don't do anything if the string length is zero.
if (slen(cvar) .eq. 0) return
C
C Loop over the length of the string in CVAR.
do 1 i = 1,slen(cvar)
C
C Change case if necessary.
if (lge(cvar(i:i),'a') .and. lle(cvar(i:i),'z'))
1 cvar(i:i) = char(ichar(cvar(i:i)) - 32)
1 continue
C Return with shifted string in CVAR.
return
end