SUBROUTINE TFRCLR (KEYWRD) C***************************************************************************** C C Description : Routine to clear screen and field copy record(s) C C Arguments : KEYWRD = STRING or INTEGER keyword info: C STRING containing one of the following keywords: C 'ALL' - clear fix, display-only and update fields C 'VAR' - clear display-only and update fields C 'DON' - clear display-only fields C 'UPD' - clear update fields C INTEGER row number from which the screen has to C be cleared C C Author : F.A.Minkema C AKZO PHARMA, Oss Holland C dept. SDA C C Version : V1.1 Date : 25-jul-1983 C C Module name : TFRCLR.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRCLR C C Updates : name F.A.Minkema version V1.1 C C description : Clear display-only fields without video-attributes 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),KEY(4),CC(3),LF(2) EQUIVALENCE (NROW,KEY(1)) DATA CC /'+','$',0/, LF /10,0/ C C C check keyword C CALL SCOPY(KEYWRD,KEY,3) IKEY=0 CALL SCVTLU(KEYWRD) IF (ISCOMP(KEYWRD,'DON').EQ.0) IKEY=1 IF (ISCOMP(KEYWRD,'UPD').EQ.0) IKEY=2 IF (ISCOMP(KEYWRD,'VAR').EQ.0) IKEY=3 IF (ISCOMP(KEYWRD,'ALL').EQ.0) NROW=1 IF (IKEY.EQ.0 .AND. NROW.LE.0) GOTO 9000 C C clear FCR if clear update fields C IF ((IKEY.AND.2).EQ.2) 10,100,100 C THEN 10 IF (NRFUFR.EQ.0) GOTO 100 DO 40 I=NRFUFR,NRLUFR CALL TFRRU(I+0,'ALL') ! read update field record and FCR DO 20 J=NPFCR,NPFCR+LENUPD-1 FCR(J)=' ' 20 CONTINUE IF (NRDEF.NE.0) 30,40,40 C THEN 30 IREC=NRDEF CALL TFRFS(IREC) ! read default-value record(s) CALL SCOPY(SBUF,FCR(NPFCR),LENUPD) LSB=LEN(SBUF) IF (LSB.LT.LENUPD) FCR(NPFCR+LSB)=' ' C ENDIF 40 CONTINUE C ENDIF C C clear screen by row C 100 IF (IKEY.EQ.0) 110,200,200 C THEN 110 CALL SWRITE(ISCR,CC,HOMSTR) DO 120 I=1,NROW-1 IF (I.LT.NROW) CALL SWRITE(ISCR,CC,LF) 120 CONTINUE CALL SWRITE(ISCR,CC,NATSTR,CLRSTR) GOTO 400 C ENDIF C C clear display-only fields C 200 IF ((IKEY.AND.1).EQ.1) 210,300,300 C THEN 210 IF (NRFDFR.EQ.0) GOTO 300 DO 220 I=NRFDFR,NRLDFR CALL TFRRU(I+0,'VAR') ! read display-only field record CALL SWRITE(ISCR,CC,DONESC,NATSTR) CALL RSWRIT(ISCR,CC,LENDON,' ') 220 CONTINUE C ENDIF C C clear error/help message C 300 IF (IHEFLG.EQ.0) CALL SWRITE(ISCR,CC,HERPOS,ERLSTR) C C clear update fields (backwards) C IF ((IKEY.AND.2).EQ.2) 310,400,400 C THEN 310 IF (NRFUFR.EQ.0) GOTO 400 DO 320 I=NRLUFR,NRFUFR,-1 CALL TFRRU(I+0,'ALL') ! read update field record CALL SWRITE(ISCR,CC,UPDESC,FCR(NPFCR)) 320 CONTINUE C ENDIF C C turn off help/error message flag and video attributes C 400 IHEFLG=0 CALL SWRITE(ISCR,CC,NATSTR) C C go back to calling routine C RETURN C C errors C 9000 CALL FATAL('TFRCLR','Invalid keyword argument') END