PROGRAM MPR C***************************************************************************** C C Description : Root-program of the MPR-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 : MPR.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE MPR C LINK/MAP:NL:/OPTIONS C Files? MPR,SDARSXLIB.OLB/LIB,[1,1]F4POTS.OLB/LIB C Option? UNITS=25 C Option? ACTFIL=6 C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C BYTE MENNAM(16),MEXNAM(16),MLSNAM(16),GMXNAM(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 LUMEN=20 ! MPR-form source file (.MEN) LUMEX=21 ! temporary MPR-library file LURMX=22 ! MPR-library file (.MEX) LUMLS=23 ! MPR-forms document list file (.MLS) LUGMX=24 ! Generated-source file of the MPREXE-subroutine LUWRK=25 ! temporary work file MAXBUF=40 CALL SCOPY('?MPR-',PROG) CALL DATE(DAT) ! get date CALL TIME(TIM) ! and time IMEX=0 IMLS=0 IGMX=0 MENREC(1)=0 MEXREC(1)=0 WRKREC(1)=0 IPAGE=0 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 : ',MENNAM,1,10,) CALL SCVTLU(MENNAM) LMEN=LEN(MENNAM) IF (LMEN.EQ.0) GOTO 10 IF (INDEX(MENNAM,'.').EQ.0) CALL SCOPY('.MEN',MENNAM(LMEN+1)) CALL SCOPY(MENNAM,NAME,INDEX(MENNAM,'.')-1) ! isolate name C C open source file and work-files (scratch-files) C OPEN (UNIT=LUMEN,NAME=MENNAM,TYPE='OLD',ERR=9000) OPEN (UNIT=LUWRK,TYPE='SCRATCH',ACCESS='DIRECT', 1 RECORDSIZE=32,INITIALSIZE=25,MAXREC=100,ERR=9010) OPEN (UNIT=LUMEX,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 IMEX=1 CALL SCOPY(NAME,MEXNAM) CALL SCOPY('.MEX',MEXNAM(LEN(MEXNAM)+1)) C ENDIF C C document-list file wanted ? C 30 IF ( LYNASK('Document file : ','Y') )32,40,40 C THEN 32 IMLS=1 CALL SCOPY(NAME,MLSNAM) CALL SCOPY('.MLS',MLSNAM(LEN(MLSNAM)+1)) OPEN (UNIT=LUMLS,NAME=MLSNAM,TYPE='NEW', 1 CARRIAGECONTROL='FORTRAN',ERR=9030) C ENDIF C C FORTRAN subroutine source file wanted ? C 40 IF ( LYNASK('FORTRAN-routine : ','Y') )42,50,50 C THEN 42 IGMX=1 CALL SCOPY(NAME,GMXNAM) CALL SCOPY('.GMX',GMXNAM(LEN(GMXNAM)+1)) C ENDIF C C initialize library file and start forms loop C 50 CALL MPRID ! initialize temporary lib.file 52 CALL MPRWW ! read menu into workfile IF (ISWRET.EQ.-2) GOTO 60 ! read error CALL MPRWD ! write menu to temp. lib.file CALL MPRWL ! screen check, write document-list IF (ISWRET.EQ.0) GOTO 52 C C end of MEN-file C 60 CALL MPRUP ! update pointers in temp. lib.file CALL MPRWT ! examine/print menu-tree CLOSE (UNIT=LUMEN) CLOSE (UNIT=LUWRK) IF (IMLS.EQ.1) 62,70,70 C THEN 62 CALL SWRITE(LUMLS,' ',FF) ! issue last form-feed CLOSE (UNIT=LUMLS) C ENDIF 70 IF (IGMX.EQ.1) 72,80,80 C THEN 72 OPEN (UNIT=LUGMX,NAME=GMXNAM,TYPE='NEW', 1 CARRIAGECONTROL='NONE',ERR=9040) CALL MPRGX ! generate source for MPREXE CLOSE (UNIT=LUGMX) C ENDIF 80 IF (IMEX.EQ.0) 82,84,84 C THEN 82 CLOSE(UNIT=LUMEX) GOTO 99 C ELSE 84 NBLK=(NMEXR/12)+1 OPEN (UNIT=LURMX,NAME=MEXNAM,TYPE='NEW',ACCESS='DIRECT', 1 RECORDSIZE=10,INITIALSIZE=NBLK,MAXREC=NMEXR+1,ERR=9050) DO 90 IREC=1,NMEXR READ (LUMEX'IREC+0,END=92) MEXREC WRITE (LURMX'IREC+0) MEXREC 90 CONTINUE 92 CLOSE (UNIT=LUMEX) CLOSE (UNIT=LURMX) C ENDIF C C stop C 99 CALL EXIT C C formats C 900 FORMAT(' MPR-menu compiler - ',A4,20X,$) C C errors C 9000 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t find MPR-menu source file',CRLF) GOTO 10 9010 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open MPR-compiler workfile',CRLF) GOTO 99 9020 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open temporary library file',CRLF) GOTO 99 9030 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open MPR-menu document list file',CRLF) GOTO 99 9040 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open generated-source file',CRLF) GOTO 99 9050 CALL SWRITE(LUSCR,' ',PROG, 1 'F-Can''t open MPR-menu library file',CRLF) GOTO 99 END SUBROUTINE MPRBF (NREC,FUNNAM,IRET) C***************************************************************************** C C Description : Routine to search for the occurrance of a function name C in a former menu C C Arguments : NREC = INTEGER number of the current menu name-record C FUNNAM = STRING containing the functionname to be searched C IRET = INTEGER return code: 0 - name not found C 1 - function name found 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C C menu name-record BYTE MENAM(8) C MENAM ! menu name C NRNXMR ! rec.nr. next menu name record C NRFFLR ! rec.nr. first function-list record C NRLFLR ! rec.nr. last function-list record C C function-list data record BYTE MXSREC(40),FUNKEY(6),FUNTYP(2),FUNPTG(8),FUNSTG(8) EQUIVALENCE (FUNKEY,MXSREC(1)) ! key-characters EQUIVALENCE (FUNTYP,MXSREC(7)) ! function type (M/F/S) EQUIVALENCE (FUNPTG,MXSREC(9)) ! primary target EQUIVALENCE (FUNSTG,MXSREC(17)) ! secondary target EQUIVALENCE (NRMTG ,MXSREC(25)) ! rec.nr. of menu target EQUIVALENCE (NRTR ,MXSREC(27)) ! number of text records C BYTE FUNNAM(1) C C C read menu's sequentially C IRET=0 NRNXMR=NGIR+1 10 IF (NRNXMR.EQ.NREC) GOTO 99 READ (LUMEX'NRNXMR) MENAM,NRNXMR,NRFFLR,NRLFLR ! read name record IREC=NRFFLR 20 IF (IREC.EQ.0 .OR. IREC.GE.NRLFLR) GOTO 10 READ (LUMEX'IREC) MXSREC ! check function-list data record IF (FUNTYP(1).NE.'M') 30,40,40 ! for 'F'- and 'S'-type functions C THEN 30 IF (ISCOMP(FUNNAM,FUNPTG).EQ.0) 32,40,40 C THEN 32 IRET=1 GOTO 99 C ENDIF C ENDIF 40 IREC=IREC+NRTR+1 GOTO 20 C C go back to calling routine C 99 RETURN END SUBROUTINE MPRCF (ITYP,TYPE,IRET) C***************************************************************************** C C Description : Routine to check the number of data items and the length C of the last one in a MPR-menu source file record C C Arguments : ITYP = INTEGER indicating what type of check: C 1 - system header record C 2 - general info line record C 3 - menu name record C 4 - function-list record for function C 5 - function-list record for sub-menu C 6 - function-list record for function followed C by a sub-menu C TYPE = STRING containing the keyword according to the value C of ITYP 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C BYTE TYPE(1),HLPST1(128),HLPST2(128),NAME(8),SLSH(2) C C C set minimum number of items according to record type C IRET=0 MINDI=3 IF (ITYP.LE.2) MINDI=2 IF (ITYP.EQ.6) MINDI=4 SLSH(1)=0 NAME(1)=0 C C count data items (strings between comma's) C ICNT=0 IPOS=1 10 ICNT=ICNT+1 CALL GSUBS(MENREC,IPOS,',',HLPST1,127,IRET) IF (ICNT.EQ.2 .AND. ITYP.GE.3) CALL SCOPY(HLPST1,NAME,6) IF (IRET.EQ.0) GOTO 10 CALL SCVTLU(NAME) IF (LEN(NAME).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,NAME, 1 '/Missing data items') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG,'E-',TYPE,SLSH,NAME, 1 '/Missing data items') IRET=-2 GOTO 99 C ENDIF C C check maximum length of last (=text/data) string in record C 20 IPOS=1 DO 30 I=1,MINDI-1 CALL GSUBS(MENREC,IPOS,',',HLPST1,127,IRET) 30 CONTINUE CALL GSUBS(MENREC,IPOS,0,HLPST1,127,IRET) LH=LEN(HLPST1) IF ((ITYP .EQ. 1 .AND. LH .GT. 53) .OR. 1 ((ITYP .EQ. 2 .OR. ITYP .EQ. 3) .AND. LH .GT. 40) .OR. 2 (ITYP .GE. 3 .AND. LH .GT. 79)) 40,50,50 C THEN 40 CALL SWRITE(LUSCR,' ',PROG,'W-',TYPE,SLSH,NAME, 1 '/Excessive number of characters in text/data-string') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG,'W-',TYPE,SLSH,NAME, 1 '/Excessive number of characters in text/data-string') IRET=-1 C ENDIF C C check occurrance of '-' character in text/data-string C 50 IPOS=1 CALL GSUBS(HLPST1,IPOS,'-',HLPST2,127,IRET) IF (ITYP.GE.4 .AND. LEN(HLPST2).GT.5) 60,99,99 C THEN 60 CALL SWRITE(LUSCR,' ',PROG,'W-',TYPE,SLSH,NAME, 1 '/Key-string too long or undefined') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG,'W-',TYPE,SLSH,NAME, 1 '/Key-string too long or undefined') IRET=-1 C ENDIF C C go back to calling routine C 99 RETURN END SUBROUTINE MPRCR (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 : MPR.FTN C C Package : MPR 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 MPRGX C***************************************************************************** C C Description : Routine to generate the FORTRAN-IV source file of the C subroutine with global-name: MPREXE 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C C menu name-record BYTE MENAM(8) C MENAM ! menu name C NRNXMR ! rec.nr. next menu name record C NRFFLR ! rec.nr. first function-list record C NRLFLR ! rec.nr. last function-list record C C function-list data record BYTE FUNKEY(6),FUNTYP(2),FUNPTG(8),FUNSTG(8) EQUIVALENCE (FUNKEY,MEXREC(1)) ! key-characters EQUIVALENCE (FUNTYP,MEXREC(7)) ! function type (M/F/S) EQUIVALENCE (FUNPTG,MEXREC(9)) ! primary target EQUIVALENCE (FUNSTG,MEXREC(17)) ! secondary target EQUIVALENCE (NRMTG ,MEXREC(25)) ! rec.nr. of menu target EQUIVALENCE (NRTR ,MEXREC(27)) ! number of text records C BYTE CC(3),FF,TAB DATA CC /'+','$',0/, FF /12/, TAB /9/ C C C initialize C LRET=999 ! label 'RETURN'-statement NLAB=1 NRMMR=NGIR+1 C C create program header C WRITE (LUGMX,900) TAB,VNR,(DAT(I),I=1,LEN(DAT)),(TIM(I),I=1,LEN(TIM)) WRITE (LUGMX,910) FF,TAB C C read menu's sequentially C NRNXMR=NRMMR 10 NREC=NRNXMR READ (LUMEX'NREC) MENAM,NRNXMR,NRFFLR,NRLFLR ! read name record IREC=NRFFLR 20 IF (IREC.EQ.0 .OR. IREC.GE.NRLFLR) GOTO 50 READ (LUMEX'IREC) MEXREC ! check function-list data record IF (FUNTYP(1).NE.'M') 30,40,40 ! for 'F'- and 'S'-type functions C THEN 30 CALL MPRBF(NREC,FUNPTG,IRET) ! check former occurrance of function IF (IRET.EQ.1) GOTO 40 WRITE (LUGMX,920) NLAB,TAB,(FUNPTG(I),I=1,LEN(FUNPTG)),NLAB+1, 1 TAB,(FUNPTG(I),I=1,LEN(FUNPTG)),TAB,LRET NLAB=NLAB+1 C ENDIF 40 IREC=IREC+NRTR+1 GOTO 20 C 50 IF (NRNXMR.NE.NRMMR) GOTO 10 C WRITE (LUGMX,950) NLAB,TAB WRITE (LUGMX,960) LRET,TAB,TAB ! write 'RETURN'-statement C C go back to calling routine C RETURN C C formats C 900 FORMAT(A1,'SUBROUTINE MPREXE (FUNNAM,IRET)',/, 1 'C',77('*'),/,'C',/, 2 'C Description : This source is generated by the ', 3 'MPR-compiler - ',A4,/,'C',/, 4 'C Date/time : ',A1,' ',A1) 910 FORMAT('C',/,'C Use : For correct functionning ', 1 'of the MPR-menu routines,',/,'C',16X, 2 'compile this routine (with or without line-numbers),' 3 ,/,'C',16X, 4 'and link it to the application program which uses',/, 5 'C',16X,'the MPR-menu''s',/,'C',/,'C',77('*'),/, 6 A1,/,A1,'BYTE FUNNAM(1)',/,'C') 920 FORMAT(I3,A1,'IF (ISCOMP(FUNNAM,''',A1, 1 ''').NE.0) GOTO ', 2 I3,/,A1,'CALL ',A1,'(IRET)',/,A1,'GOTO ',I3) 950 FORMAT(I3,A1,'CONTINUE') 960 FORMAT(I3,A1,'RETURN',/,A1,'END') END SUBROUTINE MPRID C***************************************************************************** C C Description : Routine to initialize the MPR-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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C C general info record 1 BYTE CLRSTR(8),ERLSTR(4),CLRVAT(6),FLSVAT(8) EQUIVALENCE (VERSNR,MEXREC(1)) ! version number EQUIVALENCE (NRMMR ,MEXREC(5)) ! rec.nr. of main menu EQUIVALENCE (CLRSTR,MEXREC(7)) ! esc.seq: clear screen EQUIVALENCE (ERLSTR,MEXREC(15)) ! esc.seq: erase line EQUIVALENCE (CLRVAT,MEXREC(19)) ! esc.seq: clear video attributes EQUIVALENCE (FLSVAT,MEXREC(25)) ! esc.seq: function-list key vid.att. C C general info record 2 BYTE FNPPOS(8),FNGPOS(8),FLSPOS(8),MESPAT(14) EQUIVALENCE (LMAR ,MEXREC(1)) ! left margin text lines EQUIVALENCE (FNPPOS,MEXREC(3)) ! esc.seq: pos. 'Function:'-text EQUIVALENCE (FNGPOS,MEXREC(11)) ! esc.seq: pos. to get command string EQUIVALENCE (FLSPOS,MEXREC(19)) ! esc.seq: start pos. of function-list EQUIVALENCE (MESPAT,MEXREC(27)) ! esc.seq: pos. & video-attr. messages C C general info record 3 BYTE GENVAT(8),GENLAT(4,2),MENPAT(10) EQUIVALENCE (GENVAT,MEXREC(1)) ! esc.seq: gen.header video attributes EQUIVALENCE (GENLAT,MEXREC(9)) ! esc.seq: gen.header line attributes EQUIVALENCE (MENPAT,MEXREC(17)) ! esc.seq: menu head. pos. & line att. C BYTE CLR(8),ERL(4),CLV(6),FLV(8),FNP(8),FNG(8),FLS(8), 1 MES(14),GEV(8),GEL(8),MEN(10) DATA CLR /155,'[','H',155,'[','J',2*0/, 1 ERL /155,'[','K',0/, 2 CLV /155,'[','0','m',2*0/, 3 FLV /155,'[','0',';','7','m',2*0/ DATA FNP /155,'[','7',';','4','H',2*0/, 1 FNG /155,'[','7',';','1','4','H',0/, 2 FLS /155,'[','9',';','1','H',2*0/, 3 MES /155,'[','2','2',';','1','H',155,'[','0',';','7','m',0/ DATA GEV /155,'[','0',';','7','m',2*0/, 1 GEL /155,'#','3',0,155,'#','4',0/, 2 MEN /155,'[','5',';','1','H',155,'#','6',0/ C C NGIR=6 ! number of general info records NMEXR=NGIR ISWRET=0 CALL MPRCR(MEXREC,MAXBUF) ! zero record buffer VERSNR=VNR NRMMR=NGIR+1 CALL SCOPY(CLR,CLRSTR) CALL SCOPY(ERL,ERLSTR) CALL SCOPY(CLV,CLRVAT) CALL SCOPY(FLV,FLSVAT) WRITE (LUMEX'1) MEXREC ! write first record C CALL MPRCR(MEXREC,MAXBUF) ! zero buffer IPOS=5 LMAR=ICVTS(FNP,IPOS,IRET)-1 CALL SCOPY(FNP,FNPPOS) CALL SCOPY(FNG,FNGPOS) CALL SCOPY(FLS,FLSPOS) CALL SCOPY(MES,MESPAT) WRITE (LUMEX'2) MEXREC ! write second record C CALL MPRCR(MEXREC,MAXBUF) ! zero buffer CALL SCOPY(GEV,GENVAT) CALL SCOPY(GEL(1),GENLAT(1,1)) CALL SCOPY(GEL(5),GENLAT(1,2)) CALL SCOPY(MEN,MENPAT) WRITE (LUMEX'3) MEXREC ! write third record C CALL MPRCR(MEXREC,MAXBUF) ! zero buffer DO 10 I=4,NGIR WRITE (LUMEX'4) MEXREC ! init forth record 10 CONTINUE C C go back to calling routine C RETURN END SUBROUTINE MPRLH C***************************************************************************** C C Description : Routine to write header line for MPR-menu 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C 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.0) 10,20,20 C THEN 10 CALL SWRITE(LUMLS,'1',' ') GOTO 30 C ELSE 20 CALL SWRITE(LUMLS,' ',' ') C ENDIF 30 WRITE(LUMLS,900) VNR CALL SWRITE(LUMLS,'+$',DAT,' time ',TIM) IPAGE=IPAGE+1 WRITE (LUMLS,910) IPAGE CALL SWRITE(LUMLS,' ',LF2,'Menu: ',MNAME) C C go back to calling routine C RETURN C C formats C 900 FORMAT('+MPR - ',A4,6X,'MPR-menu document list',7X,$) 910 FORMAT('+ page ',I2) END SUBROUTINE MPRUP C***************************************************************************** C C Description : Routine to update the menu-pointers in the completed C menu 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C C menu name-record BYTE MENAM(8) C MENAM ! menu name C NRNXMR ! rec.nr. next menu name record C NRFFLR ! rec.nr. first function-list record C NRLFLR ! rec.nr. last function-list record C C function-list data record BYTE FUNKEY(6),FUNTYP(2),FUNPTG(8),FUNSTG(8) EQUIVALENCE (FUNKEY,MEXREC(1)) ! key-characters EQUIVALENCE (FUNTYP,MEXREC(7)) ! function type (M/F/S) EQUIVALENCE (FUNPTG,MEXREC(9)) ! primary target EQUIVALENCE (FUNSTG,MEXREC(17)) ! secondary target EQUIVALENCE (NRMTG ,MEXREC(25)) ! rec.nr. of menu target EQUIVALENCE (NRTR ,MEXREC(27)) ! number of text records C BYTE NAME(8),LF(2) DATA LF/10,0/ C C C initialize C NRMMR=NGIR+1 CALL SCOPY('-tree-',MNAME) IF (IMLS.EQ.1) CALL MPRLH C C read menu's sequential C NRNXMR=NRMMR 10 READ (LUMEX'NRNXMR) MENAM,NRNXMR,NRFFLR,NRLFLR ! read name record C C examine function-list records C IREC=NRFFLR 30 IF (IREC.LE.0 .OR. IREC.GE.NRLFLR) GOTO 70 READ (LUMEX'IREC) MEXREC ! check function-list data record IF (FUNTYP(1).EQ.'F') GOTO 60 ! for 'M'- and 'S'-type functions CALL SCOPY(FUNPTG,NAME) IF (FUNTYP(1).EQ.'S') CALL SCOPY(FUNSTG,NAME) NRNXSR=NRMMR 40 ISREC=NRNXSR READ (LUMEX'ISREC) MENAM,NRNXSR ! search menu name-record IF (ISCOMP(NAME,MENAM).EQ.0) GOTO 50 ! with correct name IF (NRNXSR.NE.NRMMR) GOTO 40 CALL SWRITE(LUSCR,' ',PROG,'F-',NAME, 1 '/Missing menu') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',LF,PROG,'F-',NAME, 1 '/Missing menu') GOTO 60 C 50 NRMTG=ISREC ! store record number WRITE (LUMEX'IREC) MEXREC 60 IREC=IREC+NRTR+1 GOTO 30 C 70 IF (NRNXMR.NE.NRMMR) GOTO 10 C C go back to calling routine C 99 RETURN END SUBROUTINE MPRWD C***************************************************************************** C C Description : Routine to read the MPR-compiler workfile and create C a menu in the MPR-menu 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C C menu name-record BYTE FMXREC(40),MENAM(8) EQUIVALENCE (MENAM ,FMXREC(1)) ! menu name EQUIVALENCE (NRNXMR,FMXREC(9)) ! rec.nr. next menu name record EQUIVALENCE (NRFFLR,FMXREC(11)) ! rec.nr. first function-list record EQUIVALENCE (NRLFLR,FMXREC(13)) ! rec.nr. last function-list record C C function-list data record BYTE FUNKEY(6),FUNTYP(2),FUNPTG(8),FUNSTG(8) EQUIVALENCE (FUNKEY,MEXREC(1)) ! key-characters EQUIVALENCE (FUNTYP,MEXREC(7)) ! function type (M/F/S) EQUIVALENCE (FUNPTG,MEXREC(9)) ! primary target EQUIVALENCE (FUNSTG,MEXREC(17)) ! secondary target EQUIVALENCE (NRMTG ,MEXREC(25)) ! rec.nr. of menu target EQUIVALENCE (NRTR ,MEXREC(27)) ! number of text records C BYTE TYPE(4),NAME(8),RESSTR(128),HLPSTR(128) C C C prepare menu name-record C IF (NWRKR.EQ.0) GOTO 99 NMEXR=NMEXR+1 NFMXR=NMEXR ! save rec.nr. for later on CALL MPRCR(FMXREC,MAXBUF) CALL SCOPY(MNAME,MENAM) NRFFLR=0 NRLFLR=0 IF (NWRKR.LE.1) GOTO 90 C C MEN-record C CALL MPRCR(MEXREC,MAXBUF) DO 10 I=1,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'MEN').NE.0) GOTO 10 ! search MEN-type DO 12 J=1,MAXBUF MEXREC(J)=' ' 12 CONTINUE CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) LRS=LEN(RESSTR) NBL=(MAXBUF-LRS)/2 CALL SCOPY(RESSTR,MEXREC(NBL+1),39-NBL) IF (LRS.LT.MAXBUF) MEXREC(NBL+LRS+1)=' ' IF (LRS.GE.MAXBUF) MEXREC(MAXBUF)=RESSTR(MAXBUF) GOTO 20 10 CONTINUE C 20 NMEXR=NMEXR+1 WRITE (LUMEX'NMEXR) MEXREC ! write menu header record C C FUN-, SUB- and FSB-records C DO 80 I=1,NWRKR READ (LUWRK'I+0) WRKREC IPOS=1 CALL GSUBS(WRKREC,IPOS,',',TYPE,127,IRET) IF (ISCOMP(TYPE,'MEN').EQ.0) GOTO 80 ! ignore menu name-record CALL MPRCR(MEXREC,MAXBUF) CALL SCOPY('S',FUNTYP) IF (ISCOMP(TYPE,'FUN').EQ.0) CALL SCOPY('F',FUNTYP) IF (ISCOMP(TYPE,'SUB').EQ.0) CALL SCOPY('M',FUNTYP) CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,FUNPTG) ! get primary target IF (FUNTYP(1).EQ.'S') 22,30,30 C THEN 22 CALL GSUBS(WRKREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,FUNSTG) ! get secondary target C ENDIF 30 CALL GSUBS(WRKREC,IPOS,0,RESSTR,127,IRET) IX=INDEX(RESSTR,'-') ! isolate function key-string IF (IX.EQ.0) 32,50,50 C THEN ! without '-' character 32 CALL SCOPY(RESSTR,FUNKEY,5) CALL SCVTLU(FUNKEY) LRS=LEN(RESSTR) RESSTR(1)=0 IF (LRS.GT.5) 40,60,60 C THEN 40 DO 42 J=6,LRS RESSTR(J-5)=RESSTR(J) 42 CONTINUE RESSTR(LRS-4)=0 GOTO 60 C ENDIF C ELSE ! with '-' character 50 IPOS=1 CALL GSUBS(RESSTR,IPOS,'-',HLPSTR,127,IRET) CALL SCOPY(HLPSTR,FUNKEY,5) CALL SCVTLU(FUNKEY) CALL SCOPY(RESSTR(IPOS),HLPSTR) CALL TRIM(HLPSTR) CALL SCOPY(HLPSTR,RESSTR) C ENDIF 60 LRS=LEN(RESSTR) NRMTG=0 NRTR=1 IF (LRS.GE.MAXBUF) NRTR=2 NMEXR=NMEXR+1 WRITE (LUMEX'NMEXR) MEXREC ! write function-list data record NRLFLR=NRLFLR+1 CALL MPRCR(MEXREC,MAXBUF) CALL SCOPY(RESSTR,MEXREC,39) IF (LRS.GE.MAXBUF) 62,70,70 C THEN 62 MEXREC(MAXBUF)=RESSTR(MAXBUF) NMEXR=NMEXR+1 WRITE (LUMEX'NMEXR) MEXREC ! write function-list text record NRLFLR=NRLFLR+1 CALL MPRCR(MEXREC,MAXBUF) CALL SCOPY(RESSTR(MAXBUF+1),MEXREC,39) C ENDIF 70 NMEXR=NMEXR+1 WRITE (LUMEX'NMEXR) MEXREC ! write function-list text record NRLFLR=NRLFLR+1 80 CONTINUE IF (NRLFLR.EQ.0) 82,84,84 C THEN ! menu without function-list 82 NMEXR=NFMXR-1 ! is impossible GOTO 99 C ENDIF 84 NRFFLR=NMEXR-NRLFLR+1 ! update pointers in name-rec. NRLFLR=NMEXR C C update menu name-record C 90 NRNXMR=NMEXR+1 IF (ISWRET.EQ.-1) NRNXMR=NGIR+1 WRITE (LUMEX'NFMXR) FMXREC C C go back to calling routine C 99 RETURN END SUBROUTINE MPRWL C***************************************************************************** C C Description : Routine to write the MPR-menu lay-out 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C C general info record 2 BYTE FNPPOS(8),FNGPOS(8),FLSPOS(8),MESPAT(14) C FNPPOS ! esc.seq: position 'Function:'-text C FNGPOS ! esc.seq: position to get command string C FLSPOS ! esc.seq: start position of function-list C MESPAT ! esc.seq: pos. & video-attr. messages C C general info record 3 BYTE GENVAT(8),GENLAT(4,2),MENPAT(10) C GENVAT ! esc.seq: general header video attributes C GENLAT ! esc.seq: general header line attributes C MENPAT ! esc.seq: menu header pos. & line attributes C C menu name-record BYTE MENAM(8) C MENAM ! menu name C NRNXMR ! rec.nr. next menu name record C NRFFLR ! rec.nr. first function-list record C NRLFLR ! rec.nr. last function-list record C C function-list data record BYTE FMXREC(40),FUNKEY(6),FUNTYP(2),FUNPTG(8),FUNSTG(8) EQUIVALENCE (FUNKEY,FMXREC(1)) ! key-characters EQUIVALENCE (FUNTYP,FMXREC(7)) ! function type (M/F/S) EQUIVALENCE (FUNPTG,FMXREC(9)) ! primary target EQUIVALENCE (FUNSTG,FMXREC(17)) ! secondary target EQUIVALENCE (NRMTG ,FMXREC(25)) ! rec.nr. of menu target EQUIVALENCE (NRTR ,FMXREC(27)) ! number of text records C BYTE LINE(80),SCRTAB(81,24),FKITAB(50,12),LF(2) DATA LF/10,0/ C C C initialize C IF (NWRKR.LE.1) 10,20,20 C THEN 10 CALL SWRITE(LUSCR,' ',PROG,'E-',MNAME, 1 '/Empty function-list') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',LF,PROG,'E-',MNAME, 1 '/Empty function-list') GOTO 899 C ENDIF 20 LINMAX=60 ! number of lines per page IRSYS=1 IRGEN=IRSYS+1 IRMEN=5 ! menu header row IRMES=22 ! message line row IRFNP=7 ! 'Function:'-text row ICFNP=4 ! column IRFLS=9 ! function-list row ICFLS=ICFNP ! column ITLFLG=0 C C prepare screen layout print C DO 50 J=1,24 DO 40 I=1,80 SCRTAB(I,J)=' ' ! init screen table IF (J.GE.IRMES) SCRTAB(I,J)='X' SCRTAB(I+1,J)=0 40 CONTINUE IF (J.GE.IRMES) 42,50,50 C THEN 42 CALL SCOPY(' Reserved for help/error messages ',SCRTAB(23,J)) SCRTAB(58,J)=' ' C ENDIF 50 CONTINUE CALL SCOPY('Function:',SCRTAB(ICFNP,IRFNP)) SCRTAB(ICFNP+9,IRFNP)=' ' C DO 70 J=1,12 DO 60 I=1,49 FKITAB(I,J)=' ' FKITAB(I+1,J)=0 60 CONTINUE CALL SCOPY('--->',FKITAB(7,J)) FKITAB(11,J)=' ' 70 CONTINUE C C fill in system header line C READ (LUMEX'NGIR-2) MEXREC CALL SCOPY (MEXREC,LINE,MAXBUF-1) IF (MEXREC(MAXBUF) .NE. 0) 80,90,90 C THEN 80 LINE(MAXBUF)=MEXREC(MAXBUF) READ (LUMEX'NGIR-1) MEXREC CALL SCOPY (MEXREC,LINE(MAXBUF+1)) C ENDIF 90 CALL HEADER (LINE,'MPRMEN',LINE) CALL SCOPY (LINE,SCRTAB(1,IRSYS)) SCRTAB(2*MAXBUF,IRSYS)=' ' C C fill in general header line C READ (LUMEX'NGIR) MEXREC I2=0 DO 100 I=1,40 I2=I2+1 ! Double height is not SCRTAB(I2,IRGEN)=MEXREC(I) ! possible for the line- SCRTAB(I2,IRGEN+1)=MEXREC(I) ! printer, so print I2=I2+1 ! the same line twice SCRTAB(I2,IRGEN)=' ' ! with a space between SCRTAB(I2,IRGEN+1)=' ' ! every character 100 CONTINUE C C fill menu header line C READ (LUMEX'NFMXR+1) MEXREC I2=0 DO 110 I=1,40 ! Double width is not I2=I2+1 ! possible for the line- SCRTAB(I2,IRMEN)=MEXREC(I) ! printer, so print I2=I2+1 ! the line with SCRTAB(I2,IRMEN)=' ' ! a space between 110 CONTINUE ! every character C C fill function-list info in tables C READ (LUMEX'NFMXR) MENAM,NRNXMR,NRFFLR,NRLFLR ! read name-record IREC=NRFFLR IR=IRFLS IFUN=0 120 IF (IREC.EQ.0 .OR. IREC.GE.NRLFLR) GOTO 200 IC=ICFLS READ (LUMEX'IREC) FMXREC ! read function-list data record CALL SCOPY(FUNKEY,SCRTAB(IC,IR)) LFK=LEN(FUNKEY) READ (LUMEX'IREC+1) MEXREC ! read function-list first text rec. CALL SCOPY(MEXREC,SCRTAB(IC+LFK,IR),39) IF (NRTR.EQ.2) 130,140,140 C THEN 130 IC=ICFLS+LFK+MAXBUF SCRTAB(IC-1,IR)=MEXREC(MAXBUF) READ (LUMEX'IREC+NRTR) MEXREC ! read function-list second text rec. CALL SCOPY(MEXREC,SCRTAB(IC,IR),81-IC) IF (IC+LEN(MEXREC).GT.80) ITLFLG=1 C ENDIF 140 LSCR=LEN(SCRTAB(1,IR)) IF (LSCR.LT.80) SCRTAB(LSCR+1,IR)=' ' IR=IR+1 ! position next line IFUN=IFUN+1 ! count function CALL SCOPY(FUNKEY,FKITAB(1,IFUN)) ! compose function-key FKITAB(1+LEN(FUNKEY),IFUN)=' ' ! info-table, according CALL SCOPY(FUNPTG,FKITAB(12,IFUN)) ! to function-types FKITAB(12+LEN(FUNPTG),IFUN)=' ' CALL SCOPY('(routine)',FKITAB(19,IFUN)) ! type='F' IF (FUNTYP(1).EQ.'M') 150,160,160 ! type='M' C THEN 150 CALL SCOPY('(menu)',FKITAB(19,IFUN)) GOTO 180 C ENDIF 160 IF (FUNTYP(1).EQ.'S') 170,180,180 ! type='S' C THEN 170 CALL SCOPY(' ---> ',FKITAB(28,IFUN)) CALL SCOPY(FUNSTG,FKITAB(34,IFUN)) FKITAB(34+LEN(FUNSTG),IFUN)=' ' CALL SCOPY('(menu)',FKITAB(41,IFUN)) C ENDIF 180 IREC=IREC+NRTR+1 GOTO 120 C C give warning for off-screen characters C 200 IF (ITLFLG.EQ.1) CALL SWRITE(LUSCR,' ',PROG, 1 'W-Function text position(s) off-screen') IF (IMLS.EQ.0) GOTO 899 C C print screen layout C CALL SWRITE(LUMLS,' ',LF,'Screen lay-out:') CALL SWRITE(LUMLS,' ','---------------') IF (ITLFLG.EQ.1) CALL SWRITE(LUMLS,' ',LF,PROG, 1 'W-Function text position(s) off-screen') CALL SWRITE(LUMLS,' ',LF) WRITE (LUMLS,901) WRITE (LUMLS,902) WRITE (LUMLS,903) DO 210 I=1,24 WRITE (LUMLS,911) I CALL SWRITE(LUMLS,'+$',SCRTAB(1,I)) WRITE (LUMLS,912) I 210 CONTINUE WRITE (LUMLS,903) WRITE (LUMLS,902) WRITE (LUMLS,901) C C print funcion key info C CALL SWRITE(LUMLS,' ',LF,'Function-key info') CALL SWRITE(LUMLS,' ','-----------------') CALL SWRITE(LUMLS,' ',' ') DO 220 I=1,IFUN CALL SWRITE(LUMLS,' ',FKITAB(1,I)) 220 CONTINUE C C go back to calling routine C 899 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 MPRWT C***************************************************************************** C C Description : Routine to examine the menu-tree and eventually print it 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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C C menu name-record BYTE MENAM(8) C MENAM ! menu name C NRNXMR ! rec.nr. next menu name record C NRFFLR ! rec.nr. first function-list record C NRLFLR ! rec.nr. last function-list record C C function-list data record BYTE FUNKEY(6),FUNTYP(2),FUNPTG(8),FUNSTG(8) EQUIVALENCE (FUNKEY,MEXREC(1)) ! key-characters EQUIVALENCE (FUNTYP,MEXREC(7)) ! function type (M/F/S) EQUIVALENCE (FUNPTG,MEXREC(9)) ! primary target EQUIVALENCE (FUNSTG,MEXREC(17)) ! secondary target EQUIVALENCE (NRMTG ,MEXREC(25)) ! rec.nr. of menu target EQUIVALENCE (NRTR ,MEXREC(27)) ! number of text records C DIMENSION ISTACK(3,8),NPLSTK(9) BYTE ARROW(8),SP(7),LF(2),CRLF(3),VBAR(2), 1 CC(3),CC0(2),CC1(3),CC2(2) DATA ARROW /'+',4*'-','>',' ',0/, SP /6*' ',0/, 1 LF /10,0/, CRLF /13,10,0/, VBAR /'|',0/, 2 CC /'+','$',0/, CC1 /' ','$',0/, CC2 /'+',0/ C C C initialize C NPLEV=0 ! print level LSTACK=0 ! tree sub-level indicator MSTACK=8 ! max. stack-level NRMMR=NGIR+1 ! rec.nr. main-menu name-record NRNXMR=NRMMR IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',LF,CRLF) C C climb down the menu-tree C 10 READ (LUMEX'NRNXMR) MENAM,NRNXMR,NRFFLR,NRLFLR IF (NRFFLR.EQ.0) 12,20,20 C THEN 12 IF (NRNXMR.NE.NRMMR) GOTO 10 GOTO 199 C ENDIF 20 IREC=NRFFLR IEXTLN=1 IF (NPLEV.LE.MSTACK) NPLEV=NPLEV+1 NPLSTK(NPLEV)=1 IF (IMLS.EQ.1 .AND. NPLEV.EQ.1) 1 CALL SWRITE(LUMLS,' ',MENAM,' (main menu)') C C read function-list data records C 40 IF (IREC.LE.0 .OR. IREC.GT.NRLFLR) GOTO 120 READ (LUMEX'IREC) MEXREC ! read function-list data rec. IF (FUNTYP(1).EQ.'F') 42,70,70 C THEN 42 IF (IMLS.EQ.0) GOTO 62 CALL SWRITE(LUMLS,CC1,0) IF (IEXTLN.EQ.0) GOTO 52 IEXTLN=0 DO 50 I=1,NPLEV VBAR(1)='|' IF (NPLSTK(I).EQ.0) VBAR(1)=' ' CALL SWRITE(LUMLS,CC,VBAR,SP) 50 CONTINUE CALL SWRITE(LUMLS,CC,CRLF) 52 DO 60 I=1,NPLEV-1 IF (I.GE.NPLEV) GOTO 60 VBAR(1)='|' IF (NPLSTK(I).EQ.0) VBAR(1)=' ' CALL SWRITE(LUMLS,CC,VBAR,SP) 60 CONTINUE CALL SWRITE(LUMLS,CC2,ARROW,FUNPTG,' (routine)') 62 IREC=IREC+NRTR+1 GOTO 40 C ENDIF C C check possible stack overflow C 70 IF (LSTACK.GE.8) 72,80,80 C THEN 72 CALL SWRITE(LUSCR,' ',PROG,'F-', 1 'Maximum number of sub-levels exceeded') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',LF,PROG,'F-', 1 'Maximum number of sub-levels exceeded') IREC=IREC+NRTR+1 GOTO 40 C ENDIF C C print current menu-name and examine function-list C 80 IF (IMLS.EQ.1) 82,110,110 C THEN 82 CALL SWRITE(LUMLS,CC1,0) DO 90 I=1,NPLEV VBAR(1)='|' IF (NPLSTK(I).EQ.0) VBAR(1)=' ' CALL SWRITE(LUMLS,CC,VBAR,SP) 90 CONTINUE CALL SWRITE(LUMLS,CC,CRLF) DO 100 I=1,NPLEV-1 IF (I.GE.NPLEV) GOTO 100 VBAR(1)='|' IF (NPLSTK(I).EQ.0) VBAR(1)=' ' CALL SWRITE(LUMLS,CC,VBAR,SP) 100 CONTINUE CALL SWRITE(LUMLS,CC,ARROW) IF (FUNTYP(1).EQ.'M') 1 CALL SWRITE(LUMLS,CC2,FUNPTG,' (menu)') IF (FUNTYP(1).EQ.'S') 1 CALL SWRITE(LUMLS,CC2,FUNPTG,' (routine), ',FUNSTG,' (menu)') C ENDIF C C push current menu on the stack C 110 LSTACK=LSTACK+1 ISTACK(1,LSTACK)=NRFFLR ISTACK(2,LSTACK)=NRLFLR ISTACK(3,LSTACK)=IREC+NRTR+1 IF (ISTACK(3,LSTACK).GT.NRLFLR) NPLSTK(NPLEV)=0 NRNXMR=NRMTG IF (NRNXMR.GT.0) GOTO 10 IREC=ISTACK(3,LSTACK) LSTACK=LSTACK-1 GOTO 40 C C pop former menu from stack C 120 IF (LSTACK-1.LT.0) GOTO 199 NRFFLR=ISTACK(1,LSTACK) NRLFLR=ISTACK(2,LSTACK) IREC=ISTACK(3,LSTACK) LSTACK=LSTACK-1 NPLSTK(NPLEV)=0 NPLEV=NPLEV-1 IEXTLN=1 GOTO 40 C C go back to calling routine C 199 RETURN END SUBROUTINE MPRWW C***************************************************************************** C C Description : Routine to read the MPR-menu source file and to write C a menu into the MPR-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 : MPR.FTN C C Package : MPR C C Compilation/Linking : C C Updates : name version C C description : C C***************************************************************************** C BYTE PROG,MNAME,DAT,TIM,MENREC,MEXREC,WRKREC COMMON/MPRMXC/VNR,LUSCR,LUMEN,LUMEX,LUMLS,LUWRK,LUGMX,ISWRET, 1 IMLS,NGIR,NWRKR,NMEXR,NFMXR,MAXBUF,IPAGE, 2 PROG(10),MNAME(8),DAT(10),TIM(10), 3 MENREC(128),MEXREC(40),WRKREC(128) C BYTE RESSTR(128),TYPE(4),NAME(8),HNAME(8),ERR C C NWRKR=0 NSYS=0 NGEN=0 NMEN=0 NFNS=0 CALL SCOPY('*MAIN*',MNAME) IF (LEN(MENREC).NE.0) GOTO 50 ISWRET=0 C C read MPR-menu source file C 10 CALL GETSTR(LUMEN,MENREC,126,ERR) IF (ERR.EQ.-3) 12,20,20 C THEN 12 CALL SWRITE(LUSCR,' ',PROG, 1 'E-MPR-menu source record too long') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG, 1 'E-MPR-menu 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 MPR-menu source file') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG, 1 'F-READ error MPR-menu source file') 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(MENREC).EQ.0) GOTO 10 ITYP=7 IPOS=1 CALL GSUBS(MENREC,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,'SYS').EQ.0) ITYP=1 IF (ISCOMP(TYPE,'GEN').EQ.0) ITYP=2 IF (ISCOMP(TYPE,'MEN').EQ.0) ITYP=3 IF (ISCOMP(TYPE,'FUN').EQ.0) ITYP=4 IF (ISCOMP(TYPE,'SUB').EQ.0) ITYP=5 IF (ISCOMP(TYPE,'FSB').EQ.0) ITYP=6 C ENDIF 60 GOTO (100,200,300,400,400,400,70) ITYP C C unidentified type encountered C 70 CALL SWRITE(LUSCR,' ',PROG, 1 'E-Undefined MPR-menu source record') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG, 1 'E-Undefined MPR-menu source record') GOTO 10 C C type = SYS C 100 NSYS=NSYS+1 IF (NSYS .GT. 1) GOTO 250 CALL MPRCF (ITYP,TYPE,IRET) IF (IRET .EQ. -2) GOTO 10 CALL GSUBS (MENREC,IPOS,0,RESSTR,127,IRET) LRS=LEN(RESSTR) CALL MPRCR (MEXREC,MAXBUF) CALL SCOPY (RESSTR,MEXREC,MAXBUF-1) IF (LRS .GE. MAXBUF) MEXREC(MAXBUF)=RESSTR(MAXBUF) WRITE(LUMEX'NGIR-2) MEXREC CALL MPRCR (MEXREC,MAXBUF) IF (LRS .GE. MAXBUF) CALL SCOPY (RESSTR(MAXBUF+1),MEXREC,MAXBUF-1) WRITE (LUMEX'NGIR-1) MEXREC GOTO 10 C C type = GEN C 200 NGEN=NGEN+1 IF (NGEN.GT.1) GOTO 250 220 CALL MPRCF(ITYP,TYPE,IRET) IF (IRET.EQ.-2) GOTO 10 DO 230 I=1,MAXBUF MEXREC(I)=' ' 230 CONTINUE CALL GSUBS(MENREC,IPOS,0,RESSTR,127,IRET) LRS=LEN(RESSTR) NBL=(MAXBUF-LRS)/2 CALL SCOPY(RESSTR,MEXREC(NBL+1),39-NBL) IF (LRS.LT.MAXBUF) MEXREC(NBL+LRS+1)=' ' IF (LRS.GE.MAXBUF) MEXREC(MAXBUF)=RESSTR(MAXBUF) WRITE (LUMEX'NGIR) MEXREC GOTO 10 C C More than one SYS or GEN record C 250 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/More than one record not allowed') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG,'E-',TYPE, 1 '/More than one record not allowed') GOTO 10 C C type = MEN C 300 NMEN=NMEN+1 IF (NMEN.NE.1) GOTO 899 CALL MPRCF(ITYP,TYPE,IRET) IF (IRET.EQ.-2) GOTO 10 IPOS0=IPOS CALL GSUBS(MENREC,IPOS0,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,MNAME,6) CALL SCVTLU(MNAME) CALL SWRITE(LUSCR,' ',MNAME) IF (IMLS.EQ.1) CALL MPRLH GOTO 500 C C type = FUN , SUB and FSB C 400 NFNS=NFNS+1 IF (NFNS.GT.12) 410,420,420 C THEN 410 CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE, 1 '/Too many function-list records') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG,'E-',TYPE, 1 '/Too many function-list records') GOTO 10 C ENDIF 420 CALL MPRCF(ITYP,TYPE,IRET) IF (IRET.EQ.-2) GOTO 10 C C put type and name plus rest of source record in output buffer C 500 CALL SCOPY(TYPE,WRKREC) WRKREC(4)=',' CALL GSUBS(MENREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,NAME,6) CALL SCVTLU(NAME) CALL SCOPY(NAME,WRKREC(5)) LS1=LEN(RESSTR) LS2=0 IF (ITYP.EQ.6) 502,510,510 C THEN 502 CALL SCOPY(NAME,HNAME) LWRK=LEN(WRKREC)+1 WRKREC(LWRK)=',' CALL GSUBS(MENREC,IPOS,',',RESSTR,127,IRET) CALL SCOPY(RESSTR,NAME,6) CALL SCVTLU(NAME) CALL SCOPY(NAME,WRKREC(LWRK+1),6) LS2=LEN(RESSTR) C ENDIF 510 IF (LS1.GT.6 .OR. LS2.GT.6) 512,520,520 C THEN 512 IF (LS1.GT.6) CALL SCOPY(HNAME,NAME) CALL SWRITE(LUSCR,' ',PROG,'E-',TYPE,'/',NAME, 1 '/Name truncated') IF (IMLS.EQ.1) CALL SWRITE(LUMLS,' ',PROG,'E-',TYPE,'/',NAME, 1 '/Name truncated') C ENDIF 520 LR=LEN(WRKREC)+1 WRKREC(LR)=',' CALL SCOPY(MENREC(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 END