SUBROUTINE MPRDM (IPCL)
C*****************************************************************************
C
C Description  : Routine to display current menu
C                This routine is reserved for MPR-subroutines only
C
C Arguments    : IPCL  = INTEGER indicating display-mode:
C                         0  - do not execute display
C                         1  - display completely
C                         2  - display partial if IBTFLG=0
C                         3  - display partial regardless of IBTFLG
C                              and set IBTFLG=0
C
C Author       : F.A.Minkema
C                AKZO PHARMA, Oss Holland
C                dept. SDA
C
C Version      : V1.1      Date : 29-aug-1983
C
C Module name  : MPRDM.FTN
C
C Package      : TRAMP
C
C Compilation/Linking : FOR/F4P/TR:NONE MPRDM
C
C Updates      : name F.A.Minkema     version V1.1
C
C  description : For IPCL=1 display completely regardless of IBTFLG
C                Set IBTFLG=0 for IPCL=3 only.
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 PREC(80),MREC1(40),MREC2(40),CC(3),CRLF(3),PROG(6)
	EQUIVALENCE (MREC1,PREC(1))
	EQUIVALENCE (MREC2,PREC(41))
	DATA CC /'+','$',0/, CRLF /13,10,0/
	DATA PROG /'M','P','R','D','M',0/
C
C
C   display heading lines
C
	IF (IPCL.EQ.0 .OR.
	1    (IPCL.EQ.2 .AND. IBTFLG.EQ.1)) GOTO 99
	IF (IPCL.EQ.3) IBTFLG=0
	IF (IPCL.EQ.1) 10,20,20
C	THEN
10	 READ (NUNIT'NRMMR-3) MREC1
	 READ (NUNIT'NRMMR-2) MREC2
	 CALL HEADER (PREC,PROG,PREC)
	 CALL SWRITE (ISCR,CC,CLRSTR,CLRVAT,PREC,CRLF)
	 PREC(MAXBUF+1)=0
	 READ (NUNIT'NRMMR-1) MREC1		! general header
	 CALL SWRITE(ISCR,CC,GENVAT,GENLAT(1,1),PREC)
	 IF (GENLAT(1,2).NE.0) CALL SWRITE(ISCR,CC,CRLF,GENLAT(1,2),PREC)
C	ENDIF
20	PREC(MAXBUF+1)=0
	READ (NUNIT'NRNRCM+1) MREC1		! menu header
	CALL SWRITE(ISCR,CC,CLRVAT,MENPAT,PREC)	
	IF (IPCL.EQ.1) CALL SWRITE(ISCR,CC,FNPPOS,'Function: ')
C
C   display function list
C
	CALL SWRITE(ISCR,CC,FLSPOS)
	IOFUN=IFUN
	IFUN=0
	IREC=NRFFLR-1
30	IF (IREC.GE.NRLFLR) GOTO 60
	DO 40 I=1,LMAR
	  IF (I.LE.LMAR) WRITE (ISCR,900)
40	CONTINUE
	IFUN=IFUN+1
	CALL SWRITE(ISCR,CC,FLSVAT,ERLSTR,FUNTAB(1,IFUN))
	IREC=IREC+2
	READ (NUNIT'IREC) MREC1  ! function-list first text rec.
	CALL SWRITE(ISCR,CC,CLRVAT,PREC)
	IF (MREC1(MAXBUF).NE.0) 42,50,50
C	THEN
42	 IREC=IREC+1
	 READ (NUNIT'IREC) MREC1  ! function-list second text rec.
	 CALL SWRITE(ISCR,CC,MREC1)
C	ENDIF
50	CALL SWRITE(ISCR,CC,CRLF)
	GOTO 30
C
C   clear rest of function-list eventually
C
60	IF (IPCL.EQ.1 .OR. IFUN.GE.IOFUN) GOTO 99
	DO 70 I=IFUN+1,IOFUN
	  CALL SWRITE(ISCR,CC,ERLSTR,CRLF)
70	CONTINUE
C
C   go back to calling routine
C
99	RETURN
C
C   formats
C
900	FORMAT('+ ',$)
C
C   errors
C
	END