SUBROUTINE RGRCLS (LUNIT, KEYWRD) C***************************************************************************** C C Description : Routine to close an output stream final or temporary. C A temporary close de-activates an output stream for the C specified logical unit, but the output channel remains open, C a final close physically closes the output channel C C Arguments : LUNIT = INTEGER logical unit number C KEYWRD = STRING containing a keyword: C 'FIN' - final close C 'TMP' - temporary close C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V2.0 Date : 10-jun-1983 C C Module name : RGRCLS.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE RGRCLS C C Updates : name version C C description : C C***************************************************************************** C BYTE DEVNAM,OFNTAB,SETPAG,SETSCR,DAT,TIM, 1 TEXREC,DATREC,RREC,SBUF,WPGREC COMMON/RGRCOM/NUNITR,NUNITS,NOS,MNOS,NUCTAB(4,4), 1 MAXBUF,NFRXR,LENREC,NPAG,NWPGR,NWPGC,NFXHL, 2 NRNXRE,NRFFTR,NRLFTR,NRFRTR,NRLRTR,NRFRDR,NRLRDR, 3 IPHLEN,LOGLEN,LOGWID,NRFLDW,NRLLDW,NRDATE,NCDATE, 4 NRTIME,NCTIME,NRPAGE,NCPAGE,NRRELS,NCRELS, 5 DEVNAM(14),SETPAG(6),SETSCR(6),DAT(10),TIM(10), 6 OFNTAB(32,4),TEXREC(40),DATREC(40),RREC(40), 7 SBUF(120),WPGREC(133) C BYTE KEYWRD(1),PROG(8) DATA PROG/'R','G','R','C','L','S',2*0/ C C C check keyword C IKEY=0 CALL SCVTLU(KEYWRD) IF (ISCOMP(KEYWRD,'FIN').EQ.0) IKEY=1 IF (ISCOMP(KEYWRD,'TMP').EQ.0) IKEY=2 IF (IKEY.EQ.0) GOTO 9000 C C search tabel for logical unit C IF (NOS.EQ.0) GOTO 9010 DO 10 I=1,NOS IF (LUNIT.EQ.NUCTAB(1,I)) GOTO 20 10 CONTINUE GOTO 9020 C C close temporary (by switch) C 20 IF (IKEY .EQ. 2) 22,30,30 C THEN 22 NUCTAB(4,I)=0 ! temp. closed GOTO 99 C ENDIF C C close final and re-order output stream tables C 30 IF (NUCTAB(4,I).EQ.1) CLOSE (UNIT=NUCTAB(1,I)) NOS=NOS-1 IF (I.LE.NOS) 32,50,50 C THEN 32 DO 40 J=I,NOS CALL SCOPY(OFNTAB(1,J+1),OFNTAB(1,J)) DO 40 K=1,4 NUCTAB(K,J)=NUCTAB(K,J+1) 40 CONTINUE C ENDIF 50 I=NOS+1 OFNTAB(1,I)=0 DO 60 J=1,4 NUCTAB(J,I)=0 60 CONTINUE C C go back to calling routine C 99 RETURN C C errors C 9000 CALL FATAL(PROG,'Invalid keyword argument') 9010 CALL FATAL(PROG,'No output streams defined') 9020 CALL FATAL(PROG,'Logical unit number unknown') END