SUBROUTINE ADDLOG(IER)
C
C*****************************************************************************
C
C PURPOSE: TO ADD AN ACCOUNT AND/OR PROJECTS TO THE LOG FILE.
C
C*****************************************************************************
C
LOGICAL*1 RECHDR(10)
INCLUDE 'LOGHDR.ADM'
INCLUDE 'LOGVBL.ADM'
INCLUDE 'LOGPR1.ADM'
INCLUDE 'LOGPR2.ADM'
C
C
DATA RECHDR/'[',3*0,',',3*0,']',0/
C
C
C
C*****************************************************************************
C
C PRESET ERRORCODE.
C DON'T PRODUCE ERROR MESSAGES FOR END OF FILE AND READ ERRORS, BECAUSE
C THE FILE COULD BE EXTENDED.
C
C*****************************************************************************
C
IER=-1
CALL ERRSET(39,.TRUE.,.FALSE.,.TRUE.,.FALSE.)
CALL ERRSET(24,.TRUE.,.FALSE.,.TRUE.,.FALSE.)
C
C*****************************************************************************
C
C ASK FOR THE UIC, ENCODE IT AND REPLACE SPACES WITH ASCII '0'.
C
C*****************************************************************************
C
5 WRITE(6,10)
10 FORMAT(/'$ENTER GROUP,MEMBER: ')
READ(5,20,END=1000,ERR=5) IGR,MEM
20 FORMAT(2O6)
ENCODE(3,30,RECHDR(2),ERR=5) IGR
30 FORMAT(O3)
ENCODE(3,30,RECHDR(6),ERR=5) MEM
DO 35 I=2,8
35 IF(RECHDR(I).EQ.32) RECHDR(I)=48
C
C*****************************************************************************
C
C SEE IF UIC ALREADY EXISTS. IF SO, GO TO THE PROPER SECTION.
C
C*****************************************************************************
C
IFOUND=0
DO 50 I=1,30
DO 40 J=1,9
40 IF(RECHDR(J).NE.LRCHDR(J,I)) GO TO 50
IFOUND=I
GO TO 200
50 CONTINUE
C
C*****************************************************************************
C
C NO MATCH
C
C FIND FIRST FREE UIC RECORD IN THE FIRST BLOCK OF THE FILE. IF NONE,
C EXIT WITH PROPER MESSAGE.
C IF FOUND, COPY THE UIC INTO IT.
C
C*****************************************************************************
C
DO 60 I=1,30
IZERO=I
IF(IRCHDR(1,I).EQ.0) GO TO 70
60 CONTINUE
GO TO 900
70 DO 80 I=1,10
80 LRCHDR(I,IZERO)=RECHDR(I)
C
C*****************************************************************************
C
C ASK FOR THE NUMBER OF PROJECTS. IF OUT OF RANGE,TRY AGAIN.
C
C*****************************************************************************
C
85 WRITE(6,90)
90 FORMAT('$ENTER NUMBER OF PROJECTS [<=32]: ')
READ(5,94,ERR=85,END=1000) NPROJ
94 FORMAT(I5)
IF(NPROJ.LE.0.OR.NPROJ.GT.32) GO TO 85
C
C*****************************************************************************
C
C FILL UIC RECORD WITH NUMBER OF PROJECTS AND READ THE PROPER "VBN"BLOCK
C
C*****************************************************************************
C
IPROJ=1
IRCHDR(8,IZERO)=NPROJ
IVBN=(IZERO-1)/8+2
MUIC=MOD(IZERO-1,8)+1
READ(1'IVBN,END=1000,ERR=1000) IBFVBL
C
C*****************************************************************************
C
C LOOK FOR THE FIRST FREE PAIR OF PROJECT BLOCKS.
C IF READ ERROR, FILE HAS TO BE EXTENDED.
C
C*****************************************************************************
C
LVBN=6
DO 150 I=1,NPROJ
95 READ(1'LVBN,ERR=100,END=100) IBFPR1
IF(IBFPR1(1).EQ.0) GO TO 100
LVBN=LVBN+2
GO TO 95
C
C*****************************************************************************
C
C NEW PROJECT WILL BE STORED INTO BLOCKS "LVBN" AND "LVBN+1".
C
C FILL "LVBN" INTO "VBN" BLOCK.
C
C STORE PROJECT NAME, UIC, DATE/TIME INTO PROJECT BLOCK #1.
C
C*****************************************************************************
C
100 IRCVBL(I,MUIC)=LVBN
DO 110 J=1,256
IBFPR1(J)=0
110 IBFPR2(J)=0
ICURPN=1
WRITE(6,120) I
120 FORMAT('$ENTER PROJECT NAME #',I2,' [32A1]: ')
READ(5,130,END=1000) NP,(PRONAM(J),J=1,NP)
130 FORMAT(Q,32A1)
DO 140 J=1,10
140 UIC(J)=LRCHDR(J,IZERO)
CALL GETTIM(TOTSNC(1))
DO 145 J=1,8
145 GRANTS(J)=TOTSNC(J)
WRITE(1'LVBN,ERR=1000) IBFPR1
WRITE(1'LVBN+1,ERR=1000) IBFPR2
LVBN=LVBN+2
150 CONTINUE
C
C
C*****************************************************************************
C
C JUMP TO UPDATE FIRST AND CURRENT "VBN" BLOCK.
C
C*****************************************************************************
C
GO TO 300
C
C
C*****************************************************************************
C
C MATCH, SEE IF NUMBER NOT >32 ALREADY. IF SO EXIT WITH MESSAGE.
C
C READ PROPER "VBN" BLOCK.
C
C FIND NEXT FREE PAIR OF PROJECT BLOCKS. IF READ ERROR FILE WILL BE
C EXTENDED.
C
C*****************************************************************************
C
C
200 IF(IRCHDR(8,IFOUND).GE.32) GO TO 920
IVBN=(IFOUND-1)/8+2
MUIC=MOD(IFOUND-1,8)+1
READ(1'IVBN,END=1000,ERR=1000) IBFVBL
LVBN=6
205 READ(1'LVBN,ERR=210,END=210) IBFPR1
IF(IBFPR1(1).EQ.0) GO TO 210
LVBN=LVBN+2
GO TO 205
C
C*****************************************************************************
C
C VIRTUAL BLOCK NUMBER IS "LVBN".
C
C FIND FIRST FREE LOCATION IN "VBN" RECORD AND STORE "LVBN" IN IT. IF
C NOT FOUND, NUMBER OF PROJECTS IS 32 ALREADY.
C
C*****************************************************************************
C
210 DO 220 I=1,32
IF(IRCVBL(I,MUIC).NE.0) GO TO 220
IRCVBL(I,MUIC)=LVBN
GO TO 230
220 CONTINUE
GO TO 920
C
C*****************************************************************************
C
C FILL PROJECT NAME, UIC, DATE/TIME AND WRITE PROJECT BLOCKS TO DISK.
C
C*****************************************************************************
C
230 DO 240 J=1,256
IBFPR1(J)=0
240 IBFPR2(J)=0
ICURPN=1
WRITE(6,120) IRCHDR(8,IFOUND)+1
READ(5,130,END=1000) NP,(PRONAM(J),J=1,NP)
DO 250 J=1,10
250 UIC(J)=LRCHDR(J,IFOUND)
CALL GETTIM(TOTSNC(1))
DO 260 J=1,8
260 GRANTS(J)=TOTSNC(J)
WRITE(1'LVBN,ERR=1000) IBFPR1
WRITE(1'LVBN+1,ERR=1000) IBFPR2
IRCHDR(8,IFOUND)=IRCHDR(8,IFOUND)+1
C
C
C
C*****************************************************************************
C
C WRITE FIRST AND CURRENT "VBN" BLOCK TO DISK AND SET SUCCESS CODE.
C
C*****************************************************************************
C
300 WRITE(1'1,ERR=1000) IBFHDR
WRITE(1'IVBN,ERR=1000) IBFVBL
IER=1
GO TO 1000
C
C
C*****************************************************************************
C
C MESSAGE SECTION.
C
C*****************************************************************************
C
900 WRITE(6,910)
910 FORMAT(/' *** WARNING *** REACHED MAX NUMBER OF ACCOUNTS (30)'/)
GO TO 1000
C
920 WRITE(6,930)
930 FORMAT(/' *** WARNING *** REACHED MAX NUMBER OF PROJECTS (32)'/)
C
C
C
C*****************************************************************************
C
C RESET READ- AND END-OF-FILE ERROR RECOVERY TO DEFAULT.
C
C*****************************************************************************
C
1000 CALL ERRSET(24,.TRUE.,.TRUE.,.TRUE.,.TRUE.)
CALL ERRSET(39,.TRUE.,.TRUE.,.TRUE.,.TRUE.)
RETURN
END