SUBROUTINE TFRRES (FIELD, RESULT, ITRIM) C***************************************************************************** C C Description : Routine to return the contents of one or all field(s) C from the field copy record to the application program C C Arguments : FIELD = STRING containing the field name, or null-string C RESULT = STRING containing the contents of the field C ITRIM = INTEGER 0: no trim of trailing spaces C 1: trim 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 : TFRRES.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRRES 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),RESULT(1) C C C search update field with specified name C RESULT(1)=0 LF=LEN(FIELD) IF (NRFUFR.EQ.0) GOTO 100 CALL SCVTLU(FIELD) DO 20 I=NRFUFR,NRLUFR CALL TFRRU(I+0,'VAR') ! read update field record IF (LF.EQ.0 .OR. ISCOMP(FIELD,UPDFLD).EQ.0) 10,20,20 C THEN 10 CALL TFRRU(I+0,'FCR') CALL SCOPY(FCR(NPFCR),RESULT(LEN(RESULT)+1)) IF (LF.NE.0) GOTO 100 C ENDIF 20 CONTINUE IF (LF.NE.0) GOTO 9000 C C trim if required C 100 IF (LF .NE. 0 .AND. ITRIM .EQ. 1) CALL TRIM(RESULT) C C go back to calling program C 99 RETURN C C errors C 9000 CALL FATAL('TFRRES','Field not found') END