SUBROUTINE TFRPUT (KEYWRD, NRCLR) C***************************************************************************** C C Description : Routine to display fix fields and update fields with data C from the current field copy record C C Arguments : KEYWRD = STRING containing a keyword: C 'ALL' - display fix, display-only and update fields C 'FIX' - display fix fields C 'DON' - display blank display-only fields C 'UPD' - display update fields C 'VAR' - display blank displ.-only and update fields C NRCLR = INTEGER containing the row number from which the C screen must be cleared before displaying any data 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 : TFRPUT.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRPUT 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 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 KEYWRD(1),CC(3),LF(2) DATA CC /'+','$',0/, LF /10,0/ C C C check keyword C IKEY=0 CALL SCVTLU(KEYWRD) IF (ISCOMP(KEYWRD,'FIX').EQ.0) IKEY=1 IF (ISCOMP(KEYWRD,'DON').EQ.0) IKEY=2 IF (ISCOMP(KEYWRD,'UPD').EQ.0) IKEY=4 IF (ISCOMP(KEYWRD,'VAR').EQ.0) IKEY=6 IF (ISCOMP(KEYWRD,'ALL').EQ.0) IKEY=7 IF (IKEY.EQ.0) GOTO 9000 C C clear screen by row C IF (NRCLR.GT.0) 10,30,30 C THEN 10 CALL SWRITE(ISCR,CC,HOMSTR) DO 20 I=1,NRCLR-1 IF (I.LT.NRCLR) CALL SWRITE(ISCR,CC,LF) 20 CONTINUE CALL SWRITE(ISCR,CC,NATSTR,CLRSTR) C ENDIF C C display fix fields C 30 IREC=NRFFFR IF ((IKEY.AND.1).EQ.1) 32,40,40 C THEN 32 IF (IREC.EQ.0 .OR. IREC.GT.NRLFFR) GOTO 40 CALL TFRFS(IREC) CALL SWRITE(ISCR,CC,SBUF) IREC=IREC+1 GOTO 32 C ENDIF C C display blank display-only fields C 40 IF ((IKEY.AND.2).EQ.2) 42,60,60 C THEN 42 IF (NRFDFR.EQ.0) GOTO 60 DO 50 I=NRFDFR,NRLDFR CALL TFRRU(I+0,'VAR') ! read display-only field record CALL SWRITE(ISCR,CC,DONESC) CALL RSWRIT(ISCR,CC,LENDON,' ') 50 CONTINUE C ENDIF C C display update fields C 60 IF ((IKEY.AND.4).EQ.4) 62,99,99 C THEN 62 IF (NRFUFR.EQ.0) GOTO 99 DO 70 I=NRFUFR,NRLUFR CALL TFRRU(I+0,'ALL') ! read update field record and FCR CALL SWRITE(ISCR,CC,UPDESC,FCR(NPFCR)) 70 CONTINUE C ENDIF C C go back to calling routine C 99 RETURN C C errors C 9000 CALL FATAL('TFRPUT','Invalid keyword argument') END