SUBROUTINE MPRGF (IFUN, COMSTR) C***************************************************************************** C C Description : Routine to get one or more functions from screen C This routine is reserved for MPR-subroutines only C C Arguments : IFUN = INTEGER returning the function number (index C of FUNTAB) from the current menu, or C 0 - quit program C -1 - return to main menu C -2 - return to former menu C COMSTR = STRING returning the rest of the command string C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.1 Date : 21-apr-1983 C C Module name : MPRGF.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE MPRGF C C Updates : name version C F.A.Minkema V1.1 C C description : C CTRL/Z processing corrected C C***************************************************************************** C BYTE CLRSTR,ERLSTR,CLRVAT,FLSVAT,FNPPOS,FNGPOS,FLSPOS, 1 MESPAT,GENVAT,GENLAT,MENPAT,FUNTAB,TYPTAB,MFTTAB COMMON/MPRCOM/ISCR,NUNIT,IBTFLG,IMESFL,MAXBUF,LMAR, 1 MSTACK,ISTACK(8),NRMMR,NRNRCM,NRFUN, 2 NRFFLR,NRLFLR,NRTTAB(12), 3 CLRSTR(8),ERLSTR(4),CLRVAT(6),FLSVAT(8), 4 FNPPOS(8),FNGPOS(8),FLSPOS(8),MESPAT(14), 5 GENVAT(8),GENLAT(4,2),MENPAT(10), 6 FUNTAB(6,12),TYPTAB(12),MFTTAB(7,12) C BYTE NCMSTR(60),RESSTR(60),COMSTR(1),ERR BYTE CC(3),CC1(2),CC2(3),BEL(2) DATA CC /'+','$',0/, CC1 /'+',0/, CC2 /' ','$',0/, BEL /7,0/ C C C when 'break-through': do not read from screen C CALL SCOPY(COMSTR,NCMSTR,59) IF (IBTFLG.EQ.1) GOTO 100 NCMSTR(1)=0 C C position and ask for command-string C 10 CALL SWRITE(ISCR,CC,FNGPOS,ERLSTR,FLSVAT) CALL GETSTR(ISCR,NCMSTR,59,ERR) IF (IMESFL.NE.0) CALL MPRCM ! clear message field C C check input return-code C IF (ERR.EQ.-1) 12,20,20 C THEN 12 IF (NRNRCM.EQ.NRMMR) CALL SCOPY('EX',NCMSTR) IF (NRNRCM.NE.NRMMR) CALL SCOPY('<',NCMSTR) C ENDIF 20 IF (ERR.LE.-2 .OR. LEN(NCMSTR).EQ.0) 22,30,30 C THEN 22 CALL SWRITE(ISCR,CC,MESPAT,'Illegal function',BEL) IMESFL=1 GOTO 10 C ENDIF C C check for questionmark (explanation wanted) C 30 IF (INDEX(NCMSTR,'?').GT.0) 40,50,50 C THEN 40 CALL SWRITE(ISCR,CC1,MESPAT,CLRVAT,'Enter ',FLSVAT, 1 'KEY',CLRVAT,'-characters to select function') CALL SWRITE(ISCR,CC2,'Special keys: ') IF (NRNRCM.EQ.NRMMR) 1 CALL SWRITE(ISCR,CC,FLSVAT,'EX',CLRVAT,'IT = quit program, ') IF (NRNRCM.NE.NRMMR) CALL SWRITE 1 (ISCR,CC,FLSVAT,'.',CLRVAT,' = former menu, ', 2 FLSVAT,'<',CLRVAT,' = main-menu, ') CALL SWRITE(ISCR,CC1,FLSVAT,'?',CLRVAT,' = this text') CALL SWRITE(ISCR,CC2,'For ''break-through'', separate ', 1 'keys with comma''s') IMESFL=3 GOTO 10 C ENDIF C C fill command-string C 50 CALL SCOPY(NCMSTR,COMSTR) C C decode command-string C 100 IPOS=1 CALL GSUBS(NCMSTR,IPOS,',',RESSTR,59,IEOS) CALL SCOPY(NCMSTR(IPOS),COMSTR) CALL SCVTLU(RESSTR) IFUN=999 IF (NRNRCM.EQ.NRMMR .AND. 1 INDEX('EXIT',RESSTR).EQ.1 .AND. LEN(RESSTR).GE.2) IFUN=0 IX=INDEX('<.',RESSTR) IF (NRNRCM.NE.NRMMR .AND. 1 LEN(RESSTR).NE.0 .AND. IX.GT.0) IFUN=-IX IF (IFUN.LE.0) GOTO 150 DO 140 I=1,NRFUN IF (ISCOMP(RESSTR,FUNTAB(1,I)).EQ.0) 110,140,140 C THEN 110 IF (TYPTAB(I).EQ.'F' .AND. IEOS.NE.-1) 120,130,130 C THEN 120 IF (IBTFLG.EQ.1) CALL MPRDM(3) IF (IMESFL.NE.0) CALL MPRCM ! clear message field CALL SWRITE(ISCR,CC,MESPAT, 1 'Can''t pass data to function',BEL) IMESFL=1 GOTO 10 C ENDIF 130 IFUN=I GOTO 150 C ENDIF 140 CONTINUE IF (IBTFLG.EQ.1) CALL MPRDM(3) IF (IMESFL.NE.0) CALL MPRCM ! clear message field CALL SWRITE(ISCR,CC,MESPAT, 1 'Invalid function for this menu',BEL) IMESFL=1 GOTO 10 C C check for 'break-through' C 150 IBTFLG=0 IF (LEN(COMSTR).NE.0) IBTFLG=1 CALL SWRITE(ISCR,CC,CLRVAT) C C go back to calling routine C RETURN END