SUBROUTINE TFRPOS (FORM) C***************************************************************************** C C Description : Routine to initialize settings for a specified form C C Arguments : FORM = STRING containing the name of the form 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 : TFRPOS.FTN C C Package : TRAMP C C Compilation/Linking : FOR/F4P/TR:NONE TFRPOS 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 form name-record BYTE FRNAM(8) C FRNAM ! form name C NRNXFR ! rec.nr. next form C NRFFFR ! rec.nr. first fix field rec. C NRLFFR ! rec.nr. last fix field rec. C NRFDFR ! rec.nr. first display-only fld.rec. C NRLDFR ! rec.nr. last display-only fld.rec. C NRFUFR ! rec.nr. first update field rec. C NRLUFR ! rec.nr. last update field rec. 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 FORM(1) C C C search file for specified form C NEXT=NRNXFR CALL SCVTLU(FORM) 10 READ (NUNIT'NRNXFR) FRNAM,NRNXFR, 1 NRFFFR,NRLFFR,NRFDFR,NRLDFR,NRFUFR,NRLUFR IF (ISCOMP(FORM,FRNAM).EQ.0) GOTO 20 IF (NRNXFR.EQ.NEXT) GOTO 9000 GOTO 10 C C fill field copy record with default values C 20 NLFCR=0 IF (NRFUFR.EQ.0) GOTO 99 DO 60 I=NRFUFR,NRLUFR CALL TFRRU(I+0,'ALL') ! read update field record and FCR DO 40 J=NPFCR,NPFCR+LENUPD-1 FCR(J)=' ' FCR(J+1)=0 40 CONTINUE IF (NRDEF.NE.0) 50,60,60 C THEN 50 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 60 CONTINUE C C go back to calling routine C 99 RETURN C C errors C 9000 CALL FATAL('TFRPOS','Form not found') END