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