SUBROUTINE TFRDEF (FIELD, DFAULT) C***************************************************************************** C C Description : Routine to reset a field default value C C Arguments : FIELD = STRING containing the field name C DFAULT = STRING containing default value for the field 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 : TFRDEF.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRDEF 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 FIELD(1),DFAULT(1) C C C determine field copy record and fill with new default C IF (NRFUFR.EQ.0) GOTO 9000 CALL SCVTLU(FIELD) 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(DFAULT,FCR(NPFCR),LENUPD) LDF=LEN(DFAULT) IF (LDF.LT.LENUPD) FCR(NPFCR+LDF)=' ' GOTO 99 C ENDIF 20 CONTINUE GOTO 9000 C C go back to calling routine C 99 RETURN C C errors C 9000 CALL FATAL('TFRDEF','Field not found') END