PROGRAM TFR C***************************************************************************** C C Description : Root-program of the TFR-compiler C C Arguments : none C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFR C LINK/MAP:NL:/OPTIONS C Files? TFR,SDARSXLIB.OLB/LIB,[1,1]F4POTS.OLB/LIB C Options? UNITS=25 C Options? ACTFIL=6 C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C BYTE FRMNAM(16),FEXNAM(16),FLSNAM(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='V1.0' ! version number LUSCR=5 ! display unit LUFRM=20 ! TFR-form source file (.FRM) LUFEX=21 ! temporary TFR-library file LURFX=22 ! TFR-library file (.FEX) LUFLS=23 ! TFR-forms document list file (.FLS) LUWRK=24 ! temporary work file MAXBUF=40 CALL SCOPY('?TFR-',PROG) CALL DATE(DAT) ! get date CALL TIME(TIM) ! and time IFEX=0 IFLS=0 FRMREC(1)=0 FEXREC(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 : ',FRMNAM,1,11,) CALL SCVTLU(FRMNAM) LFRM=LEN(FRMNAM) IF (LFRM.EQ.0) GOTO 10 IF (INDEX(FRMNAM,'.').EQ.0) CALL SCOPY('.FRM',FRMNAM(LFRM+1)) CALL SCOPY(FRMNAM,NAME,INDEX(FRMNAM,'.')-1) ! isolate name C C open source file and work-files (scratch-files) C OPEN (UNIT=LUFRM,NAME=FRMNAM,TYPE='OLD',ERR=9000) OPEN (UNIT=LUWRK,TYPE='SCRATCH',ACCESS='DIRECT', 1 RECORDSIZE=32,INITIALSIZE=25,MAXREC=100,ERR=9010) OPEN (UNIT=LUFEX,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 IFEX=1 CALL SCOPY(NAME,FEXNAM) CALL SCOPY('.FEX',FEXNAM(LEN(FEXNAM)+1)) C ENDIF 30 IF ( LYNASK('Document file : ','Y') )32,50,50 C THEN 32 IFLS=1 CALL SCOPY(NAME,FLSNAM) CALL SCOPY('.FLS',FLSNAM(LEN(FLSNAM)+1)) OPEN (UNIT=LUFLS,NAME=FLSNAM,TYPE='NEW', 1 CARRIAGECONTROL='FORTRAN',ERR=9030) C ENDIF C C initialize library file and start forms loop C 50 CALL TFRID ! initialize temporary lib.file 60 CALL TFRWW ! read form into workfile IF (ISWRET.EQ.-2) GOTO 70 ! read error CALL TFRWD ! write form to temp. lib.file CALL TFRWL ! screen check, write document-list IPAGE=0 IF (ISWRET.EQ.0) GOTO 60 C C end of FRM-file C 70 CLOSE (UNIT=LUFRM) CLOSE (UNIT=LUWRK) IF (IFLS.EQ.1) 72,80,80 C THEN 72 CALL SWRITE(LUFLS,' ',FF) ! issue last form-feed CLOSE (UNIT=LUFLS) C ENDIF 80 IF (IFEX.EQ.0) 82,84,84 C THEN 82 CLOSE(UNIT=LUFEX) GOTO 99 C ELSE 84 NBLK=(NFEXR/12)+1 OPEN (UNIT=LURFX,NAME=FEXNAM,TYPE='NEW',ACCESS='DIRECT', 1 RECORDSIZE=10,INITIALSIZE=NBLK,MAXREC=NFEXR+1,ERR=9040) DO 90 IREC=1,NFEXR READ (LUFEX'IREC+0,END=92) FEXREC WRITE (LURFX'IREC+0) FEXREC 90 CONTINUE 92 CLOSE (UNIT=LUFEX) CLOSE (UNIT=LURFX) C ENDIF C C stop C 99 CALL EXIT C C formats C 900 FORMAT(' TFR-forms compiler - ',A4,20X,$) C C errors C 9000 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t find TFR-forms source file',CRLF) GOTO 10 9010 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open TFR-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 TFR-forms document list file',CRLF) GOTO 10 9040 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open TFR-forms library file',CRLF) GOTO 10 END SUBROUTINE TFRCF (ITYP,TYPE,SCNDI,LENGTH,FIELD,IRET) C***************************************************************************** C C Description : Routine to check the number of data items and the length C of the last one in a TFR-form 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 - form name record C 2 - fix field record C 3 - display-only field record C 4 - update field record C 5 - default-value record C 6 - help 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 LENGTH = input (if ITYP=5): C INTEGER maximum default-value string length C output (if ITYP=4): C INTEGER field length C FIELD = STRING containing the UPD-record field name which C belongs to the default-value record (if ITYP=5) 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 : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C BYTE TYPE(1),SCNDI(1),FIELD(1),HLPSTR(128),SLSH(2) C C C set minimum number of items according to record type C IRET=0 MINDI=2 IF (ITYP.GE.2 .AND. ITYP.LE.4) MINDI=4 SCNDI(1)=0 SLSH(1)=0 C C count data items (strings between comma's) C ICNT=0 IPOS=1 10 ICNT=ICNT+1 CALL GSUBS(FRMREC,IPOS,',',HLPSTR,127,IRET) IF (ICNT.EQ.2 .AND. (ITYP.EQ.1 .OR. ITYP.EQ.3 .OR. ITYP.EQ.4)) 1 CALL SCOPY(HLPSTR,SCNDI,6) IF (ICNT.EQ.3 .AND. ITYP.EQ.4) 12,20,20 C THEN 12 IPOS0=1 LENGTH=ICVTS(HLPSTR,IPOS0,IRET0) C ENDIF 20 IF (IRET.EQ.0) GOTO 10 CALL SCVTLU(SCNDI) IF (LEN(FIELD).NE.0) CALL SCOPY('/',SLSH) C C display message for wrong number of data items and event. print C IF (ICNT.LT.MINDI) 22,30,30 C THEN 22 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE,SLSH,FIELD, 1 '/Missing data items') IF (IFLS.EQ.1) CALL SWRITE(LUFLS,' ',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 30 LH=LEN(HLPSTR) IF ((ITYP.EQ.1 .AND. LH.GT.6) .OR. 1 ((ITYP.EQ.2 .OR. ITYP.EQ.6) .AND. LH.GT.79) .OR. 2 (ITYP.EQ.5 .AND. LH.GT.LENGTH)) 40,99,99 C THEN 40 CALL SWRITE(LUSCR,' ',PROG,'W-',TYPE,SLSH,FIELD, 1 '/Excessive number of characters in text/data-string') IF (IFLS.EQ.1) CALL SWRITE(LUFLS,' ',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 TFRCL (SRCSTR,IPOS,LENGTH,LUN,TYPE,FIELD,IRET) C***************************************************************************** C C Description : Routine to check the field length C C Arguments : SRCSTR = STRING containing the field length C IPOS = input: C INTEGER position in SCRSTR to start search C for number C output: C INTEGER position plus 1 of comma in SRCSTR, or C position of end-of-string character (=zero byte) C LENGTH = INTEGER returned field length C LUN = INTEGER logical unit number error message C TYPE = STRING containing the record type for error message C FIELD = STRING containing the field name for error message C IRET = INTEGER return code: 0 - normal return C -1 - error encountered C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C BYTE SRCSTR(1),TYPE(1),FIELD(1),RESSTR(128) C C IRET=0 CALL GSUBS(SRCSTR,IPOS,',',RESSTR,127,IRET0) ! get length string IPOS0=1 LENGTH=ICVTS(RESSTR,IPOS0,IRET0) C C check length C IF (LENGTH.LE.0 .OR. LENGTH.GT.79) 10,99,99 C THEN 10 LENGTH=0 IF (LUN.NE.0) CALL SWRITE(LUN,' ',PROG,'E-',TYPE,'/',FIELD, 1 '/Invalid field length') IRET=-1 C ENDIF C C go back to calling routine C 99 RETURN END SUBROUTINE TFRCR (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 : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR 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 TFRID C***************************************************************************** C C Description : Routine to initialize the TFR-forms library file C C Arguments : none C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C C general info record 1 BYTE HOMSTR(4),CLRSTR(4),ERLSTR(4),NATSTR(6) EQUIVALENCE (VERSNR,FEXREC(1)) ! version number EQUIVALENCE (NRFSFR,FEXREC(5)) ! rec.nr. first form EQUIVALENCE (HOMSTR,FEXREC(7)) ! esc.seq: home position EQUIVALENCE (CLRSTR,FEXREC(11)) ! esc.seq: clear screen EQUIVALENCE (ERLSTR,FEXREC(15)) ! esc.seq: erase line EQUIVALENCE (NATSTR,FEXREC(19)) ! esc.seq: reset video attributes C C general info record 2 BYTE HERPOS(8),ERRATT(8),HLPATT(8) EQUIVALENCE (HERPOS,FEXREC(1)) ! esc.seq: pos. error/help message EQUIVALENCE (ERRATT,FEXREC(9)) ! esc.seq: video att. error message EQUIVALENCE (HLPATT,FEXREC(17)) ! esc.seq: video att. help message C BYTE HOM(4),CLR(4),ERL(4),NAT(6),HEP(8),ERA(8),HLA(8) DATA HOM /155,'[','H',0/, 1 CLR /155,'[','J',0/, 2 ERL /155,'[','K',0/, 3 NAT /155,'[','0','m',2*0/, 4 HEP /155,'[','2','4',';','1','H',0/, 5 ERA /155,'[','0',';','1','m',2*0/, 6 HLA /155,'[','0',';','7','m',2*0/ C C NGIR=2 ! number of general info records CALL TFRCR(FEXREC,MAXBUF) ! zero record buffer VERSNR=VNR NRFSFR=NGIR+1 CALL SCOPY(HOM,HOMSTR) CALL SCOPY(CLR,CLRSTR) CALL SCOPY(ERL,ERLSTR) CALL SCOPY(NAT,NATSTR) WRITE (LUFEX'1) FEXREC ! write first record C CALL TFRCR(FEXREC,MAXBUF) ! zero buffer CALL SCOPY(HEP,HERPOS) CALL SCOPY(ERA,ERRATT) CALL SCOPY(HLA,HLPATT) WRITE (LUFEX'2) FEXREC ! write second record NFEXR=NGIR C C go back to calling program C RETURN END SUBROUTINE TFRLH C***************************************************************************** C C Description : Routine to write heder line for TFR-forms document list C C Arguments : none C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(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(LUFLS,'1',' ') GOTO 30 C ELSE 20 CALL SWRITE(LUFLS,' ',' ') IPAGE=0 C ENDIF 30 WRITE(LUFLS,900) VNR CALL SWRITE(LUFLS,'+$',DAT,' time ',TIM) IPAGE=IPAGE+1 WRITE (LUFLS,910) IPAGE CALL SWRITE(LUFLS,' ',LF2,'Form: ',FNAME) ILINE=5 C C go back to calling routine C RETURN C C formats C 900 FORMAT('+TFR - ',A4,6X,'TFR-forms document list',7X,$) 910 FORMAT('+ page ',I2) END SUBROUTINE TFRVA (IROW,ICOL,VASTR,ESCPA,LUN,TYPE,FIELD,IRET) C***************************************************************************** C C Description : Routine to convert IROW, ICOL and video-attribute code- C string to an escape sequence. C All three input arguments are validated, errors are reported C C Arguments : IROW = INTEGER screen row position C ICOL = INTEGER screen column position C VASTR = STRING containing the video-attributes code-string C ESCPA = STRING returning the escape sequence C LUN = INTEGER logical unit number error message C TYPE = STRING containing the record type for error message C FIELD = STRING containing the field name for error message 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 : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C BYTE VASTR(1),ESCPA(1),TYPE(1),FIELD(1),SESC(4),SLSH(2) DATA SESC /155,'[','0',0/ C C IRET=0 I=0 CALL SCOPY('/',SLSH) IF (LEN(FIELD).EQ.0) SLSH(1)=0 C C check and convert screen-position C IF (IROW.LE.0 .OR. IROW.GT.24 .OR. 1 ICOL.LE.0 .OR. ICOL.GT.80) 10,20,20 C THEN 10 IF (LUN.NE.0) CALL SWRITE(LUN,' ',PROG,'E-',TYPE,SLSH,FIELD, 1 '/Invalid screen position') IRET=-2 GOTO 99 C ELSE 20 CALL SCOPY(SESC,ESCPA,2) I=3 ESCPA(I)=IROW+'0' IF (IROW.GT.9) 30,40,40 C THEN 30 ITEN=IROW/10 ESCPA(I)=ITEN+'0' I=I+1 ESCPA(I)=IROW-ITEN*10+'0' C ENDIF 40 ESCPA(I+1)=';' I=I+2 ESCPA(I)=ICOL+'0' IF (ICOL.GT.9) 50,60,60 C THEN 50 ITEN=ICOL/10 ESCPA(I)=ITEN+'0' I=I+1 ESCPA(I)=ICOL-ITEN*10+'0' C ENDIF 60 I=I+1 ESCPA(I)='H' C ENDIF C C decode and check video-attribute code-string C CALL SCVTLU(VASTR) CALL SCOPY(SESC,ESCPA(I+1)) IVA=0 IF (INDEX(VASTR,'BO').NE.0) IVA=IVA+1 IF (INDEX(VASTR,'UL').NE.0) IVA=IVA+2 IF (INDEX(VASTR,'BL').NE.0) IVA=IVA+4 IF (INDEX(VASTR,'RV').NE.0) IVA=IVA+8 IF (IVA.GT.0) 70,80,80 C THEN 70 IF ((IVA.AND.1).EQ.1) CALL SCOPY(';1',ESCPA(LEN(ESCPA)+1)) IF ((IVA.AND.2).EQ.2) CALL SCOPY(';4',ESCPA(LEN(ESCPA)+1)) IF ((IVA.AND.4).EQ.4) CALL SCOPY(';5',ESCPA(LEN(ESCPA)+1)) IF ((IVA.AND.8).EQ.8) CALL SCOPY(';7',ESCPA(LEN(ESCPA)+1)) GOTO 90 C ELSE 80 IF (LEN(VASTR).NE.0 .AND. LUN.NE.0) 82,90,90 C THEN 82 CALL SWRITE(LUN,' ',PROG,'W-',TYPE,SLSH,FIELD, 1 '/Unrecognized video attributes') IRET=-1 C ENDIF C ENDIF 90 I=LEN(ESCPA)+1 ESCPA(I)='m' ESCPA(I+1)=0 C C go back to calling routine C 99 RETURN END SUBROUTINE TFRWD C***************************************************************************** C C Description : Routine to read the TFR-compiler workfile and create C a form in the TFR-forms library file C C Arguments : none C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C C form name-record BYTE FFXREC(40),FRNAM(8) EQUIVALENCE (FRNAM ,FFXREC(1)) ! form name EQUIVALENCE (NRNXFR,FFXREC(9)) ! rec.nr. next form EQUIVALENCE (NRFFFR,FFXREC(11)) ! rec.nr. first fix field rec. EQUIVALENCE (NRLFFR,FFXREC(13)) ! rec.nr. last fix field rec. EQUIVALENCE (NRFDFR,FFXREC(15)) ! rec.nr. first display-only fld.rec. EQUIVALENCE (NRLDFR,FFXREC(17)) ! rec.nr. last display-only fld.rec. EQUIVALENCE (NRFUFR,FFXREC(19)) ! rec.nr. first update field rec. EQUIVALENCE (NRLUFR,FFXREC(21)) ! rec.nr. last update field rec. C C display-only field record BYTE DONFLD(8),DONESC(22) EQUIVALENCE (DONFLD,FEXREC(1)) ! field name EQUIVALENCE (LENDON,FEXREC(9)) ! field length EQUIVALENCE (DONESC,FEXREC(11)) ! attibutes escape string C C update field record BYTE UPDFLD(8),UPDESC(22) EQUIVALENCE (UPDFLD,FEXREC(1)) ! field name EQUIVALENCE (LENUPD,FEXREC(9)) ! field length EQUIVALENCE (UPDESC,FEXREC(11)) ! attibutes escape string EQUIVALENCE (NRFCR ,FEXREC(33)) ! rec.nr. of field copy rec. EQUIVALENCE (NPFCR ,FEXREC(35)) ! pos. of field in field copy rec. EQUIVALENCE (NRDEF ,FEXREC(37)) ! rec.nr. of default-value record EQUIVALENCE (NRHLP ,FEXREC(39)) ! rec.nr. of help record C C default-value and help record BYTE DHFEXR(40) C BYTE TYPE(4),NAME(8),RESSTR(128) C C C prepare form name-record C IF (NWRKR.EQ.0) GOTO 899 NFEXR=NFEXR+1 NFFXR=NFEXR ! save rec.nr. for later on CALL TFRCR(FFXREC,MAXBUF) CALL SCOPY(FNAME,FRNAM) NRFFFR=0 NRLFFR=0 NRFDFR=0 NRLDFR=0 NRFUFR=0 NRLUFR=0 IF (NWRKR.LE.1) GOTO 300 C C FIX-records C DO 30 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'FIX').NE.0) GOTO 30 ! search FIX-record CALL TFRCR(FEXREC,MAXBUF) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) ! check/convert data IPOS0=1 IROW=ICVTS(RESSTR,IPOS0,IRET0) ICOL=ICVTS(RESSTR,IPOS0,IRET0) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL TFRVA(IROW,ICOL,RESSTR,FEXREC,LUSCR,TYPE,0,IRET) IF (IRET.EQ.-2) GOTO 30 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LR=LEN(RESSTR) LS=LEN(FEXREC) IBUFOF=0 CALL SCOPY(RESSTR,FEXREC(LS+1),MAXBUF-LS-1) ! prepare FEX-record IF (LR.GE.MAXBUF-LS) 10,20,20 C THEN ! compose more than one FEX-record 10 FEXREC(MAXBUF)=RESSTR(IBUFOF+MAXBUF-LS) ! for one FIX-record NFEXR=NFEXR+1 WRITE (LUFEX'NFEXR) FEXREC NRLFFR=NRLFFR+1 CALL TFRCR(FEXREC,MAXBUF) CALL SCOPY(RESSTR(IBUFOF+MAXBUF-LS+1),FEXREC,MAXBUF-1) LR=LEN(RESSTR(IBUFOF+MAXBUF-LS+1)) IBUFOF=IBUFOF+MAXBUF IF (LR.GE.MAXBUF) GOTO 10 C ENDIF 20 NFEXR=NFEXR+1 WRITE (LUFEX'NFEXR) FEXREC NRLFFR=NRLFFR+1 30 CONTINUE IF (NRLFFR.NE.0) NRFFFR=NFEXR-NRLFFR+1 ! update FRM-record NRLFFR=NFEXR C C DON-records C DO 50 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DON').NE.0) GOTO 50 ! search DON-record CALL TFRCR(FEXREC,MAXBUF) CALL GSUBS(WRKREC,IPOS,',',DONFLD,127,IRET) ! check/convert data CALL TFRCL(WRKREC,IPOS,LENDON,LUSCR,TYPE,DONFLD,IRET) IF (IRET.NE.0) GOTO 50 CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) IPOS0=1 IROW=ICVTS(RESSTR,IPOS0,IRET0) ICOL=ICVTS(RESSTR,IPOS0,IRET0) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL TFRVA(IROW,ICOL,RESSTR,DONESC,LUSCR,TYPE,DONFLD,IRET) IF (IRET.NE.-2) 40,50,50 C THEN 40 NFEXR=NFEXR+1 WRITE (LUFEX'NFEXR) FEXREC ! write DON-record NRLDFR=NRLDFR+1 C ENDIF 50 CONTINUE IF (NRLDFR.NE.0) NRFDFR=NFEXR-NRLDFR+1 ! update FRM-record NRLDFR=NFEXR C C UPD-records C DO 70 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'UPD').NE.0) GOTO 70 ! search UPD-record CALL TFRCR(FEXREC,MAXBUF) CALL GSUBS(WRKREC,IPOS,',',UPDFLD,127,IRET) ! check/convert data CALL TFRCL(WRKREC,IPOS,LENUPD,LUSCR,TYPE,UPDFLD,IRET) IF (IRET.NE.0) GOTO 70 CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) IPOS0=1 IROW=ICVTS(RESSTR,IPOS0,IRET0) ICOL=ICVTS(RESSTR,IPOS0,IRET0) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL TFRVA(IROW,ICOL,RESSTR,UPDESC,LUSCR,TYPE,UPDFLD,IRET) IF (IRET.NE.-2) 60,70,70 C THEN 60 NFEXR=NFEXR+1 WRITE (LUFEX'NFEXR) FEXREC ! write UPD-record NRLUFR=NRLUFR+1 C ENDIF 70 CONTINUE IF (NRLUFR.NE.0) NRFUFR=NFEXR-NRLUFR+1 NRLUFR=NFEXR C C field copy records for UPD-records C IF (NRFUFR.EQ.0) GOTO 300 IPFCR=999 DO 140 I=NRFUFR,NRLUFR READ (LUFEX'I+0) FEXREC LENF=((LENUPD/2)+1)*2 ! round length binairy up IF (IPFCR+LENF.GT.MAXBUF) 100,110,110 C THEN 100 NFEXR=NFEXR+1 IPFCR=1 C ENDIF 110 NRFCR=NFEXR NPFCR=IPFCR WRITE (LUFEX'I+0) FEXREC ! update UPD-rec. pointers IPFCR=IPFCR+LENF IF (LENF.GT.MAXBUF) 130,140,140 C THEN ! compose more than one FEX-record 130 NFEXR=NFEXR+1 ! for one FCR IPFCR=IPFCR-MAXBUF C ENDIF 140 CONTINUE C C DEF- and HLP-records for UPD-records C CALL SCOPY('***',TYPE) DO 170 I=1,5 NAME(I)=127 NAME(I+1)=0 170 CONTINUE IWRK=1 DO 250 I=NRFUFR,NRLUFR READ (LUFEX'I+0) FEXREC ! read UPD-rec. FEX-file 180 IWRK=IWRK+1 READ (LUWRK'IWRK) WRKREC ! read WRK-file IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'UPD').NE.0) GOTO 180 ! compare record type CALL GSUBS(WRKREC,IPOS,',',NAME,127,IRET) IF (ISCOMP(NAME,UPDFLD).NE.0) GOTO 180 ! compare field-name 190 IF (IWRK+1.GT.NWRKR) GOTO 300 IWRK=IWRK+1 READ (LUWRK'IWRK) WRKREC ! read WRK-file record(s) IPOS=1 ! after UPD-record CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DEF').NE.0 .AND. 1 ISCOMP(TYPE,'HLP').NE.0) 200,210,210 ! check record type C THEN 200 IWRK=IWRK-1 GOTO 250 C ELSE 210 IF (TYPE(1).EQ.'D') NRDEF=NFEXR+1 IF (TYPE(1).EQ.'H') NRHLP=NFEXR+1 WRITE (LUFEX'I+0) FEXREC ! update UPD-rec. pointers CALL TFRCR(DHFEXR,MAXBUF) CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LR=LEN(RESSTR) IBUFOF=0 CALL SCOPY(RESSTR,DHFEXR,MAXBUF-1) ! prepare FEX-record 220 IF (LR.GE.MAXBUF) 230,240,240 C THEN ! compose more than one FEX-record for 230 DHFEXR(MAXBUF)=RESSTR(IBUFOF+MAXBUF) ! one DEF/HLP-record NFEXR=NFEXR+1 WRITE (LUFEX'NFEXR) DHFEXR CALL TFRCR(DHFEXR,MAXBUF) CALL SCOPY(RESSTR(IBUFOF+MAXBUF+1),DHFEXR,MAXBUF-1) LR=LEN(RESSTR(IBUFOF+MAXBUF+1)) IBUFOF=IBUFOF+MAXBUF GOTO 220 C ENDIF 240 NFEXR=NFEXR+1 WRITE (LUFEX'NFEXR) DHFEXR GOTO 190 C ENDIF 250 CONTINUE C C update FRM-record C 300 NRNXFR=NFEXR+1 IF (ISWRET.EQ.-1) NRNXFR=NGIR+1 WRITE (LUFEX'NFFXR) FFXREC C C go back to calling routine C 899 RETURN END SUBROUTINE TFRWL C***************************************************************************** C C Description : Routine to write the TFR-forms documentation C C Arguments : none C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C C form name-record BYTE FFXREC(40),FRNAM(8) EQUIVALENCE (FRNAM ,FFXREC(1)) ! form name EQUIVALENCE (NRNXFR,FFXREC(9)) ! rec.nr. next form EQUIVALENCE (NRFFFR,FFXREC(11)) ! rec.nr. first fix field rec. EQUIVALENCE (NRLFFR,FFXREC(13)) ! rec.nr. last fix field rec. EQUIVALENCE (NRFDFR,FFXREC(15)) ! rec.nr. first display-only fld.rec. EQUIVALENCE (NRLDFR,FFXREC(17)) ! rec.nr. last display-only fld.rec. EQUIVALENCE (NRFUFR,FFXREC(19)) ! rec.nr. first update field rec. EQUIVALENCE (NRLUFR,FFXREC(21)) ! rec.nr. last update field rec. C C display-only field record BYTE DONFLD(8),DONESC(22) EQUIVALENCE (DONFLD,FEXREC(1)) ! field name EQUIVALENCE (LENDON,FEXREC(9)) ! field length EQUIVALENCE (DONESC,FEXREC(11)) ! attibutes escape string C C update field record BYTE UPDFLD(8),UPDESC(22) EQUIVALENCE (UPDFLD,FEXREC(1)) ! field name EQUIVALENCE (LENUPD,FEXREC(9)) ! field length EQUIVALENCE (UPDESC,FEXREC(11)) ! attibutes escape string EQUIVALENCE (NRFCR ,FEXREC(33)) ! rec.nr. of field copy rec. EQUIVALENCE (NPFCR ,FEXREC(35)) ! pos. of field in field copy rec. EQUIVALENCE (NRDEF ,FEXREC(37)) ! rec.nr. of default-value record EQUIVALENCE (NRHLP ,FEXREC(39)) ! rec.nr. of help record C BYTE CHAR,TYPE(4),NAME(8),RESSTR(128),DUMSTR(128), 1 SCRTAB(81,24),DEFSTR(80),HLPSTR(80),LF(2) DATA LF/10,0/ C C C initialize and prepare header line C IF (NWRKR.EQ.0) GOTO 199 ITLFLG=0 INBFLG=0 LINMAX=60 ! number of lines per page C C prepare screen layout print C DO 10 J=1,24 DO 10 I=1,80 SCRTAB(I,J)=' ' ! init screen table IF (J.EQ.24) SCRTAB(I,J)='X' SCRTAB(I+1,J)=0 10 CONTINUE CALL SCOPY(' Reserved for help/error messages ',SCRTAB(23,24)) SCRTAB(58,24)=' ' IF (NWRKR.LE.1) GOTO 140 C C fill in FIX-fields C DO 70 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'FIX').NE.0) GOTO 70 ! search FIX-record CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) ! check/convert data IPOS0=1 IROW=ICVTS(RESSTR,IPOS0,IRET0) ICOL=ICVTS(RESSTR,IPOS0,IRET0) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL TFRVA(IROW,ICOL,RESSTR,DUMSTR,0,0,0,IRET) IF (IRET.EQ.-2) GOTO 70 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LR=LEN(RESSTR) IF (LR.EQ.0) GOTO 70 DO 60 J=1,LR IHCOL=ICOL+J-1 IF (IHCOL.GT.80) 20,30,30 C THEN 20 ITLFLG=1 GOTO 70 C ELSE 30 CHAR=RESSTR(J) IF (SCRTAB(IHCOL,IROW).NE.' ' .OR. IROW.EQ.24) 40,50,50 C THEN 40 CHAR='*' INBFLG=1 C ENDIF 50 SCRTAB(IHCOL,IROW)=CHAR C ENDIF 60 CONTINUE 70 CONTINUE C C fill in UPD- and DON-fields C DO 130 I=2,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DON').NE.0 .AND. 1 ISCOMP(TYPE,'UPD').NE.0) GOTO 130 ! search UPD/DON-record CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) ! check/convert data CALL TFRCL(WRKREC,IPOS,LENF,0,0,0,IRET) IF (IRET.NE.0 .OR. LENF.EQ.0) GOTO 130 CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) IPOS0=1 IROW=ICVTS(RESSTR,IPOS0,IRET0) ICOL=ICVTS(RESSTR,IPOS0,IRET0) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL TFRVA(IROW,ICOL,RESSTR,DUMSTR,0,0,0,IRET) IF (IRET.EQ.-2) GOTO 130 DO 120 J=1,LENF IHCOL=ICOL+J-1 IF (IHCOL.GT.80) 80,90,90 C THEN 80 ITLFLG=1 GOTO 120 C ELSE 90 CHAR=TYPE(1) IF (SCRTAB(IHCOL,IROW).NE.' ' .OR. IROW.EQ.24) 100,110,110 C THEN 100 INBFLG=1 CHAR='*' C ENDIF 110 SCRTAB(IHCOL,IROW)=CHAR C ENDIF 120 CONTINUE 130 CONTINUE C C give warning for off-screen characters and/or multiple occupation C 140 IF (ITLFLG.EQ.1) CALL SWRITE(LUSCR,' ',PROG, 1 'W-Field position(s) off-screen') IF (INBFLG.EQ.1) CALL SWRITE(LUSCR,' ',PROG, 1 'W-Multiple occupation of screen positions') IF (IFLS.EQ.0) GOTO 199 C C print screen layout C CALL SWRITE(LUFLS,' ',LF,'Screen lay-out:') CALL SWRITE(LUFLS,' ','---------------') IF (ITLFLG.EQ.1) CALL SWRITE(LUFLS,' ',LF,PROG, 1 'W-Field position(s) off-screen') IF (INBFLG.EQ.1) CALL SWRITE(LUFLS,' ',LF,PROG, 1 'W-Multiple occupation of screen positions (*)') CALL SWRITE(LUFLS,' ',LF) WRITE (LUFLS,901) WRITE (LUFLS,902) WRITE (LUFLS,903) DO 150 I=1,24 WRITE (LUFLS,911) I CALL SWRITE(LUFLS,'+$',SCRTAB(1,I)) WRITE (LUFLS,912) I 150 CONTINUE WRITE (LUFLS,903) WRITE (LUFLS,902) WRITE (LUFLS,901) C C print UPD-field info C READ (LUFEX'NFFXR) FFXREC IF (NRFUFR.EQ.0) GOTO 230 CALL SCOPY('***',TYPE) DO 160 I=1,5 NAME(I)=127 NAME(I+1)=0 160 CONTINUE IWRK=1 IUPD=0 CALL TFRLH CALL SWRITE(LUFLS,' ',LF,'Update fields') CALL SWRITE(LUFLS,' ','-------------') ILINE=ILINE+3 C DO 220 I=NRFUFR,NRLUFR READ (LUFEX'I+0) FEXREC ! read UPD-rec. FEX-file 170 IWRK=IWRK+1 READ (LUWRK'IWRK) WRKREC ! read WRK-file IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'UPD').NE.0) GOTO 170 ! compare record type CALL GSUBS(WRKREC,IPOS,',',NAME,127,IRET) IF (ISCOMP(NAME,UPDFLD).NE.0) GOTO 170 ! compare field-name IUPD=IUPD+1 IF (ILINE+7.GT.LINMAX) CALL TFRLH CALL SWRITE(LUFLS,' ',LF,'Name : ',NAME) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LUFLS,' ','Field length : ',RESSTR) IPOS0=1 CALL TFRCL(RESSTR,IPOS0,LENF,LUFLS,TYPE,NAME,IRET) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LUFLS,' ','Screen position (row/col): ',RESSTR) IPOS0=1 IROW=ICVTS(RESSTR,IPOS0,IRET0) ICOL=ICVTS(RESSTR,IPOS0,IRET0) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LUFLS,' ','Video attributes : ',RESSTR) CALL TFRVA(IROW,ICOL,RESSTR,DUMSTR,LUFLS,TYPE,NAME,IRET) DEFSTR(1)=0 HLPSTR(1)=0 180 IF (IWRK+1.GT.NWRKR) GOTO 210 IWRK=IWRK+1 READ (LUWRK'IWRK) WRKREC ! read WRK-file record(s) IPOS=1 ! after UPD-record CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DEF').NE.0 .AND. 1 ISCOMP(TYPE,'HLP').NE.0) 190,200,200 ! check record type C THEN 190 IWRK=IWRK-1 GOTO 210 C ELSE 200 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) IF (TYPE(1).EQ.'D') CALL SCOPY(RESSTR,DEFSTR,79) IF (TYPE(1).EQ.'H') CALL SCOPY(RESSTR,HLPSTR,79) GOTO 180 C ENDIF 210 CALL SWRITE(LUFLS,' ','Default-value : ',DEFSTR) CALL SWRITE(LUFLS,' ','Help message : ',HLPSTR) ILINE=ILINE+7 220 CONTINUE IF (IUPD.EQ.0) CALL SWRITE(LUFLS,' ',LF,'Not available') C C print DON-field info C 230 IF (NRFDFR.EQ.0) GOTO 199 CALL SCOPY('***',TYPE) DO 240 I=1,5 NAME(I)=127 NAME(I+1)=0 240 CONTINUE IWRK=1 IDON=0 CALL TFRLH CALL SWRITE(LUFLS,' ',LF,'Display-only fields') CALL SWRITE(LUFLS,' ','-------------------') ILINE=ILINE+3 C DO 260 I=NRFDFR,NRLDFR READ (LUFEX'I+0) FEXREC ! read DON-rec. FEX-file 250 IWRK=IWRK+1 READ (LUWRK'IWRK) WRKREC ! read WRK-file IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'DON').NE.0) GOTO 250 ! compare record type CALL GSUBS(WRKREC,IPOS,',',NAME,127,IRET) IF (ISCOMP(NAME,DONFLD).NE.0) GOTO 250 ! compare field-name IDON=IDON+1 IF (ILINE+5.GT.LINMAX) CALL TFRLH CALL SWRITE(LUFLS,' ',LF,'Name : ',NAME) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LUFLS,' ','Field length : ',RESSTR) IPOS0=1 CALL TFRCL(RESSTR,IPOS0,LENF,LUFLS,TYPE,NAME,IRET) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LUFLS,' ','Screen position (row/col): ',RESSTR) IPOS0=1 IROW=ICVTS(RESSTR,IPOS0,IRET0) ICOL=ICVTS(RESSTR,IPOS0,IRET0) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SWRITE(LUFLS,' ','Video attributes : ',RESSTR) CALL TFRVA(IROW,ICOL,RESSTR,DUMSTR,LUFLS,TYPE,NAME,IRET) ILINE=ILINE+5 260 CONTINUE IF (IDON.EQ.0) CALL SWRITE(LUFLS,' ',LF,'Not available') C C go back to calling routine C 199 RETURN C C formats C 901 FORMAT(' ',12X,'1',9X,'2',9X,'3',9X,'4', 1 9X,'5',9X,'6',9X,'7',9X,'8') 902 FORMAT(' ',3X,8('1234567890')) 903 FORMAT(' ',2X,'+',80('-'),'+') 911 FORMAT(' ',I2,'|',$) 912 FORMAT('+|',I2) END SUBROUTINE TFRWW C***************************************************************************** C C Description : Routine to read the TFR-forms source file and to write C a form into the TFR-compiler workfile C C Arguments : none C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.0 Date : 1-nov-1982 C C Module name : TFR.FTN C C Package : TFR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,FNAME,DAT,TIM,FRMREC,FEXREC,WRKREC COMMON/TFRFXC/VNR,LUSCR,LUFRM,LUFEX,LUFLS,LUWRK,IFLS,ISWRET, 1 NGIR,NWRKR,NFEXR,NFFXR,MAXBUF,IPAGE,ILINE, 2 PROG(10),FNAME(8),DAT(10),TIM(10), 3 FRMREC(128),FEXREC(40),WRKREC(128) C BYTE RESSTR(128),TYPE(4),NAME(8),ERR C C NWRKR=0 NFRM=0 CALL SCOPY('******',FNAME) IF (LEN(FRMREC).NE.0) GOTO 50 ISWRET=0 C C read TFR-forms source file C 10 CALL GETSTR(LUFRM,FRMREC,126,ERR) IF (ERR.EQ.-3) 12,20,20 C THEN 12 CALL SWRITE(LUSCR,' ',PROG, 1 'E-TFR-form source record too long') IF (IFLS.EQ.1) 14,10,10 C THEN 14 IF (IPAGE.LE.0) CALL TFRLH CALL SWRITE(LUFLS,' ',PROG, 1 'E-TFR-form 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 TFR-forms source file') IF (IFLS.EQ.1) 24,26,26 C THEN 24 IF (IPAGE.LE.0) CALL TFRLH CALL SWRITE(LUFLS,' ',PROG, 1 'F-READ error TFR-forms 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(FRMREC).EQ.0) GOTO 10 ITYP=7 IPOS=1 CALL GSUBS(FRMREC,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,'FRM').EQ.0) ITYP=1 IF (ISCOMP(TYPE,'FIX').EQ.0) ITYP=2 IF (ISCOMP(TYPE,'DON').EQ.0) ITYP=3 IF (ISCOMP(TYPE,'UPD').EQ.0) ITYP=4 IF (ISCOMP(TYPE,'DEF').EQ.0) ITYP=5 IF (ISCOMP(TYPE,'HLP').EQ.0) ITYP=6 C ENDIF 60 GOTO (100,200,300,400,500,600,70) ITYP C C unidentified type encountered C 70 CALL SWRITE(LUSCR,' ',PROG, 1 'E-Undefined TFR-form source record') IF (IFLS.EQ.1) 72,10,10 C THEN 72 IF (IPAGE.LE.0) CALL TFRLH CALL SWRITE(LUFLS,' ',PROG, 1 'E-Undefined TFR-form source record') GOTO 10 C ENDIF C C type = FRM C 100 NFRM=NFRM+1 IF (NFRM.NE.1) GOTO 899 CALL TFRCF(ITYP,TYPE,FNAME,0,0,IRET) IF (IRET.EQ.-2) CALL SCOPY(',******',FRMREC(IPOS)) CALL SWRITE(LUSCR,' ',FNAME) IF (IFLS.EQ.1) CALL TFRLH IUPD=0 GOTO 800 C C type = FIX C 200 CALL TFRCF(ITYP,TYPE,RESSTR,0,0,IRET) IF (IRET.EQ.-2) GOTO 10 IF (NFRM.EQ.0) GOTO 9000 IUPD=0 GOTO 800 C C type = DON C 300 CALL TFRCF(ITYP,TYPE,NAME,0,NAME,IRET) IF (IRET.EQ.-2) GOTO 10 IF (NFRM.EQ.0) GOTO 9000 IUPD=0 GOTO 800 C C type = UPD C 400 CALL TFRCF(ITYP,TYPE,NAME,LENF,NAME,IRET) IF (IRET.EQ.-2) GOTO 10 IF (NFRM.EQ.0) GOTO 9000 IUPD=1 NDEF=0 NHLP=0 GOTO 800 C C type = DEF C 500 CALL TFRCF(ITYP,TYPE,RESSTR,LENF,NAME,IRET) IF (IRET.EQ.-2) GOTO 10 IF (NFRM.EQ.0) GOTO 9000 NDEF=NDEF+1 IF (NDEF.NE.1 .OR. IUPD.NE.1) GOTO 9010 GOTO 800 C C type = HLP C 600 CALL TFRCF(ITYP,TYPE,RESSTR,0,0,IRET) IF (IRET.EQ.-2) GOTO 10 IF (NFRM.EQ.0) GOTO 9000 NHLP=NHLP+1 IF (NHLP.NE.1 .OR. IUPD.NE.1) GOTO 9010 C C put type and name plus rest of source record in output buffer C 800 CALL SCOPY(TYPE,WRKREC) IF (ITYP.EQ.1 .OR. ITYP.EQ.3 .OR. ITYP.EQ.4) 810,820,820 C THEN 810 WRKREC(4)=',' CALL GSUBS(FRMREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,NAME,6) CALL SCVTLU(NAME) CALL SCOPY(NAME,WRKREC(5)) IF (LEN(RESSTR).GT.6) 812,820,820 C THEN 812 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE,'/',NAME, 1 '/Name truncated') IF (IFLS.EQ.1) CALL SWRITE(LUFLS,' ',PROG,'E-',TYPE,'/',NAME, 1 '/Name truncated') C ENDIF C ENDIF 820 IF (ITYP.NE.1) 830,840,840 C THEN 830 LR=LEN(WRKREC)+1 WRKREC(LR)=',' CALL SCOPY(FRMREC(IPOS),WRKREC(LR+1)) C ENDIF 840 IF (ITYP.EQ.3 .OR. ITYP.EQ.4) 1 CALL SCOPY(',',WRKREC(LEN(WRKREC)+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 C C No FRM-type record found C 9000 CALL SWRITE(LUSCR,' $',PROG,'E-',TYPE) IF (ITYP.NE.2) CALL SWRITE(LUSCR,'+$','/',NAME) CALL SWRITE(LUSCR,'+','/Missing FRM-type record') IF (IFLS.EQ.1) 9002,10,10 C THEN 9002 IF (IPAGE.LE.0) CALL TFRLH CALL SWRITE(LUFLS,' $',PROG,'E-',TYPE) IF (ITYP.NE.2) CALL SWRITE(LUFLS,'+$','/',NAME) CALL SWRITE(LUFLS,'+','/Missing FRM-type record') GOTO 10 C ENDIF C C More than one default-value/help record for one UPD-type record C 9010 IF (IUPD.EQ.1) 9020,9030,9030 C THEN 9020 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE,'/',NAME, 1 '/More than one record not allowed') IF (IFLS.EQ.1) 9022,10,10 C THEN 9022 IF (IPAGE.LE.0) CALL TFRLH CALL SWRITE(LUFLS,' ',PROG,'E-',TYPE,'/',NAME, 1 '/More than one record not allowed') GOTO 10 C ENDIF C ELSE 9030 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Misplaced record type') IF (IFLS.EQ.1) 9032,10,10 C THEN 9032 IF (IPAGE.LE.0) CALL TFRLH CALL SWRITE(LUFLS,' ',PROG,'E-',TYPE, 1 '/Misplaced record type') GOTO 10 C ENDIF C ENDIF END