SUBROUTINE RGRPRT C***************************************************************************** C C Description : Routine to write the contents of the page lay-out workfile C to all the active output streams C C Arguments : none 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 : RGRPRT.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE RGRPRT 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 C fix text-record BYTE FIXTEX(36) EQUIVALENCE (IRFTX ,RREC(1)) ! row number of fix text EQUIVALENCE (ICFTX ,RREC(3)) ! column number of fix text EQUIVALENCE (FIXTEX,RREC(5)) ! first part of fix text C BYTE FF(2),CC(3),CRLF(3),PROG(8) DATA FF /12,0/, CC /'+','$',0/, CRLF /13,10,0/, 1 PROG /'R','G','R','P','R','T',2*0/ C C C fill in header info and write last current line C 20 IF (NRDATE.NE.0) CALL RGRWS(NRDATE,NCDATE,DAT,0) ! date IF (NRTIME.NE.0) CALL RGRWS(NRTIME,NCTIME,TIM,0) ! time IF (NRPAGE.NE.0) 22,30,30 ! page number C THEN 22 CALL SCVTI(NPAG,'ZZ9',RREC) CALL RGRWS(NRPAGE,NCPAGE,RREC,0) C ENDIF C C write page lay-out workfile to the active output stream(s) C 30 CALL RGRWR(0) ! force last line in page lay-out workfile IWSLUN=0 ! wide screen off DO 32 I=LOGLEN,1,-1 ! determine last not blank line LNBLL=I READ (NUNITS'LNBLL) (WPGREC(J),J=1,LENREC) CALL TRIM(WPGREC) IF (WPGREC(1) .NE. 0) GOTO 40 32 CONTINUE 40 DO 110 INOS=1,NOS IF (NUCTAB(4,INOS).NE.1) GOTO 110 NBL=NUCTAB(3,INOS) IF (NBL.LT.0) NBL=IPHLEN IF (NBL.LT.0) NBL=IFYPAL LUN=NUCTAB(1,INOS) IF (NUCTAB(3,INOS).EQ.-2 .AND. 1 IWSLUN.EQ.0 .AND. LOGWID.GT.80) 42,50,50 C THEN 42 IWSLUN=LUN CALL SWRITE(IWSLUN,CC,SETPAG) C ENDIF 50 DO 100 ICOPY=1,NUCTAB(2,INOS) DO 60 I=1,LNBLL READ (NUNITS'I+0) (WPGREC(J),J=1,LENREC) CALL TRIM(WPGREC) CALL SWRITE(LUN,CC,WPGREC,CRLF) 60 CONTINUE IF (NUCTAB(3,INOS).EQ.-2) 62,70,70 C THEN 62 CALL SWRITE(LUN,CC,CRLF,' ') ACCEPT 900 CALL SWRITE(LUN,CC,CRLF) GOTO 100 C ENDIF 70 IF (NBL.EQ.0) 72,80,80 C THEN 72 CALL SWRITE(LUN,CC,FF) GOTO 100 C ENDIF 80 IF (NBL.LT.LNBLL) 1 NBL=(((LNBLL-1)/NUCTAB(3,INOS))+1)*NUCTAB(3,INOS) IF (NBL.EQ.LNBLL) GOTO 100 DO 90 I=1,NBL-LNBLL ! add blank lines as CALL SWRITE(LUN,CC,CRLF) ! simulated formfeed 90 CONTINUE 100 CONTINUE 110 CONTINUE C C reset scope terminal if necessary and set up new page C IF (IWSLUN.GT.0) CALL SWRITE(IWSLUN,CC,SETSCR) NPAG=NPAG+1 CALL RGRIP C C go back to calling routine C RETURN C C formats C 900 FORMAT() C C errors C END