PROGRAM RGR C***************************************************************************** C C Description : Root-program of the RGR-compiler 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 : RGR.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE RGR C LINK/MAP:NL:/OPTIONS C Files? RGR,SDARSXLIB.OLB/LIB,[1,1]F4POTS.OLB/LIB C Option? UNITS=25 C Option? ACTFIL=7 C Option? MAXBUF=136 C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C BYTE REPNAM(16),REXNAM(16),RLSNAM(16), 1 NAME(8),CRLF(3),CC(3),CC1(2),FF(2),ERR DATA CRLF /13,10,0/, CC /'+','$',0/, CC1 /'+',0/, FF /12,0/ C C C initialization C VNR='V2.0' ! version number LUSCR=5 ! display unit LUREP=20 ! RGR-report source file (.REP) LUREX=21 ! temporary RGR-library file LURRX=22 ! RGR-library file (.REX) LURLS=23 ! RGR-report document list file (.RLS) LUWRK=24 ! temporary work file LUWPG=25 ! report page scratch file MAXBUF=40 CALL SCOPY('?RGR-',PROG) CALL DATE(DAT) ! get date CALL TIME(TIM) ! and time IREX=0 IRLS=0 REPREC(1)=0 REXREC(1)=0 WRKREC(1)=0 IPAGE=-1 C C get commmand C WRITE (LUSCR,900) VNR ! display identification CALL SWRITE(LUSCR,CC1,DAT,' time ',TIM,CRLF,CRLF) C C get source file name C 10 CALL SASK('Source file : ',REPNAM,1,11,) CALL SCVTLU(REPNAM) LREP=LEN(REPNAM) IF (LREP.EQ.0) GOTO 10 IF (INDEX(REPNAM,'.').EQ.0) CALL SCOPY('.REP',REPNAM(LREP+1)) CALL SCOPY(REPNAM,NAME,INDEX(REPNAM,'.')-1) ! isolate name C C open source file and work-files (scratch-files) C OPEN (UNIT=LUREP,NAME=REPNAM,TYPE='OLD',ERR=9000) OPEN (UNIT=LUWRK,TYPE='SCRATCH',ACCESS='DIRECT', 1 RECORDSIZE=32,INITIALSIZE=25,MAXREC=100,ERR=9010) OPEN (UNIT=LUREX,TYPE='SCRATCH',ACCESS='DIRECT', 1 RECORDSIZE=10,INITIALSIZE=50,MAXREC=640,ERR=9020) C C library file wanted ? C IF ( LYNASK('Library file : ','Y') )22,30,30 C THEN 22 IREX=1 CALL SCOPY(NAME,REXNAM) CALL SCOPY('.REX',REXNAM(LEN(REXNAM)+1)) C ENDIF 30 IF ( LYNASK('Document file : ','Y') )32,50,50 C THEN 32 IRLS=1 CALL SCOPY(NAME,RLSNAM) CALL SCOPY('.RLS',RLSNAM(LEN(RLSNAM)+1)) OPEN (UNIT=LURLS,NAME=RLSNAM,TYPE='NEW', 1 CARRIAGECONTROL='FORTRAN',ERR=9030) C ENDIF C C initialize library file and start reports loop C 50 CALL RGRID ! initialize temporary lib.file 60 CALL RGRWW ! read report into workfile IF (ISWRET.EQ.-2) GOTO 70 ! read error CALL RGRWD ! write report to temp. lib.file CALL RGRWL ! screen check, write document-list IPAGE=0 IF (ISWRET.EQ.0) GOTO 60 C C end of REP-file C 70 CLOSE (UNIT=LUREP) CLOSE (UNIT=LUWRK) IF (IRLS.EQ.1) 72,80,80 C THEN 72 CALL SWRITE(LURLS,' ',FF) ! issue last form-feed CLOSE (UNIT=LURLS) C ENDIF 80 IF (IREX.EQ.0) 82,84,84 C THEN 82 CLOSE(UNIT=LUREX) GOTO 99 C ELSE 84 NBLK=(NREXR/12)+1 OPEN (UNIT=LURRX,NAME=REXNAM,TYPE='NEW',ACCESS='DIRECT', 1 RECORDSIZE=10,INITIALSIZE=NBLK,MAXREC=NREXR+1,ERR=9040) DO 90 IREC=1,NREXR READ (LUREX'IREC+0,END=92) REXREC WRITE (LURRX'IREC+0) REXREC 90 CONTINUE 92 CLOSE (UNIT=LUREX) CLOSE (UNIT=LURRX) C ENDIF C C stop C 99 TYPE *,' ' CALL EXIT C C formats C 900 FORMAT(' RGR-report compiler - ',A4,20X,$) C C errors C 9000 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t find RGR-report source file',CRLF) GOTO 10 9010 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open RGR-compiler workfile',CRLF) GOTO 10 9020 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open temporary library file',CRLF) GOTO 10 9030 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open RGR-report document list file',CRLF) GOTO 10 9040 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open RGR-report library file',CRLF) GOTO 10 END SUBROUTINE RGRCF (ITYP,TYPE,SCNDI,IRET) C***************************************************************************** C C Description : Routine to check the number of data items and the length C of the last one in a RGR-report source file record, and to C return the first 6 characters of the second item C C Arguments : ITYP = INTEGER indicating what type of check: C 1 - report name record C 2 - header info record C 3 - fix text record C 4 - abs./rel. text record C 5 - abs./rel. data record C TYPE = STRING containing the keyword according to the value C of ITYP C SCNDI = STRING containing the second data item in the record C IRET = INTEGER return code: 0 - normal return C -1 - warning reported C -2 - error encountered 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C BYTE TYPE(1),SCNDI(1),HLPSTR(128),SLSH(2) C C C set minimum number of items according to record type C IRET=0 MINDI=5 IF (ITYP.GE.3 .AND. ITYP.LE.4) MINDI=ITYP SLSH(1)=0 SCNDI(1)=0 C C count data items (strings between comma's) C ICNT=0 IPOS=1 10 ICNT=ICNT+1 CALL GSUBS(REPREC,IPOS,',',HLPSTR,127,IRET) IF (ICNT.EQ.2 .AND. (ITYP.EQ.1 .OR. ITYP.EQ.4 .OR. ITYP.EQ.5)) 1 CALL SCOPY(HLPSTR,SCNDI,6) IF (IRET.EQ.0) GOTO 10 CALL SCVTLU(SCNDI) IF (LEN(SCNDI).NE.0) CALL SCOPY('/',SLSH) C C display message for wrong number of data items and event. print C IF (ICNT.LT.MINDI) 12,20,20 C THEN 12 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE,SLSH,FIELD, 1 '/Missing data items') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE,SLSH,FIELD, 1 '/Missing data items') IRET=-2 GOTO 99 C ENDIF C C check maximum length of last (=text/data) string in record C 20 LH=LEN(HLPSTR) IF ((ITYP.GE.3 .AND. ITYP.LE.4 .AND. LH.GT.3*MAXBUF) 1 .OR. (ITYP.EQ.5 .AND. LH.GT.23)) 22,99,99 C THEN 22 CALL SWRITE(LUSCR,' ',PROG,'W-',TYPE,SLSH,FIELD, 1 '/Excessive number of characters in text/data-string') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'W-',TYPE,SLSH,FIELD, 1 '/Excessive number of characters in text/data-string') IRET=-1 C ENDIF C C go back to calling routine C 99 RETURN END SUBROUTINE RGRCP (SRCSTR,IPOS,IROW,ICOL,IAR,LUN,TYPE,FIELD) C***************************************************************************** C C Description : Routine to check and return page positions C The values of row and column are checked agains the COMMON- C variables MINROW/MAXROW and MINCOL/MAXCOL respectively C C Arguments : SRCSTR = STRING containing the page position C IPOS = input: C INTEGER position in SCRSTR to start search C for position (=2 integers with/without sign) C output: C INTEGER position plus 1 of comma in SRCSTR, or C position of end-of-string character (=zero byte) C IROW = INTEGER returned row number C ICOL = INTEGER returned column number C IAR = INTEGER indicating absolute/relative: C 0 - absolute row and column C 1 - relative row , absolute column C 2 - absolute row , relative column C 3 - relative row and column C LUN = INTEGER logical unit number error messages C TYPE = STRING containing the record type for error message C FIELD = STRING containing the field name for error message 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C BYTE SRCSTR(1),TYPE(1),FIELD(1),RESSTR(128),SLSH(2), 1 PLUS,MINUS DATA PLUS /'+'/, MINUS /'-'/ C C SLSH(1)=0 IF (LEN(FIELD).NE.0) CALL SCOPY('/',SLSH) IROW=0 ICOL=0 IAR=0 CALL GSUBS(SRCSTR,IPOS,',',RESSTR,127,IRET) ! get position C C determine abs./rel. row number C IPOSR=1 IROW=ICVTS(RESSTR,IPOSR,IRETR) IF (IRETR.LE.0) 10,20,20 C THEN 10 IROW=MINROW GOTO 40 C ENDIF 20 DO 30 I=1,IPOSR-1 IF (I.LT.IPOSR .AND. 1 (RESSTR(I).EQ.PLUS .OR.RESSTR(I).EQ.MINUS)) 22,30,30 C THEN 22 IAR=IAR+1 GOTO 40 C ENDIF 30 CONTINUE C C determine abs./rel. column number C 40 IPOSC=IPOSR ICOL=ICVTS(RESSTR,IPOSC,IRETC) IF (IRETC.LE.0) 42,50,50 C THEN 42 ICOL=MINCOL GOTO 70 C ENDIF 50 DO 60 I=IPOSR,IPOSC-1 IF (I.LT.IPOSC .AND. 1 (RESSTR(I).EQ.PLUS .OR. RESSTR(I).EQ.MINUS)) 52,60,60 C THEN 52 IAR=IAR+2 GOTO 70 C ENDIF 60 CONTINUE C C check row/column values C 70 IF (IABS(IROW).GT.MAXROW .OR. ((IAR.AND.1).EQ.0 1 .AND. IRETR.GT.0 .AND. IROW.LT.MINROW)) 72,80,80 C THEN 72 IF (LUN.NE.0) CALL SWRITE(LUN,' ',PROG,'E-',TYPE, 1 SLSH,FIELD,'/Invalid row number') IROW=MINROW C ENDIF 80 IF (IABS(ICOL).GT.MAXCOL .OR. ((IAR.AND.2).EQ.0 1 .AND. IRETC.GT.0 .AND. ICOL.LT.MINCOL)) 82,99,99 C THEN 82 IF (LUN.NE.0) CALL SWRITE(LUN,' ',PROG,'E-',TYPE, 1 SLSH,FIELD,'/Invalid column number') ICOL=MINCOL C ENDIF C C go back to calling routine C 99 RETURN END SUBROUTINE RGRCR (RECORD,NRC) C***************************************************************************** C C Description : Routine to fill a string with a number of zero-characters C C Arguments : RECORD = STRING to be filled C NRC = INTEGER number of fill-characters 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** BYTE RECORD(1) C C fill string C DO 10 I=1,NRC RECORD(I)=0 10 CONTINUE C C go back to calling routine C RETURN END SUBROUTINE RGRID C***************************************************************************** C C Description : Routine to initialize the RGR-report library file 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C C general info record BYTE SETPAG(6),SETSCR(6) C VNR ! version number C IFYPAL ! physical page length C IFYWID ! physical page width C NRFSRE ! rec.nr. first report C SETPAG ! esq.seq: set screen to 132 positions C SETSCR ! esq.seq: reset screen to 80 positions C BYTE SPAG(6),SSCR(6) DATA SPAG /155,'[','?','3','h',0/, 1 SSCR /155,'[','?','3','l',0/ C C NGIR=1 ! number of general info records CALL RGRCR(REXREC,MAXBUF) ! zero record buffer IFYPAL=66 ! max. lines per physical page IFYWID=131 ! max. characters per line NRFSRE=NGIR+1 CALL SCOPY(SPAG,SETPAG) CALL SCOPY(SSCR,SETSCR) WRITE (LUREX'1) VNR,IFYPAL,IFYWID,NRFSRE,SETPAG,SETSCR NREXR=NGIR C C go back to calling program C RETURN END SUBROUTINE RGRLH C***************************************************************************** C C Description : Routine to write header line for RGR-report document list 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C BYTE LF2(3) DATA LF2/10,10,0/ C C C write header-lines and update page- and line-counter C IF (IPAGE.NE.-1) 10,20,20 C THEN 10 CALL SWRITE(LURLS,'1',' ') GOTO 30 C ELSE 20 CALL SWRITE(LURLS,' ',' ') IPAGE=0 C ENDIF 30 WRITE (LURLS,900) VNR CALL SWRITE(LURLS,'+$',DAT,' time ',TIM) IPAGE=IPAGE+1 WRITE (LURLS,910) IPAGE CALL SWRITE(LURLS,' ',LF2,'Report: ',RNAME) ILINE=5 C C go back to calling routine C RETURN C C formats C 900 FORMAT('+RGR - ',A4,6X,'RGR-report document list',7X,$) 910 FORMAT('+ page ',I2) END SUBROUTINE RGRWD C***************************************************************************** C C Description : Routine to read the RGR-compiler workfile and create C a report in the RGR-report library file 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C C report name-record BYTE FRXREC(40),RENAM(8) EQUIVALENCE (RENAM ,FRXREC(1)) ! report name EQUIVALENCE (NRNXRE,FRXREC(9)) ! rec.nr. next report EQUIVALENCE (NRFFTR,FRXREC(11)) ! rec.nr. first fix text rec. EQUIVALENCE (NRLFTR,FRXREC(13)) ! rec.nr. last fix text rec. EQUIVALENCE (NRFRTR,FRXREC(15)) ! rec.nr. first relative text rec. EQUIVALENCE (NRLRTR,FRXREC(17)) ! rec.nr. last relative text rec. EQUIVALENCE (NRFRDR,FRXREC(19)) ! rec.nr. first relative data rec. EQUIVALENCE (NRLRDR,FRXREC(21)) ! rec.nr. last relative data rec. EQUIVALENCE (NFXHL ,FRXREC(23)) ! number of fix header lines C C report page info-record EQUIVALENCE (IPHLEN,REXREC(1)) ! phys. page length/hardware form-feed EQUIVALENCE (LOGLEN,REXREC(3)) ! logical length of report page EQUIVALENCE (LOGWID,REXREC(5)) ! logical width of report page EQUIVALENCE (NRFLDW,REXREC(7)) ! number of first line of data window EQUIVALENCE (NRLLDW,REXREC(9)) ! number of last line of data window EQUIVALENCE (NRDATE,REXREC(11)) ! row number of date string EQUIVALENCE (NCDATE,REXREC(13)) ! column number of date string EQUIVALENCE (NRTIME,REXREC(15)) ! row number of time string EQUIVALENCE (NCTIME,REXREC(17)) ! column number of time string EQUIVALENCE (NRPAGE,REXREC(19)) ! row number of page number EQUIVALENCE (NCPAGE,REXREC(21)) ! column number of page number EQUIVALENCE (NRRELS,REXREC(23)) ! starting row relative text/data EQUIVALENCE (NCRELS,REXREC(25)) ! starting column relative text/data C C fix text-record BYTE FIXTEX(36) EQUIVALENCE (IRFTX ,REXREC(1)) ! row number of fix text EQUIVALENCE (ICFTX ,REXREC(3)) ! column number of fix text EQUIVALENCE (FIXTEX,REXREC(5)) ! first part of fix text C C relative text name-record BYTE TEXFLD(8) EQUIVALENCE (TEXFLD,REXREC(1)) ! field name EQUIVALENCE (IRTEX ,REXREC(9)) ! abs./rel. row number EQUIVALENCE (ICTEX ,REXREC(11)) ! abs./rel. column number EQUIVALENCE (IARTEX,REXREC(13)) ! abs./rel. flag EQUIVALENCE (NRTR ,REXREC(15)) ! number of text records C C relative data-record BYTE DATFLD(8),DATYP(2),PICT(24) EQUIVALENCE (DATFLD,REXREC(1)) ! field name EQUIVALENCE (IRDAT ,REXREC(9)) ! abs./rel. row number EQUIVALENCE (ICDAT ,REXREC(11)) ! abs./rel. column number EQUIVALENCE (IARDAT,REXREC(13)) ! abs./rel. flag EQUIVALENCE (DATYP ,REXREC(15)) ! data type I(nt.),R(eal) or S(tring) EQUIVALENCE (DATPIC,REXREC(17)) ! picture field for I- & R-type EQUIVALENCE (LDASTR,REXREC(17)) ! string length for S-type C BYTE TYPE(4),RESSTR(128) C C C prepare report name-record C IF (NWRKR.EQ.0) GOTO 899 NREXR=NREXR+1 NFRXR=NREXR ! save rec.nr. for later on CALL RGRCR(FRXREC,MAXBUF) CALL SCOPY(RNAME,RENAM) NRFFTR=0 NRLFTR=0 NRFRTR=0 NRLRTR=0 NRFRDR=0 NRLRDR=0 NFXHL=0 C C report page info-record C CALL RGRCR(REXREC,MAXBUF) READ (LUWRK'1) WRKREC ! read REP-record IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) IPOS0=1 IPHLEN=ICVTS(RESSTR,IPOS0,IRET) IF (IPHLEN.EQ.-1) IPHLEN=IFYPAL IF (IPHLEN.LT.-1 .OR. IRET.LE.0) 10,20,20 C THEN 10 IPHLEN=IFYPAL CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Invalid physical page length') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE, 1 '/Invalid physical page length') C ENDIF 20 CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) ! get 4th data item LOGLEN=IFYPAL LOGWID=IFYWID IF (RESSTR(1).EQ.0) GOTO 30 IPOS0=1 LOGLEN=ICVTS(RESSTR,IPOS0,IRET1) LOGWID=ICVTS(RESSTR,IPOS0,IRET2) IF (IRET1.LE.0 .OR. IRET2.LE.0 1 .OR. LOGLEN.LE.0 .OR. (IPHLEN.GT.0 .AND. LOGLEN.GT.IPHLEN) 2 .OR. LOGWID.LE.0 .OR. LOGWID.GT.IFYWID) 22,30,30 C THEN 22 LOGLEN=IFYPAL LOGWID=IFYWID CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Invalid logical page size') IF (IRLS.EQ.1) CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Invalid logical page size') C ENDIF 30 CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) ! get 5th data item NRFLDW=1 NRLLDW=LOGLEN IF (RESSTR(1).EQ.0) GOTO 40 IPOS0=1 NRFLDW=ICVTS(RESSTR,IPOS0,IRET1) NRLLDW=ICVTS(RESSTR,IPOS0,IRET2) IF (IRET1.LE.0 .OR. IRET2.LE.0 .OR. 1 NRFLDW.LE.0 .OR. NRFLDW.GT.LOGLEN .OR. 2 NRLLDW.LE.0 .OR. NRLLDW.GT.LOGLEN .OR. 3 NRFLDW.GT.NRLLDW) 32,40,40 C THEN 32 NRFLDW=1 NRLLDW=LOGLEN CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Invalid data window size') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE, 1 '/Invalid data window size') C ENDIF 40 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) ! get last data item IF (RESSTR(1).EQ.0) GOTO 50 IPOS0=1 NFXHL=ICVTS(RESSTR,IPOS0,IRET1) IF (IRET1.LE.0 .OR. 1 NFXHL.LT.0 .OR. NFXHL.GT.LOGLEN) 42,50,50 C THEN 42 NFXHL=0 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Invalid number of fix header lines') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE, 1 '/Invalid number of fix header lines') C ENDIF 50 NRDATE=0 NCDATE=0 NRTIME=0 NCTIME=0 NRPAGE=0 NCPAGE=0 NRRELS=0 NCRELS=0 MINROW=0 MINCOL=0 IF (NWRKR.LE.1) GOTO 80 MAXROW=LOGLEN MAXCOL=LOGWID DO 60 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'HDR').NE.0) GOTO 60 ! search HDR-record CALL RGRCP(WRKREC,IPOS,NRDATE,NCDATE,IAR,LUSCR,TYPE,0) IARBUF=IAR CALL RGRCP(WRKREC,IPOS,NRTIME,NCTIME,IAR,LUSCR,TYPE,0) IARBUF=IARBUF+IAR CALL RGRCP(WRKREC,IPOS,NRPAGE,NCPAGE,IAR,LUSCR,TYPE,0) IARBUF=IARBUF+IAR CALL RGRCP(WRKREC,IPOS,NRRELS,NCRELS,IAR,LUSCR,TYPE,0) IARBUF=IARBUF+IAR GOTO 70 60 CONTINUE C 70 IF (IARBUF.NE.0) 72,80,80 C THEN 72 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Relative page positions not permitted') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE, 1 '/Relative page positions not permitted') C ENDIF C 80 NREXR=NREXR+1 WRITE (LUREX'NREXR) REXREC ! write page info-record IF (NWRKR.LE.1) GOTO 400 C C FIX-records C MINROW=1 MINCOL=1 DO 140 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'FIX').NE.0) GOTO 140 ! search FIX-record CALL RGRCR(REXREC,MAXBUF) ! check/convert data CALL RGRCP(WRKREC,IPOS,IRFTX,ICFTX,IAR,LUSCR,TYPE,0) IF (IAR.NE.0) 100,110,110 C THEN 100 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Relative page positions not permitted') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE, 1 '/Relative page positions not permitted') C ENDIF 110 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LR=LEN(RESSTR) IBUFOF=0 CALL SCOPY(RESSTR,FIXTEX,MAXBUF-5) ! prepare REX-record IF (LR.GE.MAXBUF-4) 120,130,130 C THEN ! compose more than one REX-record 120 REXREC(MAXBUF)=RESSTR(IBUFOF+MAXBUF-4) ! for one FIX-record NREXR=NREXR+1 WRITE (LUREX'NREXR) REXREC NRLFTR=NRLFTR+1 CALL RGRCR(REXREC,MAXBUF) CALL SCOPY(RESSTR(IBUFOF+MAXBUF-3),REXREC,MAXBUF-1) LR=LEN(RESSTR(IBUFOF+MAXBUF-3)) IBUFOF=IBUFOF+MAXBUF IF (LR.GE.MAXBUF) GOTO 120 C ENDIF 130 NREXR=NREXR+1 WRITE (LUREX'NREXR) REXREC NRLFTR=NRLFTR+1 140 CONTINUE IF (NRLFTR.NE.0) NRFFTR=NREXR-NRLFTR+1 ! update REP-record NRLFTR=NREXR C C TEX-records C DO 220 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'TEX').NE.0) GOTO 220 ! search TEX-record CALL RGRCR(REXREC,MAXBUF) ! check/convert data CALL GSUBS(WRKREC,IPOS,',',TEXFLD,127,IRET) CALL RGRCP(WRKREC,IPOS,IRTEX,ICTEX,IARTEX,LUSCR,TYPE,TEXFLD) CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LR=LEN(RESSTR) NRTR=LR/MAXBUF+1 NREXR=NREXR+1 WRITE (LUREX'NREXR) REXREC ! write relative text name-record NRLRTR=NRLRTR+1 CALL RGRCR(REXREC,MAXBUF) IBUFOF=0 CALL SCOPY(RESSTR,REXREC,MAXBUF-1) IF (LR.GE.MAXBUF-1) 200,210,210 C THEN ! compose more than one REX-record 200 REXREC(MAXBUF)=RESSTR(IBUFOF+MAXBUF) ! for one TEX-record NREXR=NREXR+1 WRITE (LUREX'NREXR) REXREC NRLRTR=NRLRTR+1 CALL RGRCR(REXREC,MAXBUF) CALL SCOPY(RESSTR(IBUFOF+MAXBUF+1),REXREC,MAXBUF-1) LR=LEN(RESSTR(IBUFOF+MAXBUF+1)) IBUFOF=IBUFOF+MAXBUF IF (LR.GE.MAXBUF) GOTO 200 C ENDIF 210 NREXR=NREXR+1 WRITE (LUREX'NREXR) REXREC NRLRTR=NRLRTR+1 220 CONTINUE IF (NRLRTR.NE.0) NRFRTR=NREXR-NRLRTR+1 ! update REP-record NRLRTR=NREXR C C DAT-records C DO 350 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DAT').NE.0) GOTO 350 ! search DAT-record CALL RGRCR(REXREC,MAXBUF) ! check/convert data CALL GSUBS(WRKREC,IPOS,',',DATFLD,127,IRET) CALL RGRCP(WRKREC,IPOS,IRDAT,ICDAT,IARDAT,LUSCR,TYPE,DATFLD) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,DATYP,1) CALL SCVTLU(DATYP) IX=INDEX('SIR',RESSTR) IF (IX.EQ.0 .OR. LEN(RESSTR).NE.1) 300,310,310 C THEN 300 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/',DATFLD,'/Invalid data type') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE, 1 '/',DATFLD,'/Invalid data type') IX=0 C ENDIF 310 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) IF (IX.GE.2) 320,330,330 C THEN ! numeric data type 320 CALL SCOPY(RESSTR,DATPIC,23) LR=LEN(RESSTR) IF (LR.EQ.0 .OR. LR.GT.23) 322,340,340 C THEN 322 CALL SWRITE(LUSCR,' ',PROG,'W-',TYPE, 1 '/',DATFLD,'/Improper length of picture-string') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'W-',TYPE, 1 '/',DATFLD,'/Improper length of picture-string') GOTO 340 C ENDIF C ELSE ! string data type 330 IPOS0=1 LDASTR=ICVTS(RESSTR,IPOS0,IRET) IF (LDASTR.LE.0 .OR. LDASTR.GT.MAXCOL) 332,340,340 C THEN 332 LDASTR=MAXCOL CALL SWRITE(LUSCR,' ',PROG,'W-',TYPE, 1 '/',DATFLD,'/Improper data length') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'W-',TYPE, 1 '/',DATFLD,'/Improper data length') GOTO 340 C ENDIF c ENDIF 340 NREXR=NREXR+1 WRITE (LUREX'NREXR) REXREC NRLRDR=NRLRDR+1 350 CONTINUE IF (NRLRDR.NE.0) NRFRDR=NREXR-NRLRDR+1 ! update REP-record NRLRDR=NREXR C C update REP-record C 400 NRNXRE=NREXR+1 IF (ISWRET.EQ.-1) NRNXRE=NGIR+1 WRITE (LUREX'NFRXR) FRXREC C C go back to calling routine C 899 RETURN END SUBROUTINE RGRWL C***************************************************************************** C C Description : Routine to write the RGR-report documentation 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C C report name-record BYTE FRXREC(40),RENAM(8) EQUIVALENCE (RENAM ,FRXREC(1)) ! report name EQUIVALENCE (NRNXRE,FRXREC(9)) ! rec.nr. next report EQUIVALENCE (NRFFTR,FRXREC(11)) ! rec.nr. first fix text rec. EQUIVALENCE (NRLFTR,FRXREC(13)) ! rec.nr. last fix text rec. EQUIVALENCE (NRFRTR,FRXREC(15)) ! rec.nr. first relative text rec. EQUIVALENCE (NRLRTR,FRXREC(17)) ! rec.nr. last relative text rec. EQUIVALENCE (NRFRDR,FRXREC(19)) ! rec.nr. first relative data rec. EQUIVALENCE (NRLRDR,FRXREC(21)) ! rec.nr. last relative data rec. EQUIVALENCE (NFXHL ,FRXREC(23)) ! number of fix header lines C C report page info-record EQUIVALENCE (IPHLEN,REXREC(1)) ! phys. page length/hardware form-feed EQUIVALENCE (LOGLEN,REXREC(3)) ! logical length of report page EQUIVALENCE (LOGWID,REXREC(5)) ! logical width of report page EQUIVALENCE (NRFLDW,REXREC(7)) ! number of first line of data window EQUIVALENCE (NRLLDW,REXREC(9)) ! number of last line of data window EQUIVALENCE (NRDATE,REXREC(11)) ! row number of date string EQUIVALENCE (NCDATE,REXREC(13)) ! column number of date string EQUIVALENCE (NRTIME,REXREC(15)) ! row number of time string EQUIVALENCE (NCTIME,REXREC(17)) ! column number of time string EQUIVALENCE (NRPAGE,REXREC(19)) ! row number of page number EQUIVALENCE (NCPAGE,REXREC(21)) ! column number of page number EQUIVALENCE (NRRELS,REXREC(23)) ! starting row relative text/data EQUIVALENCE (NCRELS,REXREC(25)) ! starting column relative text/data C BYTE CHAR,CC(2),LF(2),TYPE(4),NAME(8),RESSTR(128),HLPSTR(128),DTYPS(2), 1 WPGREC(136),CLRWPG(136) DATA LF/10,0/ C C C initialize and prepare header line C IF (NWRKR.EQ.0) GOTO 899 ITLFLG=0 INBFLG=0 IHFT=0 IWPG=0 LINMAX=60 C C prepare report page scratch file C READ (LUREX'NFRXR) FRXREC ! read report name record READ (LUREX'NFRXR+1) REXREC ! read report page info record IRCSIZ=LOGWID/4+1 LENREC=IRCSIZ*4 NBLK=(LOGLEN*LENREC/512)+1 CALL ERRSET(37,.TRUE.,.FALSE.,.FALSE.,.FALSE.,) !Inhibit inc.rec.siz. OPEN (UNIT=LUWPG,NAME='RGRWRK.TMP',TYPE='SCRATCH',ACCESS='DIRECT', 1 RECORDSIZE=IRCSIZ,INITIALSIZE=NBLK,MAXREC=LOGLEN+1,ERR=9000) IWPG=1 DO 10 I=1,LENREC CLRWPG(I)=' ' IF (I.GT.LOGWID) CLRWPG(I)=0 10 CONTINUE DO 20 I=1,LOGLEN WRITE (LUWPG'I+0) (CLRWPG(J),J=1,LENREC) 20 CONTINUE C C fill in FIX-fields C IF (NWRKR.LE.1) GOTO 400 DO 60 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'FIX').NE.0) GOTO 60 ! search FIX-record CALL RGRCP(WRKREC,IPOS,IROW,ICOL,IAR,0,TYPE,0) CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LR=LEN(RESSTR) IF (LR.EQ.0) GOTO 60 READ (LUWPG'IROW) (WPGREC(J),J=1,LENREC) DO 40 J=1,LR IHCOL=ICOL+J-1 IF (IHCOL.LE.0 .OR. IHCOL.GT.LOGWID) 22,30,30 C THEN 22 ITLFLG=1 IF (IHCOL.GT.LOGWID) GOTO 50 GOTO 40 C ELSE 30 CHAR=RESSTR(J) IF (WPGREC(IHCOL).NE.' ') 32,34,34 C THEN 32 CHAR='*' INBFLG=1 C ENDIF 34 WPGREC(IHCOL)=CHAR C ENDIF 40 CONTINUE 50 WRITE (LUWPG'IROW) (WPGREC(J),J=1,LENREC) IHFT=IHFT+1 60 CONTINUE C C fill in date/time/page info C DO 180 I=1,3 IF (I.EQ.1) 100,110,110 C THEN 100 CALL SCOPY('dd-mmm-yy',RESSTR) IROW=NRDATE ICOL=NCDATE GOTO 130 C ENDIF 110 IF (I.EQ.2) 112,120,120 C THEN 112 CALL SCOPY('hh:mm:ss',RESSTR) IROW=NRTIME ICOL=NCTIME GOTO 130 C ENDIF 120 IF (I.EQ.3) 122,130,130 C THEN 122 CALL SCOPY(' 2',RESSTR) IROW=NRPAGE ICOL=NCPAGE C ENDIF 130 IF (IROW.LE.0) GOTO 180 READ (LUWPG'IROW) (WPGREC(J),J=1,LENREC) DO 160 J=1,LEN(RESSTR) IHCOL=ICOL+J-1 IF (IHCOL.LE.0 .OR. IHCOL.GT.LOGWID) 140,150,150 C THEN 140 ITLFLG=1 IF (IHCOL.GT.LOGWID) GOTO 170 GOTO 160 C ELSE 150 CHAR=RESSTR(J) IF (WPGREC(IHCOL).NE.' ') 152,154,154 C THEN 152 CHAR='*' INBFLG=1 C ENDIF 154 WPGREC(IHCOL)=CHAR C ENDIF 160 CONTINUE 170 WRITE (LUWPG'IROW) (WPGREC(J),J=1,LENREC) IHFT=IHFT+1 180 CONTINUE C C fill in absolute TEX-fields C DO 240 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'TEX').NE.0) GOTO 240 ! search TEX-record CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) IPOS0=1 CALL RGRCP(RESSTR,IPOS0,IROW,ICOL,IAR,LURLS,TYPE,NAME) IF (IAR.NE.0) GOTO 240 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LR=LEN(RESSTR) IF (LR.EQ.0) GOTO 240 READ (LUWPG'IROW) (WPGREC(J),J=1,LENREC) DO 220 J=1,LR IHCOL=ICOL+J-1 IF (IHCOL.LE.0 .OR. IHCOL.GT.LOGWID) 200,210,210 C THEN 200 ITLFLG=1 IF (IHCOL.GT.LOGWID) GOTO 230 GOTO 220 C ELSE 210 CHAR=RESSTR(J) IF (WPGREC(IHCOL).NE.' ') 212,214,214 C THEN 212 CHAR='*' INBFLG=1 C ENDIF 214 WPGREC(IHCOL)=CHAR C ENDIF 220 CONTINUE 230 WRITE (LUWPG'IROW) (WPGREC(J),J=1,LENREC) IHFT=IHFT+1 240 CONTINUE C C fill in absolute DAT-fields C DO 380 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DAT').NE.0) GOTO 380 ! search DAT-record CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) IPOS0=1 CALL RGRCP(RESSTR,IPOS0,IROW,ICOL,IAR,LURLS,TYPE,NAME) IF (IAR.NE.0) GOTO 380 CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,DTYPS,1) CALL SCVTLU(DTYPS) CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) IF (DTYPS(1).EQ.'S') 300,320,320 C THEN 300 IPOS0=1 LR=ICVTS(RESSTR,IPOS0,IRET) IF (LR.EQ.0) GOTO 380 DO 310 J=1,LR IF (J.LE.LR) HLPSTR(J)='X' 310 CONTINUE GOTO 330 C ELSE 320 CALL SCOPY(RESSTR,HLPSTR) IF (LEN(RESSTR).EQ.0) CALL SCOPY('default',HLPSTR) LR=LEN(HLPSTR) IF (HLPSTR(LR).EQ.'E') CALL SCOPY('+99',HLPSTR(LR+1)) LR=LEN(HLPSTR) C ENDIF 330 READ (LUWPG'IROW) (WPGREC(J),J=1,LENREC) DO 360 J=1,LR IHCOL=ICOL+J-1 IF (IHCOL.LE.0 .OR. IHCOL.GT.LOGWID) 340,350,350 C THEN 340 ITLFLG=1 IF (IHCOL.GT.LOGWID) GOTO 370 GOTO 360 C ELSE 350 CHAR=HLPSTR(J) IF (WPGREC(IHCOL).NE.' ') 352,354,354 C THEN 352 CHAR='*' INBFLG=1 C ENDIF 354 WPGREC(IHCOL)=CHAR C ENDIF 360 CONTINUE 370 WRITE (LUWPG'IROW) (WPGREC(J),J=1,LENREC) IHFT=IHFT+1 380 CONTINUE C C give warning for off-screen characters and/or multiple occupation C 400 IF (ITLFLG.EQ.1) CALL SWRITE(LUSCR,' ',PROG, 1 'W-Fix text off-screen') IF (INBFLG.EQ.1) CALL SWRITE(LUSCR,' ',PROG, 1 'W-Multiple occupation of page positions') IF (IRLS.EQ.0) GOTO 600 C C print report page parameters C CALL SWRITE(LURLS,' ',LF,'Report page parameters:') CALL SWRITE(LURLS,' ','-----------------------') CALL SWRITE(LURLS,' $',LF, 1 'Physical length (0=hard-ware form-feed): ') WRITE (LURLS,910) IPHLEN CALL SWRITE(LURLS,' $', 1 'Logical length (=nr. of rows) : ') WRITE (LURLS,910) LOGLEN CALL SWRITE(LURLS,' $', 1 'Logical width (=nr. of columns) : ') WRITE (LURLS,910) LOGWID CALL SWRITE(LURLS,' $', 1 'Data window first line : ') WRITE (LURLS,910) NRFLDW CALL SWRITE(LURLS,' $', 1 'Data window last line : ') WRITE (LURLS,910) NRLLDW CALL SWRITE(LURLS,' $', 1 'Number of fix header lines : ') WRITE (LURLS,910) NFXHL CALL SWRITE(LURLS,' $',LF, 1 'Position date (row/col): ') IF (NRDATE.NE.0) WRITE (LURLS,920) NRDATE,NCDATE IF (NRDATE.EQ.0) WRITE (LURLS,930) CALL SWRITE(LURLS,' $', 1 'Position time (row/col): ') IF (NRTIME.NE.0) WRITE (LURLS,920) NRTIME,NCTIME IF (NRTIME.EQ.0) WRITE (LURLS,930) CALL SWRITE(LURLS,' $', 1 'Position page number (row/col): ') IF (NRPAGE.NE.0) WRITE (LURLS,920) NRPAGE,NCPAGE IF (NRPAGE.EQ.0) WRITE (LURLS,930) CALL SWRITE(LURLS,' $', 1 'Position printer after header (row/col): ') IF (NRRELS.NE.0) WRITE (LURLS,920) NRRELS,NCRELS IF (NRRELS.EQ.0) WRITE (LURLS,930) C C print report page lay-out C CALL SWRITE(LURLS,' ',LF,' ') CALL SWRITE(LURLS,' ',LF,'Report page lay-out:') CALL SWRITE(LURLS,' ','--------------------') IF (IHFT.EQ.0 .OR. IWPG.EQ.0) 500,510,510 C THEN 500 IF (IHFT.EQ.0) CALL SWRITE(LURLS,' ',LF,'Blank page') IF (IWPG.EQ.0) CALL SWRITE(LURLS,' ',LF,'Not available') GOTO 550 C ENDIF 510 CALL SWRITE(LURLS,' ',LF,'See next page') IF (ITLFLG.EQ.1) CALL SWRITE(LURLS,' ',LF,PROG, 1 'W-Fix text off-screen') IF (INBFLG.EQ.1) CALL SWRITE(LURLS,' ',LF,PROG, 1 'W-Multiple occupation of page positions (*)') IPAGE=IPAGE+1 ! update page counter CC(1)='1' DO 520 I=1,LOGLEN READ (LUWPG'I+0) (WPGREC(J),J=1,LENREC) CALL TRIM(WPGREC) CALL SWRITE(LURLS,CC,WPGREC) CC(1)=' ' 520 CONTINUE C C print TEX-field info C 550 ITEX=0 CALL RGRLH CALL SWRITE(LURLS,' ',LF,'Relative text') CALL SWRITE(LURLS,' ','-------------') ILINE=ILINE+3 C DO 560 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'TEX').NE.0) GOTO 560 ! search TEX-record ITEX=ITEX+1 IF (ILINE+4.GT.LINMAX) CALL RGRLH CALL GSUBS(WRKREC,IPOS,',',NAME,127,IRET) CALL SWRITE(LURLS,' ',LF,'Name : ',NAME) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LURLS,' ','Position (row/col): ',RESSTR) IPOS0=1 CALL RGRCP(RESSTR,IPOS0,IROW,ICOL,IAR,LURLS,TYPE,NAME) CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) CALL SWRITE(LURLS,' ','Text : ',RESSTR) ILINE=ILINE+4 560 CONTINUE IF (ITEX.EQ.0) CALL SWRITE(LURLS,' ',LF,'Not available') C C print DAT-field info C IDAT=0 CALL RGRLH CALL SWRITE(LURLS,' ',LF,'Relative data') CALL SWRITE(LURLS,' ','-------------') ILINE=ILINE+3 C DO 570 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DAT').NE.0) GOTO 570 ! search DAT-record IDAT=IDAT+1 IF (ILINE+6.GT.LINMAX) CALL RGRLH CALL GSUBS(WRKREC,IPOS,',',NAME,127,IRET) CALL SWRITE(LURLS,' ',LF,'Name : ',NAME) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LURLS,' ','Position (row/col): ',RESSTR) IPOS0=1 CALL RGRCP(RESSTR,IPOS0,IROW,ICOL,IAR,LURLS,TYPE,NAME) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,DTYPS,1) CALL SCVTLU(DTYPS) CALL SCOPY('tring',HLPSTR) IF (DTYPS(1).EQ.'I') CALL SCOPY('nteger',HLPSTR) IF (DTYPS(1).EQ.'R') CALL SCOPY('eal',HLPSTR) CALL SWRITE(LURLS,' ','Data type : ',DTYPS,HLPSTR) CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) CALL SCOPY('Print picture : ',HLPSTR) IF (DTYPS(1).EQ.'S') CALL SCOPY('String length : ',HLPSTR) IF (DTYPS(1).NE.'S' .AND. LEN(RESSTR).EQ.0) 1 CALL SCOPY('default',RESSTR) CALL SWRITE(LURLS,' ',HLPSTR,RESSTR) ILINE=ILINE+6 570 CONTINUE IF (IDAT.EQ.0) CALL SWRITE(LURLS,' ',LF,'Not available') C C close page lay-out workfile C 600 IF (IWPG.EQ.1) CLOSE (UNIT=LUWPG) C C go back to calling routine C 899 RETURN C C formats C 910 FORMAT('+',I3) 920 FORMAT('+',I3,' /',I3) 930 FORMAT('+not defined') C C error C 9000 CALL SWRITE(LUSCR,' ',PROG, 1 'E-Can''t open page lay-out workfile') GOTO 400 END SUBROUTINE RGRWW C***************************************************************************** C C Description : Routine to read the RGR-report source file and to write C a report into the RGR-compiler workfile 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 : RGR.FTN C C Package : RGR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,RNAME,DAT,TIM,REPREC,REXREC,WRKREC COMMON/RGRRXC/VNR,LUSCR,LUREP,LUREX,LURLS,LUWRK,LUWPG,IRLS, 1 ISWRET,NGIR,NWRKR,NREXR,NFRXR,MAXBUF,IPAGE,ILINE, 2 MINROW,MAXROW,MINCOL,MAXCOL,IFYPAL,IFYWID, 3 PROG(10),RNAME(8),DAT(10),TIM(10), 4 REPREC(128),REXREC(40),WRKREC(128) C BYTE RESSTR(128),TYPE(4),NAME(8),ERR C C NWRKR=0 NREP=0 NHDR=0 CALL SCOPY('******',RNAME) IF (LEN(REPREC).NE.0) GOTO 50 ISWRET=0 C C read RGR-report source file C 10 CALL GETSTR(LUREP,REPREC,127,ERR) IF (ERR.EQ.-3) 12,20,20 C THEN 12 CALL SWRITE(LUSCR,' ',PROG, 1 'E-RGR-report source record too long') IF (IRLS.EQ.1) 14,10,10 C THEN 14 IF (IPAGE.LE.0) CALL RGRLH CALL SWRITE(LURLS,' ',PROG, 1 'E-RGR-report source record too long') GOTO 10 C ENDIF 20 IF (ERR.EQ.-2) 22,30,30 C THEN 22 CALL SWRITE(LUSCR,' ',PROG, 1 'F-READ error RGR-report source file') IF (IRLS.EQ.1) 24,26,26 C THEN 24 IF (IPAGE.LE.0) CALL RGRLH CALL SWRITE(LURLS,' ',PROG, 1 'F-READ error RGR-report source file') C ENDIF 26 ISWRET=-2 GOTO 899 C ENDIF 30 IF (ERR.EQ.-1) 32,50,50 C THEN 32 ISWRET=-1 ! end of file GOTO 899 C ENDIF C C check record type C 50 IF (LEN(REPREC).EQ.0) GOTO 10 ITYP=7 IPOS=1 CALL GSUBS(REPREC,IPOS,',',RESSTR,127,IRET) IF (LEN(RESSTR).EQ.3) 52,60,60 C THEN 52 CALL SCOPY(RESSTR,TYPE) CALL SCVTLU(TYPE) IF (ISCOMP(TYPE,'REP').EQ.0) ITYP=1 IF (ISCOMP(TYPE,'HDR').EQ.0) ITYP=2 IF (ISCOMP(TYPE,'FIX').EQ.0) ITYP=3 IF (ISCOMP(TYPE,'TEX').EQ.0) ITYP=4 IF (ISCOMP(TYPE,'DAT').EQ.0) ITYP=5 C ENDIF 60 GOTO (100,200,300,300,300,70) ITYP C C unidentified type encountered C 70 CALL SWRITE(LUSCR,' ',PROG, 1 'E-Undefined RGR-report source record') IF (IRLS.EQ.1) 72,10,10 C THEN 72 IF (IPAGE.LE.0) CALL RGRLH CALL SWRITE(LURLS,' ',PROG, 1 'E-Undefined RGR-report source record') GOTO 10 C ENDIF C C type = REP C 100 NREP=NREP+1 IF (NREP.NE.1) GOTO 899 CALL RGRCF(ITYP,TYPE,RNAME,IRET) IF (IRET.EQ.-2) GOTO 10 CALL SWRITE(LUSCR,' ',RNAME) IF (IRLS.EQ.1) CALL RGRLH IUPD=0 GOTO 400 C C type = HDR C 200 CALL RGRCF(ITYP,TYPE,RESSTR,IRET) IF (IRET.EQ.-2) GOTO 10 IF (NREP.EQ.0) GOTO 9000 NHDR=NHDR+1 IF (NHDR.GT.1) GOTO 9010 GOTO 400 C C type = FIX ,TEX and DAT C 300 CALL RGRCF(ITYP,TYPE,NAME,IRET) IF (IRET.EQ.-2) GOTO 10 IF (NREP.EQ.0) GOTO 9000 GOTO 400 C C put type and name plus rest of source record in output buffer C 400 CALL SCOPY(TYPE,WRKREC) IF (ITYP.EQ.1 .OR. ITYP.GE.4) 410,420,420 C THEN 410 WRKREC(4)=',' CALL GSUBS(REPREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,NAME,6) CALL SCVTLU(NAME) CALL SCOPY(NAME,WRKREC(5)) IF (LEN(RESSTR).GT.6) 412,420,420 C THEN 412 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE,'/',NAME, 1 '/Name truncated') IF (IRLS.EQ.1) CALL SWRITE(LURLS,' ',PROG,'E-',TYPE,'/',NAME, 1 '/Name truncated') C ENDIF C ENDIF 420 LR=LEN(WRKREC)+1 WRKREC(LR)=',' CALL SCOPY(REPREC(IPOS),WRKREC(LR+1)) NWRKR=NWRKR+1 WRITE (LUWRK'NWRKR) WRKREC ! write workfile GOTO 10 C C go back to calling routine C 899 RETURN C C errors C 9000 CALL SWRITE(LUSCR,' $',PROG,'E-',TYPE) IF (ITYP.GE.4) CALL SWRITE(LUSCR,'+$','/',NAME) CALL SWRITE(LUSCR,'+','/Missing REP-type record') IF (IRLS.EQ.1) 9002,10,10 C THEN 9002 IF (IPAGE.LE.0) CALL RGRLH CALL SWRITE(LURLS,' $',PROG,'E-',TYPE) IF (ITYP.GE.4) CALL SWRITE(LURLS,'+$','/',NAME) CALL SWRITE(LURLS,'+','/Missing REP-type record') GOTO 10 C ENDIF C C More than one HDR-type record C 9010 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/More than one record not allowed') IF (IRLS.EQ.1) 9012,10,10 C THEN 9012 IF (IPAGE.LE.0) CALL RGRLH CALL SWRITE(LURLS,' ',PROG,'E-',TYPE, 1 '/More than one record not allowed') GOTO 10 C ENDIF END