SUBROUTINE TFRFLD (FIELD, TEXT) C***************************************************************************** C C Description : Routine to display a text in a specified field and (in C case of an update field) change the field copy record C C Arguments : FIELD = STRING containing the field name C TEXT = STRING containing (new) contents for the field C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.1 Date : 4-jul-1983 C C Module name : TFRFLD.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRFLD C C Updates : name F.A.Minkema version V1.1 C C description : Pad blanks for clear update field C Clear video attributes for disp-only field when null-string 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 display-only field record BYTE DONFLD(8),DONESC(22) EQUIVALENCE (DONFLD,FREC(1)) ! field name EQUIVALENCE (LENDON,FREC(9)) ! field length EQUIVALENCE (DONESC,FREC(11)) ! attibutes escape string 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 FIELD(1),TEXT(1),CC(3) DATA CC /'+','$',0/ C C C search update field with specified name C LTX=LEN(TEXT) CALL SCVTLU(FIELD) IF (NRFUFR.EQ.0) GOTO 30 DO 20 I=NRFUFR,NRLUFR CALL TFRRU(I+0,'VAR') ! read update field record IF (ISCOMP(FIELD,UPDFLD).EQ.0) 10,20,20 C THEN 10 CALL TFRRU(I+0,'FCR') ! read field copy record(s) CALL SCOPY(TEXT,FCR(NPFCR),LENUPD) IF (LTX.LT.LENUPD) 12,16,16 C THEN 12 DO 14 J=NPFCR+LTX,NPFCR+LENUPD-1 FCR(J)=' ' 14 CONTINUE C ENDIF 16 CALL SWRITE(ISCR,CC,UPDESC,FCR(NPFCR)) GOTO 99 C ENDIF 20 CONTINUE C C search display-only field with specified name C 30 IF (NRFDFR.EQ.0) GOTO 9000 DO 50 I=NRFDFR,NRLDFR CALL TFRRU(I+0,'VAR') ! read display-only record IF (ISCOMP(FIELD,DONFLD).EQ.0) 40,50,50 C THEN 40 IF (LTX.EQ.0) 42,44,44 C THEN 42 CALL SWRITE(ISCR,CC,DONESC,NATSTR) CALL RSWRIT(ISCR,CC,LENDON,' ') GOTO 99 C ELSE 44 CALL SCOPY(TEXT,SBUF,LENDON) CALL SWRITE(ISCR,CC,DONESC,SBUF) IF (LTX.LT.LENDON) CALL RSWRIT(ISCR,CC,LENDON-LTX,' ') GOTO 99 C ENDIF C ENDIF 50 CONTINUE GOTO 9000 C C go back to calling routine C 99 RETURN C C errors C 9000 CALL FATAL('TFRFLD','Field not found') END