SUBROUTINE TFRMES (MESS, FIELD) C***************************************************************************** C C Description : Routine to put error message on screen C C Arguments : MESS = STRING containing the message or null-string C If MESS is a null-string: the help-text for C the field will be displayed. In that case FIELD C must not be empty C FIELD = STRING containing the field name if MESS is a C null-string 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 : TFRMES.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRMES C C Updates : name version C C description : C C***************************************************************************** C BYTE HOMSTR,CLRSTR,ERLSTR,NATSTR,HERPOS,ERRATT,HLPATT,FCR,SBUF,FREC COMMON/TFRCOM/NUNIT,MAXBUF,NRNXFR,LLFLD,NLFCR,IHEFLG,ISCR, 1 NRFFFR,NRLFFR,NRFDFR,NRLDFR,NRFUFR,NRLUFR, 2 HOMSTR(4),CLRSTR(4),ERLSTR(4),NATSTR(6),HERPOS(8), 3 ERRATT(8),HLPATT(8),FCR(80),SBUF(120),FREC(40) C C update field record BYTE UPDFLD(8),UPDESC(22) EQUIVALENCE (UPDFLD,FREC(1)) ! field name EQUIVALENCE (LENUPD,FREC(9)) ! field length EQUIVALENCE (UPDESC,FREC(11)) ! attibutes escape string EQUIVALENCE (NRFCR ,FREC(33)) ! rec.nr. of field copy rec. EQUIVALENCE (NPFCR ,FREC(35)) ! pos. of field in field copy rec. EQUIVALENCE (NRDEF ,FREC(37)) ! rec.nr. of default-value record EQUIVALENCE (NRHLP ,FREC(39)) ! rec.nr. of help record C BYTE MESS(1),FIELD(1) C C C check arguments C IF (LEN(MESS).GT.0) 10,20,20 C THEN 10 CALL SCOPY(MESS,SBUF,2*MAXBUF-1) GOTO 50 C ELSE 20 IF (LEN(FIELD).EQ.0 .OR. NRFUFR.EQ.0) GOTO 9000 CALL SCVTLU(FIELD) DO 40 I=NRFUFR,NRLUFR CALL TFRRU(I+0,'VAR') ! read update field record IF (ISCOMP(FIELD,UPDFLD).EQ.0) 30,40,40 C THEN 30 IREC=NRHLP IF (IREC.EQ.0) CALL SCOPY('No help available',SBUF) IF (IREC.NE.0) CALL TFRFS(IREC) ! read help message GOTO 50 C ENDIF 40 CONTINUE GOTO 9000 C ENDIF C C print message C 50 CALL SWRITE(ISCR,'+$',HERPOS,ERLSTR,HLPATT,SBUF) IHEFLG=1 C C go back to calling routine C RETURN C C errors C 9000 CALL FATAL('TFRERR','Field not found') END