SUBROUTINE RGRIP C***************************************************************************** C C Description : Routine to initialize the page lay-out workfile C This routine is reserved for RGR-subroutines only 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 : RGRIP.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE RGRIP 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 C blank the page C DO 10 I=1,LENREC WPGREC(I)=' ' IF (I.GT.LOGWID) WPGREC(I)=0 10 CONTINUE DO 20 I=NFXHL+1,LOGLEN WRITE (NUNITS'I+0) (WPGREC(J),J=1,LENREC) 20 CONTINUE C C fill in FIX-fields C NWPGR=0 IREC=NRFFTR 30 IF (IREC.EQ.0 .OR. IREC.GT.NRLFTR) GOTO 40 READ (NUNITR'IREC) RREC ! read FIX-text record IREC=IREC+1 IBUFOF=-4 CALL RGRWS(IRFTX,ICFTX,FIXTEX,IBUFOF+MAXBUF) IBUFOF=IBUFOF+ICFTX 32 IF (RREC(MAXBUF).EQ.0) GOTO 30 READ (NUNITR'IREC) RREC ! compose string from IREC=IREC+1 ! more than one record IBUFOF=IBUFOF+MAXBUF CALL RGRCS(IBUFOF,RREC,MAXBUF) GOTO 32 C C put last line in page lay-out workfile and reset relative start position C 40 CALL RGRWR(0) ! force last line in page lay-out workfile CALL RGRWR(NRRELS) NWPGC=NCRELS C C go back to calling routine C RETURN END